{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE UndecidableInstances #-}
#include "free-common.h"

-----------------------------------------------------------------------------
-- |
-- 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 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.Compat

#if !(MIN_VERSION_base(4,8,0))
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
#endif

-- | The \"free monad transformer\" for a functor @f@
newtype FT f m a = FT { 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 }

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Functor f, Monad m, Eq1 f, Eq1 m) => Eq1 (FT f m) where
  liftEq :: (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 = (a -> b -> Bool) -> FreeT f m a -> FreeT f m b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq (FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
x) (FT f m b -> FreeT f m b
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 :: (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= (a -> b -> Ordering) -> FreeT f m a -> FreeT f m b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp (FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
x) (FT f m b -> FreeT f m b
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m b
y)
#else
instance ( Functor f, Monad m, Eq1 f, Eq1 m
# if !(MIN_VERSION_base(4,8,0))
         , Functor m
# endif
         ) => Eq1 (FT f m) where
  eq1 x y = eq1 (fromFT x) (fromFT y)

instance ( Functor f, Monad m, Ord1 f, Ord1 m
# if !(MIN_VERSION_base(4,8,0))
         , Functor m
# endif
         ) => Ord1 (FT f m) where
  compare1 x y = compare1 (fromFT x) (fromFT y)
#endif

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

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

instance Functor (FT f m) where
  fmap :: (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 r.
 (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
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 r.
  (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m b)
-> (forall r.
    (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
forall a b. (a -> b) -> a -> b
$ \b -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k (b -> m r
a (b -> m r) -> (a -> b) -> a -> m r
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
  <.> :: FT f m (a -> b) -> FT f m a -> FT f m 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 :: a -> FT f m a
pure a
a = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 r.
  (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m a)
-> (forall r.
    (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
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 <*> :: 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 r.
 (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
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 r.
  (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m b)
-> (forall r.
    (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
forall a b. (a -> b) -> a -> b
$ \b -> m r
b forall x. (x -> m r) -> f x -> m r
fr -> ((a -> b) -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
forall r.
((a -> b) -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk (\a -> b
e -> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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
  >>- :: FT f m a -> (a -> FT f m b) -> FT f m 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 :: a -> FT f m a
return = a -> FT f m a
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 >>= :: FT f m a -> (a -> FT f m b) -> FT f m b
>>= a -> FT f m b
f = (forall r.
 (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
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 r.
  (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m b)
-> (forall r.
    (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m b
forall a b. (a -> b) -> a -> b
$ \b -> m r
b forall x. (x -> m r) -> f x -> m r
fr -> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
fk (\a
d -> FT f m b
-> (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 MonadFree f (FT f m) where
  wrap :: f (FT f m a) -> FT f m a
wrap f (FT f m a)
f = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 (\a -> m r
kp forall x. (x -> m r) -> f x -> m r
kf -> (FT f m a -> m r) -> f (FT f m a) -> m r
forall x. (x -> m r) -> f x -> m r
kf (\FT f m a
ft -> FT f m a
-> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 :: m a -> FT f m a
lift m a
m = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 (\a -> m r
a forall x. (x -> m r) -> f x -> m r
_ -> m a
m m a -> (a -> m r) -> m r
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 :: FT f m a
empty = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 (\a -> m r
_ forall x. (x -> m r) -> f x -> m r
_ -> 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 <|> :: 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 r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 r.
  (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m a)
-> (forall r.
    (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
forall a b. (a -> b) -> a -> b
$ \a -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 m r -> m r -> m r
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 :: FT f m a
mzero = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 (\a -> m r
_ forall x. (x -> m r) -> f x -> m r
_ -> m r
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
  mplus :: 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 r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 r.
  (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m a)
-> (forall r.
    (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
forall a b. (a -> b) -> a -> b
$ \a -> m r
a forall x. (x -> m r) -> f x -> m r
fr -> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 m r -> m r -> m r
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 :: (a -> b -> b) -> b -> FT f m a -> b
foldr a -> b -> b
f b
r FT f m a
xs = ((b -> b) -> (b -> b) -> b -> b)
-> (b -> b) -> m (b -> b) -> b -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (b -> b) -> (b -> b) -> b -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(<<<) b -> b
forall a. a -> a
id m (b -> b)
inner b
r
    where
      inner :: m (b -> b)
inner = FT f m a
-> (a -> m (b -> b))
-> (forall x. (x -> m (b -> b)) -> f x -> m (b -> b))
-> m (b -> b)
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 ((b -> b) -> m (b -> b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b -> b) -> m (b -> b)) -> (a -> b -> b) -> a -> m (b -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> b
f) (\x -> m (b -> b)
xg f x
xf -> (x -> m (b -> b) -> m (b -> b)) -> m (b -> b) -> f x -> m (b -> b)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (((b -> b) -> (b -> b) -> b -> b)
-> m (b -> b) -> m (b -> b) -> m (b -> b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (b -> b) -> (b -> b) -> b -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(<<<) (m (b -> b) -> m (b -> b) -> m (b -> b))
-> (x -> m (b -> b)) -> x -> m (b -> b) -> m (b -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (b -> b)
xg) ((b -> b) -> m (b -> b)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> b
forall a. a -> a
id) f x
xf)
  {-# INLINE foldr #-}

#if MIN_VERSION_base(4,6,0)
  foldl' :: (b -> a -> b) -> b -> FT f m a -> b
foldl' b -> a -> b
f b
z FT f m a
xs = ((b -> b) -> (b -> b) -> b -> b)
-> (b -> b) -> m (b -> b) -> b -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (b -> b) -> (b -> b) -> b -> b
forall t a b. (t -> a) -> (a -> b) -> t -> b
(!>>>) b -> 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 (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$! t -> a
h t
r
      inner :: m (b -> b)
inner = FT f m a
-> (a -> m (b -> b))
-> (forall x. (x -> m (b -> b)) -> f x -> m (b -> b))
-> m (b -> b)
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 ((b -> b) -> m (b -> b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b -> b) -> m (b -> b)) -> (a -> b -> b) -> a -> m (b -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> b
f) (\x -> m (b -> b)
xg f x
xf -> (x -> m (b -> b) -> m (b -> b)) -> m (b -> b) -> f x -> m (b -> b)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (((b -> b) -> (b -> b) -> b -> b)
-> m (b -> b) -> m (b -> b) -> m (b -> b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (b -> b) -> (b -> b) -> b -> b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) (m (b -> b) -> m (b -> b) -> m (b -> b))
-> (x -> m (b -> b)) -> x -> m (b -> b) -> m (b -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m (b -> b)
xg) ((b -> b) -> m (b -> b)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> b
forall a. a -> a
id) f x
xf)
  {-# INLINE foldl' #-}
#endif

instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where
  traverse :: (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) = (m (FT f m b) -> FT f m b) -> f (m (FT f m b)) -> f (FT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FT f m (FT f m b) -> FT f m b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (FT f m (FT f m b) -> FT f m b)
-> (m (FT f m b) -> FT f m (FT f m b)) -> m (FT f m b) -> FT f m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FT f m b) -> FT f m (FT f m b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (f (m (FT f m b)) -> f (FT f m b))
-> (m (f (FT f m b)) -> f (m (FT f m b)))
-> m (f (FT f m b))
-> f (FT f m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (f (FT f m b)) -> f (m (FT f m b))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (m (f (FT f m b)) -> f (FT f m b))
-> m (f (FT f m b)) -> f (FT f m b)
forall a b. (a -> b) -> a -> b
$ (a -> m (f (FT f m b)))
-> (forall x. (x -> m (f (FT f m b))) -> f x -> m (f (FT f m b)))
-> m (f (FT f m 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 x. (x -> m (f (FT f m b))) -> f x -> m (f (FT f m b))
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 = f (FT f m b) -> m (f (FT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (FT f m b) -> m (f (FT f m b)))
-> (a -> f (FT f m b)) -> a -> m (f (FT f m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> FT f m b) -> f b -> f (FT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> FT f m b
forall (m :: * -> *) a. Monad m => a -> m a
return (f b -> f (FT f m b)) -> (a -> f b) -> a -> f (FT f m b)
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 = f (t m a) -> m (f (t m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (t m a) -> m (f (t m a)))
-> (f a -> f (t m a)) -> f a -> m (f (t m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (m (t m a)) -> t m a) -> f (f (m (t m a))) -> f (t m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f (t m a) -> t m a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (t m a) -> t m a)
-> (f (m (t m a)) -> f (t m a)) -> f (m (t m a)) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (t m a) -> t m a) -> f (m (t m a)) -> f (t m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t m (t m a) -> t m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t m (t m a) -> t m a)
-> (m (t m a) -> t m (t m a)) -> m (t m a) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (t m a) -> t m (t m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)) (f (f (m (t m a))) -> f (t m a))
-> (f a -> f (f (m (t m a)))) -> f a -> f (t m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (m (t m a))) -> f a -> f (f (m (t m a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (m (f (t m a)) -> f (m (t m a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (m (f (t m a)) -> f (m (t m a)))
-> (a -> m (f (t m a))) -> a -> f (m (t m a))
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 :: IO a -> FT f m a
liftIO = m a -> FT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FT f m a) -> (IO a -> m a) -> IO a -> FT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
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 :: e -> FT f m a
throwError = m a -> FT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FT f m a) -> (e -> m a) -> e -> FT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  {-# INLINE throwError #-}
  FT f m a
m catchError :: FT f m a -> (e -> FT f m a) -> FT f m a
`catchError` e -> FT f m a
f = FreeT f m a -> FT f m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT f m a -> FT f m a) -> FreeT f m a -> FT f m a
forall a b. (a -> b) -> a -> b
$ FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
m FreeT f m a -> (e -> FreeT f m a) -> FreeT f m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT (FT f m a -> FreeT f m a) -> (e -> FT f m a) -> e -> FreeT f m a
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 :: ((a -> FT f m b) -> FT f m a) -> FT f m a
callCC (a -> FT f m b) -> FT f m a
f = FT f m (FT f m a) -> FT f m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (FT f m (FT f m a) -> FT f m a)
-> (m (FT f m a) -> FT f m (FT f m a)) -> m (FT f m a) -> FT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FT f m a) -> FT f m (FT f m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (FT f m a) -> FT f m a) -> m (FT f m a) -> FT f m a
forall a b. (a -> b) -> a -> b
$ ((FT f m a -> m b) -> m (FT f m a)) -> m (FT f m a)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (\FT f m a -> m b
k -> FT f m a -> m (FT f m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FT f m a -> m (FT f m a)) -> FT f m a -> m (FT f m a)
forall a b. (a -> b) -> a -> b
$ (a -> FT f m b) -> FT f m a
f (m b -> FT f m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> FT f m b) -> (a -> m b) -> a -> FT f m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT f m a -> m b
k (FT f m a -> m b) -> (a -> FT f m a) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FT f m a
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 = m r -> FT f m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  {-# INLINE ask #-}
  local :: (r -> r) -> FT f m a -> FT f m a
local r -> r
f = (forall a. m a -> m a) -> FT f m a -> FT f m a
forall (m :: * -> *) (n :: * -> *) (f :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT ((r -> r) -> m a -> m a
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 = m () -> FT f m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> FT f m ()) -> (w -> m ()) -> w -> FT f m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  {-# INLINE tell #-}
  listen :: FT f m a -> FT f m (a, w)
listen = FreeT f m (a, w) -> FT f m (a, w)
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT f m (a, w) -> FT f m (a, w))
-> (FT f m a -> FreeT f m (a, w)) -> FT f m a -> FT f m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m a -> FreeT f m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (FreeT f m a -> FreeT f m (a, w))
-> (FT f m a -> FreeT f m a) -> FT f m a -> FreeT f m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT
  pass :: FT f m (a, w -> w) -> FT f m a
pass = FreeT f m a -> FT f m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT f m a -> FT f m a)
-> (FT f m (a, w -> w) -> FreeT f m a)
-> FT f m (a, w -> w)
-> FT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m (a, w -> w) -> FreeT f m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (FreeT f m (a, w -> w) -> FreeT f m a)
-> (FT f m (a, w -> w) -> FreeT f m (a, w -> w))
-> FT f m (a, w -> w)
-> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT f m (a, w -> w) -> FreeT f m (a, w -> w)
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT
#if MIN_VERSION_mtl(2,1,1)
  writer :: (a, w) -> FT f m a
writer (a, w)
w = m a -> FT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((a, w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a, w)
w)
  {-# INLINE writer #-}
#endif

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

instance MonadThrow m => MonadThrow (FT f m) where
  throwM :: e -> FT f m a
throwM = m a -> FT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FT f m a) -> (e -> m a) -> e -> FT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
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 :: 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 = FreeT f m a -> FT f m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT f m a -> FT f m a) -> FreeT f m a -> FT f m a
forall a b. (a -> b) -> a -> b
$ FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
m FreeT f m a -> (e -> FreeT f m a) -> FreeT f m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Control.Monad.Catch.catch` (FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT (FT f m a -> FreeT f m a) -> (e -> FT f m a) -> e -> FreeT f m a
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 :: FreeT f m a -> FT f m a
toFT (FreeT m (FreeF f a (FreeT f m a))
f) = (forall r.
 (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m 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 r.
  (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
 -> FT f m a)
-> (forall r.
    (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r)
-> FT f m a
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 -> (FreeT f m a -> m r) -> f (FreeT f m a) -> m r
forall x. (x -> m r) -> f x -> m r
kfr (\FreeT f m a
x -> FT f m a
-> (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 (FreeT f m a -> FT f m a
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 :: 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) = m (FreeF f a (FreeT f m a)) -> FreeT f m a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f a (FreeT f m a)) -> FreeT f m a)
-> m (FreeF f a (FreeT f m a)) -> FreeT f m a
forall a b. (a -> b) -> a -> b
$ (a -> m (FreeF f a (FreeT f m a)))
-> (forall x.
    (x -> m (FreeF f a (FreeT f m a)))
    -> f x -> m (FreeF f a (FreeT f m a)))
-> m (FreeF f a (FreeT f m a))
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
k (FreeF f a (FreeT f m a) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeF f a (FreeT f m a) -> m (FreeF f a (FreeT f m a)))
-> (a -> FreeF f a (FreeT f m a))
-> a
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure) (\x -> m (FreeF f a (FreeT f m a))
xg -> FreeT f m a -> m (FreeF f a (FreeT f m a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (FreeT f m a -> m (FreeF f a (FreeT f m a)))
-> (f x -> FreeT f m a) -> f x -> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m a) -> FreeT f m a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (FreeT f m a) -> FreeT f m a)
-> (f x -> f (FreeT f m a)) -> f x -> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> FreeT f m a) -> f x -> f (FreeT f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m (FreeF f a (FreeT f m a)) -> FreeT f m a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f a (FreeT f m a)) -> FreeT f m a)
-> (x -> m (FreeF f a (FreeT f m a))) -> x -> FreeT f m a
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 :: 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 -> Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> Identity r -> r
forall a b. (a -> b) -> a -> b
$ (a -> Identity r)
-> (forall x. (x -> Identity r) -> f x -> Identity r) -> Identity r
forall r.
(a -> Identity r)
-> (forall x. (x -> Identity r) -> f x -> Identity r) -> Identity r
m (r -> Identity r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Identity r) -> (a -> r) -> a -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> r
kp) (\x -> Identity r
xg -> r -> Identity r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Identity r) -> (f x -> r) -> f x -> Identity r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f r -> r
kf (f r -> r) -> (f x -> f r) -> f x -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> r) -> f x -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (x -> Identity r) -> x -> r
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 r. (a -> r) -> (f r -> r) -> r) -> F f a
free forall r. (a -> r) -> (f r -> r) -> r
f = (forall r.
 (a -> Identity r)
 -> (forall x. (x -> Identity r) -> f x -> Identity r)
 -> Identity r)
-> F f 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 (\a -> Identity r
kp forall x. (x -> Identity r) -> f x -> Identity r
kf -> r -> Identity r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Identity r) -> r -> Identity r
forall a b. (a -> b) -> a -> b
$ (a -> r) -> (f r -> r) -> r
forall r. (a -> r) -> (f r -> r) -> r
f (Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (a -> Identity r) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity r
kp) (Identity r -> r
forall a. Identity a -> a
runIdentity (Identity r -> r) -> (f r -> Identity r) -> f r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> Identity r) -> f r -> Identity r
forall x. (x -> Identity r) -> f x -> Identity r
kf r -> Identity r
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 :: (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) = (a -> m a) -> (forall x. (x -> m a) -> f x -> m a) -> m a
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (\x -> m a
xg -> f (m a) -> m a
phi (f (m a) -> m a) -> (f x -> f (m a)) -> f x -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> m a) -> f x -> f (m a)
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 :: (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) = t m (t m a) -> t m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t m (t m a) -> t m a)
-> (m (t m a) -> t m (t m a)) -> m (t m a) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (t m a) -> t m (t m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (t m a) -> t m a) -> m (t m a) -> t m a
forall a b. (a -> b) -> a -> b
$ (a -> m (t m a))
-> (forall x. (x -> m (t m a)) -> f x -> m (t m a)) -> m (t m a)
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (t m a -> m (t m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (t m a -> m (t m a)) -> (a -> t m a) -> a -> m (t m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (t m a)
xg -> t m a -> m (t m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (t m a -> m (t m a)) -> (f x -> t m a) -> f x -> m (t m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (t m a) -> t m a
f (f (t m a) -> t m a) -> (f x -> f (t m a)) -> f x -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> t m a) -> f x -> f (t m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t m (t m a) -> t m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t m (t m a) -> t m a) -> (x -> t m (t m a)) -> x -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (t m a) -> t m (t m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (t m a) -> t m (t m a)) -> (x -> m (t m a)) -> x -> t m (t m a)
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 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 r.
 (b -> n r) -> (forall x. (x -> n r) -> f x -> n r) -> n r)
-> FT f n b
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 -> n (n r) -> n r
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (n (n r) -> n r) -> (m (n r) -> n (n r)) -> m (n r) -> n r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (n r) -> n (n r)
forall a. m a -> n a
phi (m (n r) -> n r) -> m (n r) -> n r
forall a b. (a -> b) -> a -> b
$ (b -> m (n r))
-> (forall x. (x -> m (n r)) -> f x -> m (n r)) -> m (n r)
forall r. (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (n r -> m (n r)
forall (m :: * -> *) a. Monad m => a -> m a
return (n r -> m (n r)) -> (b -> n r) -> b -> m (n r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> n r
kp) (\x -> m (n r)
xg -> n r -> m (n r)
forall (m :: * -> *) a. Monad m => a -> m a
return (n r -> m (n r)) -> (f x -> n r) -> f x -> m (n r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> n r) -> f x -> n r
forall x. (x -> n r) -> f x -> n r
kf (n (n r) -> n r
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (n (n r) -> n r) -> (x -> n (n r)) -> x -> n r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (n r) -> n (n r)
forall a. m a -> n a
phi (m (n r) -> n (n r)) -> (x -> m (n r)) -> x -> n (n r)
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 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 r.
 (b -> m r) -> (forall x. (x -> m r) -> g x -> m r) -> m r)
-> FT g m b
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 -> (b -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
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 -> (x -> m r) -> g x -> m r
forall x. (x -> m r) -> g x -> m r
kf x -> m r
xg (g x -> m r) -> (f x -> g x) -> f x -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
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 :: 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) = (a -> m (F f a))
-> (forall x. (x -> m (F f a)) -> f x -> m (F f a)) -> m (F f a)
forall r. (a -> m r) -> (forall x. (x -> m r) -> f x -> m r) -> m r
m (F f a -> m (F f a)
forall (m :: * -> *) a. Monad m => a -> m a
return (F f a -> m (F f a)) -> (a -> F f a) -> a -> m (F f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> F f a
forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (F f a)
xg -> (f (F f a) -> F f a) -> m (f (F f a)) -> m (F f a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM f (F f a) -> F f a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (m (f (F f a)) -> m (F f a))
-> (f x -> m (f (F f a))) -> f x -> m (F f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> m (F f a)) -> f x -> m (f (F f a))
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 :: Integer -> FT f m a -> FT f m (Maybe a)
cutoff Integer
n = FreeT f m (Maybe a) -> FT f m (Maybe a)
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
FreeT f m a -> FT f m a
toFT (FreeT f m (Maybe a) -> FT f m (Maybe a))
-> (FT f m a -> FreeT f m (Maybe a))
-> FT f m a
-> FT f m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FreeT f m a -> FreeT f m (Maybe a)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Integer -> FreeT f m a -> FreeT f m (Maybe a)
FreeT.cutoff Integer
n (FreeT f m a -> FreeT f m (Maybe a))
-> (FT f m a -> FreeT f m a) -> FT f m a -> FreeT f m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT f m a -> FreeT f m a
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'
-- @
#if __GLASGOW_HASKELL__ < 710
retract :: (Functor f, Monad f) => F f a -> f a
#else
retract :: Monad f => F f a -> f a
#endif
retract :: F f a -> f a
retract F f a
m = F f a -> (a -> f a) -> (f (f a) -> f a) -> f a
forall (f :: * -> *) a.
Functor f =>
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return f (f a) -> f a
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 :: 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) = t m (t m a) -> t m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t m (t m a) -> t m a)
-> (m (t m a) -> t m (t m a)) -> m (t m a) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (t m a) -> t m (t m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (t m a) -> t m a) -> m (t m a) -> t m a
forall a b. (a -> b) -> a -> b
$ (a -> m (t m a))
-> (forall x. (x -> m (t m a)) -> t m x -> m (t m a)) -> m (t m a)
forall r.
(a -> m r) -> (forall x. (x -> m r) -> t m x -> m r) -> m r
m (t m a -> m (t m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (t m a -> m (t m a)) -> (a -> t m a) -> a -> m (t m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return) (\x -> m (t m a)
xg t m x
xf -> t m a -> m (t m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (t m a -> m (t m a)) -> t m a -> m (t m a)
forall a b. (a -> b) -> a -> b
$ t m x
xf t m x -> (x -> t m a) -> t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t m (t m a) -> t m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t m (t m a) -> t m a) -> (x -> t m (t m a)) -> x -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (t m a) -> t m (t m a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (t m a) -> t m (t m a)) -> (x -> m (t m a)) -> x -> t m (t m a)
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 :: (f a -> a) -> F f a -> a
iter f a -> a
phi = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (F f a -> Identity a) -> F f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Identity a) -> Identity a) -> F f a -> Identity a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FT f m a -> m a
iterT (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a)
-> (f (Identity a) -> a) -> f (Identity a) -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a
phi (f a -> a) -> (f (Identity a) -> f a) -> f (Identity a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity a -> a) -> f (Identity a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity a -> a
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 :: (f (m a) -> m a) -> F f a -> m a
iterM f (m a) -> m a
phi = (f (m a) -> m a) -> FT f m a -> m a
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 f m a -> m a) -> (F f a -> FT f m a) -> F f a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Identity a -> m a) -> F f a -> FT f m a
forall (m :: * -> *) (n :: * -> *) (f :: * -> *) b.
(Monad m, Monad n) =>
(forall a. m a -> n a) -> FT f m b -> FT f n b
hoistFT (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Identity a -> a) -> Identity a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity)

-- | Convert to another free monad representation.
fromF :: (Functor f, MonadFree f m) => F f a -> m a
fromF :: F f a -> m a
fromF F f a
m = F f a -> (a -> m a) -> (f (m a) -> m a) -> m a
forall (f :: * -> *) a.
Functor f =>
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F f a
m a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return f (m a) -> m a
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 :: Free f a -> F f a
toF = Free f a -> F f a
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:
--
-- <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 :: (forall (m :: * -> *). MonadFree f m => m a) -> Free f a
improve forall (m :: * -> *). MonadFree f m => m a
m = F f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
F f a -> m a
fromF F f a
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 (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a)
-> FreeT f m a
improveT forall (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a
m = FT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
FT f m a -> FreeT f m a
fromFT FT f m a
forall (t :: (* -> *) -> * -> *). MonadFree f (t m) => t m a
m
{-# INLINE improveT #-}