MonadCompose 0.2.0.0 → 0.3.0.0

raw patch · 3 files changed

+59/−41 lines, 3 filesdep +MaybeT

Dependencies added: MaybeT

Files

• Control/Monad/Distributive.hs +55/−37
• Control/Monad/Plus.hs +1/−1
• MonadCompose.cabal +3/−3

@@ -1,60 +1,78 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FunctionalDependencies, TypeOperators #-}
 
-module Control.Monad.Distributive (Distributive(dist)) where
+module Control.Monad.Distributive where
 
 import qualified Control.Monad.State.Strict as Strict
 import Control.Monad.State
 import Control.Monad.Writer
 import Control.Monad.Reader
+import Control.Monad.Maybe
+import Control.Monad.Error
+import Control.Monad.List
 import Control.Monad.Identity
-import Data.Functor.Compose
+import Control.Monad.Morph
 
--- | Monads that distribute over one another.
-class (Monad m, Monad n) => Distributive m n where
-	dist :: m (n t) -> n (m t)
+swap ~(x, y) = (y, x)
 
-instance (Monad n) => Distributive Maybe n where
-	dist (Just m) = liftM Just m
-	dist Nothing = return Nothing
+class (MonadTrans m) => Takeout m y | m -> y where
+	-- | Pop out the underlying monad of a transformer, with a data structure to hold the state.
+	takeout :: (Monad n) => m n t -> m Identity (n (y t))
+	-- | Put the data structure back in.
+	combine :: (Monad x) => m x (y t) -> m x t
 
-instance (Monad n) => Distributive (Either t) n where
-	dist (Left x) = return (Left x)
-	dist (Right m) = liftM Right m
+instance Takeout (Strict.StateT s) ((,) s) where
+	takeout m = Strict.get >>= return . liftM swap . Strict.runStateT m
+	combine m = m >>= \(s, x) -> Strict.put s >> return x
 
-instance (Monad n, Monoid x) => Distributive (WriterT x Identity) n where
-	dist wr = let (m, w) = runWriter wr in m >>= \x -> return (tell w >> return x)
+instance Takeout (StateT s) ((,) s) where
+	takeout m = get >>= return . liftM swap . runStateT m
+	combine m = m >>= \(s, x) -> put s >> return x
 
-instance (Monad n) => Distributive [] n where
-	dist = sequence
+instance Takeout (ReaderT r) Identity where
+	takeout m = ask >>= return . liftM Identity . runReaderT m
+	combine = liftM runIdentity
 
-instance (Monad m) => Distributive m (Strict.StateT v Identity) where
-	dist m = get >>= \x -> return (m >>= \st -> return $ Strict.evalState st x)
+instance (Monoid w) => Takeout (WriterT w) ((,) w) where
+	takeout = return . liftM swap . runWriterT
+	combine m = m >>= \(w, x) -> tell w >> return x
 
-instance (Monad m) => Distributive m (StateT v Identity) where
-	dist m = get >>= \x -> return (m >>= \st -> return $ evalState st x)
+-- | The opposite of takeout.
+putin m = hoist lift (liftM (hoist (return . runIdentity)) m) >>= lift
 
-instance (Monad m) => Distributive m (ReaderT v Identity) where
-	dist m = ask >>= \x -> return (m >>= \rd -> return $ runReader rd x)
+putin1 m = hoist (return . runIdentity) m >>= lift
 
-instance (Monad m) => Distributive m Identity where
-	dist m = Identity (m >>= return . runIdentity)
+-- | Transformers that distribute over one another.
+--
+--   For reorganizing a monad stack.
+class Leftdistr m where
+	ldist :: (Monad (n x), Monad x) => m (n x) t -> n x (m Identity t)
 
-instance (Monad n) => Distributive Identity n where
-	dist (Identity m) = m >>= return . Identity
+class Rightdistr m where
+	rdist :: (Monad (n Identity), Monad (n x), MonadTrans n, MFunctor n, Monad x) => n Identity (m x t) -> m (n x) (n x t)
 
-instance (Distributive n2 n, Distributive m n2, Distributive m n) => Distributive m (Compose n n2) where
-	dist = Compose . liftM dist . dist . liftM getCompose
+instance Leftdistr MaybeT where
+	ldist m = runMaybeT m >>= return . maybe mzero return
 
-instance (Distributive m n, Distributive m2 m, Distributive m2 n) => Distributive (Compose m m2) n where
-	dist = liftM Compose . dist . liftM dist . getCompose
+instance (Error t) => Leftdistr (ErrorT t) where
+	ldist m = runErrorT m >>= return . either throwError return
 
-join' m = Compose $ join $ liftM (liftM join . dist) m
+instance (Monoid x) => Leftdistr (WriterT x) where
+	ldist m = runWriterT m >>= \(x, w) -> return $ tell w >> return x
 
--- | Monads with a distributive law compose to give another monad.
-instance (Distributive n m) => Monad (Compose m n) where
-	return = Compose . return . return
-	Compose m >>= f = join' (liftM (liftM (getCompose . f)) m)
+instance Leftdistr ListT where
+	ldist m = runListT m >>= return . msum . map return
 
-instance (Monad m) => MonadTrans (Compose m) where
-	lift = Compose . return
+instance Rightdistr (Strict.StateT v) where
+	rdist m = get >>= \s -> return $ putin1 $ liftM (`Strict.evalStateT` s) m
 
+instance Rightdistr (StateT v) where
+	rdist m = get >>= \s -> return $ putin1 $ liftM (`evalStateT` s) m
+
+instance Rightdistr (ReaderT v) where
+	rdist m = ask >>= \v -> return $ putin1 $ liftM (`runReaderT` v) m
+
+-- | Left distributivity of a monad transformer.
+ldist' m = putin $ ldist m
+
+-- | Right distributivity.
+rdist' m = liftM combine (rdist $ takeout m) >>= lift

@@ -43,7 +43,7 @@ 	hoist = mapPlus id
 
 comm :: (m ::+ n) t -> (n ::+ m) t
-comm (Plus f) = Plus (flip f)
+comm (Plus f) = Plus (\h i -> f i h)
 
 assoc (Plus f) = Plus (\h i -> f (\m -> unPlus m h (i . inl)) (i . inr))
 

@@ -1,7 +1,7 @@ name:                MonadCompose
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Methods for composing monads.
-description:         See also Control.Monad.Trans.Adjoint.
+description:         Includes basically the known ways of composing monads. Also includes an IO monad transformer.
 homepage:            http://alkalisoftware.net
 license:             BSD3
 license-file:        LICENSE
@@ -15,4 +15,4 @@ library
   exposed-modules:     Control.Monad.IOT, Control.Monad.Distributive, Control.Monad.Plus
   -- other-modules: 
-  build-depends:       base ==4.6.*, ghc-prim ==0.3.*, mtl ==2.1.*, mmorph ==1.0.*, monad-products, transformers
+  build-depends:       base ==4.6.*, ghc-prim ==0.3.*, mtl ==2.1.*, mmorph ==1.0.*, monad-products, transformers, MaybeT