{-# 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
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
#if __GLASGOW_HASKELL__ >= 707
           ,Typeable ,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
#endif
           )

#ifdef LIFTED_FUNCTOR_CLASSES
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
#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 :: 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
#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 :: 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
(==)
#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 :: 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
#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 :: 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 #-}

#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
(==) = 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 :: 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
#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 = 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 :: 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
#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 :: 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
#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 = 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 :: 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
#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 = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance (Functor f, Monad 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM 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, Functor m, 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, Functor m, 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
#if MIN_VERSION_mtl(2,1,1)
  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 #-}
#endif

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 #-}
#if MIN_VERSION_mtl(2,1,1)
  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 #-}
#endif

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

-- @

#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 :: 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)

#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