{-# 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"

-----------------------------------------------------------------------------
-- |
-- 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.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 a functor @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 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 :: 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 (Functor f, 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 f m (a -> b) -> FreeT f m a -> FreeT f m 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
  <.> :: FreeT f m (a -> b) -> FreeT f m a -> FreeT f m 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
  >>- :: FreeT f m a -> (a -> FreeT f m b) -> FreeT f m 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 :: 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 (Functor f, 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 Functor f => 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 (Functor f, 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 (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where
  liftBase :: b α -> FreeT f m α
liftBase = m α -> FreeT f m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> FreeT f m α) -> (b α -> m α) -> b α -> FreeT f m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
  {-# INLINE liftBase #-}

instance (Functor f, Functor 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.
(Functor m, Functor 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 (Functor f, Functor 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.
(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 (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 (Functor f, 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 (Functor f, 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 (Functor f, 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 (Functor f, 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 (Functor f, 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 (Functor f, 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 (Functor f, 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 (Functor f, 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 #-}

-- | 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 :: (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.
(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 -> 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

-- | 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 :: (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.
(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 -> 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' :: ('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 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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.
(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)) (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

-- | 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 (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) = 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 t m (FreeF f a (FreeT f m a))
-> (FreeF f a (FreeT f m a) -> t m a) -> t m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FreeF f a (FreeT f m a) -> t m a
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) = a -> t n a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    foldFreeF (Free f (FreeT f n a)
as) = f (FreeT f n a) -> t n (FreeT f n a)
forall (n :: * -> *) x. Monad n => f x -> t n x
f f (FreeT f n a)
as t n (FreeT f n a) -> (FreeT f n a -> t n a) -> t n a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (n :: * -> *) x. Monad n => f x -> t n x)
-> FreeT f n a -> t n a
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 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, Functor 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) => 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) =>
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) =>
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

-- | Tear down a 'Free' 'Monad' using iteration.
iter :: Functor 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.
(Functor 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 :: (Functor 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.
(Functor 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.
(Functor m, Functor 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 :: (Functor f, 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.
(Functor f, 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, Functor 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.
(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 (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), Functor (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.
(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 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