constrained-monads 0.3.0.0 → 0.4.0.0

raw patch · 3 files changed

+328/−42 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• constrained-monads.cabal +2/−1
• src/Control/Monad/Constrained.hs +92/−41
• src/Control/Monad/Constrained/Ap.hs +234/−0

@@ -1,5 +1,5 @@ name:                constrained-monads-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Typeclasses and instances for monads with constraints.  description:         A library for monads with constraints over the types they contain. This allows set, etc to conform to the monad class. It is structured as a prelude replacement: everything that doesn't conflict with the new definitions of 'Functor', 'Monad', etc is reexported.                      @@ -24,6 +24,7 @@                      , Control.Monad.Constrained.IO                      , Control.Monad.Constrained.Cont                      , Control.Monad.Constrained.IntSet+                     , Control.Monad.Constrained.Ap   build-depends:       base >= 4.9 && < 5                      , containers >= 0.5                      , transformers >= 0.5

@@ -23,11 +23,13 @@   ,Monad(..)   ,Alternative(..)   ,Traversable(..)+  ,MonadFail(..)   ,    -- * Horrible type-level stuff-  Free(..)+  Ap(..)   ,lowerP   ,lowerM+  ,liftAp   ,    -- * Useful functions    guard@@ -46,10 +48,10 @@   ,void   ,forever   ,for_+  ,join   ,    -- * Syntax    ifThenElse-  ,fail   ,(>>)   ,return   ,module RestPrelude)@@ -93,20 +95,22 @@  -- | A free applicative. Applicative operations are defined in terms of -- /interpretations/ of this.-infixl 5 :>-data Free f a where-  Pure :: a -> Free f a-  (:>) :: Free f (a -> b) -> f a -> Free f b+data Ap f a where+  Pure :: a -> Ap f a+  Ap :: Ap f (a -> b) -> f a -> Ap f b -instance Prelude.Functor (Free f) where+instance Prelude.Functor (Ap f) where   fmap f (Pure a) = Pure (f a)-  fmap f (x :> y) = ((f .) Prelude.<$> x) :> y+  fmap f (Ap x y) = Ap ((f .) Prelude.<$> x) y -instance Prelude.Applicative (Free f) where+instance Prelude.Applicative (Ap f) where   pure = Pure   Pure f <*> y = Prelude.fmap f y-  (x :> y) <*> z = (flip Prelude.<$> x Prelude.<*> z) :> y+  Ap x y <*> z = Ap (flip Prelude.<$> x Prelude.<*> z) y +liftAp :: f a -> Ap f a+liftAp = Ap (Pure id)+ -------------------------------------------------------------------------------- -- Standard classes --------------------------------------------------------------------------------@@ -291,39 +295,40 @@     -- in terms of @('>>=')@, which is what 'lowerM' does.     lower         :: Suitable f a-        => Free f a -> f a+        => Ap f a -> f a      liftA2         :: Suitable f c         => (a -> b -> c) -> f a -> f b -> f c     liftA2 f xs ys =-        lower (Pure f :> xs :> ys)+        lower (Ap (Ap (Pure f) xs) ys)      liftA3         :: Suitable f d         => (a -> b -> c -> d) -> f a -> f b -> f c -> f d     liftA3 f xs ys zs =-        lower (Pure f :> xs :> ys :> zs)+        lower (Ap (Ap (Ap (Pure f) xs) ys) zs)      {-# INLINE liftA2 #-}     {-# INLINE liftA3 #-} +infixl 4 <**> -- | A variant of '<*>' with the arguments reversed. (<**>) :: (Applicative f, Suitable f b) => f a -> f (a -> b) -> f b (<**>) = liftA2 (flip ($))  -- | A definition of 'lower' that uses monadic operations.-lowerM :: (Monad f, Suitable f a) => Free f a -> f a+lowerM :: (Monad f, Suitable f a) => Ap f a -> f a lowerM = go pure where-  go :: (Suitable f b, Monad f) => (a -> f b) -> Free f a -> f b+  go :: (Suitable f b, Monad f) => (a -> f b) -> Ap f a -> f b   go f (Pure x) = f x-  go f (xs :> x) = go (\c -> x >>= f . c) xs+  go f (Ap xs x) = go (\c -> x >>= f . c) xs  -- | A definition of 'lower' which uses the "Prelude"'s @('Prelude.<*>')@.-lowerP :: Prelude.Applicative f => Free f a -> f a+lowerP :: Prelude.Applicative f => Ap f a -> f a lowerP (Pure x) = Prelude.pure x-lowerP (Pure f :> xs) = Prelude.fmap f xs-lowerP (ys :> xs) = lowerP ys Prelude.<*> xs+lowerP (Ap (Pure f) xs) = Prelude.fmap f xs+lowerP (Ap ys xs) = lowerP ys Prelude.<*> xs {-# INLINABLE lowerP #-}  {-# INLINE liftA2P #-}@@ -375,6 +380,14 @@     (>>=)         :: Suitable f b         => f a -> (a -> f b) -> f b++-- | See+-- <https://hackage.haskell.org/package/base-4.9.1.0/docs/Control-Monad-Fail.html here>+-- for more details.+class Monad f => MonadFail f where+  -- | Called when a pattern match fails in do-notation.+  fail :: Suitable f a => String -> f a+ -- | A monoid on applicative functors. -- -- If defined, 'some' and 'many' should be the least solutions@@ -684,6 +697,10 @@ void :: (Functor f, Suitable f ()) => f a -> f () void = (<$) () +-- | Collapse one monadic layer.+join :: (Monad f, Suitable f a) => f (f a) -> f a+join x = x >>= id+ -------------------------------------------------------------------------------- -- syntax --------------------------------------------------------------------------------@@ -693,10 +710,7 @@ ifThenElse True t _ = t ifThenElse False _ f = f --- | Called on a failed pattern match in a monadic bind. To be avoided.-fail :: String -> a-fail = error-+infixl 1 >> -- | Sequence two actions, discarding the result of the first. Alias for -- @('*>')@. (>>)@@ -733,10 +747,13 @@   (<|>) = (++)  instance Monad [] where-  (>>=) = (Prelude.>>=)+    (>>=) = (Prelude.>>=) +instance MonadFail [] where+    fail _ = []+ instance Traversable [] where-  traverse f = foldr (liftA2 (:) . f) (pure [])+    traverse f = foldr (liftA2 (:) . f) (pure [])  instance Functor Maybe where     type Suitable Maybe a = ()@@ -759,6 +776,9 @@ instance Monad Maybe where     (>>=) = (Prelude.>>=) +instance MonadFail Maybe where+    fail _ = Nothing+ instance Traversable Maybe where     traverse _ Nothing = pure Nothing     traverse f (Just x) = fmap Just (f x)@@ -784,6 +804,9 @@ instance Monad IO where     (>>=) = (Prelude.>>=) +instance MonadFail IO where+    fail = Prelude.fail+ instance Functor Identity where     type Suitable Identity a = ()     fmap = Prelude.fmap@@ -821,8 +844,12 @@ instance Monad (Either a) where     (>>=) = (Prelude.>>=) +instance IsString a =>+         MonadFail (Either a) where+    fail = Left . fromString+ instance Traversable (Either a) where-  traverse f = either (pure . Left) (fmap Right . f)+    traverse f = either (pure . Left) (fmap Right . f)  instance Functor Set where     type Suitable Set a = Ord a@@ -839,6 +866,9 @@ instance Monad Set where     (>>=) = flip foldMap +instance MonadFail Set where+    fail _ = Set.empty+ instance Alternative Set where     empty = Set.empty     (<|>) = Set.union@@ -894,6 +924,9 @@ instance Monad Seq where     (>>=) = (Prelude.>>=) +instance MonadFail Seq where+    fail _ = empty+ instance Functor Tree where     type Suitable Tree a = ()     fmap = Prelude.fmap@@ -1061,9 +1094,9 @@     f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r     {-# INLINE (<*>) #-}     lower ys = ReaderT $ \r -> lower (tr r ys) where-      tr :: r -> Free (ReaderT r m) xs -> Free m xs+      tr :: r -> Ap (ReaderT r m) xs -> Ap m xs       tr _ (Pure x) = Pure x-      tr r (xs :> x) = tr r xs :> runReaderT x r+      tr r (Ap xs x) = Ap (tr r xs) (runReaderT x r)     ReaderT xs *> ReaderT ys = ReaderT (\c -> xs c *> ys c)     ReaderT xs <* ReaderT ys = ReaderT (\c -> xs c <* ys c) @@ -1073,6 +1106,10 @@     m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r     {-# INLINE (<|>) #-} +instance MonadFail m =>+         MonadFail (ReaderT r m) where+    fail = ReaderT . const . fail+ instance (Monad m) => Monad (ReaderT r m) where     m >>= k  = ReaderT $ \ r -> do         a <- runReaderT m r@@ -1083,22 +1120,29 @@ liftReaderT m = ReaderT (const m) {-# INLINE liftReaderT #-} -instance Functor m => Functor (MaybeT m) where-  type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a)-  fmap f (MaybeT xs) = MaybeT ((fmap.fmap) f xs)-  x <$ MaybeT xs = MaybeT (fmap (x<$) xs)+instance Functor m =>+         Functor (MaybeT m) where+    type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a)+    fmap f (MaybeT xs) = MaybeT ((fmap . fmap) f xs)+    x <$ MaybeT xs = MaybeT (fmap (x <$) xs) -instance Monad m => Applicative (MaybeT m) where-  pure x = MaybeT (pure (Just x))-  MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs)-  lower = lowerM-  MaybeT xs *> MaybeT ys = MaybeT (liftA2 (*>) xs ys)-  MaybeT xs <* MaybeT ys = MaybeT (liftA2 (<*) xs ys)+instance Monad m =>+         Applicative (MaybeT m) where+    pure x = MaybeT (pure (Just x))+    MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs)+    lower = lowerM+    MaybeT xs *> MaybeT ys = MaybeT (liftA2 (*>) xs ys)+    MaybeT xs <* MaybeT ys = MaybeT (liftA2 (<*) xs ys) -instance Monad m => Monad (MaybeT m) where-  MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f))+instance Monad m =>+         Monad (MaybeT m) where+    MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f))  instance Monad m =>+         MonadFail (MaybeT m) where+    fail _ = empty++instance Monad m =>          Alternative (MaybeT m) where     empty = MaybeT (pure Nothing)     MaybeT x <|> MaybeT y = MaybeT (x >>= maybe y (pure . Just))@@ -1117,6 +1161,9 @@     ExceptT xs *> ExceptT ys = ExceptT (xs *> ys)     ExceptT xs <* ExceptT ys = ExceptT (xs <* ys) +instance (Monad m, IsString e) => MonadFail (ExceptT e m) where+    fail = ExceptT . pure . Left . fromString+ instance Monad m => Monad (ExceptT e m) where   ExceptT xs >>= f = ExceptT (xs >>= either (pure . Left) (runExceptT . f)) @@ -1141,7 +1188,7 @@         (coerce :: (f (a -> b) -> f a -> f b) -> IdentityT f (a -> b) -> IdentityT f a -> IdentityT f b)             (<*>)     lower =-        (coerce :: (Free f xs -> f b) -> (Free (IdentityT f) xs -> IdentityT f b))+        (coerce :: (Ap f xs -> f b) -> (Ap (IdentityT f) xs -> IdentityT f b))             lower     IdentityT xs *> IdentityT ys = IdentityT (xs *> ys)     IdentityT xs <* IdentityT ys = IdentityT (xs <* ys)@@ -1151,3 +1198,7 @@     (>>=) =         (coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b)             (>>=)++instance MonadFail m =>+         MonadFail (IdentityT m) where+    fail = IdentityT . fail

@@ -0,0 +1,234 @@+{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeFamilies     #-}++-- | This module allows the use of the Applicative Do extension with+-- constrained monads.+module Control.Monad.Constrained.Ap+  (Monad(..)+  ,MonadFail(..)+  ,return+  ,ifThenElse+  ,(>>))+  where++import           Control.Monad.Constrained        (Ap (..), liftAp, lower)+import qualified Control.Monad.Constrained        as Constrained++import           GHC.Exts++import qualified Control.Monad+import           Prelude                          hiding (Monad (..))+import qualified Prelude++import           Control.Monad.Trans.Cont         (ContT)+import           Control.Monad.Trans.Except       (ExceptT(..))+import           Control.Monad.Trans.Identity     (IdentityT (..))+import           Control.Monad.Trans.Maybe        (MaybeT(..))+import           Control.Monad.Trans.Reader       (ReaderT (..))+import           Control.Monad.Trans.State        (StateT)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)+import           Data.Functor.Identity            (Identity)+import           Data.Sequence                    (Seq)++-- | This class is for types which have no constraints on their applicative+-- operations, but /do/ have constraints on the monadic operations.+--+-- Most types which can conform are just standard unconstrained monads, with+-- the exception of the free applicative. The type @'Ap' f a@ is an applicative+-- for /any/ @f@. However, it can only be made a monad by interpreting the+-- underlying type (which may be constrained), running the monadic operation,+-- and then lifting the result. In practice, this allows you to write code on+-- on the @Ap@ type, using applicative do notation, and have it be interpreted+-- correctly.+--+-- For instance, take the following expression:+--+-- @example = do+--   x <- pure 1+--   y <- pure 2+--   pure (x + y)@+--+-- With the standard constrained monad module, you can instantiate that at+-- any type which is a constrained monad. 'Data.Set.Set', for instance. However,+-- if @-XApplicativeDo@ is turned on, you will get the error:+--+-- @No instance for ('Ord' ('Integer' -> 'Data.Set.Set' 'Integer'))@+--+-- The solution is to use @'Ap' 'Data.Set.Set'@ instead, which has the same+-- constraints on expressions built with '<*>' as those built with '>>='.+class Applicative f =>+      Monad f  where+    type Suitable f a :: Constraint+    infixl 1 >>=+    (>>=)+        :: (Suitable f a, Suitable f b)+        => f a -> (a -> f b) -> f b+    join+        :: Suitable f a+        => f (f a) -> f a++-- | See+-- <https://hackage.haskell.org/package/base-4.9.1.0/docs/Control-Monad-Fail.html here>+-- for more details.+class Monad f => MonadFail f where+  -- | Called when a pattern match fails in do-notation.+  fail :: Suitable f a => String -> f a++instance Constrained.Monad f =>+         Monad (Ap f) where+    type Suitable (Ap f) a = Constrained.Suitable f a+    (>>=) ap f = liftAp (lower ap Constrained.>>= (lower . f))+    join = liftAp . go id . fmap lower+      where+        go+            :: forall a f b.+               (Constrained.Suitable f b, Constrained.Monad f)+            => (a -> f b) -> Ap f a -> f b+        go c (Pure x) = c x+        go f (Ap xs x) =+            go+                (\c ->+                      x Constrained.>>= (f . c))+                xs+-- | An alias for 'pure'+return :: Applicative f => a -> f a+return = pure++-- | Function to which the @if ... then ... else@ syntax desugars to+ifThenElse :: Bool -> a -> a -> a+ifThenElse True t _ = t+ifThenElse False _ f = f++infixl 1 >>+-- | Sequence two actions, discarding the result of the first. Alias for+-- @('*>')@.+(>>)+    :: Applicative f+    => f a -> f b -> f b+(>>) = (*>)++instance Monad [] where+    type Suitable [] a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance MonadFail [] where+    fail _ = []++instance Monad Maybe where+    type Suitable Maybe a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance MonadFail Maybe where+    fail _ = Nothing++instance Monad IO where+    type Suitable IO a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance MonadFail IO where+    fail = Prelude.fail++instance Monad Identity where+    type Suitable Identity a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Monad (Either e) where+    type Suitable (Either e) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance IsString a =>+         MonadFail (Either a) where+    fail = Left . fromString++instance Monoid m =>+         Monad ((,) m) where+    type Suitable ((,) m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Monad Seq where+    type Suitable Seq a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance MonadFail Seq where+    fail _ = Constrained.empty++instance Monad ((->) b) where+    type Suitable ((->) b) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Monad (ContT r m) where+    type Suitable (ContT r m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Prelude.Monad m =>+         Monad (Strict.StateT s m) where+    type Suitable (Strict.StateT s m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Prelude.Monad m =>+         Monad (StateT s m) where+    type Suitable (StateT s m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Monad m =>+         Monad (ReaderT s m) where+    type Suitable (ReaderT s m) a = Suitable m a+    m >>= k =+        ReaderT $+        \r -> do+            a <- runReaderT m r+            runReaderT (k a) r+    {-# INLINE (>>=) #-}+    join (ReaderT x) =+        ReaderT+            (\r ->+                  join (flip runReaderT r <$> x r))+    {-# INLINE join #-}++instance MonadFail m =>+         MonadFail (ReaderT r m) where+    fail = ReaderT . const . fail++instance Prelude.Monad m =>+         Monad (MaybeT m) where+    type Suitable (MaybeT m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance Prelude.Monad m =>+         MonadFail (MaybeT m) where+    fail _ = Control.Monad.mzero++instance Prelude.Monad m =>+         Monad (ExceptT e m) where+    type Suitable (ExceptT e m) a = ()+    (>>=) = (Prelude.>>=)+    join = Control.Monad.join++instance (Prelude.Monad m, IsString e) => MonadFail (ExceptT e m) where+    fail = ExceptT . pure . Left . fromString++instance Monad m =>+         Monad (IdentityT m) where+    type Suitable (IdentityT m) a = Suitable m a+    (>>=) =+        (coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b)+            (>>=)+    join (IdentityT x) = IdentityT (join (fmap runIdentityT x))++instance MonadFail m =>+         MonadFail (IdentityT m) where+    fail = IdentityT . fail