module Control.Monad.Trans.Fraxl.Free
(
FreeF(..)
, FreeT(..)
, Free
, liftF
, iterT
, iterTM
, hoistFreeT
, transFreeT
, joinFreeT
, retractT
, retract
, iter
, iterM
, MonadFree(..)
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Free.Class
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans
import Control.Monad.Writer.Class
import Data.Functor.Identity
import Data.Monoid
import Data.TASequence.FastCatQueue
(>.<) :: (Applicative m, TASequence s)
=> (m b -> m c)
-> s (Kleisli m) a b
-> s (Kleisli m) a c
(>.<) f arrs = case tviewr arrs of
TAEmptyR -> tsingleton $ Kleisli (f . pure)
ks :> Kleisli ar -> ks |> Kleisli (f . ar)
qApp :: (Monad m, TASequence s)
=> s (Kleisli m) a b
-> Kleisli m a b
qApp arrs = case tviewl arrs of
TAEmptyL -> Kleisli pure
k :< ks -> k >>> qApp ks
data FreeF f m a where
Pure :: a -> FreeF f m a
Free :: f b -> FastTCQueue (Kleisli (FreeT f m)) b a -> FreeF f m a
instance (Applicative f, Monad m) => Functor (FreeF f m) where
fmap f (Pure a) = Pure (f a)
fmap f (Free b k) = Free b (fmap f >.< k)
transFreeF :: (Applicative f, Monad m)
=> (forall x. f x -> g x)
-> FreeF f m a
-> FreeF g m a
transFreeF _ (Pure a) = Pure a
transFreeF t (Free b k) = Free (t b) k' where
k' = tmap (Kleisli . (transFreeT t .) . runKleisli) k
newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f m a) }
instance (Applicative f, Monad m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT $ fmap (fmap f) m
freePure :: Applicative m => a -> FreeT f m a
freePure = FreeT . pure . Pure
instance (Applicative f, Monad m) => Applicative (FreeT f m) where
pure = freePure
FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where
g :: FreeF f m (a -> b) -> FreeF f m a -> FreeF f m b
g (Pure f') a' = fmap f' a'
g (Free b kf) (Pure a') = Free b (fmap ($ a') >.< kf)
g (Free b kf) (Free c ka) = Free (f' <$> b <*> c) (tsingleton (Kleisli id))
where f' b' c' = runKleisli (qApp kf) b' <*> runKleisli (qApp ka) c'
instance (Applicative f, Monad m) => Monad (FreeT f m) where
FreeT ma >>= k = FreeT $ do
freef <- ma
case freef of
Pure a -> runFreeT (k a)
Free b k' -> return $ Free b (k' |> Kleisli k)
instance MonadTrans (FreeT f) where
lift = FreeT . fmap Pure
instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where
wrap = FreeT . return . flip Free (tsingleton $ Kleisli id)
instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where
liftIO = lift . liftIO
instance (Applicative f, MonadReader r m) => MonadReader r (FreeT f m) where
ask = lift ask
local f = hoistFreeT (local f)
instance (Applicative f, MonadWriter w m) => MonadWriter w (FreeT f m) where
tell = lift . tell
listen (FreeT m) = FreeT $ concat' <$> listen (relisten <$> m)
where
relisten (Pure a) = Pure (a, mempty)
relisten (Free y ks) = Free y (listen >.< ks)
concat' (Pure (x, w1), w2) = Pure (x, w1 <> w2)
concat' (Free x ks, w) = Free x $ fmap (second (w <>)) >.< ks
pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m
where
clean = pass . fmap (\x -> (x, const mempty))
pass' = join . fmap g
g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)
g (Free x ks) = return $ Free x $ (FreeT . pass' . runFreeT) >.< ks
writer w = lift (writer w)
instance (Applicative f, MonadState s m) => MonadState s (FreeT f m) where
get = lift get
put = lift . put
state f = lift (state f)
instance (Applicative f, MonadError e m) => MonadError e (FreeT f m) where
throwError = lift . throwError
FreeT m `catchError` f = FreeT $ fmap recatch m `catchError` (runFreeT . f)
where recatch (Pure x) = Pure x
recatch (Free x ks) = Free x $ (`catchError` f) >.< ks
instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where
callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))
instance (Applicative f, MonadPlus m) => Alternative (FreeT f m) where
empty = FreeT mzero
FreeT ma <|> FreeT mb = FreeT (mplus ma mb)
instance (Applicative f, MonadPlus m) => MonadPlus (FreeT f m) where
mzero = FreeT mzero
mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)
instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where
throwM = lift . throwM
instance (Applicative f, MonadCatch m) => MonadCatch (FreeT f m) where
FreeT m `catch` f = FreeT $ fmap recatch m `catch` (runFreeT . f)
where recatch (Pure x) = Pure x
recatch (Free x ks) = Free x $ (`catch` f) >.< ks
iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
iterT f (FreeT m) = do
val <- m
case val of
Pure x -> return x
Free y k -> f $ fmap (iterT f . runKleisli (qApp k)) y
iterTM :: ( Applicative 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 val of
Pure x -> return x
Free y k -> f $ fmap (iterTM f . runKleisli (qApp k)) y
hoistFreeT :: (Monad m, Applicative f)
=> (forall a. m a -> n a)
-> FreeT f m b
-> FreeT f n b
hoistFreeT mh = FreeT . mh . fmap f . runFreeT where
f (Pure a) = Pure a
f (Free b k) = Free b $ tmap (Kleisli . (hoistFreeT mh .) . runKleisli) k
transFreeT :: (Applicative f, Monad m)
=> (forall a. f a -> g a)
-> FreeT f m b
-> FreeT g m b
transFreeT nt = FreeT . fmap (transFreeF nt) . runFreeT
joinFreeT :: forall m f a. ( Monad m
, Traversable f
, Applicative f)
=> FreeT f m a -> m (Free f a)
joinFreeT (FreeT m) = m >>= joinFreeF
where
joinFreeF :: FreeF f m a -> m (Free f a)
joinFreeF (Pure x) = return (return x)
joinFreeF (Free y ks) = wrap <$> mapM (joinFreeT . runKleisli (qApp ks)) y
retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a
retractT (FreeT m) = do
val <- lift m
case val of
Pure x -> return x
Free y k -> y >>= retractT . runKleisli (qApp k)
type Free f = FreeT f Identity
retract :: Monad f => Free f a -> f a
retract m =
case runIdentity (runFreeT m) of
Pure a -> return a
Free x ks -> x >>= retract . runKleisli (qApp ks)
iter :: Applicative f => (f a -> a) -> Free f a -> a
iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)
iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a
iterM phi = iterT phi . hoistFreeT (return . runIdentity)