{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Free
-- Copyright   :  (C) 2008-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- The free monad transformer
--
----------------------------------------------------------------------------
module Control.Monad.Trans.Free
  (
  -- * The base functor
    FreeF(..)
  -- * The free monad transformer
  , FreeT(..)
  -- * The free monad
  , Free, free, runFree
  -- * Operations
  , liftF
  , iterT
  , iterTM
  , hoistFreeT
  , foldFreeT
  , 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(..), ap, join)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Trans.Class
import Control.Monad.Free.Class
import qualified Control.Monad.Fail as Fail
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
import Data.Functor.Identity
import Data.Traversable
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.Data
import GHC.Generics

-- | 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
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,FreeF f a b -> FreeF f a b -> Bool
FreeF f a b -> FreeF f a b -> Ordering
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
Ord,Int -> FreeF f a b -> ShowS
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)
ReadS [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,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 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,FreeF f a b -> DataType
FreeF f a b -> Constr
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FreeF f a b)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FreeF f a b -> c (FreeF f a b)
forall {f :: * -> *} {a} {b}.
(Typeable f, Typeable b, Data a, Data (f b)) =>
Typeable (FreeF f a b)
forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
FreeF f a b -> DataType
forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
FreeF f a b -> Constr
forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall b. Data b => b -> b) -> FreeF f a b -> FreeF f a b
forall (f :: * -> *) a b u.
(Typeable f, Typeable b, Data a, Data (f b)) =>
Int -> (forall d. Data d => d -> u) -> FreeF f a b -> u
forall (f :: * -> *) a b u.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall d. Data d => d -> u) -> FreeF f a b -> [u]
forall (f :: * -> *) a b r r'.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
forall (f :: * -> *) a b r r'.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
forall (f :: * -> *) a b (m :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Monad m) =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
forall (f :: * -> *) a b (m :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), MonadPlus m) =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
forall (f :: * -> *) a b (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FreeF f a b)
forall (f :: * -> *) a b (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FreeF f a b -> c (FreeF f a b)
forall (f :: * -> *) a b (t :: * -> *) (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (FreeF f a b))
forall (f :: * -> *) a b (t :: * -> * -> *) (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FreeF f a b))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
$cgmapMo :: forall (f :: * -> *) a b (m :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), MonadPlus m) =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
$cgmapMp :: forall (f :: * -> *) a b (m :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), MonadPlus m) =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
$cgmapM :: forall (f :: * -> *) a b (m :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Monad m) =>
(forall d. Data d => d -> m d) -> FreeF f a b -> m (FreeF f a b)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FreeF f a b -> u
$cgmapQi :: forall (f :: * -> *) a b u.
(Typeable f, Typeable b, Data a, Data (f b)) =>
Int -> (forall d. Data d => d -> u) -> FreeF f a b -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> FreeF f a b -> [u]
$cgmapQ :: forall (f :: * -> *) a b u.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall d. Data d => d -> u) -> FreeF f a b -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
$cgmapQr :: forall (f :: * -> *) a b r r'.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
$cgmapQl :: forall (f :: * -> *) a b r r'.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FreeF f a b -> r
gmapT :: (forall b. Data b => b -> b) -> FreeF f a b -> FreeF f a b
$cgmapT :: forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall b. Data b => b -> b) -> FreeF f a b -> FreeF f a b
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FreeF f a b))
$cdataCast2 :: forall (f :: * -> *) a b (t :: * -> * -> *) (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (FreeF f a b))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (FreeF f a b))
$cdataCast1 :: forall (f :: * -> *) a b (t :: * -> *) (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b), Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (FreeF f a b))
dataTypeOf :: FreeF f a b -> DataType
$cdataTypeOf :: forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
FreeF f a b -> DataType
toConstr :: FreeF f a b -> Constr
$ctoConstr :: forall (f :: * -> *) a b.
(Typeable f, Typeable b, Data a, Data (f b)) =>
FreeF f a b -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FreeF f a b)
$cgunfold :: forall (f :: * -> *) a b (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (FreeF f a b)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FreeF f a b -> c (FreeF f a b)
$cgfoldl :: forall (f :: * -> *) a b (c :: * -> *).
(Typeable f, Typeable b, Data a, Data (f b)) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FreeF f a b -> c (FreeF f a b)
Data)

instance Show1 f => Show2 (FreeF f) where
  liftShowsPrec2 :: forall a b.
(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) =
    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) =
    forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (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 :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FreeF f a a -> ShowS
liftShowsPrec = forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 forall a. Show a => Int -> a -> ShowS
showsPrec forall a. Show a => [a] -> ShowS
showList

instance Read1 f => Read2 (FreeF f) where
  liftReadsPrec2 :: forall a b.
(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 = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
    forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rpa String
"Pure" forall (f :: * -> *) a b. a -> FreeF f a b
Pure forall a. Monoid a => a -> a -> a
`mappend`
    forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS b
rpb ReadS [b]
rlb) String
"Free" forall (f :: * -> *) a b. f b -> FreeF f a b
Free

instance (Read1 f, Read a) => Read1 (FreeF f a) where
  liftReadsPrec :: forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (FreeF f a a)
liftReadsPrec = forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 forall a. Read a => Int -> ReadS a
readsPrec forall a. Read a => ReadS [a]
readList

instance Eq1 f => Eq2 (FreeF f) where
  liftEq2 :: forall a b c d.
(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) = 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 :: forall a b. (a -> b -> Bool) -> FreeF f a a -> FreeF f a b -> Bool
liftEq = forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 forall a. Eq a => a -> a -> Bool
(==)

instance Ord1 f => Ord2 (FreeF f) where
  liftCompare2 :: forall a b c d.
(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) = 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 :: forall a b.
(a -> b -> Ordering) -> FreeF f a a -> FreeF f a b -> Ordering
liftCompare = forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 forall a. Ord a => a -> a -> Ordering
compare

instance Functor f => Functor (FreeF f a) where
  fmap :: forall a b. (a -> b) -> FreeF f a a -> FreeF f a b
fmap a -> b
_ (Pure a
a)  = forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
  fmap a -> b
f (Free f a
as) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free (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 :: forall m a. Monoid m => (a -> m) -> FreeF f a a -> m
foldMap a -> m
f (Free f a
as) = 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
_         = forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

instance Traversable f => Traversable (FreeF f a) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FreeF f a a -> f (FreeF f a b)
traverse a -> f b
_ (Pure a
a)  = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a)
  traverse a -> f b
f (Free f a
as) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> 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 :: forall a b c d. (a -> b) -> (c -> d) -> FreeF f a c -> FreeF f b d
bimap a -> b
f c -> d
_ (Pure a
a)  = 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) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free (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 :: forall m a b. Monoid m => (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) = 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 :: forall (f :: * -> *) a c b d.
Applicative f =>
(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)  = forall (f :: * -> *) a b. a -> FreeF f a b
Pure 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) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (f :: * -> *) (g :: * -> *) a b.
(forall x. f x -> g x) -> FreeF f a b -> FreeF g a b
transFreeF forall x. f x -> g x
_ (Pure a
a) = forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a
transFreeF forall x. f x -> g x
t (Free f b
as) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free (forall x. f x -> g x
t f b
as)
{-# INLINE transFreeF #-}

-- | The \"free monad transformer\" for a functor @f@
newtype FreeT f m a = FreeT { forall (f :: * -> *) (m :: * -> *) a.
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 a functor @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 :: forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
runFree = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
free = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity
{-# INLINE free #-}

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

instance (Eq1 f, Eq1 m) => Eq1 (FreeT f m) where
  liftEq :: forall a b. (a -> b -> Bool) -> FreeT f m a -> FreeT f m b -> Bool
liftEq a -> b -> Bool
eq = 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) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (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

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

instance (Ord1 f, Ord1 m) => Ord1 (FreeT f m) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> FreeT f m a -> FreeT f m b -> Ordering
liftCompare a -> b -> Ordering
cmp = 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) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (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

instance (Show1 f, Show1 m) => Show1 (FreeT f m) where
  liftShowsPrec :: forall a.
(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 = 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) = forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
        (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec (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) (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

instance (Show1 f, Show1 m, Show a) => Show (FreeT f m a) where
  showsPrec :: Int -> FreeT f m a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Read1 f, Read1 m) => Read1 (FreeT f m) where
  liftReadsPrec :: forall a.
(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 = 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 = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$ forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith
        (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (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) (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" forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT

instance (Read1 f, Read1 m, Read a) => Read (FreeT f m a) where
  readsPrec :: Int -> ReadS (FreeT f m a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance (Functor f, Functor m) => Functor (FreeT f m) where
  fmap :: forall a b. (a -> b) -> FreeT f m a -> FreeT f m b
fmap a -> b
f (FreeT m (FreeF f a (FreeT f m a))
m) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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)  = forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> b
f a
a)
    f' (Free f (f a)
as) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (f a)
as)

instance (Functor f, Monad m) => Applicative (FreeT f m) where
  pure :: forall a. a -> FreeT f m a
pure a
a = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
a))
  {-# INLINE pure #-}
  <*> :: forall a b. FreeT f m (a -> b) -> FreeT f m a -> FreeT f m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance (Functor f, Monad m) => Apply (FreeT f m) where
  <.> :: forall a b. FreeT f m (a -> b) -> FreeT f m a -> FreeT f m b
(<.>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

instance (Functor f, Monad m) => Bind (FreeT f m) where
  >>- :: forall a b. 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
(>>=)

instance (Functor f, Monad m) => Monad (FreeT f m) where
  return :: forall a. a -> FreeT f m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  FreeT m (FreeF f a (FreeT f m a))
m >>= :: forall a b. FreeT f m a -> (a -> FreeT f m b) -> FreeT f m b
>>= a -> FreeT f m b
f = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ m (FreeF f a (FreeT f m a))
m 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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. f b -> FreeF f a b
Free (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (Functor f, Fail.MonadFail m) => Fail.MonadFail (FreeT f m) where
  fail :: forall a. String -> FreeT f m a
fail String
e = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
e)

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

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

instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where
  liftBase :: forall α. b α -> FreeT f m α
liftBase = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
  {-# INLINE liftBase #-}

instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where
  ask :: FreeT f m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  {-# INLINE ask #-}
  local :: forall a. (r -> r) -> FreeT f m a -> FreeT f m a
local r -> r
f = forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Functor m, Functor f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT (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 (FreeT f m) where
  tell :: w -> FreeT f m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  {-# INLINE tell #-}
  listen :: forall a. FreeT f m a -> FreeT f m (a, w)
listen (FreeT m (FreeF f a (FreeT f m a))
m) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM 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' forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen 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) = forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a
x, c
w)
      concat' (Free f (f (p a c))
y, c
w) = forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (c
w forall a. Monoid a => a -> a -> a
`mappend`)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f (p a c))
y
  pass :: forall a. FreeT f m (a, w -> w) -> FreeT f m a
pass FreeT f m (a, w -> w)
m = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Functor m, Functor f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall {a}. m a -> m a
clean forall a b. (a -> b) -> a -> b
$ 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 = forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, forall a b. a -> b -> a
const 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' = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)) = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (t -> w
f t
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
x)
      g (Free f (FreeT f m ((a, t -> w), t))
f)           = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FreeF f ((a, t -> w), t) (FreeT f m ((a, t -> w), t)))
-> m (FreeF f a (FreeT f m a))
pass' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT) forall a b. (a -> b) -> a -> b
$ f (FreeT f m ((a, t -> w), t))
f
  writer :: forall a. (a, w) -> FreeT f m a
writer (a, w)
w = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a, w)
w)
  {-# INLINE writer #-}

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

instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where
  throwError :: forall a. e -> FreeT f m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  {-# INLINE throwError #-}
  FreeT m (FreeF f a (FreeT f m a))
m catchError :: forall a. FreeT f m a -> (e -> FreeT f m a) -> FreeT f m a
`catchError` e -> FreeT f m a
f = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FreeT f m a
f)

instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where
  callCC :: forall a b. ((a -> FreeT f m b) -> FreeT f m a) -> FreeT f m a
callCC (a -> FreeT f m b) -> FreeT f m a
f = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (\FreeF f a (FreeT f m a) -> m b
k -> forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall a b. (a -> b) -> a -> b
$ (a -> FreeT f m b) -> FreeT f m a
f (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeF f a (FreeT f m a) -> m b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. a -> FreeF f a b
Pure))

instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where
  empty :: forall a. FreeT f m a
empty = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall (m :: * -> *) a. MonadPlus m => m a
mzero
  FreeT m (FreeF f a (FreeT f m a))
ma <|> :: forall a. FreeT f m a -> FreeT f m a -> FreeT f m a
<|> FreeT m (FreeF f a (FreeT f m a))
mb = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (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 (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where
  mzero :: forall a. FreeT f m a
mzero = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall (m :: * -> *) a. MonadPlus m => m a
mzero
  {-# INLINE mzero #-}
  mplus :: forall a. 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) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (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 (Functor f, Monad m) => MonadFree f (FreeT f m) where
  wrap :: forall a. f (FreeT f m a) -> FreeT f m a
wrap = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. f b -> FreeF f a b
Free
  {-# INLINE wrap #-}

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

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

-- | Tear down a free monad transformer using iteration.
iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
iterT :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) a.
(Functor 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 -> 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

-- | 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) -> FreeT f m a -> t m a
iterTM :: forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (FreeF f a (FreeT f m a))
m
    case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM f (t m a) -> t m a
f) FreeF f a (FreeT f m a)
val of
        Pure a
x -> 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 :: forall m a. Monoid m => (a -> m) -> FreeT f m a -> m
foldMap a -> m
f (FreeT m (FreeF f a (FreeT f m a))
m) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f (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 :: forall (f :: * -> *) a b.
Applicative f =>
(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) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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 (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' :: ('Functor' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@
hoistFreeT :: (Functor m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT :: forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Functor m, Functor f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> n a
mh = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. m a -> n a
mh forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) (f :: * -> *) (n :: * -> *) b.
(Functor m, Functor f) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> n a
mh)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT

-- | The very definition of a free monad transformer is that given a natural
-- transformation you get a monad transformer homomorphism.
foldFreeT :: (MonadTrans t, Monad (t m), Monad m)
          => (forall n x. Monad n => f x -> t n x) -> FreeT f m a -> t m a
foldFreeT :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) (f :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
(forall (n :: * -> *) x. Monad n => f x -> t n x)
-> FreeT f m a -> t m a
foldFreeT forall (n :: * -> *) x. Monad n => f x -> t n x
f (FreeT m (FreeF f a (FreeT f m a))
m) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (FreeF f a (FreeT f m a))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {n :: * -> *} {a}.
(Monad n, Monad (t n)) =>
FreeF f a (FreeT f n a) -> t n a
foldFreeF
  where
    foldFreeF :: FreeF f a (FreeT f n a) -> t n a
foldFreeF (Pure a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    foldFreeF (Free f (FreeT f n a)
as) = forall (n :: * -> *) x. Monad n => f x -> t n x
f f (FreeT f n a)
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) (f :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
(forall (n :: * -> *) x. Monad n => f x -> t n x)
-> FreeT f m a -> t m a
foldFreeT forall (n :: * -> *) x. Monad n => f x -> t n x
f

-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@
transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT :: forall (m :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Monad m, Functor g) =>
(forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT forall a. f a -> g a
nt = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) (g :: * -> *) (f :: * -> *) b.
(Monad m, Functor g) =>
(forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT forall a. f a -> g a
nt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) => FreeT f m a -> m (Free f a)
joinFreeT :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f) =>
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {f :: * -> *} {a}.
(Monad m, Traversable 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
    joinFreeF (Free f (FreeT f m a)
f) = forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Data.Traversable.mapM forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable 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 :: forall (f :: * -> *) a. Monad f => Free f a -> f a
retract Free f a
m =
  case forall a. Identity a -> a
runIdentity (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  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Free f (Free f a)
as -> f (Free f a)
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Monad f => Free f a -> f a
retract

-- | Tear down a 'Free' 'Monad' using iteration.
iter :: Functor f => (f a -> a) -> Free f a -> a
iter :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Free f a -> a
iter f a -> a
phi = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterT (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a
phi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity)

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

-- | 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 :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff Integer
n FreeT f m a
_ | Integer
n forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
cutoff Integer
n (FreeT m (FreeF f a (FreeT f m a))
m) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. a -> Maybe a
Just (forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff (Integer
n forall a. Num a => a -> a -> a
- Integer
1)) 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 :: forall (m :: * -> *) (f :: * -> *) b.
Monad m =>
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 forall a. Ord a => a -> a -> Bool
<= Integer
0 = FreeT f m b
m
  | Bool
otherwise = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ do
      FreeF f b (FreeT f m b)
val <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. a -> FreeF f a b
Pure b
a)
        Free f (FreeT f m b)
f -> forall a. f a -> m a
phi f (FreeT f m b)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (f :: * -> *) b.
Monad m =>
Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b
partialIterT (Integer
n 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, Functor f) => f a -> FreeT f m b -> FreeT f m b
intersperseT :: forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Functor f) =>
f a -> FreeT f m b -> FreeT f m b
intersperseT f a
f (FreeT m (FreeF f b (FreeT f m b))
m) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. a -> FreeF f a b
Pure b
x
    Free f (FreeT f m b)
y -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FreeT f m a -> t m a
iterTM (forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad (t m), Monad m) =>
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 <- 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 -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
-- @
intercalateT :: (Monad m, MonadTrans t, Monad (t m)) => t m a -> FreeT (t m) m b -> t m b
intercalateT :: forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t, Monad (t m)) =>
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 <- 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 -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join t m (t m b)
x)