{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE UndecidableInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Free.Church
-- Copyright   :  (C) 2008-2014 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable (rank-2 polymorphism, MTPCs)
--
-- Church-encoded free monad transformer.
--
-----------------------------------------------------------------------------
module Control.Monad.Trans.Free.Church
  (
  -- * The free monad transformer
    FT(..)
  -- * The free monad
  , F, free, runF
  -- * Operations
  , improveT
  , toFT, fromFT
  , iterT
  , iterTM
  , hoistFT
  , transFT
  , joinFT
  , cutoff
  -- * Operations of free monad
  , improve
  , fromF, toF
  , retract
  , retractT
  , iter
  , iterM
  -- * Free Monads With Class
  , MonadFree(..)
  , liftF
  ) where

import Control.Applicative
import Control.Category ((<<<), (>>>))
import Control.Monad
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.Identity
import Control.Monad.Trans.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 Control.Monad.Free.Class
import Control.Monad.Trans.Free (FreeT(..), FreeF(..), Free)
import qualified Control.Monad.Trans.Free as FreeT
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import Data.Functor.Bind hiding (join)
import Data.Functor.Classes

-- | The \"free monad transformer\" for a functor @f@
newtype FT f m a = FT { forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT :: forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r }

instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where
  liftEq :: forall a b. (a -> b -> Bool) -> FT f m a -> FT f m b -> Bool
liftEq a -> b -> Bool
eq FT f m a
x FT f m b
y = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
x) (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m b
y)

instance (Functor f, Monad m, Ord1 f, Ord1 m) => Ord1 (FT f m) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> FT f m a -> FT f m b -> Ordering
liftCompare a -> b -> Ordering
cmp FT f m a
x FT f m b
y= forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
x) (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m b
y)

instance (Functor f, Monad m, Eq1 f, Eq1 m, Eq a) => Eq (FT f m a) where
  == :: FT f m a -> FT f m a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Functor f, Monad m, Ord1 f, Ord1 m, Ord a) => Ord (FT f m a) where
  compare :: FT f m a -> FT f m a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance Functor (FT f m) where
  fmap :: forall a b. (a -> b) -> FT f m a -> FT f m b
fmap a -> b
f (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k) = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \b -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k (b -> m r
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) forall x. (x -> m r) -> f x -> m r
fr

instance Apply (FT f m) where
  <.> :: forall a b. FT f m (a -> b) -> FT f m a -> FT f m b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

instance Applicative (FT f m) where
  pure :: forall a. a -> FT f m a
pure a
a = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \a -> m r
k forall x. (x -> m r) -> f x -> m r
_ -> a -> m r
k a
a
  FT forall r.
((a -> b) -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk <*> :: forall a b. FT f m (a -> b) -> FT f m a -> FT f m b
<*> FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
ak = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \b -> m r
b forall x. (x -> m r) -> f x -> m r
fr -> forall r.
((a -> b) -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk (\a -> b
e -> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
ak (\a
d -> b -> m r
b (a -> b
e a
d)) forall x. (x -> m r) -> f x -> m r
fr) forall x. (x -> m r) -> f x -> m r
fr

instance Bind (FT f m) where
  >>- :: forall a b. FT f m a -> (a -> FT f m b) -> FT f m b
(>>-) = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)

instance Monad (FT f m) where
  return :: forall a. a -> FT f m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk >>= :: forall a b. FT f m a -> (a -> FT f m b) -> FT f m b
>>= a -> FT f m b
f = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \b -> m r
b forall x. (x -> m r) -> f x -> m r
fr -> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk (\a
d -> forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT (a -> FT f m b
f a
d) b -> m r
b forall x. (x -> m r) -> f x -> m r
fr) forall x. (x -> m r) -> f x -> m r
fr

instance Fail.MonadFail m => Fail.MonadFail (FT f m) where
  fail :: forall a. String -> FT f m a
fail = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}

instance MonadFree f (FT f m) where
  wrap :: forall a. f (FT f m a) -> FT f m a
wrap f (FT f m a)
f = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\a -> m r
kp forall x. (x -> m r) -> f x -> m r
kf -> forall x. (x -> m r) -> f x -> m r
kf (\FT f m a
ft -> forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT FT f m a
ft a -> m r
kp forall x. (x -> m r) -> f x -> m r
kf) f (FT f m a)
f)

instance MonadTrans (FT f) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> FT f m a
lift m a
m = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\a -> m r
a forall x. (x -> m r) -> f x -> m r
_ -> m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m r
a)

instance Alternative m => Alternative (FT f m) where
  empty :: forall a. FT f m a
empty = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\a -> m r
_ forall x. (x -> m r) -> f x -> m r
_ -> forall (f :: * -> *) a. Alternative f => f a
empty)
  FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k1 <|> :: forall a. FT f m a -> FT f m a -> FT f m a
<|> FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k2 = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \a -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k1 a -> m r
a forall x. (x -> m r) -> f x -> m r
fr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k2 a -> m r
a forall x. (x -> m r) -> f x -> m r
fr

instance MonadPlus m => MonadPlus (FT f m) where
  mzero :: forall a. FT f m a
mzero = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\a -> m r
_ forall x. (x -> m r) -> f x -> m r
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero)
  mplus :: forall a. FT f m a -> FT f m a -> FT f m a
mplus (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k1) (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k2) = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \a -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k1 a -> m r
a forall x. (x -> m r) -> f x -> m r
fr forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k2 a -> m r
a forall x. (x -> m r) -> f x -> m r
fr

instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where
  foldr :: forall a b. (a -> b -> b) -> b -> FT f m a -> b
foldr a -> b -> b
f b
r FT f m a
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(<<<) forall a. a -> a
id m (b -> b)
inner b
r
    where
      inner :: m (b -> b)
inner = forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT FT f m a
xs (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> b
f) (\x -> m (b -> b)
xg f x
xf -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(<<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (b -> b)
xg) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id) f x
xf)
  {-# INLINE foldr #-}

  foldl' :: forall b a. (b -> a -> b) -> b -> FT f m a -> b
foldl' b -> a -> b
f b
z FT f m a
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {t} {a} {b}. (t -> a) -> (a -> b) -> t -> b
(!>>>) forall a. a -> a
id m (b -> b)
inner b
z
    where
      !>>> :: (t -> a) -> (a -> b) -> t -> b
(!>>>) t -> a
h a -> b
g = \t
r -> a -> b
g forall a b. (a -> b) -> a -> b
$! t -> a
h t
r
      inner :: m (b -> b)
inner = forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT FT f m a
xs (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
f) (\x -> m (b -> b)
xg f x
xf -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (b -> b)
xg) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id) f x
xf)
  {-# INLINE foldl' #-}

instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FT f m a -> f (FT f m b)
traverse a -> f b
f (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA forall a b. (a -> b) -> a -> b
$ forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k a -> m (f (FT f m b))
traversePure forall {f :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *}
       {m :: * -> *} {f :: * -> *} {a} {a}.
(MonadFree f (t m), MonadTrans t, Monad m, Monad m, Traversable f,
 Traversable m, Applicative f) =>
(a -> m (f (t m a))) -> f a -> m (f (t m a))
traverseFree
    where
      traversePure :: a -> m (f (FT f m b))
traversePure = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f
      traverseFree :: (a -> m (f (t m a))) -> f a -> m (f (t m a))
traverseFree a -> m (f (t m a))
xg = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (f (t m a))
xg)

instance (MonadIO m) => MonadIO (FT f m) where
  liftIO :: forall a. IO a -> FT f m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance (Functor f, MonadError e m) => MonadError e (FT f m) where
  throwError :: forall a. e -> FT f m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  {-# INLINE throwError #-}
  FT f m a
m catchError :: forall a. FT f m a -> (e -> FT f m a) -> FT f m a
`catchError` e -> FT f m a
f = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
m forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FT f m a
f)

instance MonadCont m => MonadCont (FT f m) where
  callCC :: forall a b. ((a -> FT f m b) -> FT f m a) -> FT f m a
callCC (a -> FT f m b) -> FT f m a
f = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (\FT f m a -> m b
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (a -> FT f m b) -> FT f m a
f (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT f m a -> m b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return))

instance MonadReader r m => MonadReader r (FT f m) where
  ask :: FT f m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  {-# INLINE ask #-}
  local :: forall a. (r -> r) -> FT f m a -> FT f m a
local r -> r
f = forall (m :: * -> *) (n :: * -> *) (f :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f)
  {-# INLINE local #-}

instance (Functor f, MonadWriter w m) => MonadWriter w (FT f m) where
  tell :: w -> FT f m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  {-# INLINE tell #-}
  listen :: forall a. FT f m a -> FT f m (a, w)
listen = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT
  pass :: forall a. FT f m (a, w -> w) -> FT f m a
pass = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT
  writer :: forall a. (a, w) -> FT f m a
writer (a, w)
w = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a, w)
w)
  {-# INLINE writer #-}

instance MonadState s m => MonadState s (FT f m) where
  get :: FT f m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  {-# INLINE get #-}
  put :: s -> FT f m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put
  {-# INLINE put #-}
  state :: forall a. (s -> (a, s)) -> FT f m a
state s -> (a, s)
f = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state s -> (a, s)
f)
  {-# INLINE state #-}

instance MonadThrow m => MonadThrow (FT f m) where
  throwM :: forall e a. Exception e => e -> FT f m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
  {-# INLINE throwM #-}

instance (Functor f, MonadCatch m) => MonadCatch (FT f m) where
  catch :: forall e a. Exception e => FT f m a -> (e -> FT f m a) -> FT f m a
catch FT f m a
m e -> FT f m a
f = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
m forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Control.Monad.Catch.catch` (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FT f m a
f)
  {-# INLINE catch #-}

-- | Generate a Church-encoded free monad transformer from a 'FreeT' monad
-- transformer.
toFT :: Monad m => FreeT f m a -> FT f m a
toFT :: forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT m (FreeF f a (FreeT f m a))
f) = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT forall a b. (a -> b) -> a -> b
$ \a -> m r
ka forall x. (x -> m r) -> f x -> m r
kfr -> do
  FreeF f a (FreeT f m a)
freef <- m (FreeF f a (FreeT f m a))
f
  case FreeF f a (FreeT f m a)
freef of
    Pure a
a -> a -> m r
ka a
a
    Free f (FreeT f m a)
fb -> forall x. (x -> m r) -> f x -> m r
kfr (\FreeT f m a
x -> forall (f :: * -> *) (m :: * -> *) a.
FT f m a
-> forall r.
   (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
runFT (forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT FreeT f m a
x) a -> m r
ka forall x. (x -> m r) -> f x -> m r
kfr) f (FreeT f m a)
fb

-- | Convert to a 'FreeT' free monad representation.
fromFT :: (Monad m, Functor f) => FT f m a -> FreeT f m a
fromFT :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. a -> FreeF f a b
Pure) (\x -> m (FreeF f a (FreeT f m a))
xg -> forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (FreeF f a (FreeT f m a))
xg))

-- | The \"free monad\" for a functor @f@.
type F f = FT f Identity

-- | Unwrap the 'Free' monad to obtain it's Church-encoded representation.
runF :: Functor f => F f a -> (forall r. (a -> r) -> (f r -> r) -> r)
runF :: forall (f :: * -> *) a.
Functor f =>
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF (FT forall r.
(a -> Identity r)
-> (forall x. (x -> Identity r) -> f x -> Identity r) -> Identity r
m) = \a -> r
kp f r -> r
kf -> forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r.
(a -> Identity r)
-> (forall x. (x -> Identity r) -> f x -> Identity r) -> Identity r
m (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> r
kp) (\x -> Identity r
xg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. f r -> r
kf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Identity r
xg))

-- | Wrap a Church-encoding of a \"free monad\" as the free monad for a functor.
free :: (forall r. (a -> r) -> (f r -> r) -> r) -> F f a
free :: forall a (f :: * -> *).
(forall r. (a -> r) -> (f r -> r) -> r) -> F f a
free forall r. (a -> r) -> (f r -> r) -> r
f = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\a -> Identity r
kp forall x. (x -> Identity r) -> f x -> Identity r
kf -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r. (a -> r) -> (f r -> r) -> r
f (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity r
kp) (forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. (x -> Identity r) -> f x -> Identity r
kf forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FT f m a -> m a
iterT f (m a) -> m a
phi (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m) = forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m forall (m :: * -> *) a. Monad m => a -> m a
return (\x -> m a
xg -> f (m a) -> m a
phi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> m a
xg)
{-# INLINE iterT #-}

-- | Tear down a free monad transformer using iteration over a transformer.
iterTM :: (Functor f, Monad m, MonadTrans t, Monad (t m)) => (f (t m a) -> t m a) -> FT f m a -> t m a
iterTM :: forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FT f m a -> t m a
iterTM f (t m a) -> t m a
f (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m) = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (t m a)
xg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (t m a) -> t m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (t m a)
xg))

-- | 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) => (forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT :: forall (m :: * -> *) (n :: * -> *) (f :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT forall a. m a -> n a
phi (FT forall r. (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m) = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\b -> n r
kp forall x. (x -> n r) -> f x -> n r
kf -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> n a
phi forall a b. (a -> b) -> a -> b
$ forall r. (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> n r
kp) (\x -> m (n r)
xg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. (x -> n r) -> f x -> n r
kf (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> n a
phi forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (n r)
xg)))

-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FT' f m@ to @'FT' g n@
transFT :: (forall a. f a -> g a) -> FT f m b -> FT g m b
transFT :: forall (f :: * -> *) (g :: * -> *) (m :: * -> *) b.
(forall a. f a -> g a) -> FT f m b -> FT g m b
transFT forall a. f a -> g a
phi (FT forall r. (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m) = forall (f :: * -> *) (m :: * -> *) a.
(forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
FT (\b -> m r
kp forall x. (x -> m r) -> g x -> m r
kf -> forall r. (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m b -> m r
kp (\x -> m r
xg -> forall x. (x -> m r) -> g x -> m r
kf x -> m r
xg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. f a -> g a
phi))

-- | Pull out and join @m@ layers of @'FreeT' f m a@.
joinFT :: (Monad m, Traversable f) => FT f m a -> m (F f a)
joinFT :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f) =>
FT f m a -> m (F f a)
joinFT (FT forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m) = forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (F f a)
xg -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM x -> m (F f a)
xg)

-- | Cuts off a tree of computations at a given depth.
-- If the depth is 0 or less, no computation nor
-- monadic effects will take place.
--
-- Some examples (n ≥ 0):
--
-- prop> cutoff 0     _        == return Nothing
-- prop> cutoff (n+1) . return == return . Just
-- prop> cutoff (n+1) . lift   ==   lift . liftM Just
-- prop> cutoff (n+1) . wrap   ==  wrap . fmap (cutoff n)
--
-- Calling 'retract . cutoff n' is always terminating, provided each of the
-- steps in the iteration is terminating.
cutoff :: (Functor f, Monad m) => Integer -> FT f m a -> FT f m (Maybe a)
cutoff :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Integer -> FT f m a -> FT f m (Maybe a)
cutoff Integer
n = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Integer -> FreeT f m a -> FreeT f m (Maybe a)
FreeT.cutoff Integer
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT

-- |
-- 'retract' is the left inverse of 'liftF'
--
-- @
-- 'retract' . 'liftF' = 'id'
-- @
retract :: Monad f => F f a -> f a
retract :: forall (f :: * -> *) a. Monad f => F f a -> f a
retract F f a
m = forall (f :: * -> *) a.
Functor f =>
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
{-# INLINE retract #-}

-- | Tear down a free monad transformer using iteration over a transformer.
retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a
retractT :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
FT (t m) m a -> t m a
retractT (FT forall r.
(a -> m r) -> (forall x. (x -> m r) -> t m x -> m r) -> m r
m) = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r.
(a -> m r) -> (forall x. (x -> m r) -> t m x -> m r) -> m r
m (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (t m a)
xg t m x
xf -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t m x
xf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (t m a)
xg)

-- | Tear down an 'F' 'Monad' using iteration.
iter :: Functor f => (f a -> a) -> F f a -> a
iter :: forall (f :: * -> *) a. Functor f => (f a -> a) -> F f a -> a
iter f a -> a
phi = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FT f m a -> m a
iterT (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a
phi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity)
{-# INLINE iter #-}

-- | Like 'iter' for monadic values.
iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> F f a -> m a
iterM :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> F f a -> m a
iterM f (m a) -> m a
phi = forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FT f m a -> m a
iterT f (m a) -> m a
phi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (n :: * -> *) (f :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)

-- | Convert to another free monad representation.
fromF :: (Functor f, MonadFree f m) => F f a -> m a
fromF :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
F f a -> m a
fromF F f a
m = forall (f :: * -> *) a.
Functor f =>
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap
{-# INLINE fromF #-}

-- | Generate a Church-encoded free monad from a 'Free' monad.
toF :: Free f a -> F f a
toF :: forall (f :: * -> *) a. Free f a -> F f a
toF = forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
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:
--
-- <https://ekmett.github.io/reader/2011/free-monads-for-less/>
-- <https://ekmett.github.io/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 :: forall (f :: * -> *) a.
Functor f =>
(forall (m :: * -> *). MonadFree f m => m a) -> Free f a
improve forall (m :: * -> *). MonadFree f m => m a
m = forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
F f a -> m a
fromF forall (m :: * -> *). MonadFree f m => m a
m
{-# INLINE improve #-}

-- | Improve the asymptotic performance of code that builds a free monad transformer
-- with only binds and returns by using 'FT' behind the scenes.
--
-- Similar to 'improve'.
improveT :: (Functor f, Monad m) => (forall t. MonadFree f (t m) => t m a) -> FreeT f m a
improveT :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(forall (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a)
-> FreeT f m a
improveT forall (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a
m = forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT forall (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a
m
{-# INLINE improveT #-}