free 4.4 → 4.5
raw patch · 8 files changed
+483/−9 lines, 8 filesdep +template-haskell
Dependencies added: template-haskell
Files
- CHANGELOG.markdown +5/−0
- free.cabal +5/−2
- src/Control/Comonad/Cofree.hs +9/−7
- src/Control/Monad/Free/Church.hs +6/−0
- src/Control/Monad/Free/TH.hs +186/−0
- src/Control/Monad/Trans/Free.hs +52/−0
- src/Control/Monad/Trans/Free/Church.hs +201/−0
- src/Control/Monad/Trans/Iter.hs +19/−0
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+4.5+-----+* Added `Control.Monad.Free.TH` with `makeFree` to make it easier to write free monads.+* Added missing instances for `MonadFix` and `MonadCont` where appropriate.+ 4.2 ----- * Added `Control.Monad.Trans.Iter` and `Control.Comonad.Trans.Coiter`.
free.cabal view
@@ -1,6 +1,6 @@ name: free category: Control, Monads-version: 4.4+version: 4.5 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -60,7 +60,8 @@ profunctors == 4.*, semigroupoids == 4.*, semigroups >= 0.8.3.1 && < 1,- transformers >= 0.2.0 && < 0.4+ transformers >= 0.2.0 && < 0.4,+ template-haskell >= 2.7.0.0 && < 3 if impl(ghc) cpp-options: -DGHC_TYPEABLE@@ -75,7 +76,9 @@ Control.Monad.Free Control.Monad.Free.Church Control.Monad.Free.Class+ Control.Monad.Free.TH Control.Monad.Trans.Free+ Control.Monad.Trans.Free.Church Control.Monad.Trans.Iter Control.MonadPlus.Free
src/Control/Comonad/Cofree.hs view
@@ -39,6 +39,8 @@ import Control.Comonad.Store.Class as Class import Control.Comonad.Traced.Class import Control.Category+import Control.Monad(ap)+import Control.Monad.Zip import Data.Functor.Bind import Data.Functor.Extend import Data.Distributive@@ -135,6 +137,9 @@ (a :< m) >>= k = case k a of b :< n -> b :< (n <|> fmap (>>= k) m) +instance (Alternative f, MonadZip f) => MonadZip (Cofree f) where+ mzip (a :< as) (b :< bs) = (a, b) :< fmap (uncurry mzip) (mzip as bs)+ -- | -- -- @'lower' . 'section' = 'id'@@@ -157,14 +162,11 @@ (_ :< fs) @> (a :< as) = a :< (( @>) <$> fs <@> as) {-# INLINE (@>) #-} -instance Applicative f => Applicative (Cofree f) where- pure a = as where as = a :< pure as- (f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as)+instance Alternative f => Applicative (Cofree f) where+ pure = return+ {-# INLINE pure #-}+ (<*>) = ap {-# INLINE (<*>) #-}- (f :< fs) <* (_ :< as) = f :< ((<* ) <$> fs <*> as)- {-# INLINE (<*) #-}- (_ :< fs) *> (a :< as) = a :< (( *>) <$> fs <*> as)- {-# INLINE (*>) #-} instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where showsPrec d (a :< as) = showParen (d > 5) $
src/Control/Monad/Free/Church.hs view
@@ -32,6 +32,7 @@ import Control.Applicative import Control.Monad as Monad+import Control.Monad.Fix import Control.Monad.Free hiding (retract, iterM) import Control.Monad.Reader.Class import Control.Monad.Writer.Class@@ -71,6 +72,11 @@ instance Monad (F f) where return a = F (\kp _ -> kp a) F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)++instance MonadFix (F f) where+ mfix f = a where+ a = f (impure a)+ impure (F x) = x id (error "MonadFix (F f): wrap") instance MonadPlus f => MonadPlus (F f) where mzero = F (\_ kf -> kf mzero)
+ src/Control/Monad/Free/TH.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Trans.TH+-- Copyright : (C) 2008-2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : MPTCs, fundeps+--+-- Automatic generation of free monadic actions.+--+----------------------------------------------------------------------------+module Control.Monad.Free.TH+ ( makeFree+ ) where++import Control.Arrow+import Control.Applicative+import Control.Monad+import Data.Char (toLower)+import Language.Haskell.TH++data Arg+ = Captured Type Exp+ | Param Type+ deriving (Show)++params :: [Arg] -> [Type]+params [] = []+params (Param t : xs) = t : params xs+params (_ : xs) = params xs++captured :: [Arg] -> [(Type, Exp)]+captured [] = []+captured (Captured t e : xs) = (t, e) : captured xs+captured (_ : xs) = captured xs++zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp]+zipExprs (p:ps) cs (Param _ : as) = p : zipExprs ps cs as+zipExprs ps (c:cs) (Captured _ _ : as) = c : zipExprs ps cs as+zipExprs _ _ _ = []++tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name++findTypeOrFail :: String -> Q Name+findTypeOrFail s = lookupTypeName s >>= maybe (fail $ s ++ " is not in scope") return++findValueOrFail :: String -> Q Name+findValueOrFail s = lookupValueName s >>= maybe (fail $ s ++ "is not in scope") return++-- | Pick a name for an operation.+-- For normal constructors it lowers first letter.+-- For infix ones it omits the first @:@.+mkOpName :: String -> Q String+mkOpName (':':name) = return name+mkOpName ( c :name) = return $ toLower c : name+mkOpName _ = fail "null constructor name"++-- | Check if parameter is used in type.+usesTV :: Name -> Type -> Bool+usesTV n (VarT name) = n == name+usesTV n (AppT t1 t2) = any (usesTV n) [t1, t2]+usesTV n (SigT t _ ) = usesTV n t+usesTV n (ForallT bs _ t) = usesTV n t && n `notElem` map tyVarBndrName bs+usesTV _ _ = False++-- | Analyze constructor argument.+mkArg :: Name -> Type -> Q Arg+mkArg n t+ | usesTV n t =+ case t of+ -- if parameter is used as is, the return type should be ()+ -- as well as the corresponding expression+ VarT _ -> return $ Captured (TupleT 0) (TupE [])+ -- if argument is of type (a1 -> ... -> aN -> param) then the+ -- return type is N-tuple (a1, ..., aN) and the corresponding+ -- expression is an N-tuple secion (,...,).+ AppT (AppT ArrowT _) _ -> do+ (ts, name) <- arrowsToTuple t+ when (name /= n) $ fail "return type is not the parameter"+ let tup = foldl AppT (TupleT $ length ts) ts+ xs <- mapM (const $ newName "x") ts+ return $ Captured tup (LamE (map VarP xs) (TupE (map VarE xs)))+ _ -> fail "don't know how to make Arg"+ | otherwise = return $ Param t+ where+ arrowsToTuple (AppT (AppT ArrowT t1) (VarT name)) = return ([t1], name)+ arrowsToTuple (AppT (AppT ArrowT t1) t2) = do+ (ts, name) <- arrowsToTuple t2+ return (t1:ts, name)+ arrowsToTuple _ = fail "return type is not a variable"++-- | Apply transformation to the return value independently of how many+-- parameters does @e@ have.+-- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to+-- @\x y z -> Just (x + y * z)@+mapRet :: (Exp -> Exp) -> Exp -> Exp+mapRet f (LamE ps e) = LamE ps $ mapRet f e+mapRet f e = f e++-- | Unification of two types.+-- @next@ with @a -> next@ gives @Maybe a@ return type+-- @a -> next@ with @b -> next@ gives @Either a b@ return type+unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])+unifyT (TupleT 0, _) (TupleT 0, _) = fail "can't accept 2 mere parameters"+unifyT (TupleT 0, _) (t, e) = do+ maybe' <- ConT <$> findTypeOrFail "Maybe"+ nothing' <- ConE <$> findValueOrFail "Nothing"+ just' <- ConE <$> findValueOrFail "Just"+ return $ (AppT maybe' t, [nothing', mapRet (AppE just') e])+unifyT x y@(TupleT 0, _) = second reverse <$> unifyT y x+unifyT (t1, e1) (t2, e2) = do+ either' <- ConT <$> findTypeOrFail "Either"+ left' <- ConE <$> findValueOrFail "Left"+ right' <- ConE <$> findValueOrFail "Right"+ return $ (AppT (AppT either' t1) t2, [mapRet (AppE left') e1, mapRet (AppE right') e2])++-- | Unifying a list of types (possibly refining expressions).+-- Name is used when the return type is supposed to be arbitrary.+unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp])+unifyCaptured a [] = return (VarT a, [])+unifyCaptured _ [(t, e)] = return (t, [e])+unifyCaptured _ [x, y] = unifyT x y+unifyCaptured _ _ = fail "can't unify more than 2 arguments that use type parameter"++liftCon' :: Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]+liftCon' f n ns cn ts = do+ -- prepare some names+ opName <- mkName <$> mkOpName (nameBase cn)+ m <- newName "m"+ a <- newName "a"+ monadFree <- findTypeOrFail "MonadFree"+ liftF <- findValueOrFail "liftF"+ -- look at the constructor parameters+ args <- mapM (mkArg n) ts+ let ps = params args -- these are not using type parameter+ cs = captured args -- these capture it somehow+ -- based on cs we get return type and refined expressions+ -- (e.g. with Nothing/Just or Left/Right tags)+ (retType, es) <- unifyCaptured a cs+ -- operation type is (a1 -> a2 -> ... -> aN -> m r)+ let opType = foldr (AppT . AppT ArrowT) (AppT (VarT m) retType) ps+ -- picking names for the implementation+ xs <- mapM (const $ newName "p") ps+ let pat = map VarP xs -- this is LHS+ exprs = zipExprs (map VarE xs) es args -- this is what ctor would be applied to+ fval = foldl AppE (ConE cn) exprs -- this is RHS without liftF+ q = map PlainTV $ qa ++ m : ns+ qa = case retType of VarT b | a == b -> [a]; _ -> []+ f' = foldl AppT f (map VarT ns)+ return $+ [ SigD opName (ForallT q [ClassP monadFree [f', VarT m]] opType)+ , FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ]++-- | Provide free monadic actions for a single value constructor.+liftCon :: Type -> Name -> [Name] -> Con -> Q [Dec]+liftCon f n ns con =+ case con of+ NormalC cName fields -> liftCon' f n ns cName $ map snd fields+ RecC cName fields -> liftCon' f n ns cName $ map (\(_, _, ty) -> ty) fields+ _ -> fail $ "liftCon: Don't know how to lift " ++ show con++-- | Provide free monadic actions for a type declaration.+liftDec :: Dec -> Q [Dec]+liftDec (DataD _ tyName tyVarBndrs cons _)+ | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable"+ | otherwise = concat <$> mapM (liftCon con nextTyName (init tyNames)) cons+ where+ tyNames = map tyVarBndrName tyVarBndrs+ nextTyName = last tyNames+ con = ConT tyName+liftDec dec = fail $ "liftDec: Don't know how to lift " ++ show dec++-- | @$(makeFree ''Type)@ provides free monadic actions for the+-- constructors of the given type.+makeFree :: Name -> Q [Dec]+makeFree tyCon = do+ info <- reify tyCon+ case info of+ TyConI dec -> liftDec dec+ _ -> fail "makeFree expects a type constructor"+
src/Control/Monad/Trans/Free.hs view
@@ -34,6 +34,10 @@ , iterT , hoistFreeT , transFreeT+ -- * Operations of free monad+ , retract+ , iter+ , iterM -- * Free Monads With Class , MonadFree(..) ) where@@ -43,6 +47,10 @@ import Control.Monad.Trans.Class import Control.Monad.Free.Class import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class import Data.Monoid import Data.Foldable import Data.Functor.Identity@@ -148,6 +156,30 @@ liftIO = lift . liftIO {-# INLINE liftIO #-} +instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = hoistFreeT (local f)+ {-# INLINE local #-}++instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where+ get = lift get+ {-# INLINE get #-}+ put = lift . put+ {-# INLINE put #-}+#if MIN_VERSION_mtl(2,1,1)+ state f = lift (state f)+ {-# INLINE state #-}+#endif++instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ FreeT m `catchError` f = FreeT $ (liftM (fmap (`catchError` f)) m) `catchError` (runFreeT . f)++instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where+ callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))+ instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where empty = FreeT mzero FreeT ma <|> FreeT mb = FreeT (mplus ma mb)@@ -186,6 +218,26 @@ -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g n@ transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT++-- |+-- 'retract' is the left inverse of 'liftF'+--+-- @+-- 'retract' . 'liftF' = 'id'+-- @+retract :: Monad f => Free f a -> f a+retract m =+ case runIdentity (runFreeT m) of+ Pure a -> return a+ Free as -> as >>= retract++-- | Tear down a 'Free' 'Monad' using iteration.+iter :: Functor f => (f a -> a) -> Free f a -> a+iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)++-- | Like 'iter' for monadic values.+iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a+iterM phi = iterT phi . hoistFreeT (return . runIdentity) #if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable2 (FreeF f) where
+ src/Control/Monad/Trans/Free/Church.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.Trans.Free.Church+ (+ -- * The free monad transformer+ FT(..)+ -- * The free monad+ , F, free, runF+ -- * Operations+ , toFT, fromFT+ , iterT+ , hoistFT+ , transFT+ -- * Operations of free monad+ , improve+ , fromF, toF+ , retract+ , iter+ , iterM+ -- * Free Monads With Class+ , MonadFree(..)+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Control.Monad.Free.Class+import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free)+import Data.Foldable (Foldable)+import qualified Data.Foldable as F+import Data.Traversable (Traversable)+import qualified Data.Traversable as T+import Data.Monoid+import Data.Functor.Bind hiding (join)+import Data.Function++-- | The \"free monad transformer\" for a functor @f@+newtype FT f m a = FT {runFT :: forall r. (a -> m r) -> (f (m r) -> m r) -> m r}++instance (Functor f, Monad m, Eq (FreeT f m a)) => Eq (FT f m a) where+ (==) = (==) `on` fromFT++instance (Functor f, Monad m, Ord (FreeT f m a)) => Ord (FT f m a) where+ compare = compare `on` fromFT++instance Functor (FT f m) where+ fmap f (FT k) = FT $ \a fr -> k (a . f) fr++instance Apply (FT f m) where+ (<.>) = (<*>)++instance Applicative (FT f m) where+ pure a = FT $ \k _ -> k a+ FT fk <*> FT ak = FT $ \b fr -> ak (\d -> fk (\e -> b (e d)) fr) fr++instance Bind (FT f m) where+ (>>-) = (>>=)++instance Monad (FT f m) where+ return = pure+ FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr++instance (Functor f) => MonadFree f (FT f m) where+ wrap f = FT (\kp kf -> kf (fmap (\(FT m) -> m kp kf) f))++instance MonadTrans (FT f) where+ lift m = FT (\a _ -> m >>= a)++instance Alternative m => Alternative (FT f m) where+ empty = FT (\_ _ -> empty)+ FT k1 <|> FT k2 = FT $ \a fr -> k1 a fr <|> k2 a fr++instance MonadPlus m => MonadPlus (FT f m) where+ mzero = FT (\_ _ -> mzero)+ mplus (FT k1) (FT k2) = FT $ \a fr -> k1 a fr `mplus` k2 a fr++instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where+ foldMap f (FT k) = F.fold $ k (return . f) (F.foldr (liftM2 mappend) (return mempty))++instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where+ traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree+ where+ traversePure = return . fmap return . f+ traverseFree = return . fmap (wrap . fmap (join . lift)) . T.sequenceA . fmap T.sequenceA++instance (MonadIO m) => MonadIO (FT f m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance (Functor f, MonadError e m) => MonadError e (FT f m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ m `catchError` f = toFT $ fromFT m `catchError` (fromFT . f)++instance (MonadCont m) => MonadCont (FT f m) where+ callCC f = join . lift $ callCC (\k -> return $ f (lift . k . return))++instance (Functor f, MonadReader r m) => MonadReader r (FT f m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = hoistFT (local f)+ {-# INLINE local #-}++instance (Functor f, MonadState s m) => MonadState s (FT f m) where+ get = lift get+ {-# INLINE get #-}+ put = lift . put+ {-# INLINE put #-}+#if MIN_VERSION_mtl(2,1,1)+ state f = lift (state f)+ {-# INLINE state #-}+#endif++-- | Generate a Church-encoded free monad transformer from a 'FreeT' monad+-- transformer.+toFT :: (Monad m, Functor f) => FreeT f m a -> FT f m a+toFT (FreeT f) = FT $ \ka kfr -> do+ freef <- f+ case freef of+ Pure a -> ka a+ Free fb -> kfr $ fmap (($ kfr) . ($ ka) . runFT . toFT) fb++-- | Convert to a 'FreeT' free monad representation.+fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a+fromFT (FT k) = FreeT $ k (return . Pure) (runFreeT . wrap . fmap FreeT)++-- | The \"free monad\" for a functor @f@.+type F f = FT f Identity++runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r)+runF (FT m) = \kp kf -> runIdentity $ m (return . kp) (return . kf . fmap runIdentity)++free :: Functor f => (forall r. (a -> r) -> (f r -> r) -> r) -> F f a+free f = FT (\kp kf -> return $ f (runIdentity . kp) (runIdentity . kf . fmap return))++-- | Tear down a free monad transformer using iteration.+iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a+iterT phi (FT m) = m return phi+{-# INLINE iterT #-}++-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FT' f m@ to @'FT' f n@+--+-- @'hoistFT' :: ('Monad' m, 'Monad' n, 'Functor' f) => (m ~> n) -> 'FT' f m ~> 'FT' f n@+hoistFT :: (Monad m, Monad n, Functor f) => (forall a. m a -> n a) -> FT f m b -> FT f n b+hoistFT phi (FT m) = FT (\kp kf -> join . phi $ m (return . kp) (return . kf . fmap (join . phi)))++-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@+transFT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FT f m b -> FT g m b+transFT phi (FT m) = FT (\kp kf -> m kp (kf . phi))++-- |+-- 'retract' is the left inverse of 'liftF'+--+-- @+-- 'retract' . 'liftF' = 'id'+-- @+retract :: (Functor f, Monad f) => F f a -> f a+retract m = runF m return join+{-# INLINE retract #-}++-- | Tear down an 'F' 'Monad' using iteration.+iter :: Functor f => (f a -> a) -> F f a -> a+iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)+{-# INLINE iter #-}++-- | Like 'iter' for monadic values.+iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> F f a -> m a+iterM phi = iterT phi . hoistFT (return . runIdentity)++-- | Convert to another free monad representation.+fromF :: (Functor f, MonadFree f m) => F f a -> m a+fromF m = runF m return wrap+{-# INLINE fromF #-}++-- | Generate a Church-encoded free monad from a 'Free' monad.+toF :: (Functor f) => Free f a -> F f a+toF = toFT+{-# INLINE toF #-}++-- | Improve the asymptotic performance of code that builds a free monad with only binds and returns by using 'F' behind the scenes.+--+-- This is based on the \"Free Monads for Less\" series of articles by Edward Kmett:+--+-- <http://comonad.com/reader/2011/free-monads-for-less/>+-- <http://comonad.com/reader/2011/free-monads-for-less-2/>+--+-- and \"Asymptotic Improvement of Computations over Free Monads\" by Janis Voightländer:+--+-- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>+improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a+improve m = fromF m+{-# INLINE improve #-}+
src/Control/Monad/Trans/Iter.hs view
@@ -37,6 +37,7 @@ -- * Consuming iterative monads , retract , fold+ , foldM -- * IterT ~ FreeT Identity , MonadFree(..) ) where@@ -47,7 +48,10 @@ import Control.Monad.Trans.Class import Control.Monad.Free.Class import Control.Monad.State.Class+import Control.Monad.Error.Class import Control.Monad.Reader.Class+import Control.Monad.Cont.Class+import Control.Monad.IO.Class import Data.Bifunctor import Data.Bitraversable import Data.Functor.Bind@@ -176,6 +180,17 @@ {-# INLINE state #-} #endif +instance (Functor m, MonadError e m) => MonadError e (IterT m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ IterT m `catchError` f = IterT $ (liftM (fmap (`catchError` f)) m) `catchError` (runIterT . f)++instance (Functor m, MonadIO m) => MonadIO (IterT m) where+ liftIO = lift . liftIO++instance (MonadCont m) => MonadCont (IterT m) where+ callCC f = IterT $ callCC (\k -> runIterT $ f (lift . k . Left))+ instance Monad m => MonadFree Identity (IterT m) where wrap = IterT . return . Right . runIdentity {-# INLINE wrap #-}@@ -196,6 +211,10 @@ -- | Tear down a 'Free' 'Monad' using iteration. fold :: Monad m => (m a -> a) -> IterT m a -> a fold phi (IterT m) = phi (either id (fold phi) `liftM` m)++-- | Like 'fold' with monadic result.+foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a+foldM phi (IterT m) = phi (either return (foldM 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