control-monad-free-0.6.1/0000755000000000000000000000000012460274222013400 5ustar0000000000000000control-monad-free-0.6.1/control-monad-free.cabal0000644000000000000000000000222512460274222020060 0ustar0000000000000000name: control-monad-free version: 0.6.1 Cabal-Version: >= 1.6 build-type: Simple license: PublicDomain author: Luke Palmer, Pepe Iborra maintainer: pepeiborra@gmail.com homepage: http://github.com/pepeiborra/control-monad-free description: This package provides datatypes to construct Free monads, Free monad transformers, and useful instances. In addition it provides the constructs to avoid quadratic complexity of left associative bind, as explained in: . * Janis Voigtlander, /Asymptotic Improvement of Computations over Free Monads, MPC'08/ synopsis: Free monads and monad transformers category: Control, Monads stability: experimental tested-with: GHC >= 6.8 source-repository head type: git location: git://github.com/pepeiborra/control-monad-free Library buildable: True build-depends: base >= 2 && < 5, transformers, prelude-extras extensions: StandaloneDeriving, Rank2Types, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, OverlappingInstances exposed-modules: Control.Monad.Free Control.Monad.Free.Zip Control.Monad.Free.Improve control-monad-free-0.6.1/Setup.hs0000644000000000000000000000005612460274222015035 0ustar0000000000000000import Distribution.Simple main = defaultMain control-monad-free-0.6.1/Control/0000755000000000000000000000000012460274222015020 5ustar0000000000000000control-monad-free-0.6.1/Control/Monad/0000755000000000000000000000000012460274222016056 5ustar0000000000000000control-monad-free-0.6.1/Control/Monad/Free.hs0000644000000000000000000001571212460274222017301 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} module Control.Monad.Free ( module Control.Monad, -- * Free Monads MonadFree(..), Free(..), isPure, isImpure, foldFree, evalFree, mapFree, mapFreeM, mapFreeM', -- * Monad Morphisms foldFreeM, induce, -- * Free Monad Transformers FreeT(..), foldFreeT, foldFreeT', mapFreeT, foldFreeA, mapFreeA, -- * Translate between Free monad and Free monad transformer computations trans, trans', untrans,liftFree ) where import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Foldable import Data.Traversable as T import Data.Typeable (Typeable) import GHC.Generics (Generic) import Prelude.Extras -- | This type class generalizes over encodings of Free Monads. class (Functor f, Monad m) => MonadFree f m where free :: m a -> m (Either a (f (m a))) -- ^ 'Opens' a computation and allows to observe the side effects wrap :: f (m a) -> m a -- ^ Wraps a side effect into a monadic computation instance Functor f => MonadFree f (Free f) where free = evalFree (Pure . Left) (Pure . Right) wrap = Impure data Free f a = Impure (f (Free f a)) | Pure a deriving (Generic, Typeable) instance (Eq1 f) => Eq1 (Free f) where (==#) = (==) instance (Eq a, Eq1 f) => Eq (Free f a) where Pure a == Pure b = a == b Impure a == Impure b = a ==# b _ == _ = False instance Ord1 f => Ord1 (Free f) where compare1 = compare instance (Ord a, Ord1 f) => Ord (Free f a) where compare Impure{} Pure{} = LT compare Pure{} Impure{} = GT compare (Pure a) (Pure b) = compare a b compare (Impure a) (Impure b) = compare1 a b instance (Show a, Show1 f) => Show (Free f a) where showsPrec p (Pure a) = showParen (p > 0) $ ("Pure " ++) . showsPrec 11 a showsPrec p (Impure a) = showParen (p > 0) $ ("Impure " ++) . showsPrec1 11 a instance Functor f => Functor (Free f) where fmap f (Pure a) = Pure (f a) fmap f (Impure fa) = Impure (fmap (fmap f) fa) instance (Functor f, Foldable f) => Foldable (Free f) where foldMap f (Pure a) = f a foldMap f (Impure fa) = fold $ fmap (foldMap f) fa instance Traversable f => Traversable (Free f) where traverse f (Pure a) = Pure <$> f a traverse f (Impure a) = Impure <$> traverse (traverse f) a instance Functor f => Monad (Free f) where return = Pure Pure a >>= f = f a Impure fa >>= f = Impure (fmap (>>= f) fa) instance Functor f => Applicative (Free f) where pure = Pure Pure f <*> x = fmap f x Impure f <*> x = Impure (fmap (<*> x) f) isPure Pure{} = True; isPure _ = False isImpure = not . isPure foldFree :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b foldFree pure _ (Pure x) = pure x foldFree pure imp (Impure x) = imp (fmap (foldFree pure imp) x) foldFreeM :: (Traversable f, Monad m) => (a -> m b) -> (f b -> m b) -> Free f a -> m b foldFreeM pure _ (Pure x) = pure x foldFreeM pure imp (Impure x) = imp =<< T.mapM (foldFreeM pure imp) x foldFreeA :: (Traversable f, Applicative m) => (a -> m b) -> m (f b -> b) -> Free f a -> m b foldFreeA pure _ (Pure x) = pure x foldFreeA pure imp (Impure x) = imp <*> traverse (foldFreeA pure imp) x induce :: (Functor f, Monad m) => (forall a. f a -> m a) -> Free f a -> m a induce f = foldFree return (join . f) evalFree :: (a -> b) -> (f(Free f a) -> b) -> Free f a -> b evalFree p _ (Pure x) = p x evalFree _ i (Impure x) = i x mapFree :: (Functor f, Functor g) => (f (Free g a) -> g (Free g a)) -> Free f a -> Free g a mapFree eta = foldFree Pure (Impure . eta) mapFreeM :: (Traversable f, Functor g, Monad m) => (f (Free g a) -> m(g (Free g a))) -> Free f a -> m(Free g a) mapFreeM eta = foldFreeM (return . Pure) (liftM Impure . eta) mapFreeA :: (Traversable f, Functor g, Applicative m) => m (f (Free g a) -> g (Free g a)) -> Free f a -> m(Free g a) mapFreeA eta = foldFreeA (pure . Pure) (liftA (Impure .) eta) mapFreeM' :: (Functor f, Traversable g, Monad m) => (forall a. f a -> m(g a)) -> Free f a -> m(Free g a) mapFreeM' eta = foldFree (return . Pure) (liftM Impure . join . liftM T.sequence . eta) -- * Monad Transformer -- (built upon Luke Palmer control-monad-free hackage package) newtype FreeT f m a = FreeT { unFreeT :: m (Either a (f (FreeT f m a))) } instance (Traversable m, Traversable f) => Foldable (FreeT f m) where foldMap = foldMapDefault instance (Traversable m, Traversable f) => Traversable (FreeT f m) where traverse f (FreeT a) = FreeT <$> ( traverse f' a) where f' (Left x) = Left <$> f x f' (Right x) = Right <$> (traverse.traverse) f x editEither l r = either (Left . l) (Right . r) conj f = FreeT . f . unFreeT instance (Functor f, Functor m) => Functor (FreeT f m) where fmap f = conj $ fmap (editEither f ((fmap.fmap) f)) instance (Functor f, Functor a, Monad a) => Applicative (FreeT f a) where pure = FreeT . return . Left (<*>) = ap instance (Functor f, Monad m) => Monad (FreeT f m) where return = FreeT . return . Left m >>= f = FreeT $ unFreeT m >>= \r -> case r of Left x -> unFreeT $ f x Right xc -> return . Right $ fmap (>>= f) xc instance (Functor f, Monad m) => MonadFree f (FreeT f m) where wrap = FreeT . return . Right free = lift . unFreeT instance (Functor f) => MonadTrans (FreeT f) where lift = FreeT . liftM Left instance (Functor f, Monad m, MonadIO m) => MonadIO (FreeT f m) where liftIO = lift . liftIO instance (Functor f, Monad m, MonadPlus m) => MonadPlus (FreeT f m) where mzero = lift mzero mplus a b = FreeT (mplus (unFreeT a) (unFreeT b)) instance (Functor f, Functor m, Monad m, MonadPlus m) => Alternative (FreeT f m) where empty = mzero (<|>) = mplus foldFreeT :: (Traversable f, Monad m) => (a -> m b) -> (f b -> m b) -> FreeT f m a -> m b foldFreeT p i m = unFreeT m >>= \r -> case r of Left x -> p x Right fx -> T.mapM (foldFreeT p i) fx >>= i foldFreeT' :: (Traversable f, Monad m) => (a -> b) -> (f b -> b) -> FreeT f m a -> m b foldFreeT' p i (FreeT m) = m >>= f where f (Left x) = return (p x) f (Right fx) = i `liftM` T.mapM (foldFreeT' p i) fx mapFreeT :: (Functor f, Functor m) => (forall a. m a -> m' a) -> FreeT f m a -> FreeT f m' a mapFreeT f (FreeT m) = FreeT (f ((fmap.fmap.fmap) (mapFreeT f) m)) untrans :: (Traversable f, Monad m) => FreeT f m a -> m(Free f a) untrans = foldFreeT (return . Pure) (return . Impure) trans :: MonadFree f m => Free f a -> m a trans = foldFree return wrap trans' :: (Functor f, Monad m) => m(Free f a) -> FreeT f m a trans' = FreeT . join . liftM unFreeT . liftM trans liftFree :: (Functor f, Monad m) => (a -> Free f b) -> (a -> FreeT f m b) liftFree f = trans . f control-monad-free-0.6.1/Control/Monad/Free/0000755000000000000000000000000012460274222016737 5ustar0000000000000000control-monad-free-0.6.1/Control/Monad/Free/Improve.hs0000644000000000000000000000325012460274222020714 0ustar0000000000000000{- | Naive Free monads suffer from a quadratic complexity, as explained in * Janis Voigtlander, /Asymptotic Improvement of Computations over Free Monads, MPC'08/ The solution is to redefine the Free datatype in CPS, similar to what is done in difference lists to solve the problem on quadratic append for lists. -} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} module Control.Monad.Free.Improve ( C(..), rep, improve ) where import Control.Applicative import Control.Monad import Control.Monad.Free import Control.Monad.Trans.Class newtype C mu a = C (forall b. (a -> mu b) -> mu b) rep :: Monad mu => mu a -> C mu a rep m = C (m >>=) improve :: Monad mu => C mu a -> mu a improve (C p) = p return instance Functor (C mu) where fmap f (C m) = C (\h -> m (h.f)) -- fmap f (C m) = C (m . (.f)) instance Monad (C mu) where return a = C (\h -> h a) C p >>= k = C (\h -> p (\a -> case k a of C q -> q h)) instance Applicative (C mu) where pure = return (<*>) = ap instance Functor f => MonadFree f (C (Free f)) where wrap t = C (\h -> wrap (fmap (\(C p) -> p h) t)) free = rep . (fmap.fmap.fmap) rep . free . improve instance (Monad m, Functor f) => MonadFree f (C (FreeT f m)) where wrap t = C (\h -> wrap (fmap (\(C p) -> p h) t)) free = rep . (liftM.fmap.fmap) rep . free . improve instance MonadPlus mu => MonadPlus (C mu) where mzero = rep mzero mplus p1 p2 = rep (mplus (improve p1) (improve p2)) instance MonadPlus mu => Alternative (C mu) where empty = mzero (<|>) = mplus instance MonadTrans C where lift m = C (m >>=) control-monad-free-0.6.1/Control/Monad/Free/Zip.hs0000644000000000000000000000217612460274222020043 0ustar0000000000000000{-# LANGUAGE CPP #-} module Control.Monad.Free.Zip (zipFree, zipFree_) where import Control.Monad.Free import Control.Monad.Trans.Class import Control.Monad.Trans.State import Data.Foldable import Data.Traversable as T zipFree :: (Traversable f, Eq (f ()), Monad m) => (Free f a -> Free f b -> m (Free f c)) -> Free f a -> Free f b -> m (Free f c) zipFree f m1@(Impure a) m2@(Impure b) | fmap (const ()) a == fmap (const ()) b = Impure `liftM` unsafeZipWithG f a b zipFree _ _ _ = fail "zipFree: structure mistmatch" zipFree_ :: (Traversable f, Eq (f ()), Monad m) => (Free f a -> Free f b -> m ()) -> Free f a -> Free f b -> m () zipFree_ f m1@(Impure a) m2@(Impure b) | fmap (const ()) a == fmap (const ()) b = zipWithM_ f (toList a) (toList b) zipFree_ _ _ _ = fail "zipFree_: structure mismatch" unsafeZipWithG :: (Traversable t1, Traversable t2, Monad m) => (a -> b -> m c) -> t1 a -> t2 b -> m(t2 c) unsafeZipWithG f t1 t2 = evalStateT (T.mapM zipG' t2) (toList t1) where zipG' y = do (x:xx) <- get put xx lift (f x y)