free 4.1 → 4.2
raw patch · 6 files changed
+443/−4 lines, 6 files
Files
- CHANGELOG.markdown +8/−0
- free.cabal +6/−4
- src/Control/Applicative/Free.hs +5/−0
- src/Control/Comonad/Trans/Coiter.hs +120/−0
- src/Control/Monad/Free/Class.hs +22/−0
- src/Control/Monad/Trans/Iter.hs +282/−0
CHANGELOG.markdown view
@@ -1,3 +1,11 @@+4.2+-----+* Added `Control.Monad.Trans.Iter` and `Control.Comonad.Trans.Coiter`.++4.1.1+-----+* Added a default signature to `wrap`, based on a construction by @fizruk.+ 4.0 --- * Updated to work with `semigroupoids` and `comonad` 4.0
free.cabal view
@@ -1,6 +1,6 @@ name: free category: Control, Monads-version: 4.1+version: 4.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -68,13 +68,15 @@ exposed-modules: Control.Applicative.Free Control.Alternative.Free+ Control.Comonad.Cofree+ Control.Comonad.Cofree.Class+ Control.Comonad.Trans.Cofree+ Control.Comonad.Trans.Coiter Control.Monad.Free Control.Monad.Free.Church Control.Monad.Free.Class Control.Monad.Trans.Free+ Control.Monad.Trans.Iter Control.MonadPlus.Free- Control.Comonad.Cofree- Control.Comonad.Cofree.Class- Control.Comonad.Trans.Cofree ghc-options: -Wall
src/Control/Applicative/Free.hs view
@@ -22,6 +22,7 @@ , runAp , liftAp , hoistAp+ , retractAp ) where import Control.Applicative@@ -66,6 +67,10 @@ hoistAp :: (forall a. f a -> g a) -> Ap f b -> Ap g b hoistAp _ (Pure a) = Pure a hoistAp f (Ap x y) = Ap (f x) (hoistAp f y)++retractAp :: Applicative f => Ap f a -> f a+retractAp (Pure a) = pure a+retractAp (Ap x y) = x <**> retractAp y #if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Ap f) where
+ src/Control/Comonad/Trans/Coiter.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Control.Comonad.Trans.Coiter+-- Copyright : (C) 2008-2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : MPTCs, fundeps+--+-- The iterative comonad generated by a comonad+----------------------------------------------------------------------------+module Control.Comonad.Trans.Coiter+ ( CoiterT(..)+ , ComonadCofree(..)+ , coiterT+ ) where++import Control.Arrow+import Control.Comonad+import Control.Comonad.Trans.Class+import Control.Comonad.Cofree.Class+import Control.Category+import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Foldable+import Data.Functor.Identity+import Data.Traversable+import Prelude hiding (id,(.))++#if defined(GHC_TYPEABLE) || __GLASGOW_HASKELL__ >= 707+import Data.Data+#endif++-- | This is the (co?)iterative comonad generated by a comonad+newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) }++instance Functor w => Functor (CoiterT w) where+ fmap f = CoiterT . fmap (bimap f (fmap f)) . runCoiterT++instance Comonad w => Comonad (CoiterT w) where+ extract = fst . extract . runCoiterT+ extend f = CoiterT . extend (\w -> (f (CoiterT w), extend f $ snd $ extract w)) . runCoiterT++instance Foldable w => Foldable (CoiterT w) where+ foldMap f = foldMap (bifoldMap f (foldMap f)) . runCoiterT++instance Traversable w => Traversable (CoiterT w) where+ traverse f = fmap CoiterT . traverse (bitraverse f (traverse f)) . runCoiterT++instance ComonadTrans CoiterT where+ lower = fmap fst . runCoiterT++instance Comonad w => ComonadCofree Identity (CoiterT w) where+ unwrap = Identity . snd . extract . runCoiterT++instance Show (w (a, CoiterT w a)) => Show (CoiterT w a) where+ showsPrec d w = showParen (d > 10) $+ showString "CoiterT " . showsPrec 11 w++instance Read (w (a, CoiterT w a)) => Read (CoiterT w a) where+ readsPrec d = readParen (d > 10) $ \r ->+ [(CoiterT w, t) | ("CoiterT", s) <- lex r, (w, t) <- readsPrec 11 s]++instance Eq (w (a, CoiterT w a)) => Eq (CoiterT w a) where+ CoiterT a == CoiterT b = a == b++instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where+ compare (CoiterT a) (CoiterT b) = compare a b++-- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed.+coiterT :: Comonad w => (w a -> a) -> w a -> CoiterT w a+coiterT psi = CoiterT . extend (extract &&& coiterT psi . extend psi)++#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707++instance Typeable1 w => Typeable1 (CoiterT w) where+ typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where+ w :: CoiterT w a -> w a+ w = undefined++coiterTTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT"+#else+coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT"+#endif+{-# NOINLINE coiterTTyCon #-}++instance+ ( Typeable1 w, Typeable a+ , Data (w (a, CoiterT w a))+ , Data a+ ) => Data (CoiterT w a) where+ gfoldl f z (CoiterT w) = z CoiterT `f` w+ toConstr _ = coiterTConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z CoiterT)+ _ -> error "gunfold"+ dataTypeOf _ = coiterTDataType+ dataCast1 f = gcast1 f++coiterTConstr :: Constr+coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix+{-# NOINLINE coiterTConstr #-}++coiterTDataType :: DataType+coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr]+{-# NOINLINE coiterTDataType #-}+#endif
src/Control/Monad/Free/Class.hs view
@@ -2,6 +2,10 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Free.Class@@ -17,9 +21,12 @@ module Control.Monad.Free.Class ( MonadFree(..) , liftF+ , wrapT ) where import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.State.Lazy as Lazy@@ -82,7 +89,15 @@ -- for a 'Functor'. class Monad m => MonadFree f m | m -> f where -- | Add a layer.+ --+ -- @+ -- wrap (fmap f x) ≡ wrap (fmap return x) >>= f+ -- @ wrap :: f (m a) -> m a+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+ default wrap :: (m ~ t n, MonadTrans t, MonadFree f n, Functor f) => f (m a) -> m a+ wrap = join . lift . wrap . fmap return+#endif instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm@@ -123,3 +138,10 @@ -- | A version of lift that can be used with just a Functor for f. liftF :: (Functor f, MonadFree f m) => f a -> m a liftF = wrap . fmap return++-- | A version of wrap for monad transformers over a free monad.+--+-- /Note:/ that this is the default implementation for 'wrap' for+-- @MonadFree f (t m)@.+wrapT :: (Functor f, MonadFree f m, MonadTrans t, Monad (t m)) => f (t m a) -> t m a+wrapT = join . lift . liftF
+ src/Control/Monad/Trans/Iter.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable #-}++#ifndef MIN_VERSION_MTL+#define MIN_VERSION_MTL(x,y,z) 1+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.Iter+-- Copyright : (C) 2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : MPTCs, fundeps+--+-- Based on <http://www.ioc.ee/~tarmo/tday-veskisilla/uustalu-slides.pdf Capretta's Iterative Monad Transformer>+--+-- Unlike 'Free', this is a true monad transformer.+----------------------------------------------------------------------------+module Control.Monad.Trans.Iter+ ( MonadFree(..)+ , IterF(..)+ , IterT(..)+ , delay+ , retract+ , iter+ , hoistIterT+ ) where++import Control.Applicative+import Control.Monad (ap, liftM, MonadPlus(..))+import Control.Monad.Fix+import Control.Monad.Trans.Class+import Control.Monad.Free.Class+import Control.Monad.State.Class+import Control.Monad.Reader.Class+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Functor.Bind+import Data.Functor.Identity+import Data.Foldable+import Data.Monoid+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Typeable++#ifdef GHC_TYPEABLE+import Data.Data+#endif++data IterF a b = Pure a | Iter b+ deriving (Eq,Ord,Show,Read,Typeable)++instance Functor (IterF a) where+ fmap _ (Pure a) = Pure a+ fmap f (Iter b) = Iter (f b)++instance Foldable (IterF a) where+ foldMap f (Iter b) = f b+ foldMap _ _ = mempty++instance Traversable (IterF a) where+ traverse _ (Pure a) = pure (Pure a)+ traverse f (Iter b) = Iter <$> f b++instance Bifunctor IterF where+ bimap f _ (Pure a) = Pure (f a)+ bimap _ g (Iter b) = Iter (g b)++instance Bifoldable IterF where+ bifoldMap f _ (Pure a) = f a+ bifoldMap _ g (Iter b) = g b++instance Bitraversable IterF where+ bitraverse f _ (Pure a) = Pure <$> f a+ bitraverse _ g (Iter b) = Iter <$> g b++iterF :: (a -> r) -> (b -> r) -> IterF a b -> r+iterF f _ (Pure a) = f a+iterF _ g (Iter b) = g b+{-# INLINE iterF #-}++-- | The monad supporting iteration based over a base monad @m@.+--+-- @+-- 'IterT' ~ 'FreeT' 'Identity'+-- @+data IterT m a = IterT { runIterT :: m (IterF a (IterT m a)) }+#if __GLASGOW_HASKELL__ >= 707+ deriving (Typeable)+#endif++instance Eq (m (IterF a (IterT m a))) => Eq (IterT m a) where+ IterT m == IterT n = m == n++instance Ord (m (IterF a (IterT m a))) => Ord (IterT m a) where+ compare (IterT m) (IterT n) = compare m n++instance Show (m (IterF a (IterT m a))) => Show (IterT m a) where+ showsPrec d (IterT m) = showParen (d > 10) $+ showString "IterT " . showsPrec 11 m++instance Read (m (IterF a (IterT m a))) => Read (IterT m a) where+ readsPrec d = readParen (d > 10) $ \r ->+ [ (IterT m,t) | ("IterT",s) <- lex r, (m,t) <- readsPrec 11 s]++instance Monad m => Functor (IterT m) where+ fmap f = IterT . liftM (bimap f (fmap f)) . runIterT+ {-# INLINE fmap #-}++instance Monad m => Applicative (IterT m) where+ pure = IterT . return . Pure+ {-# INLINE pure #-}+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad m => Monad (IterT m) where+ return = IterT . return . Pure+ {-# INLINE return #-}+ IterT m >>= k = IterT $ m >>= iterF (runIterT . k) (return . Iter . (>>= k))+ {-# INLINE (>>=) #-}+ fail = IterT . fail+ {-# INLINE fail #-}++instance Monad m => Apply (IterT m) where+ (<.>) = ap+ {-# INLINE (<.>) #-}++instance Monad m => Bind (IterT m) where+ (>>-) = (>>=)+ {-# INLINE (>>-) #-}++instance MonadFix m => MonadFix (IterT m) where+ mfix f = IterT $ mfix (runIterT . f . unPure) where+ unPure (Pure x) = x+ unPure (Iter _) = error "mfix (IterT m): Iter"+ {-# INLINE mfix #-}++instance MonadPlus m => Alternative (IterT m) where+ empty = IterT mzero+ {-# INLINE empty #-}+ IterT a <|> IterT b = IterT (mplus a b)+ {-# INLINE (<|>) #-}++instance MonadPlus m => MonadPlus (IterT m) where+ mzero = IterT mzero+ {-# INLINE mzero #-}+ IterT a `mplus` IterT b = IterT (mplus a b)+ {-# INLINE mplus #-}++-- | This is not a true monad transformer. It is only a monad transformer \"up to 'retract'\".+instance MonadTrans IterT where+ lift = IterT . liftM Pure+ {-# INLINE lift #-}++instance Foldable m => Foldable (IterT m) where+ foldMap f = foldMap (iterF f (foldMap f)) . runIterT+ {-# INLINE foldMap #-}++instance Foldable1 m => Foldable1 (IterT m) where+ foldMap1 f = foldMap1 (iterF f (foldMap1 f)) . runIterT+ {-# INLINE foldMap1 #-}++instance (Monad m, Traversable m) => Traversable (IterT m) where+ traverse f (IterT m) = IterT <$> traverse (bitraverse f (traverse f)) m+ {-# INLINE traverse #-}++instance (Monad m, Traversable1 m) => Traversable1 (IterT m) where+ traverse1 f (IterT m) = IterT <$> traverse1 go m where+ go (Pure a) = Pure <$> f a+ go (Iter a) = Iter <$> traverse1 f a+ {-# INLINE traverse1 #-}++{-+instance MonadWriter e m => MonadWriter e (IterT m) where+ tell = lift . tell+ {-# INLINE tell #-}+ listen = lift . listen . retract+ {-# INLINE listen #-}+ pass = lift . pass . retract+ {-# INLINE pass #-}+-}++instance (Functor m, MonadReader e m) => MonadReader e (IterT m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = hoistIterT (local f)+ {-# INLINE local #-}++instance (Functor m, MonadState s m) => MonadState s (IterT m) where+ get = lift get+ {-# INLINE get #-}+ put s = lift (put s)+ {-# INLINE put #-}+#if MIN_VERSION_mtl(2,1,1)+ state f = lift (state f)+ {-# INLINE state #-}+#endif++{-+instance (Functor m, MonadError e m) => MonadError e (Free m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ catchError as f = lift (catchError (retract as) (retract . f))+ {-# INLINE catchError #-}++instance (Functor m, MonadCont m) => MonadCont (Free m) where+ callCC f = lift (callCC (retract . f . liftM lift))+ {-# INLINE callCC #-}+-}++instance Monad m => MonadFree Identity (IterT m) where+ wrap = IterT . return . Iter . runIdentity+ {-# INLINE wrap #-}++delay :: (Monad f, MonadFree f m) => m a -> m a+delay = wrap . return+{-# INLINE delay #-}++-- |+-- 'retract' is the left inverse of 'lift'+--+-- @+-- 'retract' . 'lift' = 'id'+-- @+retract :: Monad m => IterT m a -> m a+retract m = runIterT m >>= iterF return retract++-- | Tear down a 'Free' 'Monad' using iteration.+iter :: Monad m => (m a -> a) -> IterT m a -> a+iter phi (IterT m) = phi (iterF id (iter phi) `liftM` m)++-- | Lift a monad homomorphism from @m@ to @n@ into a Monad homomorphism from @'IterT' m@ to @'IterT' n@.+hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b+hoistIterT f (IterT as) = IterT (fmap (hoistIterT f) `liftM` f as)++#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+instance Typeable1 m => Typeable1 (IterT m) where+ typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where+ f :: IterT m a -> m a+ f = undefined++freeTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+freeTyCon = mkTyCon "Control.Monad.Iter.IterT"+#else+freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT"+#endif+{-# NOINLINE freeTyCon #-}++instance+ ( Typeable1 m, Typeable a+ , Data (m (IterF a (IterT m a)))+ , Data a+ ) => Data (IterT m a) where+ gfoldl f z (IterT as) = z IterT `f` as+ toConstr IterT{} = iterConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z IterT)+ _ -> error "gunfold"+ dataTypeOf _ = iterDataType+ dataCast1 f = gcast1 f++iterConstr :: Constr+iterConstr = mkConstr iterDataType "IterT" [] Prefix+{-# NOINLINE iterConstr #-}++iterDataType :: DataType+iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr]+{-# NOINLINE iterDataType #-}++#endif