control-monad-free 0.3 → 0.4

raw patch · 7 files changed

+230/−50 lines, 7 filessetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/Free.hs +128/−0
• Control/Monad/Free/Improve.hs +45/−0
• Control/Monad/Free/Zip.hs +25/−0
• Control/Monad/FreeT.hs +0/−35
• Setup.hs +0/−2
• Setup.lhs +3/−0
• control-monad-free.cabal +29/−13

@@ -0,0 +1,128 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++module Control.Monad.Free (+   module Control.Monad,+-- * Free Monads+   MonadFree(..),+   Free(..),+   foldFree, foldFreeM,+   evalFree, mapFree,+-- * Free Monad Transformers+   FreeT(..),+   foldFreeT, foldFreeT', mapFreeT,+-- * Translate between Free monad and Free monad transformer computations+   trans, trans', untrans,liftFree+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.Foldable+import Data.Monoid+import Data.Traversable as T+import Prelude hiding (abs)++-- | 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 instance (Eq a, Eq (f(Free f a))) => Eq (Free f a)+deriving instance (Ord a, Ord (f(Free f a))) => Ord (Free f a)+deriving instance (Show a, Show (f(Free f a))) => Show (Free f 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)++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 :: (Functor f, 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++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) => (forall a. f a -> g a) -> Free f a -> Free g a+mapFree eta (Pure a)   = Pure a+mapFree eta (Impure x) = Impure (fmap (mapFree eta) (eta x))++-- * 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, 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) => MonadTrans (FreeT f) where+    lift = FreeT . liftM Left++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 :: (Functor f, Monad m) => Free f a -> FreeT f m a+trans  = FreeT . foldFree (return . Left) (return . Right . fmap FreeT)++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

@@ -0,0 +1,45 @@+{- |+  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 #-}++module Control.Monad.Free.Improve (+   C(..), rep, improve+  ) where++import Control.Monad+import Control.Monad.Free+++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 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 MonadPlus mu => MonadPlus (C mu) where+    mzero       = rep mzero+    mplus p1 p2 = rep (mplus (improve p1) (improve p2))

@@ -0,0 +1,25 @@+module Control.Monad.Free.Zip (zipFree, zipFree_) where++import Control.Monad.Free+import Control.Monad.State+import Data.Foldable+import Data.Traversable as T++zipFree :: (Traversable f, Eq (f ()), Monad m) => (a -> b -> m c) -> Free f a -> Free f b -> m (Free f c)+zipFree f (Pure a) (Pure b) = Pure `liftM` f a b+zipFree f m1@(Impure a) m2@(Impure b)+      | fmap (const ()) a == fmap (const ()) b = Impure `liftM` unsafeZipWithG (zipFree f) a b+zipFree _ _ _ = fail "zipFree: not the same structure"++zipFree_ :: (Traversable f, Eq (f ()), Monad m) => (a -> b -> m ()) -> Free f a -> Free f b -> m ()+zipFree_ f (Pure a) (Pure b) = f a b+zipFree_ f m1@(Impure a) m2@(Impure b)+      | fmap (const ()) a == fmap (const ()) b = zipWithM_ (zipFree_ f) (toList a) (toList b)+zipFree_ _ _ _ = fail "zipFree: not the same structure"+++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)

@@ -1,35 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Control.Monad.FreeT (FreeT(..), MonadFree(..)) where--import Control.Applicative-import Control.Monad (liftM)-import Control.Monad.Trans--{- | @FreeT f@ is a monad transformer for free monads over a functor @f@. --}-newtype FreeT f m a = FreeT { runFreeT :: m (Either a (f (FreeT f m a))) }--editEither l r = either (Left . l) (Right . r)-conj f = FreeT . f . runFreeT--instance (Functor f, Functor m) => Functor (FreeT f m) where-    fmap f = conj $ fmap (editEither f ((fmap.fmap) f))--instance (Functor f, Monad m) => Monad (FreeT f m) where-    return = FreeT . return . Left-    m >>= f = FreeT $ do-        r <- runFreeT m-        case r of-             Left x   -> runFreeT $ f x-             Right xc -> return . Right $ fmap (>>= f) xc--instance (Functor f) => MonadTrans (FreeT f) where-    lift = FreeT . liftM Left---class (Functor f, Monad m) => MonadFree f m where-    free :: m a -> m (Either a (f (m a)))--instance (Functor f, Monad m) => MonadFree f (FreeT f m) where-    free = lift . runFreeT

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -1,13 +1,29 @@-Name: control-monad-free-Description:-    A monad transformer for free monads.-Version: 0.3-Stability: experimental-Synopsis: A monad transformer for free monads.-License: PublicDomain-Category: Control-Author: Luke Palmer-Maintainer: lrpalmer@gmail.com-Build-Type: Simple-Build-Depends: base, mtl-Exposed-Modules: Control.Monad.FreeT+name: control-monad-free+version: 0.4+Cabal-Version:  >= 1.2.3+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+++Library+  buildable: True+  build-depends: base, mtl+  extensions:  StandaloneDeriving, Rank2Types, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances+  exposed-modules:+     Control.Monad.Free+     Control.Monad.Free.Zip+     Control.Monad.Free.Improve