mmorph-1.0.6/0000755000000000000000000000000012654306052011211 5ustar0000000000000000mmorph-1.0.6/mmorph.cabal0000644000000000000000000000156612654306052013507 0ustar0000000000000000Name: mmorph Version: 1.0.6 Cabal-Version: >= 1.8.0.2 Build-Type: Simple License: BSD3 License-File: LICENSE Copyright: 2013 Gabriel Gonzalez Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com Bug-Reports: https://github.com/Gabriel439/Haskell-MMorph-Library/issues Synopsis: Monad morphisms Description: This library provides monad morphism utilities, most commonly used for manipulating monad transformer stacks. Category: Control Source-Repository head Type: git Location: https://github.com/Gabriel439/Haskell-MMorph-Library Library Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5 , mtl >= 2.0.1 && < 2.3, transformers >= 0.2.0.0 && < 0.6, transformers-compat >= 0.3 && < 0.6 Exposed-Modules: Control.Monad.Morph, Control.Monad.Trans.Compose GHC-Options: -O2 mmorph-1.0.6/LICENSE0000644000000000000000000000272212654306052012221 0ustar0000000000000000Copyright (c) 2013, Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Gabriel Gonzalez nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. mmorph-1.0.6/Setup.hs0000644000000000000000000000005612654306052012646 0ustar0000000000000000import Distribution.Simple main = defaultMain mmorph-1.0.6/src/0000755000000000000000000000000012654306052012000 5ustar0000000000000000mmorph-1.0.6/src/Control/0000755000000000000000000000000012654306052013420 5ustar0000000000000000mmorph-1.0.6/src/Control/Monad/0000755000000000000000000000000012654306052014456 5ustar0000000000000000mmorph-1.0.6/src/Control/Monad/Morph.hs0000644000000000000000000003207012654306052016101 0ustar0000000000000000{-# LANGUAGE CPP, RankNTypes #-} {-| A monad morphism is a natural transformation: > morph :: forall a . m a -> n a ... that obeys the following two laws: > morph $ do x <- m = do x <- morph m > f x morph (f x) > > morph (return x) = return x ... which are equivalent to the following two functor laws: > morph . (f >=> g) = morph . f >=> morph . g > > morph . return = return Examples of monad morphisms include: * 'lift' (from 'MonadTrans') * 'squash' (See below) * @'hoist' f@ (See below), if @f@ is a monad morphism * @(f . g)@, if @f@ and @g@ are both monad morphisms * 'id' Monad morphisms commonly arise when manipulating existing monad transformer code for compatibility purposes. The 'MFunctor', 'MonadTrans', and 'MMonad' classes define standard ways to change monad transformer stacks: * 'lift' introduces a new monad transformer layer of any type. * 'squash' flattens two identical monad transformer layers into a single layer of the same type. * 'hoist' maps monad morphisms to modify deeper layers of the monad transformer stack. -} module Control.Monad.Morph ( -- * Functors over Monads MFunctor(..), generalize, -- * Monads over Monads MMonad(..), MonadTrans(lift), squash, (>|>), (<|<), (=<|), (|>=) -- * Tutorial -- $tutorial -- ** Generalizing base monads -- $generalize -- ** Monad morphisms -- $mmorph -- ** Mixing diverse transformers -- $interleave -- ** Embedding transformers -- $embed ) where import Control.Monad.Trans.Class (MonadTrans(lift)) import qualified Control.Monad.Trans.Error as E import qualified Control.Monad.Trans.Except as Ex import qualified Control.Monad.Trans.Identity as I import qualified Control.Monad.Trans.List as L import qualified Control.Monad.Trans.Maybe as M import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.RWS.Lazy as RWS import qualified Control.Monad.Trans.RWS.Strict as RWS' import qualified Control.Monad.Trans.State.Lazy as S import qualified Control.Monad.Trans.State.Strict as S' import qualified Control.Monad.Trans.Writer.Lazy as W' import qualified Control.Monad.Trans.Writer.Strict as W import Data.Monoid (Monoid, mappend) import Data.Functor.Compose (Compose (Compose)) import Data.Functor.Identity (runIdentity) import Data.Functor.Product (Product (Pair)) import Control.Applicative.Backwards (Backwards (Backwards)) import Control.Applicative.Lift (Lift (Pure, Other)) -- For documentation import Control.Exception (try, IOException) import Control.Monad ((=<<), (>=>), (<=<), join) import Data.Functor.Identity (Identity) {-| A functor in the category of monads, using 'hoist' as the analog of 'fmap': > hoist (f . g) = hoist f . hoist g > > hoist id = id -} class MFunctor t where {-| Lift a monad morphism from @m@ to @n@ into a monad morphism from @(t m)@ to @(t n)@ -} hoist :: (Monad m) => (forall a . m a -> n a) -> t m b -> t n b instance MFunctor (E.ErrorT e) where hoist nat m = E.ErrorT (nat (E.runErrorT m)) instance MFunctor (Ex.ExceptT e) where hoist nat m = Ex.ExceptT (nat (Ex.runExceptT m)) instance MFunctor I.IdentityT where hoist nat m = I.IdentityT (nat (I.runIdentityT m)) instance MFunctor L.ListT where hoist nat m = L.ListT (nat (L.runListT m)) instance MFunctor M.MaybeT where hoist nat m = M.MaybeT (nat (M.runMaybeT m)) instance MFunctor (R.ReaderT r) where hoist nat m = R.ReaderT (\i -> nat (R.runReaderT m i)) instance MFunctor (RWS.RWST r w s) where hoist nat m = RWS.RWST (\r s -> nat (RWS.runRWST m r s)) instance MFunctor (RWS'.RWST r w s) where hoist nat m = RWS'.RWST (\r s -> nat (RWS'.runRWST m r s)) instance MFunctor (S.StateT s) where hoist nat m = S.StateT (\s -> nat (S.runStateT m s)) instance MFunctor (S'.StateT s) where hoist nat m = S'.StateT (\s -> nat (S'.runStateT m s)) instance MFunctor (W.WriterT w) where hoist nat m = W.WriterT (nat (W.runWriterT m)) instance MFunctor (W'.WriterT w) where hoist nat m = W'.WriterT (nat (W'.runWriterT m)) instance Functor f => MFunctor (Compose f) where hoist nat (Compose f) = Compose (fmap nat f) instance MFunctor (Product f) where hoist nat (Pair f g) = Pair f (nat g) instance MFunctor Backwards where hoist nat (Backwards f) = Backwards (nat f) instance MFunctor Lift where hoist _ (Pure a) = Pure a hoist nat (Other f) = Other (nat f) -- | A function that @generalize@s the 'Identity' base monad to be any monad. generalize :: Monad m => Identity a -> m a generalize = return . runIdentity {-# INLINABLE generalize #-} {-| A monad in the category of monads, using 'lift' from 'MonadTrans' as the analog of 'return' and 'embed' as the analog of ('=<<'): > embed lift = id > > embed f (lift m) = f m > > embed g (embed f t) = embed (\m -> embed g (f m)) t -} class (MFunctor t, MonadTrans t) => MMonad t where {-| Embed a newly created 'MMonad' layer within an existing layer 'embed' is analogous to ('=<<') -} embed :: (Monad n) => (forall a . m a -> t n a) -> t m b -> t n b {-| Squash two 'MMonad' layers into a single layer 'squash' is analogous to 'join' -} squash :: (Monad m, MMonad t) => t (t m) a -> t m a squash = embed id {-# INLINABLE squash #-} infixr 2 >|>, =<| infixl 2 <|<, |>= {-| Compose two 'MMonad' layer-building functions ('>|>') is analogous to ('>=>') -} (>|>) :: (Monad m3, MMonad t) => (forall a . m1 a -> t m2 a) -> (forall b . m2 b -> t m3 b) -> m1 c -> t m3 c (f >|> g) m = embed g (f m) {-# INLINABLE (>|>) #-} {-| Equivalent to ('>|>') with the arguments flipped ('<|<') is analogous to ('<=<') -} (<|<) :: (Monad m3, MMonad t) => (forall b . m2 b -> t m3 b) -> (forall a . m1 a -> t m2 a) -> m1 c -> t m3 c (g <|< f) m = embed g (f m) {-# INLINABLE (<|<) #-} {-| An infix operator equivalent to 'embed' ('=<|') is analogous to ('=<<') -} (=<|) :: (Monad n, MMonad t) => (forall a . m a -> t n a) -> t m b -> t n b (=<|) = embed {-# INLINABLE (=<|) #-} {-| Equivalent to ('=<|') with the arguments flipped ('|>=') is analogous to ('>>=') -} (|>=) :: (Monad n, MMonad t) => t m b -> (forall a . m a -> t n a) -> t n b t |>= f = embed f t {-# INLINABLE (|>=) #-} instance (E.Error e) => MMonad (E.ErrorT e) where embed f m = E.ErrorT (do x <- E.runErrorT (f (E.runErrorT m)) return (case x of Left e -> Left e Right (Left e) -> Left e Right (Right a) -> Right a ) ) instance MMonad (Ex.ExceptT e) where embed f m = Ex.ExceptT (do x <- Ex.runExceptT (f (Ex.runExceptT m)) return (case x of Left e -> Left e Right (Left e) -> Left e Right (Right a) -> Right a ) ) instance MMonad I.IdentityT where embed f m = f (I.runIdentityT m) instance MMonad L.ListT where embed f m = L.ListT (do x <- L.runListT (f (L.runListT m)) return (concat x)) instance MMonad M.MaybeT where embed f m = M.MaybeT (do x <- M.runMaybeT (f (M.runMaybeT m)) return (case x of Nothing -> Nothing Just Nothing -> Nothing Just (Just a) -> Just a ) ) instance MMonad (R.ReaderT r) where embed f m = R.ReaderT (\i -> R.runReaderT (f (R.runReaderT m i)) i) instance (Monoid w) => MMonad (W.WriterT w) where embed f m = W.WriterT (do ~((a, w1), w2) <- W.runWriterT (f (W.runWriterT m)) return (a, mappend w1 w2) ) instance (Monoid w) => MMonad (W'.WriterT w) where embed f m = W'.WriterT (do ((a, w1), w2) <- W'.runWriterT (f (W'.runWriterT m)) return (a, mappend w1 w2) ) {- $tutorial Monad morphisms solve the common problem of fixing monadic code after the fact without modifying the original source code or type signatures. The following sections illustrate various examples of transparently modifying existing functions. -} {- $generalize Imagine that some library provided the following 'S.State' code: > import Control.Monad.Trans.State > > tick :: State Int () > tick = modify (+1) ... but we would prefer to reuse @tick@ within a larger @('S.StateT' Int 'IO')@ block in order to mix in 'IO' actions. We could patch the original library to generalize @tick@'s type signature: > tick :: (Monad m) => StateT Int m () ... but we would prefer not to fork upstream code if possible. How could we generalize @tick@'s type without modifying the original code? We can solve this if we realize that 'S.State' is a type synonym for 'S.StateT' with an 'Identity' base monad: > type State s = StateT s Identity ... which means that @tick@'s true type is actually: > tick :: StateT Int Identity () Now all we need is a function that @generalize@s the 'Identity' base monad to be any monad: > import Data.Functor.Identity > > generalize :: (Monad m) => Identity a -> m a > generalize m = return (runIdentity m) ... which we can 'hoist' to change @tick@'s base monad: > hoist :: (Monad m, MFunctor t) => (forall a . m a -> n a) -> t m b -> t n b > > hoist generalize :: (Monad m, MFunctor t) => t Identity b -> t m b > > hoist generalize tick :: (Monad m) => StateT Int m () This lets us mix @tick@ alongside 'IO' using 'lift': > import Control.Monad.Morph > import Control.Monad.Trans.Class > > tock :: StateT Int IO () > tock = do > hoist generalize tick :: (Monad m) => StateT Int m () > lift $ putStrLn "Tock!" :: (MonadTrans t) => t IO () >>> runStateT tock 0 Tock! ((), 1) -} {- $mmorph Notice that @generalize@ is a monad morphism, and the following two proofs show how @generalize@ satisfies the monad morphism laws. You can refer to these proofs as an example for how to prove a function obeys the monad morphism laws: > generalize (return x) > > -- Definition of 'return' for the Identity monad > = generalize (Identity x) > > -- Definition of 'generalize' > = return (runIdentity (Identity x)) > > -- runIdentity (Identity x) = x > = return x > generalize $ do x <- m > f x > > -- Definition of (>>=) for the Identity monad > = generalize (f (runIdentity m)) > > -- Definition of 'generalize' > = return (runIdentity (f (runIdentity m))) > > -- Monad law: Left identity > = do x <- return (runIdentity m) > return (runIdentity (f x)) > > -- Definition of 'generalize' in reverse > = do x <- generalize m > generalize (f x) -} {- $interleave You can combine 'hoist' and 'lift' to insert arbitrary layers anywhere within a monad transformer stack. This comes in handy when interleaving two diverse stacks. For example, we might want to combine the following @save@ function: > import Control.Monad.Trans.Writer > > -- i.e. :: StateT Int (WriterT [Int] Identity) () > save :: StateT Int (Writer [Int]) () > save = do > n <- get > lift $ tell [n] ... with our previous @tock@ function: > tock :: StateT Int IO () However, @save@ and @tock@ differ in two ways: * @tock@ lacks a 'W.WriterT' layer * @save@ has an 'Identity' base monad We can mix the two by inserting a 'W.WriterT' layer for @tock@ and generalizing @save@'s base monad: > import Control.Monad > > program :: StateT Int (WriterT [Int] IO) () > program = replicateM_ 4 $ do > hoist lift tock > :: (MonadTrans t) => StateT Int (t IO) () > hoist (hoist generalize) save > :: (Monad m) => StateT Int (WriterT [Int] m ) () >>> execWriterT (runStateT program 0) Tock! Tock! Tock! Tock! [1,2,3,4] -} {- $embed Suppose we decided to @check@ all 'IOException's using a combination of 'try' and 'ErrorT': > import Control.Exception > import Control.Monad.Trans.Class > import Control.Monad.Trans.Error > > check :: IO a -> ErrorT IOException IO a > check io = ErrorT (try io) ... but then we forget to use @check@ in one spot, mistakenly using 'lift' instead: > program :: ErrorT IOException IO () > program = do > str <- lift $ readFile "test.txt" > check $ putStr str >>> runErrorT program *** Exception: test.txt: openFile: does not exist (No such file or directory) How could we go back and fix 'program' without modifying its source code? Well, @check@ is a monad morphism, but we can't 'hoist' it to modify the base monad because then we get two 'E.ErrorT' layers instead of one: > hoist check :: (MFunctor t) => t IO a -> t (ErrorT IOException IO) a > > hoist check program :: ErrorT IOException (ErrorT IOException IO) () We'd prefer to 'embed' all newly generated exceptions in the existing 'E.ErrorT' layer: > embed check :: ErrorT IOException IO a -> ErrorT IOException IO a > > embed check program :: ErrorT IOException IO () This correctly checks the exceptions that slipped through the cracks: >>> import Control.Monad.Morph >>> runErrorT (embed check program) Left test.txt: openFile: does not exist (No such file or directory) -} mmorph-1.0.6/src/Control/Monad/Trans/0000755000000000000000000000000012654306052015545 5ustar0000000000000000mmorph-1.0.6/src/Control/Monad/Trans/Compose.hs0000644000000000000000000001031512654306052017506 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-| Composition of monad transformers. A higher-order version of "Data.Functor.Compose". -} module Control.Monad.Trans.Compose ( -- * ComposeT ComposeT(ComposeT, getComposeT), mapComposeT ) where import Control.Applicative ( Applicative(pure, (<*>), (*>), (<*)), Alternative(empty, (<|>)) ) import Control.Monad (MonadPlus(mzero, mplus), liftM) import Control.Monad.Cont.Class (MonadCont(callCC)) import Control.Monad.Error.Class (MonadError(throwError, catchError)) import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.RWS.Class (MonadRWS) import Control.Monad.Reader.Class (MonadReader(ask, local, reader)) import Control.Monad.State.Class (MonadState(get, put, state)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Writer.Class (MonadWriter(writer, tell, listen, pass)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Foldable (Foldable(fold, foldMap, foldr, foldl, foldr1, foldl1)) import Data.Traversable (Traversable(traverse, sequenceA, mapM, sequence)) import Prelude hiding (foldr, foldl, foldr1, foldl1, mapM, sequence) infixr 9 `ComposeT` -- | Composition of monad transformers. newtype ComposeT (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) m a = ComposeT { getComposeT :: f (g m) a } deriving (Eq, Ord, Read, Show) instance (MFunctor f, MonadTrans f, MonadTrans g) => MonadTrans (ComposeT f g) where lift = ComposeT . hoist lift . lift instance Functor (f (g m)) => Functor (ComposeT f g m) where fmap f (ComposeT m) = ComposeT (fmap f m) instance Applicative (f (g m)) => Applicative (ComposeT f g m) where pure a = ComposeT (pure a) ComposeT f <*> ComposeT a = ComposeT (f <*> a) ComposeT a *> ComposeT b = ComposeT (a *> b) ComposeT a <* ComposeT b = ComposeT (a <* b) instance Alternative (f (g m)) => Alternative (ComposeT f g m) where empty = ComposeT empty ComposeT a <|> ComposeT b = ComposeT (a <|> b) instance Monad (f (g m)) => Monad (ComposeT f g m) where return a = ComposeT (return a) m >>= f = ComposeT (getComposeT m >>= \x -> getComposeT (f x)) fail e = ComposeT (fail e) instance MonadPlus (f (g m)) => MonadPlus (ComposeT f g m) where mzero = ComposeT mzero ComposeT a `mplus` ComposeT b = ComposeT (a `mplus` b) instance MonadIO (f (g m)) => MonadIO (ComposeT f g m) where liftIO m = ComposeT (liftIO m) instance Foldable (f (g m)) => Foldable (ComposeT f g m) where fold (ComposeT m) = fold m foldMap f (ComposeT m) = foldMap f m foldr f a (ComposeT m) = foldr f a m foldl f a (ComposeT m) = foldl f a m foldr1 f (ComposeT m) = foldr1 f m foldl1 f (ComposeT m) = foldl1 f m instance Traversable (f (g m)) => Traversable (ComposeT f g m) where traverse f (ComposeT m) = fmap ComposeT (traverse f m) sequenceA (ComposeT m) = fmap ComposeT (sequenceA m) mapM f (ComposeT m) = liftM ComposeT (mapM f m) sequence (ComposeT m) = liftM ComposeT (sequence m) instance MonadCont (f (g m)) => MonadCont (ComposeT f g m) where callCC f = ComposeT $ callCC $ \c -> getComposeT (f (ComposeT . c)) instance MonadError e (f (g m)) => MonadError e (ComposeT f g m) where throwError = ComposeT . throwError catchError m h = ComposeT $ catchError (getComposeT m) (getComposeT . h) instance MonadRWS r w s (f (g m)) => MonadRWS r w s (ComposeT f g m) instance MonadReader r (f (g m)) => MonadReader r (ComposeT f g m) where ask = ComposeT ask local = mapComposeT . local reader = ComposeT . reader instance MonadState s (f (g m)) => MonadState s (ComposeT f g m) where get = ComposeT get put = ComposeT . put state = ComposeT . state instance MonadWriter w (f (g m)) => MonadWriter w (ComposeT f g m) where writer = ComposeT . writer tell = ComposeT . tell listen = mapComposeT listen pass = mapComposeT pass -- | Transform the computation inside a 'ComposeT'. mapComposeT :: (f (g m) a -> p (q n) b) -> ComposeT f g m a -> ComposeT p q n b mapComposeT f = ComposeT . f . getComposeT