{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
module Control.Monad.Trans.Free
(
FreeF(..)
, FreeT(..)
, Free, free, runFree
, liftF
, iterT
, iterTM
, hoistFreeT
, transFreeT
, cutoff
, retract
, iter
, iterM
, MonadFree(..)
) where
import Control.Applicative
import Control.Monad (liftM, MonadPlus(..), ap, join)
import Control.Monad.Trans.Class
import Control.Monad.Free.Class
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.Error.Class
import Control.Monad.Cont.Class
import Data.Functor.Bind hiding (join)
import Data.Monoid
import Data.Foldable
import Data.Function (on)
import Data.Functor.Identity
import Data.Traversable
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.Data
import Prelude.Extras
data FreeF f a b = Pure a | Free (f b)
deriving (Eq,Ord,Show,Read
#if __GLASGOW_HASKELL__ >= 707
,Typeable
#endif
)
instance Show1 f => Show2 (FreeF f) where
showsPrec2 d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a
showsPrec2 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as
instance (Show1 f, Show a) => Show1 (FreeF f a) where
showsPrec1 = showsPrec2
instance Read1 f => Read2 (FreeF f) where
readsPrec2 d r = readParen (d > 10)
(\r' -> [ (Pure m, t)
| ("Pure", s) <- lex r'
, (m, t) <- readsPrec 11 s]) r
++ readParen (d > 10)
(\r' -> [ (Free m, t)
| ("Free", s) <- lex r'
, (m, t) <- readsPrec1 11 s]) r
instance (Read1 f, Read a) => Read1 (FreeF f a) where
readsPrec1 = readsPrec2
instance Eq1 f => Eq2 (FreeF f) where
Pure a ==## Pure b = a == b
Free as ==## Free bs = as ==# bs
_ ==## _ = False
instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where
(==#) = (==##)
instance Ord1 f => Ord2 (FreeF f) where
Pure a `compare2` Pure b = a `compare` b
Pure _ `compare2` Free _ = LT
Free _ `compare2` Pure _ = GT
Free fa `compare2` Free fb = fa `compare1` fb
instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where
compare1 = compare2
instance Functor f => Functor (FreeF f a) where
fmap _ (Pure a) = Pure a
fmap f (Free as) = Free (fmap f as)
{-# INLINE fmap #-}
instance Foldable f => Foldable (FreeF f a) where
foldMap f (Free as) = foldMap f as
foldMap _ _ = mempty
{-# INLINE foldMap #-}
instance Traversable f => Traversable (FreeF f a) where
traverse _ (Pure a) = pure (Pure a)
traverse f (Free as) = Free <$> traverse f as
{-# INLINE traverse #-}
instance Functor f => Bifunctor (FreeF f) where
bimap f _ (Pure a) = Pure (f a)
bimap _ g (Free as) = Free (fmap g as)
{-# INLINE bimap #-}
instance Foldable f => Bifoldable (FreeF f) where
bifoldMap f _ (Pure a) = f a
bifoldMap _ g (Free as) = foldMap g as
{-# INLINE bifoldMap #-}
instance Traversable f => Bitraversable (FreeF f) where
bitraverse f _ (Pure a) = Pure <$> f a
bitraverse _ g (Free as) = Free <$> traverse g as
{-# INLINE bitraverse #-}
transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
transFreeF _ (Pure a) = Pure a
transFreeF t (Free as) = Free (t as)
{-# INLINE transFreeF #-}
newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f a (FreeT f m a)) }
type Free f = FreeT f Identity
runFree :: Free f a -> FreeF f a (Free f a)
runFree = runIdentity . runFreeT
{-# INLINE runFree #-}
free :: FreeF f a (Free f a) -> Free f a
free = FreeT . Identity
{-# INLINE free #-}
deriving instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a)
instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where
(==#) = on (==#) (fmap (Lift1 . fmap Lift1) . runFreeT)
deriving instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a)
instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where
compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)
instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where
showsPrec1 d (FreeT m) = showParen (d > 10) $
showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)
instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where
showsPrec d (FreeT m) = showParen (d > 10) $
showString "FreeT " . showsPrec 11 m
instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where
readsPrec1 d = readParen (d > 10) $ \r ->
[ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]
instance Read (m (FreeF f a (FreeT f m a))) => Read (FreeT f m a) where
readsPrec d = readParen (d > 10) $ \r ->
[ (FreeT m,t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec 11 s]
instance (Functor f, Monad m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT (liftM f' m) where
f' (Pure a) = Pure (f a)
f' (Free as) = Free (fmap (fmap f) as)
instance (Functor f, Monad m) => Applicative (FreeT f m) where
pure a = FreeT (return (Pure a))
{-# INLINE pure #-}
(<*>) = ap
{-# INLINE (<*>) #-}
instance (Functor f, Monad m) => Apply (FreeT f m) where
(<.>) = (<*>)
instance (Functor f, Monad m) => Bind (FreeT f m) where
(>>-) = (>>=)
instance (Functor f, Monad m) => Monad (FreeT f m) where
return a = FreeT (return (Pure a))
{-# INLINE return #-}
FreeT m >>= f = FreeT $ m >>= \v -> case v of
Pure a -> runFreeT (f a)
Free w -> return (Free (fmap (>>= f) w))
instance MonadTrans (FreeT f) where
lift = FreeT . liftM Pure
{-# INLINE lift #-}
instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where
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, MonadWriter w m) => MonadWriter w (FreeT f m) where
tell = lift . tell
{-# INLINE tell #-}
listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)
where
concat' (Pure x, w) = Pure (x, w)
concat' (Free y, w) = Free $ fmap (second (w <>)) <$> y
pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m
where
clean = pass . liftM (\x -> (x, const mempty))
pass' = join . liftM g
g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)
g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f
#if MIN_VERSION_mtl(2,1,1)
writer w = lift (writer w)
{-# INLINE writer #-}
#endif
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)
{-# INLINE (<|>) #-}
instance (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where
mzero = FreeT mzero
{-# INLINE mzero #-}
mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)
{-# INLINE mplus #-}
instance (Functor f, Monad m) => MonadFree f (FreeT f m) where
wrap = FreeT . return . Free
{-# INLINE wrap #-}
iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
iterT f (FreeT m) = do
val <- m
case fmap (iterT f) val of
Pure x -> return x
Free y -> f y
iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM f (FreeT m) = do
val <- lift m
case fmap (iterTM f) val of
Pure x -> return x
Free y -> f y
instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m
instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where
traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m
hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT
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 :: Monad f => Free f a -> f a
retract m =
case runIdentity (runFreeT m) of
Pure a -> return a
Free as -> as >>= retract
iter :: Functor f => (f a -> a) -> Free f a -> a
iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)
iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a
iterM phi = iterT phi . hoistFreeT (return . runIdentity)
cutoff :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff 0 _ = return Nothing
cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m
#if __GLASGOW_HASKELL__ < 707
instance Typeable1 f => Typeable2 (FreeF f) where
typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where
f :: FreeF f a b -> f a
f = undefined
instance (Typeable1 f, Typeable1 w) => Typeable1 (FreeT f w) where
typeOf1 t = mkTyConApp freeTTyCon [typeOf1 (f t), typeOf1 (w t)] where
f :: FreeT f w a -> f a
f = undefined
w :: FreeT f w a -> w a
w = undefined
freeFTyCon, freeTTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
freeTTyCon = mkTyCon "Control.Monad.Trans.Free.FreeT"
freeFTyCon = mkTyCon "Control.Monad.Trans.Free.FreeF"
#else
freeTTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeT"
freeFTyCon = mkTyCon3 "free" "Control.Monad.Trans.Free" "FreeF"
#endif
{-# NOINLINE freeTTyCon #-}
{-# NOINLINE freeFTyCon #-}
instance
( Typeable1 f, Typeable a, Typeable b
, Data a, Data (f b), Data b
) => Data (FreeF f a b) where
gfoldl f z (Pure a) = z Pure `f` a
gfoldl f z (Free as) = z Free `f` as
toConstr Pure{} = pureConstr
toConstr Free{} = freeConstr
gunfold k z c = case constrIndex c of
1 -> k (z Pure)
2 -> k (z Free)
_ -> error "gunfold"
dataTypeOf _ = freeFDataType
dataCast1 f = gcast1 f
instance
( Typeable1 f, Typeable1 w, Typeable a
, Data (w (FreeF f a (FreeT f w a)))
, Data a
) => Data (FreeT f w a) where
gfoldl f z (FreeT w) = z FreeT `f` w
toConstr _ = freeTConstr
gunfold k z c = case constrIndex c of
1 -> k (z FreeT)
_ -> error "gunfold"
dataTypeOf _ = freeTDataType
dataCast1 f = gcast1 f
pureConstr, freeConstr, freeTConstr :: Constr
pureConstr = mkConstr freeFDataType "Pure" [] Prefix
freeConstr = mkConstr freeFDataType "Free" [] Prefix
freeTConstr = mkConstr freeTDataType "FreeT" [] Prefix
{-# NOINLINE pureConstr #-}
{-# NOINLINE freeConstr #-}
{-# NOINLINE freeTConstr #-}
freeFDataType, freeTDataType :: DataType
freeFDataType = mkDataType "Control.Monad.Trans.Free.FreeF" [pureConstr, freeConstr]
freeTDataType = mkDataType "Control.Monad.Trans.Free.FreeT" [freeTConstr]
{-# NOINLINE freeFDataType #-}
{-# NOINLINE freeTDataType #-}
#endif