{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE Safe #-}
#else
-- Manual Typeable instances
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"

--------------------------------------------------------------------------------
-- |
-- Given an applicative, the free monad transformer.
--------------------------------------------------------------------------------

module Control.Monad.Trans.Free.Ap
  (
  -- * The base functor
    FreeF(..)
  -- * The free monad transformer
  , FreeT(..)
  -- * The free monad
  , Free, free, runFree
  -- * Operations
  , liftF
  , iterT
  , iterTM
  , hoistFreeT
  , transFreeT
  , joinFreeT
  , cutoff
  , partialIterT
  , intersperseT
  , intercalateT
  , retractT
  -- * Operations of free monad
  , retract
  , iter
  , iterM
  -- * Free Monads With Class
  , MonadFree(..)
  ) where

import Control.Applicative
import Control.Monad (liftM, MonadPlus(..), join)
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Trans.Class
import qualified Control.Monad.Fail as Fail
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.Functor.Classes.Compat
import Data.Functor.Identity
import Data.Traversable
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.Data
#if __GLASGOW_HASKELL__ >= 707
import GHC.Generics
#endif

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

-- | The base functor for a free monad.
data FreeF f a b = Pure a | Free (f b)
  deriving (FreeF f a b -> FreeF f a b -> Bool
(FreeF f a b -> FreeF f a b -> Bool)
-> (FreeF f a b -> FreeF f a b -> Bool) -> Eq (FreeF f a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a b.
(Eq a, Eq (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
/= :: FreeF f a b -> FreeF f a b -> Bool
$c/= :: forall (f :: * -> *) a b.
(Eq a, Eq (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
== :: FreeF f a b -> FreeF f a b -> Bool
$c== :: forall (f :: * -> *) a b.
(Eq a, Eq (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
Eq,Eq (FreeF f a b)
Eq (FreeF f a b)
-> (FreeF f a b -> FreeF f a b -> Ordering)
-> (FreeF f a b -> FreeF f a b -> Bool)
-> (FreeF f a b -> FreeF f a b -> Bool)
-> (FreeF f a b -> FreeF f a b -> Bool)
-> (FreeF f a b -> FreeF f a b -> Bool)
-> (FreeF f a b -> FreeF f a b -> FreeF f a b)
-> (FreeF f a b -> FreeF f a b -> FreeF f a b)
-> Ord (FreeF f a b)
FreeF f a b -> FreeF f a b -> Bool
FreeF f a b -> FreeF f a b -> Ordering
FreeF f a b -> FreeF f a b -> FreeF f a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (f :: * -> *) a b. (Ord a, Ord (f b)) => Eq (FreeF f a b)
forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Ordering
forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> FreeF f a b
min :: FreeF f a b -> FreeF f a b -> FreeF f a b
$cmin :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> FreeF f a b
max :: FreeF f a b -> FreeF f a b -> FreeF f a b
$cmax :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> FreeF f a b
>= :: FreeF f a b -> FreeF f a b -> Bool
$c>= :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
> :: FreeF f a b -> FreeF f a b -> Bool
$c> :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
<= :: FreeF f a b -> FreeF f a b -> Bool
$c<= :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
< :: FreeF f a b -> FreeF f a b -> Bool
$c< :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Bool
compare :: FreeF f a b -> FreeF f a b -> Ordering
$ccompare :: forall (f :: * -> *) a b.
(Ord a, Ord (f b)) =>
FreeF f a b -> FreeF f a b -> Ordering
$cp1Ord :: forall (f :: * -> *) a b. (Ord a, Ord (f b)) => Eq (FreeF f a b)
Ord,Int -> FreeF f a b -> ShowS
[FreeF f a b] -> ShowS
FreeF f a b -> String
(Int -> FreeF f a b -> ShowS)
-> (FreeF f a b -> String)
-> ([FreeF f a b] -> ShowS)
-> Show (FreeF f a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
Int -> FreeF f a b -> ShowS
forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
[FreeF f a b] -> ShowS
forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
FreeF f a b -> String
showList :: [FreeF f a b] -> ShowS
$cshowList :: forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
[FreeF f a b] -> ShowS
show :: FreeF f a b -> String
$cshow :: forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
FreeF f a b -> String
showsPrec :: Int -> FreeF f a b -> ShowS
$cshowsPrec :: forall (f :: * -> *) a b.
(Show a, Show (f b)) =>
Int -> FreeF f a b -> ShowS
Show,ReadPrec [FreeF f a b]
ReadPrec (FreeF f a b)
Int -> ReadS (FreeF f a b)
ReadS [FreeF f a b]
(Int -> ReadS (FreeF f a b))
-> ReadS [FreeF f a b]
-> ReadPrec (FreeF f a b)
-> ReadPrec [FreeF f a b]
-> Read (FreeF f a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadPrec [FreeF f a b]
forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadPrec (FreeF f a b)
forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
Int -> ReadS (FreeF f a b)
forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadS [FreeF f a b]
readListPrec :: ReadPrec [FreeF f a b]
$creadListPrec :: forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadPrec [FreeF f a b]
readPrec :: ReadPrec (FreeF f a b)
$creadPrec :: forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadPrec (FreeF f a b)
readList :: ReadS [FreeF f a b]
$creadList :: forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
ReadS [FreeF f a b]
readsPrec :: Int -> ReadS (FreeF f a b)
$creadsPrec :: forall (f :: * -> *) a b.
(Read a, Read (f b)) =>
Int -> ReadS (FreeF f a b)
Read
#if __GLASGOW_HASKELL__ >= 707
           ,Typeable ,(forall x. FreeF f a b -> Rep (FreeF f a b) x)
-> (forall x. Rep (FreeF f a b) x -> FreeF f a b)
-> Generic (FreeF f a b)
forall x. Rep (FreeF f a b) x -> FreeF f a b
forall x. FreeF f a b -> Rep (FreeF f a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) a b x. Rep (FreeF f a b) x -> FreeF f a b
forall (f :: * -> *) a b x. FreeF f a b -> Rep (FreeF f a b) x
$cto :: forall (f :: * -> *) a b x. Rep (FreeF f a b) x -> FreeF f a b
$cfrom :: forall (f :: * -> *) a b x. FreeF f a b -> Rep (FreeF f a b) x
Generic, (forall a. FreeF f a a -> Rep1 (FreeF f a) a)
-> (forall a. Rep1 (FreeF f a) a -> FreeF f a a)
-> Generic1 (FreeF f a)
forall a. Rep1 (FreeF f a) a -> FreeF f a a
forall a. FreeF f a a -> Rep1 (FreeF f a) a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
forall (f :: * -> *) a a. Rep1 (FreeF f a) a -> FreeF f a a
forall (f :: * -> *) a a. FreeF f a a -> Rep1 (FreeF f a) a
$cto1 :: forall (f :: * -> *) a a. Rep1 (FreeF f a) a -> FreeF f a a
$cfrom1 :: forall (f :: * -> *) a a. FreeF f a a -> Rep1 (FreeF f a) a
Generic1
#endif
           )

#ifdef LIFTED_FUNCTOR_CLASSES
instance Show1 f => Show2 (FreeF f) where
  liftShowsPrec2 :: (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> FreeF f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
spa [a] -> ShowS
_sla Int -> b -> ShowS
_spb [b] -> ShowS
_slb Int
d (Pure a
a) =
    (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
spa String
"Pure" Int
d a
a
  liftShowsPrec2 Int -> a -> ShowS
_spa [a] -> ShowS
_sla Int -> b -> ShowS
spb [b] -> ShowS
slb Int
d (Free f b
as) =
    (Int -> f b -> ShowS) -> String -> Int -> f b -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f b -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> b -> ShowS
spb [b] -> ShowS
slb) String
"Free" Int
d f b
as

instance (Show1 f, Show a) => Show1 (FreeF f a) where
  liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FreeF f a a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> FreeF f a a
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList
#else
instance (Show1 f, Show a) => Show1 (FreeF f a) where
  showsPrec1 d (Pure a)  = showParen (d > 10) $ showString "Pure " . showsPrec 11 a
  showsPrec1 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance Read1 f => Read2 (FreeF f) where
  liftReadsPrec2 :: (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (FreeF f a b)
liftReadsPrec2 Int -> ReadS a
rpa ReadS [a]
_rla Int -> ReadS b
rpb ReadS [b]
rlb = (String -> ReadS (FreeF f a b)) -> Int -> ReadS (FreeF f a b)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (FreeF f a b)) -> Int -> ReadS (FreeF f a b))
-> (String -> ReadS (FreeF f a b)) -> Int -> ReadS (FreeF f a b)
forall a b. (a -> b) -> a -> b
$
    (Int -> ReadS a)
-> String -> (a -> FreeF f a b) -> String -> ReadS (FreeF f a b)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rpa String
"Pure" a -> FreeF f a b
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (String -> ReadS (FreeF f a b))
-> (String -> ReadS (FreeF f a b)) -> String -> ReadS (FreeF f a b)
forall a. Monoid a => a -> a -> a
`mappend`
    (Int -> ReadS (f b))
-> String -> (f b -> FreeF f a b) -> String -> ReadS (FreeF f a b)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f b)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS b
rpb ReadS [b]
rlb) String
"Free" f b -> FreeF f a b
forall (f :: * -> *) a b. f b -> FreeF f a b
Free

instance (Read1 f, Read a) => Read1 (FreeF f a) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (FreeF f a a)
liftReadsPrec = (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (FreeF f a a)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec ReadS [a]
forall a. Read a => ReadS [a]
readList
#else
instance (Read1 f, Read a) => Read1 (FreeF f a) where
  readsPrec1 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
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance Eq1 f => Eq2 (FreeF f) where
  liftEq2 :: (a -> b -> Bool)
-> (c -> d -> Bool) -> FreeF f a c -> FreeF f b d -> Bool
liftEq2 a -> b -> Bool
eq c -> d -> Bool
_ (Pure a
a) (Pure b
b) = a -> b -> Bool
eq a
a b
b
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
eq (Free f c
as) (Free f d
bs) = (c -> d -> Bool) -> f c -> f d -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq c -> d -> Bool
eq f c
as f d
bs
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ FreeF f a c
_ FreeF f b d
_ = Bool
False

instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where
  liftEq :: (a -> b -> Bool) -> FreeF f a a -> FreeF f a b -> Bool
liftEq = (a -> a -> Bool)
-> (a -> b -> Bool) -> FreeF f a a -> FreeF f a b -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)
#else
instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where
  Pure a  `eq1` Pure b = a == b
  Free as `eq1` Free bs = as `eq1` bs
  _       `eq1` _ = False
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance Ord1 f => Ord2 (FreeF f) where
  liftCompare2 :: (a -> b -> Ordering)
-> (c -> d -> Ordering) -> FreeF f a c -> FreeF f b d -> Ordering
liftCompare2 a -> b -> Ordering
cmp c -> d -> Ordering
_ (Pure a
a) (Pure b
b) = a -> b -> Ordering
cmp a
a b
b
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ (Pure a
_) (Free f d
_) = Ordering
LT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ (Free f c
_) (Pure b
_) = Ordering
GT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
cmp (Free f c
fa) (Free f d
fb) = (c -> d -> Ordering) -> f c -> f d -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare c -> d -> Ordering
cmp f c
fa f d
fb

instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where
  liftCompare :: (a -> b -> Ordering) -> FreeF f a a -> FreeF f a b -> Ordering
liftCompare = (a -> a -> Ordering)
-> (a -> b -> Ordering) -> FreeF f a a -> FreeF f a b -> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
#else
instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where
  Pure a `compare1` Pure b = a `compare` b
  Pure _ `compare1` Free _ = LT
  Free _ `compare1` Pure _ = GT
  Free fa `compare1` Free fb = fa `compare1` fb
#endif

instance Functor f => Functor (FreeF f a) where
  fmap :: (a -> b) -> FreeF f a a -> FreeF f a b
fmap a -> b
_ (Pure a
a)  = a -> FreeF f a b
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
  fmap a -> b
f (Free f a
as) = f b -> FreeF f a b
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
as)
  {-# INLINE fmap #-}

instance Foldable f => Foldable (FreeF f a) where
  foldMap :: (a -> m) -> FreeF f a a -> m
foldMap a -> m
f (Free f a
as) = (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
as
  foldMap a -> m
_ FreeF f a a
_         = m
forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

instance Traversable f => Traversable (FreeF f a) where
  traverse :: (a -> f b) -> FreeF f a a -> f (FreeF f a b)
traverse a -> f b
_ (Pure a
a)  = FreeF f a b -> f (FreeF f a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> FreeF f a b
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a)
  traverse a -> f b
f (Free f a
as) = f b -> FreeF f a b
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f b -> FreeF f a b) -> f (f b) -> f (FreeF f a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> f a -> f (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f f a
as
  {-# INLINE traverse #-}

instance Functor f => Bifunctor (FreeF f) where
  bimap :: (a -> b) -> (c -> d) -> FreeF f a c -> FreeF f b d
bimap a -> b
f c -> d
_ (Pure a
a)  = b -> FreeF f b d
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> b
f a
a)
  bimap a -> b
_ c -> d
g (Free f c
as) = f d -> FreeF f b d
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g f c
as)
  {-# INLINE bimap #-}

instance Foldable f => Bifoldable (FreeF f) where
  bifoldMap :: (a -> m) -> (b -> m) -> FreeF f a b -> m
bifoldMap a -> m
f b -> m
_ (Pure a
a)  = a -> m
f a
a
  bifoldMap a -> m
_ b -> m
g (Free f b
as) = (b -> m) -> f b -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> m
g f b
as
  {-# INLINE bifoldMap #-}

instance Traversable f => Bitraversable (FreeF f) where
  bitraverse :: (a -> f c) -> (b -> f d) -> FreeF f a b -> f (FreeF f c d)
bitraverse a -> f c
f b -> f d
_ (Pure a
a)  = c -> FreeF f c d
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (c -> FreeF f c d) -> f c -> f (FreeF f c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a
  bitraverse a -> f c
_ b -> f d
g (Free f b
as) = f d -> FreeF f c d
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f d -> FreeF f c d) -> f (f d) -> f (FreeF f c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> f d) -> f b -> f (f d)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> f d
g f b
as
  {-# INLINE bitraverse #-}

transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
transFreeF :: (forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
transFreeF forall x. f x -> g x
_ (Pure a
a) = a -> FreeF g a b
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
transFreeF forall x. f x -> g x
t (Free f b
as) = g b -> FreeF g a b
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f b -> g b
forall x. f x -> g x
t f b
as)
{-# INLINE transFreeF #-}

-- | The \"free monad transformer\" for an applicative @f@
newtype FreeT f m a = FreeT { FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT :: m (FreeF f a (FreeT f m a)) }

-- | The \"free monad\" for an applicative @f@.
type Free f = FreeT f Identity

-- | Evaluates the first layer out of a free monad value.
runFree :: Free f a -> FreeF f a (Free f a)
runFree :: Free f a -> FreeF f a (Free f a)
runFree = Identity (FreeF f a (Free f a)) -> FreeF f a (Free f a)
forall a. Identity a -> a
runIdentity (Identity (FreeF f a (Free f a)) -> FreeF f a (Free f a))
-> (Free f a -> Identity (FreeF f a (Free f a)))
-> Free f a
-> FreeF f a (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free f a -> Identity (FreeF f a (Free f a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT
{-# INLINE runFree #-}

-- | Pushes a layer into a free monad value.
free :: FreeF f a (Free f a) -> Free f a
free :: FreeF f a (Free f a) -> Free f a
free = Identity (FreeF f a (Free f a)) -> Free f a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (Identity (FreeF f a (Free f a)) -> Free f a)
-> (FreeF f a (Free f a) -> Identity (FreeF f a (Free f a)))
-> FreeF f a (Free f a)
-> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeF f a (Free f a) -> Identity (FreeF f a (Free f a))
forall a. a -> Identity a
Identity
{-# INLINE free #-}

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Eq1 f, Eq1 m, Eq a) => Eq (FreeT f m a) where
#else
instance (Functor f, Eq1 f, Functor m, Eq1 m, Eq a)=> Eq (FreeT f m a) where
#endif
    == :: FreeT f m a -> FreeT f m a -> Bool
(==) = FreeT f m a -> FreeT f m a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where
  liftEq :: (a -> b -> Bool) -> FreeT f m a -> FreeT f m b -> Bool
liftEq a -> b -> Bool
eq = FreeT f m a -> FreeT f m b -> Bool
forall (f :: * -> *) (f :: * -> *).
(Eq1 f, Eq1 f) =>
FreeT f f a -> FreeT f f b -> Bool
go
    where
      go :: FreeT f f a -> FreeT f f b -> Bool
go (FreeT f (FreeF f a (FreeT f f a))
x) (FreeT f (FreeF f b (FreeT f f b))
y) = (FreeF f a (FreeT f f a) -> FreeF f b (FreeT f f b) -> Bool)
-> f (FreeF f a (FreeT f f a))
-> f (FreeF f b (FreeT f f b))
-> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq ((a -> b -> Bool)
-> (FreeT f f a -> FreeT f f b -> Bool)
-> FreeF f a (FreeT f f a)
-> FreeF f b (FreeT f f b)
-> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> b -> Bool
eq FreeT f f a -> FreeT f f b -> Bool
go) f (FreeF f a (FreeT f f a))
x f (FreeF f b (FreeT f f b))
y
#else
instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where
  eq1 = on eq1 (fmap (Lift1 . fmap Lift1) . runFreeT)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Ord1 f, Ord1 m, Ord a) => Ord (FreeT f m a) where
#else
instance (Functor f, Ord1 f, Functor m, Ord1 m, Ord a) => Ord (FreeT f m a) where
#endif
    compare :: FreeT f m a -> FreeT f m a -> Ordering
compare = FreeT f m a -> FreeT f m a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where
  liftCompare :: (a -> b -> Ordering) -> FreeT f m a -> FreeT f m b -> Ordering
liftCompare a -> b -> Ordering
cmp = FreeT f m a -> FreeT f m b -> Ordering
forall (f :: * -> *) (f :: * -> *).
(Ord1 f, Ord1 f) =>
FreeT f f a -> FreeT f f b -> Ordering
go
    where
      go :: FreeT f f a -> FreeT f f b -> Ordering
go (FreeT f (FreeF f a (FreeT f f a))
x) (FreeT f (FreeF f b (FreeT f f b))
y) = (FreeF f a (FreeT f f a) -> FreeF f b (FreeT f f b) -> Ordering)
-> f (FreeF f a (FreeT f f a))
-> f (FreeF f b (FreeT f f b))
-> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare ((a -> b -> Ordering)
-> (FreeT f f a -> FreeT f f b -> Ordering)
-> FreeF f a (FreeT f f a)
-> FreeF f b (FreeT f f b)
-> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> b -> Ordering
cmp FreeT f f a -> FreeT f f b -> Ordering
go) f (FreeF f a (FreeT f f a))
x f (FreeF f b (FreeT f f b))
y
#else
instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where
  compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Show1 f, Show1 m) => Show1 (FreeT f m) where
  liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FreeT f m a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl = Int -> FreeT f m a -> ShowS
go
    where
      goList :: [FreeT f m a] -> ShowS
goList = (Int -> a -> ShowS) -> ([a] -> ShowS) -> [FreeT f m a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl
      go :: Int -> FreeT f m a -> ShowS
go Int
d (FreeT m (FreeF f a (FreeT f m a))
x) = (Int -> m (FreeF f a (FreeT f m a)) -> ShowS)
-> String -> Int -> m (FreeF f a (FreeT f m a)) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
        ((Int -> FreeF f a (FreeT f m a) -> ShowS)
-> ([FreeF f a (FreeT f m a)] -> ShowS)
-> Int
-> m (FreeF f a (FreeT f m a))
-> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec ((Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> FreeT f m a -> ShowS)
-> ([FreeT f m a] -> ShowS)
-> Int
-> FreeF f a (FreeT f m a)
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp [a] -> ShowS
sl Int -> FreeT f m a -> ShowS
go [FreeT f m a] -> ShowS
goList) ((Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> FreeT f m a -> ShowS)
-> ([FreeT f m a] -> ShowS)
-> [FreeF f a (FreeT f m a)]
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> [f a b]
-> ShowS
liftShowList2 Int -> a -> ShowS
sp [a] -> ShowS
sl Int -> FreeT f m a -> ShowS
go [FreeT f m a] -> ShowS
goList))
        String
"FreeT" Int
d m (FreeF f a (FreeT f m a))
x
#else
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)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where
#else
instance (Functor f, Show1 f, Functor m, Show1 m, Show a) => Show (FreeT f m a) where
#endif
  showsPrec :: Int -> FreeT f m a -> ShowS
showsPrec = Int -> FreeT f m a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Read1 f, Read1 m) => Read1 (FreeT f m) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (FreeT f m a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = Int -> ReadS (FreeT f m a)
go
    where
      goList :: ReadS [FreeT f m a]
goList = (Int -> ReadS a) -> ReadS [a] -> ReadS [FreeT f m a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl
      go :: Int -> ReadS (FreeT f m a)
go = (String -> ReadS (FreeT f m a)) -> Int -> ReadS (FreeT f m a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (FreeT f m a)) -> Int -> ReadS (FreeT f m a))
-> (String -> ReadS (FreeT f m a)) -> Int -> ReadS (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (m (FreeF f a (FreeT f m a))))
-> String
-> (m (FreeF f a (FreeT f m a)) -> FreeT f m a)
-> String
-> ReadS (FreeT f m a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith
        ((Int -> ReadS (FreeF f a (FreeT f m a)))
-> ReadS [FreeF f a (FreeT f m a)]
-> Int
-> ReadS (m (FreeF f a (FreeT f m a)))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec ((Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS (FreeT f m a))
-> ReadS [FreeT f m a]
-> Int
-> ReadS (FreeF f a (FreeT f m a))
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
rp ReadS [a]
rl Int -> ReadS (FreeT f m a)
go ReadS [FreeT f m a]
goList) ((Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS (FreeT f m a))
-> ReadS [FreeT f m a]
-> ReadS [FreeF f a (FreeT f m a)]
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
liftReadList2 Int -> ReadS a
rp ReadS [a]
rl Int -> ReadS (FreeT f m a)
go ReadS [FreeT f m a]
goList))
        String
"FreeT" 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
#else
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]
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where
#else
instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a) where
#endif
  readsPrec :: Int -> ReadS (FreeT f m a)
readsPrec = Int -> ReadS (FreeT f m a)
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance (Functor f, Monad m) => Functor (FreeT f m) where
  fmap :: (a -> b) -> FreeT f m a -> FreeT f m b
fmap a -> b
f (FreeT m (FreeF f a (FreeT f m a))
m) = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT ((FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) (f :: * -> *).
(Functor f, Functor f) =>
FreeF f a (f a) -> FreeF f b (f b)
f' m (FreeF f a (FreeT f m a))
m) where
    f' :: FreeF f a (f a) -> FreeF f b (f b)
f' (Pure a
a)  = b -> FreeF f b (f b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> b
f a
a)
    f' (Free f (f a)
as) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (f a)
as)

instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where
  pure :: a -> FreeT f m a
pure a
a = 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 (FreeF f a (FreeT f m a) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a))
  {-# INLINE pure #-}
  FreeT m (FreeF f (a -> b) (FreeT f m (a -> b)))
f <*> :: FreeT f m (a -> b) -> FreeT f m a -> FreeT f m b
<*> FreeT m (FreeF f a (FreeT f m a))
a = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ FreeF f (a -> b) (FreeT f m (a -> b))
-> FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) (f :: * -> *) a b.
(Applicative f, Applicative f) =>
FreeF f (a -> b) (f (a -> b)) -> FreeF f a (f a) -> FreeF f b (f b)
g (FreeF f (a -> b) (FreeT f m (a -> b))
 -> FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
-> m (FreeF f (a -> b) (FreeT f m (a -> b)))
-> m (FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (FreeF f (a -> b) (FreeT f m (a -> b)))
f m (FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (FreeF f a (FreeT f m a))
a where
    g :: FreeF f (a -> b) (f (a -> b)) -> FreeF f a (f a) -> FreeF f b (f b)
g (Pure a -> b
f') (Pure a
a') = b -> FreeF f b (f b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> b
f' a
a')
    g (Pure a -> b
f') (Free f (f a)
as) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f a)
as
    g (Free f (f (a -> b))
fs) (Pure a
a') = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a') (f (a -> b) -> f b) -> f (f (a -> b)) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (a -> b))
fs
    g (Free f (f (a -> b))
fs) (Free f (f a)
as) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (f (a -> b) -> f a -> f b) -> f (f (a -> b)) -> f (f a -> f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (a -> b))
fs f (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (f a)
as
  {-# INLINE (<*>) #-}

instance (Apply f, Apply m, Monad m) => Apply (FreeT f m) where
  FreeT m (FreeF f (a -> b) (FreeT f m (a -> b)))
f <.> :: FreeT f m (a -> b) -> FreeT f m a -> FreeT f m b
<.> FreeT m (FreeF f a (FreeT f m a))
a = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ FreeF f (a -> b) (FreeT f m (a -> b))
-> FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) (f :: * -> *) a b.
(Apply f, Apply f) =>
FreeF f (a -> b) (f (a -> b)) -> FreeF f a (f a) -> FreeF f b (f b)
g (FreeF f (a -> b) (FreeT f m (a -> b))
 -> FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
-> m (FreeF f (a -> b) (FreeT f m (a -> b)))
-> m (FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (FreeF f (a -> b) (FreeT f m (a -> b)))
f m (FreeF f a (FreeT f m a) -> FreeF f b (FreeT f m b))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> m (FreeF f a (FreeT f m a))
a where
    g :: FreeF f (a -> b) (f (a -> b)) -> FreeF f a (f a) -> FreeF f b (f b)
g (Pure a -> b
f') (Pure a
a') = b -> FreeF f b (f b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> b
f' a
a')
    g (Pure a -> b
f') (Free f (f a)
as) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f a)
as
    g (Free f (f (a -> b))
fs) (Pure a
a') = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a') (f (a -> b) -> f b) -> f (f (a -> b)) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (a -> b))
fs
    g (Free f (f (a -> b))
fs) (Free f (f a)
as) = f (f b) -> FreeF f b (f b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f b) -> FreeF f b (f b)) -> f (f b) -> FreeF f b (f b)
forall a b. (a -> b) -> a -> b
$ f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>) (f (a -> b) -> f a -> f b) -> f (f (a -> b)) -> f (f a -> f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (a -> b))
fs f (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f (f a)
as

instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where
  FreeT m (FreeF f a (FreeT f m a))
m >>- :: FreeT f m a -> (a -> FreeT f m b) -> FreeT f m b
>>- a -> FreeT f m b
f = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ m (FreeF f a (FreeT f m a))
m m (FreeF f a (FreeT f m a))
-> (FreeF f a (FreeT f m a) -> m (FreeF f b (FreeT f m b)))
-> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FreeF f a (FreeT f m a)
v -> case FreeF f a (FreeT f m a)
v of
    Pure a
a -> FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (a -> FreeT f m b
f a
a)
    Free f (FreeT f m a)
w -> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (FreeT f m b) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((FreeT f m a -> FreeT f m b) -> f (FreeT f m a) -> f (FreeT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FreeT f m a -> (a -> FreeT f m b) -> FreeT f m b
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- a -> FreeT f m b
f) f (FreeT f m a)
w))

instance (Applicative f, Applicative m, Monad m) => Monad (FreeT f m) where
  return :: a -> FreeT f m a
return = a -> FreeT f m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  FreeT m (FreeF f a (FreeT f m a))
m >>= :: FreeT f m a -> (a -> FreeT f m b) -> FreeT f m b
>>= a -> FreeT f m b
f = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ m (FreeF f a (FreeT f m a))
m m (FreeF f a (FreeT f m a))
-> (FreeF f a (FreeT f m a) -> m (FreeF f b (FreeT f m b)))
-> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FreeF f a (FreeT f m a)
v -> case FreeF f a (FreeT f m a)
v of
    Pure a
a -> FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (a -> FreeT f m b
f a
a)
    Free f (FreeT f m a)
w -> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (FreeT f m b) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((FreeT f m a -> FreeT f m b) -> f (FreeT f m a) -> f (FreeT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FreeT f m a -> (a -> FreeT f m b) -> FreeT f m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> FreeT f m b
f) f (FreeT f m a)
w))
#if !MIN_VERSION_base(4,13,0)
  fail e = FreeT (fail e)
#endif

instance (Applicative f, Applicative m, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where
  fail :: String -> FreeT f m a
fail String
e = 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 (String -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
e)

instance MonadTrans (FreeT f) where
  lift :: m a -> FreeT f m a
lift = 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 a -> m (FreeF f a (FreeT f m a))) -> m a -> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> FreeF f a (FreeT f m a))
-> m a -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure
  {-# INLINE lift #-}

instance (Applicative f, Applicative m, MonadIO m) => MonadIO (FreeT f m) where
  liftIO :: IO a -> FreeT f m a
liftIO = m a -> FreeT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FreeT f m a) -> (IO a -> m a) -> IO a -> FreeT 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 (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where
  ask :: FreeT f m r
ask = m r -> FreeT 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) -> FreeT f m a -> FreeT f m a
local r -> r
f = (forall a. m a -> m a) -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Monad m, Applicative f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT ((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 (Applicative f, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where
  tell :: w -> FreeT f m ()
tell = m () -> FreeT f m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> FreeT f m ()) -> (w -> m ()) -> w -> FreeT 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 :: FreeT f m a -> FreeT f m (a, w)
listen (FreeT m (FreeF f a (FreeT f m a))
m) = m (FreeF f (a, w) (FreeT f m (a, w))) -> FreeT f m (a, w)
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f (a, w) (FreeT f m (a, w))) -> FreeT f m (a, w))
-> m (FreeF f (a, w) (FreeT f m (a, w))) -> FreeT f m (a, w)
forall a b. (a -> b) -> a -> b
$ ((FreeF f a (FreeT f m (a, w)), w)
 -> FreeF f (a, w) (FreeT f m (a, w)))
-> m (FreeF f a (FreeT f m (a, w)), w)
-> m (FreeF f (a, w) (FreeT f m (a, w)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (FreeF f a (FreeT f m (a, w)), w)
-> FreeF f (a, w) (FreeT f m (a, w))
forall (f :: * -> *) (f :: * -> *) (p :: * -> * -> *) c a a.
(Functor f, Functor f, Bifunctor p, Monoid c) =>
(FreeF f a (f (p a c)), c) -> FreeF f (a, c) (f (p a c))
concat' (m (FreeF f a (FreeT f m (a, w)), w)
 -> m (FreeF f (a, w) (FreeT f m (a, w))))
-> m (FreeF f a (FreeT f m (a, w)), w)
-> m (FreeF f (a, w) (FreeT f m (a, w)))
forall a b. (a -> b) -> a -> b
$ m (FreeF f a (FreeT f m (a, w)))
-> m (FreeF f a (FreeT f m (a, w)), w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ((FreeT f m a -> FreeT f m (a, w))
-> FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m (a, w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m a -> FreeT f m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m (a, w)))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m (a, w)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (FreeF f a (FreeT f m a))
m)
    where
      concat' :: (FreeF f a (f (p a c)), c) -> FreeF f (a, c) (f (p a c))
concat' (Pure a
x, c
w) = (a, c) -> FreeF f (a, c) (f (p a c))
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a
x, c
w)
      concat' (Free f (f (p a c))
y, c
w) = f (f (p a c)) -> FreeF f (a, c) (f (p a c))
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (f (p a c)) -> FreeF f (a, c) (f (p a c)))
-> f (f (p a c)) -> FreeF f (a, c) (f (p a c))
forall a b. (a -> b) -> a -> b
$ (p a c -> p a c) -> f (p a c) -> f (p a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((c -> c) -> p a c -> p a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (c
w c -> c -> c
forall a. Monoid a => a -> a -> a
`mappend`)) (f (p a c) -> f (p a c)) -> f (f (p a c)) -> f (f (p a c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (p a c))
y
  pass :: FreeT f m (a, w -> w) -> FreeT f m a
pass FreeT f m (a, w -> w)
m = 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)
-> (FreeT f m ((a, w -> w), w) -> m (FreeF f a (FreeT f m a)))
-> FreeT f m ((a, w -> w), w)
-> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w)))
-> m (FreeF f a (FreeT f m a))
forall a t.
m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (FreeF f a (FreeT f m a))
pass' (m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w)))
 -> m (FreeF f a (FreeT f m a)))
-> (FreeT f m ((a, w -> w), w)
    -> m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w))))
-> FreeT f m ((a, w -> w), w)
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m ((a, w -> w), w)
-> m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w)))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (FreeT f m ((a, w -> w), w)
 -> m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w))))
-> (FreeT f m ((a, w -> w), w) -> FreeT f m ((a, w -> w), w))
-> FreeT f m ((a, w -> w), w)
-> m (FreeF f ((a, w -> w), w) (FreeT f m ((a, w -> w), w)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. m a -> m a)
-> FreeT f m ((a, w -> w), w) -> FreeT f m ((a, w -> w), w)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Monad m, Applicative f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> m a
clean (FreeT f m ((a, w -> w), w) -> FreeT f m a)
-> FreeT f m ((a, w -> w), w) -> FreeT f m a
forall a b. (a -> b) -> a -> b
$ FreeT f m (a, w -> w) -> FreeT f m ((a, w -> w), w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen FreeT f m (a, w -> w)
m
    where
      clean :: m a -> m a
clean = m (a, w -> w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m (a, w -> w) -> m a) -> (m a -> m (a, w -> w)) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, w -> w)) -> m a -> m (a, w -> w)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, w -> w -> w
forall a b. a -> b -> a
const w
forall a. Monoid a => a
mempty))
      pass' :: m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (FreeF f a (FreeT f m a))
pass' = m (m (FreeF f a (FreeT f m a))) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (FreeF f a (FreeT f m a))) -> m (FreeF f a (FreeT f m a)))
-> (m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
    -> m (m (FreeF f a (FreeT f m a))))
-> m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t))
 -> m (FreeF f a (FreeT f m a)))
-> m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (m (FreeF f a (FreeT f m a)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t))
-> m (FreeF f a (FreeT f m a))
g
      g :: FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t))
-> m (FreeF f a (FreeT f m a))
g (Pure ((a
x, t -> w
f), t
w)) = w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (t -> w
f t
w) m () -> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FreeF f a (FreeT f m a) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
x)
      g (Free f (FreeT f m ((a, t -> w), t))
f)           = 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)))
-> (f (FreeT f m ((a, t -> w), t)) -> FreeF f a (FreeT f m a))
-> f (FreeT f m ((a, t -> w), t))
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> (f (FreeT f m ((a, t -> w), t)) -> f (FreeT f m a))
-> f (FreeT f m ((a, t -> w), t))
-> FreeF f a (FreeT f m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeT f m ((a, t -> w), t) -> FreeT f m a)
-> f (FreeT f m ((a, t -> w), t)) -> 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)
-> (FreeT f m ((a, t -> w), t) -> m (FreeF f a (FreeT f m a)))
-> FreeT f m ((a, t -> w), t)
-> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (FreeF f a (FreeT f m a))
pass' (m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
 -> m (FreeF f a (FreeT f m a)))
-> (FreeT f m ((a, t -> w), t)
    -> m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t))))
-> FreeT f m ((a, t -> w), t)
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m ((a, t -> w), t)
-> m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT) (f (FreeT f m ((a, t -> w), t)) -> m (FreeF f a (FreeT f m a)))
-> f (FreeT f m ((a, t -> w), t)) -> m (FreeF f a (FreeT f m a))
forall a b. (a -> b) -> a -> b
$ f (FreeT f m ((a, t -> w), t))
f
#if MIN_VERSION_mtl(2,1,1)
  writer :: (a, w) -> FreeT f m a
writer (a, w)
w = m a -> FreeT 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 (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where
  get :: FreeT f m s
get = m s -> FreeT 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 -> FreeT f m ()
put = m () -> FreeT f m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> FreeT f m ()) -> (s -> m ()) -> s -> FreeT 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)) -> FreeT f m a
state s -> (a, s)
f = m a -> FreeT 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 (Applicative f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where
  throwError :: e -> FreeT f m a
throwError = m a -> FreeT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FreeT f m a) -> (e -> m a) -> e -> FreeT 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 #-}
  FreeT m (FreeF f a (FreeT f m a))
m catchError :: FreeT f m a -> (e -> FreeT f m a) -> FreeT f m a
`catchError` e -> FreeT f m a
f = 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
$ (FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m a))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FreeT f m a -> FreeT f m a)
-> FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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` e -> FreeT f m a
f)) m (FreeF f a (FreeT f m a))
m m (FreeF f a (FreeT f m a))
-> (e -> m (FreeF f a (FreeT f m a)))
-> m (FreeF f a (FreeT f m a))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (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)))
-> (e -> FreeT f m a) -> e -> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FreeT f m a
f)

instance (Applicative f, Applicative m, MonadCont m) => MonadCont (FreeT f m) where
  callCC :: ((a -> FreeT f m b) -> FreeT f m a) -> FreeT f m a
callCC (a -> FreeT f m b) -> FreeT f m a
f = 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
$ ((FreeF f a (FreeT f m a) -> m b) -> m (FreeF f a (FreeT f m a)))
-> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (\FreeF f a (FreeT f m a) -> m b
k -> 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)))
-> FreeT f m a -> m (FreeF f a (FreeT f m a))
forall a b. (a -> b) -> a -> b
$ (a -> FreeT f m b) -> FreeT f m a
f (m b -> FreeT f m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> FreeT f m b) -> (a -> m b) -> a -> FreeT f m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeF f a (FreeT f m a) -> m b
k (FreeF f a (FreeT f m a) -> m b)
-> (a -> FreeF f a (FreeT f m a)) -> a -> m b
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))

instance (Applicative f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where
  empty :: FreeT f m a
empty = 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))
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  FreeT m (FreeF f a (FreeT f m a))
ma <|> :: FreeT f m a -> FreeT f m a -> FreeT f m a
<|> FreeT m (FreeF f a (FreeT f m a))
mb = 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))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus m (FreeF f a (FreeT f m a))
ma m (FreeF f a (FreeT f m a))
mb)
  {-# INLINE (<|>) #-}

instance (Applicative f, Applicative m, MonadPlus m) => MonadPlus (FreeT f m) where
  mzero :: FreeT f m a
mzero = 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))
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  {-# INLINE mzero #-}
  mplus :: FreeT f m a -> FreeT f m a -> FreeT f m a
mplus (FreeT m (FreeF f a (FreeT f m a))
ma) (FreeT m (FreeF f a (FreeT f m a))
mb) = 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))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus m (FreeF f a (FreeT f m a))
ma m (FreeF f a (FreeT f m a))
mb)
  {-# INLINE mplus #-}

instance (Applicative f, Applicative m, Monad m) => MonadFree f (FreeT f m) where
  wrap :: f (FreeT f m a) -> FreeT f m a
wrap = 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)
-> (f (FreeT f m a) -> m (FreeF f a (FreeT f m a)))
-> f (FreeT f m a)
-> FreeT f m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)))
-> (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a)
-> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free
  {-# INLINE wrap #-}

instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where
  throwM :: e -> FreeT f m a
throwM = m a -> FreeT f m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FreeT f m a) -> (e -> m a) -> e -> FreeT 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 (Applicative f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where
  FreeT m (FreeF f a (FreeT f m a))
m catch :: FreeT f m a -> (e -> FreeT f m a) -> FreeT f m a
`catch` e -> FreeT f m a
f = 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
$ (FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m a))
-> m (FreeF f a (FreeT f m a)) -> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FreeT f m a -> FreeT f m a)
-> FreeF f a (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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` e -> FreeT f m a
f)) m (FreeF f a (FreeT f m a))
m
                                m (FreeF f a (FreeT f m a))
-> (e -> m (FreeF f a (FreeT f m a)))
-> m (FreeF f a (FreeT f m a))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Control.Monad.Catch.catch` (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)))
-> (e -> FreeT f m a) -> e -> m (FreeF f a (FreeT f m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FreeT f m a
f)
  {-# INLINE catch #-}

-- | Given an applicative homomorphism from @f (m a)@ to @m a@,
-- tear down a free monad transformer using iteration.
iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
iterT :: (f (m a) -> m a) -> FreeT f m a -> m a
iterT f (m a) -> m a
f (FreeT m (FreeF f a (FreeT f m a))
m) = do
    FreeF f a (FreeT f m a)
val <- m (FreeF f a (FreeT f m a))
m
    case (FreeT f m a -> m a) -> FreeF f a (FreeT f m a) -> FreeF f a (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (m a) -> m a) -> FreeT f m a -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Applicative f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterT f (m a) -> m a
f) FreeF f a (FreeT f m a)
val of
        Pure a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Free f (m a)
y -> f (m a) -> m a
f f (m a)
y

-- | Given an applicative homomorphism from @f (t m a)@ to @t m a@,
-- tear down a free monad transformer using iteration over a transformer.
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 (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM f (t m a) -> t m a
f (FreeT m (FreeF f a (FreeT f m a))
m) = do
    FreeF f a (FreeT f m a)
val <- m (FreeF f a (FreeT f m a)) -> t m (FreeF f a (FreeT f m a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (FreeF f a (FreeT f m a))
m
    case (FreeT f m a -> t m a)
-> FreeF f a (FreeT f m a) -> FreeF f a (t m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (t m a) -> t m a) -> FreeT f m a -> t m a
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(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 (t m a) -> t m a
f) FreeF f a (FreeT f m a)
val of
        Pure a
x -> a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Free f (t m a)
y -> f (t m a) -> t m a
f f (t m a)
y

instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
  foldMap :: (a -> m) -> FreeT f m a -> m
foldMap a -> m
f (FreeT m (FreeF f a (FreeT f m a))
m) = (FreeF f a (FreeT f m a) -> m) -> m (FreeF f a (FreeT f m a)) -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> (FreeT f m a -> m) -> FreeF f a (FreeT f m a) -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f ((a -> m) -> FreeT f m a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f)) m (FreeF f a (FreeT f m a))
m

instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where
  traverse :: (a -> f b) -> FreeT f m a -> f (FreeT f m b)
traverse a -> f b
f (FreeT m (FreeF f a (FreeT f m a))
m) = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> f (m (FreeF f b (FreeT f m b))) -> f (FreeT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FreeF f a (FreeT f m a) -> f (FreeF f b (FreeT f m b)))
-> m (FreeF f a (FreeT f m a)) -> f (m (FreeF f b (FreeT f m b)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b)
-> (FreeT f m a -> f (FreeT f m b))
-> FreeF f a (FreeT f m a)
-> f (FreeF f b (FreeT f m b))
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f b
f ((a -> f b) -> FreeT f m a -> f (FreeT f m b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f)) m (FreeF f a (FreeT f m a))
m

-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@
--
-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@
hoistFreeT :: (Monad m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT :: (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> n a
mh = n (FreeF f b (FreeT f n b)) -> FreeT f n b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (n (FreeF f b (FreeT f n b)) -> FreeT f n b)
-> (FreeT f m b -> n (FreeF f b (FreeT f n b)))
-> FreeT f m b
-> FreeT f n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FreeF f b (FreeT f n b)) -> n (FreeF f b (FreeT f n b))
forall a. m a -> n a
mh (m (FreeF f b (FreeT f n b)) -> n (FreeF f b (FreeT f n b)))
-> (FreeT f m b -> m (FreeF f b (FreeT f n b)))
-> FreeT f m b
-> n (FreeF f b (FreeT f n b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeF f b (FreeT f m b) -> FreeF f b (FreeT f n b))
-> m (FreeF f b (FreeT f m b)) -> m (FreeF f b (FreeT f n b))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FreeT f m b -> FreeT f n b)
-> FreeF f b (FreeT f m b) -> FreeF f b (FreeT f n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Monad m, Applicative f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> n a
mh)) (m (FreeF f b (FreeT f m b)) -> m (FreeF f b (FreeT f n b)))
-> (FreeT f m b -> m (FreeF f b (FreeT f m b)))
-> FreeT f m b
-> m (FreeF f b (FreeT f n b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT

-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@
transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT :: (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT forall a. f a -> g a
nt = m (FreeF g b (FreeT g m b)) -> FreeT g m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF g b (FreeT g m b)) -> FreeT g m b)
-> (FreeT f m b -> m (FreeF g b (FreeT g m b)))
-> FreeT f m b
-> FreeT g m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeF f b (FreeT f m b) -> FreeF g b (FreeT g m b))
-> m (FreeF f b (FreeT f m b)) -> m (FreeF g b (FreeT g m b))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((FreeT f m b -> FreeT g m b)
-> FreeF g b (FreeT f m b) -> FreeF g b (FreeT g m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
forall (m :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Monad m, Applicative g) =>
(forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT forall a. f a -> g a
nt) (FreeF g b (FreeT f m b) -> FreeF g b (FreeT g m b))
-> (FreeF f b (FreeT f m b) -> FreeF g b (FreeT f m b))
-> FreeF f b (FreeT f m b)
-> FreeF g b (FreeT g m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. f a -> g a)
-> FreeF f b (FreeT f m b) -> FreeF g b (FreeT f m b)
forall (f :: * -> *) (g :: * -> *) a b.
(forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
transFreeF forall a. f a -> g a
nt) (m (FreeF f b (FreeT f m b)) -> m (FreeF g b (FreeT g m b)))
-> (FreeT f m b -> m (FreeF f b (FreeT f m b)))
-> FreeT f m b
-> m (FreeF g b (FreeT g m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT

-- | Pull out and join @m@ layers of @'FreeT' f m a@.
joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)
joinFreeT :: FreeT f m a -> m (Free f a)
joinFreeT (FreeT m (FreeF f a (FreeT f m a))
m) = m (FreeF f a (FreeT f m a))
m m (FreeF f a (FreeT f m a))
-> (FreeF f a (FreeT f m a) -> m (Free f a)) -> m (Free f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeF f a (FreeT f m a) -> m (Free f a)
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Applicative f) =>
FreeF f a (FreeT f m a) -> m (FreeT f Identity a)
joinFreeF
  where
    joinFreeF :: FreeF f a (FreeT f m a) -> m (FreeT f Identity a)
joinFreeF (Pure a
x) = FreeT f Identity a -> m (FreeT f Identity a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> FreeT f Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
    joinFreeF (Free f (FreeT f m a)
f) = f (FreeT f Identity a) -> FreeT f Identity a
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (FreeT f Identity a) -> FreeT f Identity a)
-> m (f (FreeT f Identity a)) -> m (FreeT f Identity a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (FreeT f m a -> m (FreeT f Identity a))
-> f (FreeT f m a) -> m (f (FreeT f Identity a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Data.Traversable.mapM FreeT f m a -> m (FreeT f Identity a)
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Applicative f) =>
FreeT f m a -> m (Free f a)
joinFreeT f (FreeT f m a)
f

-- |
-- 'retract' is the left inverse of 'liftF'
--
-- @
-- 'retract' . 'liftF' = 'id'
-- @
retract :: Monad f => Free f a -> f a
retract :: Free f a -> f a
retract Free f a
m =
  case Identity (FreeF f a (Free f a)) -> FreeF f a (Free f a)
forall a. Identity a -> a
runIdentity (Free f a -> Identity (FreeF f a (Free f a))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT Free f a
m) of
    Pure a
a  -> a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Free f (Free f a)
as -> f (Free f a)
as f (Free f a) -> (Free f a -> f a) -> f a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Free f a -> f a
forall (f :: * -> *) a. Monad f => Free f a -> f a
retract

-- | Given an applicative homomorphism from @f@ to 'Identity', tear down a 'Free' 'Monad' using iteration.
iter :: Applicative f => (f a -> a) -> Free f a -> a
iter :: (f a -> a) -> Free f a -> a
iter f a -> a
phi = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (Free f a -> Identity a) -> Free f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (Identity a) -> Identity a) -> Free f a -> Identity a
forall (f :: * -> *) (m :: * -> *) a.
(Applicative f, Monad m) =>
(f (m a) -> m a) -> FreeT 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)

-- | Like 'iter' for monadic values.
iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a
iterM :: (f (m a) -> m a) -> Free f a -> m a
iterM f (m a) -> m a
phi = (f (m a) -> m a) -> FreeT f m a -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Applicative f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterT f (m a) -> m a
phi (FreeT f m a -> m a)
-> (Free f a -> FreeT f m a) -> Free f a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Identity a -> m a) -> Free f a -> FreeT f m a
forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Monad m, Applicative f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT (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)

-- | 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@):
--
-- @
-- 'cutoff' 0     _        ≡ 'return' 'Nothing'
-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just'
-- 'cutoff' (n+1) '.' 'lift'   ≡ 'lift' '.' 'liftM' 'Just'
-- '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 :: (Applicative f, Applicative m, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff :: Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff Integer
n FreeT f m a
_ | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Maybe a -> FreeT f m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
cutoff Integer
n (FreeT m (FreeF f a (FreeT f m a))
m) = m (FreeF f (Maybe a) (FreeT f m (Maybe a))) -> FreeT f m (Maybe a)
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f (Maybe a) (FreeT f m (Maybe a)))
 -> FreeT f m (Maybe a))
-> m (FreeF f (Maybe a) (FreeT f m (Maybe a)))
-> FreeT f m (Maybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Maybe a)
-> (FreeT f m a -> FreeT f m (Maybe a))
-> FreeF f a (FreeT f m a)
-> FreeF f (Maybe a) (FreeT f m (Maybe a))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> Maybe a
forall a. a -> Maybe a
Just (Integer -> FreeT f m a -> FreeT f m (Maybe a)
forall (f :: * -> *) (m :: * -> *) a.
(Applicative f, Applicative m, Monad m) =>
Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)) (FreeF f a (FreeT f m a)
 -> FreeF f (Maybe a) (FreeT f m (Maybe a)))
-> m (FreeF f a (FreeT f m a))
-> m (FreeF f (Maybe a) (FreeT f m (Maybe a)))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (FreeF f a (FreeT f m a))
m

-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.
-- This is sort of the opposite for @'cutoff'@.
--
-- Some examples (@n ≥ 0@):
--
-- @
-- 'partialIterT' 0 _ m              ≡ m
-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return'
-- 'partialIterT' (n+1) phi '.' 'lift'   ≡ 'lift'
-- 'partialIterT' (n+1) phi '.' 'wrap'   ≡ 'join' . 'lift' . phi
-- @
partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
partialIterT :: Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
partialIterT Integer
n forall a. f a -> m a
phi FreeT f m b
m
  | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = FreeT f m b
m
  | Bool
otherwise = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ do
      FreeF f b (FreeT f m b)
val <- FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT FreeT f m b
m
      case FreeF f b (FreeT f m b)
val of
        Pure b
a -> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure b
a)
        Free f (FreeT f m b)
f -> f (FreeT f m b) -> m (FreeT f m b)
forall a. f a -> m a
phi f (FreeT f m b)
f m (FreeT f m b)
-> (FreeT f m b -> m (FreeF f b (FreeT f m b)))
-> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeT f m b -> m (FreeF f b (FreeT f m b))
forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (FreeT f m b -> m (FreeF f b (FreeT f m b)))
-> (FreeT f m b -> FreeT f m b)
-> FreeT f m b
-> m (FreeF f b (FreeT f m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
forall (m :: * -> *) (f :: * -> *) b.
Monad m =>
Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
partialIterT (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) forall a. f a -> m a
phi

-- | @intersperseT f m@ inserts a layer @f@ between every two layers in
-- @m@.
--
-- @
-- 'intersperseT' f '.' 'return' ≡ 'return'
-- 'intersperseT' f '.' 'lift'   ≡ 'lift'
-- 'intersperseT' f '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))
-- @
intersperseT :: (Monad m, Applicative m, Applicative f) => f a -> FreeT f m b -> FreeT f m b
intersperseT :: f a -> FreeT f m b -> FreeT f m b
intersperseT f a
f (FreeT m (FreeF f b (FreeT f m b))
m) = m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF f b (FreeT f m b)) -> FreeT f m b)
-> m (FreeF f b (FreeT f m b)) -> FreeT f m b
forall a b. (a -> b) -> a -> b
$ do
  FreeF f b (FreeT f m b)
val <- m (FreeF f b (FreeT f m b))
m
  case FreeF f b (FreeT f m b)
val of
    Pure b
x -> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b)))
-> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall a b. (a -> b) -> a -> b
$ b -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure b
x
    Free f (FreeT f m b)
y -> FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeF f b (FreeT f m b) -> m (FreeF f b (FreeT f m b)))
-> (f (FreeT f m b) -> FreeF f b (FreeT f m b))
-> f (FreeT f m b)
-> m (FreeF f b (FreeT f m b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m b) -> FreeF f b (FreeT f m b)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m b) -> m (FreeF f b (FreeT f m b)))
-> f (FreeT f m b) -> m (FreeF f b (FreeT f m b))
forall a b. (a -> b) -> a -> b
$ (FreeT f m b -> FreeT f m b) -> f (FreeT f m b) -> f (FreeT f m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (FreeT f m b) -> FreeT f m b) -> FreeT f m b -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(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 f m b) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (f (FreeT f m b) -> FreeT f m b)
-> (f (FreeT f m b) -> f (FreeT f m b))
-> f (FreeT f m b)
-> FreeT f m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeT f m b -> f a -> f (FreeT f m b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
f) (FreeT f m b -> f (FreeT f m b))
-> (f (FreeT f m b) -> FreeT f m b)
-> f (FreeT f m b)
-> f (FreeT f m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (FreeT f m b) -> FreeT f m b
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap)) f (FreeT f m b)
y

-- | Tear down a free monad transformer using Monad instance for @t m@.
retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a
retractT :: FreeT (t m) m a -> t m a
retractT (FreeT m (FreeF (t m) a (FreeT (t m) m a))
m) = do
  FreeF (t m) a (FreeT (t m) m a)
val <- m (FreeF (t m) a (FreeT (t m) m a))
-> t m (FreeF (t m) a (FreeT (t m) m a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (FreeF (t m) a (FreeT (t m) m a))
m
  case FreeF (t m) a (FreeT (t m) m a)
val of
    Pure a
x -> a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    Free t m (FreeT (t m) m a)
y -> t m (FreeT (t m) m a)
y t m (FreeT (t m) m a) -> (FreeT (t m) m a -> t m a) -> t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeT (t m) m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
FreeT (t m) m a -> t m a
retractT

-- | @intercalateT f m@ inserts a layer @f@ between every two layers in
-- @m@ and then retracts the result.
--
-- @
-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f
-- @
#if __GLASGOW_HASKELL__ < 710
intercalateT :: (Monad m, MonadTrans t, Monad (t m), Applicative (t m)) => t m a -> FreeT (t m) m b -> t m b
#else
intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b
#endif
intercalateT :: t m a -> FreeT (t m) m b -> t m b
intercalateT t m a
f (FreeT m (FreeF (t m) b (FreeT (t m) m b))
m) = do
  FreeF (t m) b (FreeT (t m) m b)
val <- m (FreeF (t m) b (FreeT (t m) m b))
-> t m (FreeF (t m) b (FreeT (t m) m b))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (FreeF (t m) b (FreeT (t m) m b))
m
  case FreeF (t m) b (FreeT (t m) m b)
val of
    Pure b
x -> b -> t m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
    Free t m (FreeT (t m) m b)
y -> t m (FreeT (t m) m b)
y t m (FreeT (t m) m b) -> (FreeT (t m) m b -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (t m (t m b) -> t m b) -> FreeT (t m) m b -> t m b
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Applicative f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM (\t m (t m b)
x -> t m a
f t m a -> t m b -> t m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t m (t m b) -> t m b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join t m (t m b)
x)

#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