MonadCompose 0.8.4.1 → 0.8.4.2

raw patch · 2 files changed

+106/−88 lines, 2 filesdep +kan-extensionsdep −monad-loops

Dependencies added: kan-extensions

Dependencies removed: monad-loops

Files

Control/Monad/PlusMonad.hs +102/−84
MonadCompose.cabal +4/−4

Control/Monad/PlusMonad.hs view

@@ -1,37 +1,40 @@-{-# LANGUAGE RankNTypes, FlexibleInstances, DeriveFunctor, TypeOperators #-}
+{-# LANGUAGE Safe, Rank2Types, FlexibleInstances, DeriveFunctor, TypeOperators #-}
 
-module Control.Monad.PlusMonad ((::+)(..), Lifting, Dist(..), leftMap, rightMap, leftSum, rightSum, inl, inr, sym, commute, File, runFile, readLine, mapPlus, refl) where
+-- | A construction combining two monads, based on the work of Luth and Ghani, "Composing Monads Using Coproducts."
+module Control.Monad.PlusMonad (Composition, (::+), Dist(..), leftMap, rightMap, inl, inr, sym, commute, mapPlus, refl,
+-- * Example
+File, runFile, readLine) where
 
 import qualified Control.Monad.State.Strict as Strict
 import Control.Monad.State
-import Control.Monad.Reader
 import Control.Monad.Writer hiding (Sum)
 import Control.Monad.Error
-import Control.Monad.List
 import Control.Monad.Identity
 import Control.Monad.Morph
-import Control.Applicative
+import Control.Monad.Codensity
 import Control.Exception
-import Data.Functor.Sum
+import Control.Applicative
 import Data.Functor.Compose
+import Data.Functor.Sum
+import Data.Functor.Yoneda
 import System.IO
 
--- | The following construction on two monads is a monad whenever the two monads have extended distributive laws, defined below.
-data (m ::+ n) t = ExtendedComposition !(forall x. (Monad x) => Lifting (Sum m n) x (m (n t))) | Rtn t
+data Composition m n t = Composition (m (n (Composition m n t))) | Rtn t deriving Functor
 
--- | Lifting along an arbitrary morphism.
-type Lifting m x t = (forall u. m u -> x u) -> x t
+-- | The following construction on two monads is a monad provided the two monads
+--   have extended distributive laws, defined below.
+type (m ::+ n) = Yoneda (Composition m n)
 
--- | An extended distributive law allows to permute two layers in a composition.
+-- | An extended distributive law allows one to permute two layers.
 --
 -- Laws are:
 --
--- join . T dist = dist . join :: TTS -> TST
---
--- TS join . dist . dist = dist :: TS -> TST
+-- >>> join . T dist = dist . join :: TTS -> TST
+-- >>> TS join . dist . dist = dist :: TS -> TST
 class Dist n where
 	dist :: (Applicative m) => n (m t) -> n (m (n t))
 
+-- Extended distributed laws for common monads.
 instance Dist (StateT s Identity) where
 	dist m = do
 		n <- m
@@ -56,98 +59,119 @@ instance Dist Maybe where
 	dist m = fmap (fmap return) m
 
-sumMap :: (m t -> x u) -> (n t -> y u) -> Sum m n t -> Sum x y u
-sumMap f _ (InL x) = InL (f x)
-sumMap _ g (InR x) = InR (g x)
+instance Dist (Either t) where
+	dist m = fmap (fmap return) m
 
+instance (Error e) => Dist (ErrorT e Identity) where
+	dist m = fmap (fmap return) m
+
+_hoist :: (forall u. m u -> n u) -> Yoneda m t -> Yoneda n t
+_hoist f (Yoneda g) = Yoneda (f . g)
+
+_leftMap :: (Functor n, Functor x) => (forall u. m u -> n u) -> Composition m x t -> Composition n x t
+_leftMap f (Composition m) = Composition (fmap (fmap (_leftMap f)) (f m))
+_leftMap _ (Rtn x) = Rtn x
+
+_rightMap :: (Functor n, Functor x) => (forall u. m u -> n u) -> Composition x m t -> Composition x n t
+_rightMap f (Composition m) = Composition (fmap (fmap (_rightMap f) . f) m)
+_rightMap _ (Rtn x) = Rtn x
+
 -- | Left and right maps...
-leftMap :: (Monad x) => (forall u. m u -> n u) -> (m ::+ x) t -> (n ::+ x) t
-leftMap f (ExtendedComposition g) = ExtendedComposition (\h -> liftM f (g (h . sumMap f id)))
-leftMap _ (Rtn x) = Rtn x
+leftMap :: (Monad m, Functor n, Functor x) => (forall u. m u -> n u) -> (m ::+ x) t -> (n ::+ x) t
+leftMap f m = _hoist (_leftMap f) m
 
-rightMap :: (Monad x) => (forall u. m u -> n u) -> (x ::+ m) t -> (x ::+ n) t
-rightMap f (ExtendedComposition g) = ExtendedComposition (\h -> liftM (liftM f) (g (h . sumMap id f)))
-rightMap _ (Rtn x) = Rtn x
+rightMap :: (Monad x, Monad m, Functor n) => (forall u. m u -> n u) -> (x ::+ m) t -> (x ::+ n) t
+rightMap f m = _hoist (_rightMap f) m
 
--- | And sums...
-leftSum (ExtendedComposition f) (ExtendedComposition g) = ExtendedComposition (\h -> liftM2 mplus (f h) (g h))
+-- Distribute over three layers.
+distributive1 :: (Dist m, Monad m, Applicative n, Applicative x, Applicative y) => m (n (x (y (m t)))) -> m (n (x (y (m t))))
+distributive1 m = (fmap (fmap (fmap (fmap join) . getCompose) . getCompose) . dist . fmap (Compose . fmap Compose)) m
 
-rightSum (ExtendedComposition f) (ExtendedComposition g) = ExtendedComposition (\h -> liftM2 (liftM2 mplus) (f h) (g h))
+-- Each layer is distributed over the inner layer in sequence, from inside to outside.
+distributive2 :: (Dist m, Dist n, Monad m, Monad n, Applicative x) => Composition m n (x (m (n t))) -> Composition m n (x (m (n t)))
+distributive2 (Composition m) = (
+	Composition
+	. fmap (fmap distributive2)
+	. fmap distributive1
+	. distributive1)
+	m
+distributive2 (Rtn x) = Rtn x
 
-distributive1 x = fmap getCompose (dist (fmap Compose x))
+-- These two instances are needed to use '::+' in a nested manner.
+instance (Dist m, Dist n, Monad m, Monad n) => Dist (Composition m n) where
+	dist = fmap (fmap (Composition . fmap (fmap Rtn))) . distributive2 . fmap (fmap (return . return))
 
-instance (Dist m, Dist n, Monad m, Monad n) => Dist (m ::+ n) where
-	dist (ExtendedComposition f) = ExtendedComposition (\g -> (
-		fmap (fmap (fmap (fmap (\m -> ExtendedComposition (\_ -> return m)))))
-		. fmap (fmap distributive1)
-		. fmap distributive1)
-		(f g))
-	dist (Rtn x) = return (fmap return x)
+instance (Dist m, Functor m) => Dist (Yoneda m) where
+	dist = liftYoneda . fmap (fmap liftYoneda) . dist . lowerYoneda
 
-instance (Functor m, Functor n) => Functor (m ::+ n) where
-	fmap f (ExtendedComposition g) = ExtendedComposition (\h -> fmap (fmap (fmap f)) (g h))
-	fmap f (Rtn x) = Rtn (f x)
+distributive :: (Dist m, Monad m, Applicative n) => m (n (m t)) -> m (n (m t))
+distributive x = (fmap (fmap join) . dist) x
 
-distributive x = (fmap (getCompose . fmap join) . dist . fmap Compose) x
+bringDown :: (Monad m, Monad n) => Composition m n t -> m (n (Composition m n t))
+bringDown (Composition m) = m
+bringDown (Rtn x) = return (return (Rtn x))
 
-instance (Dist m, Dist n, Monad m, Monad n) => Monad (m ::+ n) where
-	return x = ExtendedComposition (\_ -> return (return (return x)))
-	ExtendedComposition h >>= f = ExtendedComposition (\g -> (
-		join
-		. join
-		. fmap join
-		. fmap (g . InL)
-		. fmap (fmap (g . InR))
-		. fmap (fmap distributive)
+instance (Dist m, Dist n, Monad m, Monad n) => Monad (Composition m n) where
+	return = Rtn
+	Composition m >>= f = Composition ((fmap (fmap Composition)
+		. distributive
 		. fmap distributive
-		. fmap (fmap (fmap (\x -> case f x of
-			ExtendedComposition i -> i g
-			Rtn x -> return (return (return x))))))
-		(h g))
+		. fmap (fmap (bringDown . (>>= f))))
+		m)
 	Rtn x >>= f = f x
-	fail s = ExtendedComposition (\_ -> fail s)
+	fail = Composition . fail
 
-instance (Dist m, Dist n, Monad m, Monad n) => Applicative (m ::+ n) where
+instance (Dist m, Dist n, Monad m, MonadPlus n) => MonadPlus (Composition m n) where
+	mzero = Composition (return mzero)
+	mplus (Composition m) (Composition n) = Composition (liftM2 (liftM2 mplus) m n)
+	mplus (Rtn x) (Composition n) = Composition (liftM (return (Rtn x) `mplus`) n)
+	mplus (Composition m) (Rtn x) = Composition (liftM (mplus (return (Rtn x))) m)
+	mplus (Rtn x) (Rtn y) = Composition (return (return (Rtn x) `mplus` return (Rtn y)))
+
+instance (Dist m, Dist n, Monad m, Monad n) => Applicative (Composition m n) where
 	pure = return
 	(<*>) = ap
 
-instance (Dist m, Dist n, MonadPlus m, MonadPlus n) => MonadPlus (m ::+ n) where
-	mzero = ExtendedComposition (\_ -> return (return mzero))
-	mplus = rightSum
-
-instance (Dist m, Dist n, MonadPlus m, MonadPlus n) => Alternative (m ::+ n) where
+instance (Dist m, Dist n, Monad m, MonadPlus n) => Alternative (Composition m n) where
 	empty = mzero
 	(<|>) = mplus
 
-instance (Monad m) => MonadTrans ((::+) m) where
-	lift = inr
+instance (Monad m) => MonadTrans (Composition m) where
+	lift = Composition . return . fmap Rtn
 
-instance (Monad m) => MFunctor ((::+) m) where
-	hoist = rightMap
+instance (Dist m, Dist n, Monad m, Monad n, MonadIO n) => MonadIO (Composition m n) where
+	liftIO = lift . liftIO
 
-instance (Dist m, Dist n, Monad m, Monad n, MonadIO n) => MonadIO (m ::+ n) where
-	liftIO = inr . liftIO
+-- | Injections into the '::+' type.
+inl :: (Dist m, Dist n, Monad m, Monad n) => m t -> (m ::+ n) t
+inl m = lift (Composition (fmap (return . Rtn) m))
 
--- | Injections into the 'ExtendedComposition' type.
-inl m = ExtendedComposition (\_ -> return (liftM return m))
+inr :: (Dist m, Dist n, Monad m, Monad n) => n t -> (m ::+ n) t
+inr m = lift (Composition (return (fmap Rtn m)))
 
-inr m = ExtendedComposition (\_ -> return (return m))
+_sym :: (Monad m) => Composition m m t -> m t
+_sym (Composition m) = m >>= (>>= _sym)
+_sym (Rtn x) = return x
 
-symSum (InL x) = x
-symSum (InR x) = x
+-- | If you have a '::+' over a monad, you can extract the underlying action.
+sym :: (Monad m) => (m ::+ m) t -> m t
+sym m = _sym (lowerYoneda m)
 
--- | If you have an 'ExtendedComposition' over a monad, you can extract the underlying action.
-sym (ExtendedComposition f) = join (join (f symSum))
-sym (Rtn x) = return x
+_commute :: (Monad m, Functor n) => n (Composition m n t) -> Composition n m t
+_commute n = Composition (fmap (\m -> case m of
+	Composition m -> fmap _commute m
+	Rtn x -> return (Rtn x)) n)
 
-mirror (InL x) = InR x
-mirror (InR x) = InL x
+-- | '::+' is commutative.
+commute :: (Monad m, Monad n) => (m ::+ n) t -> (n ::+ m) t
+commute m = _hoist (_commute . return) m
 
--- | 'ExtendedComposition' is commutative, provided the distributive laws for 'm' and 'n' witness an isomorphism.
-commute :: (Dist m, Monad n) => (m ::+ n) t -> (n ::+ m) t
-commute (ExtendedComposition f) = ExtendedComposition (\g -> join (fmap (g . InR . dist) (f (g . mirror))))
-commute (Rtn x) = Rtn x
+mapPlus :: (Monad m, Monad n, Functor m1, Functor n1) => (forall u. m u -> m1 u) -> (forall u. n u -> n1 u) -> (m ::+ n) t -> (m1 ::+ n1) t
+mapPlus f g = leftMap f . rightMap g
 
+refl :: (MonadPlus m) => (m ::+ m) t -> m t
+refl = sym
+
 ---------------------------------------
 
 -- | Example of an IO-performing ADT.
@@ -175,10 +199,4 @@ 		n <- m
 		s <- File get
 		return (fmap (\x -> File (put s) >> return x) n)
-
-mapPlus :: (Monad m, Monad n1) => (forall u. m u -> m1 u) -> (forall u. n u -> n1 u) -> (m ::+ n) t -> (m1 ::+ n1) t
-mapPlus f g = leftMap f . rightMap g
-
-refl :: (MonadPlus m) => (m ::+ m) t -> m t
-refl = sym

MonadCompose.cabal view

@@ -1,11 +1,11 @@ name:                MonadCompose
-version:             0.8.4.1
+version:             0.8.4.2
 synopsis:            Methods for composing monads.
 description:         Methods for composing monads.
   .
-  The IO monad transformer solves the problem of combining two IO-performing monads, so that neither one needs to provide a MonadIO interface and both can be transformed separately.
+  The IO monad transformer solves the problem of combining two IO-performing monads, so that both may be transformed separately.
   .
-  A monad transformer can transform another monad, but if you have two monads both lacking a transformer, you can define an /extended distributive law/ which allows a monad to arise - see Control.Monad.PlusMonad. This is an alternate solution to the same problem.
+  A monad transformer can transform another monad, but if you have two monads both lacking a transformer, one can define an /extended distributive law/ which allows a monad to arise - see Control.Monad.PlusMonad.
 homepage:            http://alkalisoftware.net
 license:             BSD3
 license-file:        LICENSE
@@ -19,5 +19,5 @@ library
   exposed-modules:     Control.Monad.IOT, Control.Monad.PlusMonad, Control.Monad.Lifter, Control.Linear
   -- other-modules: 
-  build-depends:       base >=4 && <=5, ghc-prim, mtl >= 2.2, mmorph ==1.0.*, monad-products, transformers, random, data-default, parallel >=3.2, transformers-compat ==0.4.*, monad-loops >= 0.4.2.1
+  build-depends:       base >=4 && <=5, ghc-prim, mtl >= 2.2, mmorph ==1.0.*, monad-products, transformers, random, parallel >=3.2, transformers-compat ==0.4.*, kan-extensions, data-default
   ghc-options:         -fno-cse