{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"
module Control.Monad.Free
( MonadFree(..)
, Free(..)
, retract
, liftF
, iter
, iterA
, iterM
, hoistFree
, foldFree
, toFreeT
, cutoff
, unfold
, unfoldM
, _Pure, _Free
) where
import Control.Applicative
import Control.Arrow ((>>>))
import Control.Monad (liftM, MonadPlus(..), (>=>))
import Control.Monad.Fix
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.Free as FreeT
import Control.Monad.Free.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
import Data.Functor.Classes.Compat
import Data.Functor.WithIndex
import Data.Foldable
import Data.Foldable.WithIndex
import Data.Profunctor
import Data.Traversable
import Data.Traversable.WithIndex
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Data
import Prelude hiding (foldr)
#if __GLASGOW_HASKELL__ >= 707
import GHC.Generics
#endif
data Free f a = Pure a | Free (f (Free f a))
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) a x. Rep (Free f a) x -> Free f a
forall (f :: * -> *) a x. Free f a -> Rep (Free f a) x
$cto :: forall (f :: * -> *) a x. Rep (Free f a) x -> Free f a
$cfrom :: forall (f :: * -> *) a x. Free f a -> Rep (Free f a) 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. Functor f => Rep1 (Free f) a -> Free f a
forall (f :: * -> *) a. Functor f => Free f a -> Rep1 (Free f) a
$cto1 :: forall (f :: * -> *) a. Functor f => Rep1 (Free f) a -> Free f a
$cfrom1 :: forall (f :: * -> *) a. Functor f => Free f a -> Rep1 (Free f) a
Generic1)
deriving instance (Typeable f, Data (f (Free f a)), Data a) => Data (Free f a)
#endif
#ifdef LIFTED_FUNCTOR_CLASSES
instance Eq1 f => Eq1 (Free f) where
liftEq :: forall a b. (a -> b -> Bool) -> Free f a -> Free f b -> Bool
liftEq a -> b -> Bool
eq = forall {f :: * -> *}. Eq1 f => Free f a -> Free f b -> Bool
go
where
go :: Free f a -> Free f b -> Bool
go (Pure a
a) (Pure b
b) = a -> b -> Bool
eq a
a b
b
go (Free f (Free f a)
fa) (Free f (Free f b)
fb) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq Free f a -> Free f b -> Bool
go f (Free f a)
fa f (Free f b)
fb
go Free f a
_ Free f b
_ = Bool
False
#else
instance (Functor f, Eq1 f) => Eq1 (Free f) where
Pure a `eq1` Pure b = a == b
Free fa `eq1` Free fb = fmap Lift1 fa `eq1` fmap Lift1 fb
_ `eq1` _ = False
#endif
#ifdef LIFTED_FUNCTOR_CLASSES
instance (Eq1 f, Eq a) => Eq (Free f a) where
#else
instance (Eq1 f, Functor f, Eq a) => Eq (Free f a) where
#endif
== :: Free f a -> Free f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1
#ifdef LIFTED_FUNCTOR_CLASSES
instance Ord1 f => Ord1 (Free f) where
liftCompare :: forall a b.
(a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
liftCompare a -> b -> Ordering
cmp = forall {f :: * -> *}. Ord1 f => Free f a -> Free f b -> Ordering
go
where
go :: Free f a -> Free f b -> Ordering
go (Pure a
a) (Pure b
b) = a -> b -> Ordering
cmp a
a b
b
go (Pure a
_) (Free f (Free f b)
_) = Ordering
LT
go (Free f (Free f a)
_) (Pure b
_) = Ordering
GT
go (Free f (Free f a)
fa) (Free f (Free f b)
fb) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare Free f a -> Free f b -> Ordering
go f (Free f a)
fa f (Free f b)
fb
#else
instance (Functor f, Ord1 f) => Ord1 (Free f) where
Pure a `compare1` Pure b = a `compare` b
Pure _ `compare1` Free _ = LT
Free _ `compare1` Pure _ = GT
Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb
#endif
#ifdef LIFTED_FUNCTOR_CLASSES
instance (Ord1 f, Ord a) => Ord (Free f a) where
#else
instance (Ord1 f, Functor f, Ord a) => Ord (Free f a) where
#endif
compare :: Free f a -> Free f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1
#ifdef LIFTED_FUNCTOR_CLASSES
instance Show1 f => Show1 (Free f) where
liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl = forall {f :: * -> *}. Show1 f => Int -> Free f a -> ShowS
go
where
go :: Int -> Free f a -> ShowS
go Int
d (Pure a
a) = forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
sp String
"Pure" Int
d a
a
go Int
d (Free f (Free f a)
fa) = 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 -> Free f a -> ShowS
go (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl)) String
"Free" Int
d f (Free f a)
fa
#else
instance (Functor f, Show1 f) => Show1 (Free f) where
showsPrec1 d (Pure a) = showParen (d > 10) $
showString "Pure " . showsPrec 11 a
showsPrec1 d (Free m) = showParen (d > 10) $
showString "Free " . showsPrec1 11 (fmap Lift1 m)
#endif
#ifdef LIFTED_FUNCTOR_CLASSES
instance (Show1 f, Show a) => Show (Free f a) where
#else
instance (Show1 f, Functor f, Show a) => Show (Free f a) where
#endif
showsPrec :: Int -> Free f a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
#ifdef LIFTED_FUNCTOR_CLASSES
instance Read1 f => Read1 (Free f) where
liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Free f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = Int -> ReadS (Free f a)
go
where
go :: Int -> ReadS (Free f 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 Int -> ReadS a
rp String
"Pure" forall (f :: * -> *) a. a -> Free f a
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 (Free f a)
go (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"Free" forall (f :: * -> *) a. f (Free f a) -> Free f a
Free
#else
instance (Functor f, Read1 f) => Read1 (Free f) 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 (fmap lower1 m), t)
| ("Free", s) <- lex r'
, (m, t) <- readsPrec1 11 s]) r
#endif
#ifdef LIFTED_FUNCTOR_CLASSES
instance (Read1 f, Read a) => Read (Free f a) where
#else
instance (Read1 f, Functor f, Read a) => Read (Free f a) where
#endif
readsPrec :: Int -> ReadS (Free f a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1
instance Functor f => Functor (Free f) where
fmap :: forall a b. (a -> b) -> Free f a -> Free f b
fmap a -> b
f = forall {f :: * -> *}. Functor f => Free f a -> Free f b
go where
go :: Free f a -> Free f b
go (Pure a
a) = forall (f :: * -> *) a. a -> Free f a
Pure (a -> b
f a
a)
go (Free f (Free f a)
fa) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Free f a -> Free f b
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
fa)
{-# INLINE fmap #-}
instance Functor f => Apply (Free f) where
Pure a -> b
a <.> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
<.> Pure a
b = forall (f :: * -> *) a. a -> Free f a
Pure (a -> b
a a
b)
Pure a -> b
a <.> Free f (Free f a)
fb = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
fb
Free f (Free f (a -> b))
fa <.> Free f a
b = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> Free f a
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f (a -> b))
fa
instance Functor f => Applicative (Free f) where
pure :: forall a. a -> Free f a
pure = forall (f :: * -> *) a. a -> Free f a
Pure
{-# INLINE pure #-}
Pure a -> b
a <*> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
<*> Pure a
b = forall (f :: * -> *) a. a -> Free f a
Pure forall a b. (a -> b) -> a -> b
$ a -> b
a a
b
Pure a -> b
a <*> Free f (Free f a)
mb = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
mb
Free f (Free f (a -> b))
ma <*> Free f a
b = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Free f a
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f (a -> b))
ma
instance Functor f => Bind (Free f) where
Pure a
a >>- :: forall a b. Free f a -> (a -> Free f b) -> Free f b
>>- a -> Free f b
f = a -> Free f b
f a
a
Free f (Free f a)
m >>- a -> Free f b
f = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- a -> Free f b
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
m)
instance Functor f => Monad (Free f) where
return :: forall a. a -> Free f a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
Pure a
a >>= :: forall a b. Free f a -> (a -> Free f b) -> Free f b
>>= a -> Free f b
f = a -> Free f b
f a
a
Free f (Free f a)
m >>= a -> Free f b
f = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Free f b
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
m)
instance Functor f => MonadFix (Free f) where
mfix :: forall a. (a -> Free f a) -> Free f a
mfix a -> Free f a
f = Free f a
a where a :: Free f a
a = a -> Free f a
f (forall {f :: * -> *} {a}. Free f a -> a
impure Free f a
a); impure :: Free f a -> a
impure (Pure a
x) = a
x; impure (Free f (Free f a)
_) = forall a. HasCallStack => String -> a
error String
"mfix (Free f): Free"
instance Alternative v => Alternative (Free v) where
empty :: forall a. Free v a
empty = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
Free v a
a <|> :: forall a. Free v a -> Free v a -> Free v a
<|> Free v a
b = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall (f :: * -> *) a. Applicative f => a -> f a
pure Free v a
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Free v a
b)
{-# INLINE (<|>) #-}
instance (Functor v, MonadPlus v) => MonadPlus (Free v) where
mzero :: forall a. Free v a
mzero = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE mzero #-}
Free v a
a mplus :: forall a. Free v a -> Free v a -> Free v a
`mplus` Free v a
b = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall (m :: * -> *) a. Monad m => a -> m a
return Free v a
a forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return Free v a
b)
{-# INLINE mplus #-}
instance MonadTrans Free where
lift :: forall (m :: * -> *) a. Monad m => m a -> Free m a
lift = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free 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. a -> Free f a
Pure
{-# INLINE lift #-}
instance Foldable f => Foldable (Free f) where
foldMap :: forall m a. Monoid m => (a -> m) -> Free f a -> m
foldMap a -> m
f = forall {t :: * -> *}. Foldable t => Free t a -> m
go where
go :: Free t a -> m
go (Pure a
a) = a -> m
f a
a
go (Free t (Free t a)
fa) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Free t a -> m
go t (Free t a)
fa
{-# INLINE foldMap #-}
foldr :: forall a b. (a -> b -> b) -> b -> Free f a -> b
foldr a -> b -> b
f = forall {t :: * -> *}. Foldable t => b -> Free t a -> b
go where
go :: b -> Free t a -> b
go b
r Free t a
free =
case Free t a
free of
Pure a
a -> a -> b -> b
f a
a b
r
Free t (Free t a)
fa -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> Free t a -> b
go) b
r t (Free t a)
fa
{-# INLINE foldr #-}
#if MIN_VERSION_base(4,6,0)
foldl' :: forall b a. (b -> a -> b) -> b -> Free f a -> b
foldl' b -> a -> b
f = forall {t :: * -> *}. Foldable t => b -> Free t a -> b
go where
go :: b -> Free t a -> b
go b
r Free t a
free =
case Free t a
free of
Pure a
a -> b -> a -> b
f b
r a
a
Free t (Free t a)
fa -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> Free t a -> b
go b
r t (Free t a)
fa
{-# INLINE foldl' #-}
#endif
instance Foldable1 f => Foldable1 (Free f) where
foldMap1 :: forall m a. Semigroup m => (a -> m) -> Free f a -> m
foldMap1 a -> m
f = forall {t :: * -> *}. Foldable1 t => Free t a -> m
go where
go :: Free t a -> m
go (Pure a
a) = a -> m
f a
a
go (Free t (Free t a)
fa) = forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 Free t a -> m
go t (Free t a)
fa
{-# INLINE foldMap1 #-}
instance Traversable f => Traversable (Free f) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Free f a -> f (Free f b)
traverse a -> f b
f = forall {f :: * -> *}. Traversable f => Free f a -> f (Free f b)
go where
go :: Free f a -> f (Free f b)
go (Pure a
a) = forall (f :: * -> *) a. a -> Free f a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
go (Free f (Free f a)
fa) = forall (f :: * -> *) a. f (Free f a) -> Free f a
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 Free f a -> f (Free f b)
go f (Free f a)
fa
{-# INLINE traverse #-}
instance Traversable1 f => Traversable1 (Free f) where
traverse1 :: forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> Free f a -> f (Free f b)
traverse1 a -> f b
f = forall {f :: * -> *}. Traversable1 f => Free f a -> f (Free f b)
go where
go :: Free f a -> f (Free f b)
go (Pure a
a) = forall (f :: * -> *) a. a -> Free f a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
go (Free f (Free f a)
fa) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 Free f a -> f (Free f b)
go f (Free f a)
fa
{-# INLINE traverse1 #-}
instance FunctorWithIndex i f => FunctorWithIndex [i] (Free f) where
imap :: forall a b. ([i] -> a -> b) -> Free f a -> Free f b
imap [i] -> a -> b
f (Pure a
a) = forall (f :: * -> *) a. a -> Free f a
Pure forall a b. (a -> b) -> a -> b
$ [i] -> a -> b
f [] a
a
imap [i] -> a -> b
f (Free f (Free f a)
s) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (\i
i -> forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap ([i] -> a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) i
i)) f (Free f a)
s
{-# INLINE imap #-}
instance FoldableWithIndex i f => FoldableWithIndex [i] (Free f) where
ifoldMap :: forall m a. Monoid m => ([i] -> a -> m) -> Free f a -> m
ifoldMap [i] -> a -> m
f (Pure a
a) = [i] -> a -> m
f [] a
a
ifoldMap [i] -> a -> m
f (Free f (Free f a)
s) = forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (\i
i -> forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap ([i] -> a -> m
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) i
i)) f (Free f a)
s
{-# INLINE ifoldMap #-}
instance TraversableWithIndex i f => TraversableWithIndex [i] (Free f) where
itraverse :: forall (f :: * -> *) a b.
Applicative f =>
([i] -> a -> f b) -> Free f a -> f (Free f b)
itraverse [i] -> a -> f b
f (Pure a
a) = forall (f :: * -> *) a. a -> Free f a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [i] -> a -> f b
f [] a
a
itraverse [i] -> a -> f b
f (Free f (Free f a)
s) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (\i
i -> forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse ([i] -> a -> f b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) i
i)) f (Free f a)
s
{-# INLINE itraverse #-}
instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where
tell :: e -> Free 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. Free m a -> Free m (a, e)
listen = 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 :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Monad f => Free f a -> f a
retract
{-# INLINE listen #-}
pass :: forall a. Free m (a, e -> e) -> Free m a
pass = 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 :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Monad f => Free f a -> f a
retract
{-# INLINE pass #-}
instance (Functor m, MonadReader e m) => MonadReader e (Free m) where
ask :: Free m e
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. (e -> e) -> Free m a -> Free m a
local e -> e
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
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Monad f => Free f a -> f a
retract
{-# INLINE local #-}
instance (Functor m, MonadState s m) => MonadState s (Free m) where
get :: Free 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 -> Free m ()
put s
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s)
{-# INLINE put #-}
instance (Functor m, MonadError e m) => MonadError e (Free m) where
throwError :: forall a. e -> Free 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 #-}
catchError :: forall a. Free m a -> (e -> Free m a) -> Free m a
catchError Free m a
as e -> Free m a
f = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall (f :: * -> *) a. Monad f => Free f a -> f a
retract Free m a
as) (forall (f :: * -> *) a. Monad f => Free f a -> f a
retract forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Free m a
f))
{-# INLINE catchError #-}
instance (Functor m, MonadCont m) => MonadCont (Free m) where
callCC :: forall a b. ((a -> Free m b) -> Free m a) -> Free m a
callCC (a -> Free m b) -> Free m a
f = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (forall (f :: * -> *) a. Monad f => Free f a -> f a
retract forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Free m b) -> Free m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift))
{-# INLINE callCC #-}
instance Functor f => MonadFree f (Free f) where
wrap :: forall a. f (Free f a) -> Free f a
wrap = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free
{-# INLINE wrap #-}
retract :: Monad f => Free f a -> f a
retract :: forall (f :: * -> *) a. Monad f => Free f a -> f a
retract (Pure a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
retract (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
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
_ (Pure a
a) = a
a
iter f a -> a
phi (Free f (Free f a)
m) = f a -> a
phi (forall (f :: * -> *) a. Functor f => (f a -> a) -> Free f a -> a
iter f a -> a
phi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
m)
iterA :: (Applicative p, Functor f) => (f (p a) -> p a) -> Free f a -> p a
iterA :: forall (p :: * -> *) (f :: * -> *) a.
(Applicative p, Functor f) =>
(f (p a) -> p a) -> Free f a -> p a
iterA f (p a) -> p a
_ (Pure a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
iterA f (p a) -> p a
phi (Free f (Free f a)
f) = f (p a) -> p a
phi (forall (p :: * -> *) (f :: * -> *) a.
(Applicative p, Functor f) =>
(f (p a) -> p a) -> Free f a -> p a
iterA f (p a) -> p a
phi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
f)
iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a
iterM :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
(f (m a) -> m a) -> Free f a -> m a
iterM f (m a) -> m a
_ (Pure a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
iterM f (m a) -> m a
phi (Free f (Free f a)
f) = f (m a) -> m a
phi (forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Functor f) =>
(f (m a) -> m a) -> Free f a -> m a
iterM f (m a) -> m a
phi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f a)
f)
hoistFree :: Functor g => (forall a. f a -> g a) -> Free f b -> Free g b
hoistFree :: forall (g :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. f a -> g a) -> Free f b -> Free g b
hoistFree forall a. f a -> g a
_ (Pure b
a) = forall (f :: * -> *) a. a -> Free f a
Pure b
a
hoistFree forall a. f a -> g a
f (Free f (Free f b)
as) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (forall (g :: * -> *) (f :: * -> *) b.
Functor g =>
(forall a. f a -> g a) -> Free f b -> Free g b
hoistFree forall a. f a -> g a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. f a -> g a
f f (Free f b)
as)
foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
foldFree :: forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> Free f a -> m a
foldFree forall x. f x -> m x
_ (Pure a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
foldFree forall x. f x -> m x
f (Free f (Free f a)
as) = forall x. f x -> m x
f f (Free f a)
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> Free f a -> m a
foldFree forall x. f x -> m x
f
toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a
toFreeT :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Free f a -> FreeT f m a
toFreeT (Pure a
a) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT.FreeT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. a -> FreeF f a b
FreeT.Pure a
a))
toFreeT (Free f (Free f a)
f) = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT.FreeT (forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. f b -> FreeF f a b
FreeT.Free (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
Free f a -> FreeT f m a
toFreeT f (Free f a)
f)))
cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a)
cutoff :: forall (f :: * -> *) a.
Functor f =>
Integer -> Free f a -> Free f (Maybe a)
cutoff Integer
n Free f 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 (Free f (Free f a)
f) = forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a.
Functor f =>
Integer -> Free f a -> Free f (Maybe a)
cutoff (Integer
n forall a. Num a => a -> a -> a
- Integer
1)) f (Free f a)
f
cutoff Integer
_ Free f a
m = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Free f a
m
unfold :: Functor f => (b -> Either a (f b)) -> b -> Free f a
unfold :: forall (f :: * -> *) b a.
Functor f =>
(b -> Either a (f b)) -> b -> Free f a
unfold b -> Either a (f b)
f = b -> Either a (f b)
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. a -> Free f a
Pure (forall (f :: * -> *) a. f (Free f a) -> Free f a
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 :: * -> *) b a.
Functor f =>
(b -> Either a (f b)) -> b -> Free f a
unfold b -> Either a (f b)
f))
unfoldM :: (Traversable f, Applicative m, Monad m) => (b -> m (Either a (f b))) -> b -> m (Free f a)
unfoldM :: forall (f :: * -> *) (m :: * -> *) b a.
(Traversable f, Applicative m, Monad m) =>
(b -> m (Either a (f b))) -> b -> m (Free f a)
unfoldM b -> m (Either a (f b))
f = b -> m (Either a (f b))
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) (m :: * -> *) b a.
(Traversable f, Applicative m, Monad m) =>
(b -> m (Either a (f b))) -> b -> m (Free f a)
unfoldM b -> m (Either a (f b))
f))
_Pure :: forall f m a p. (Choice p, Applicative m)
=> p a (m a) -> p (Free f a) (m (Free f a))
_Pure :: forall (f :: * -> *) (m :: * -> *) a (p :: * -> * -> *).
(Choice p, Applicative m) =>
p a (m a) -> p (Free f a) (m (Free f a))
_Pure = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {f :: * -> *} {b}. Free f b -> Either (Free f b) b
impure (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. a -> Free f a
Pure)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
where
impure :: Free f b -> Either (Free f b) b
impure (Pure b
x) = forall a b. b -> Either a b
Right b
x
impure Free f b
x = forall a b. a -> Either a b
Left Free f b
x
{-# INLINE impure #-}
{-# INLINE _Pure #-}
_Free :: forall f g m a p. (Choice p, Applicative m)
=> p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a))
_Free :: forall (f :: * -> *) (g :: * -> *) (m :: * -> *) a
(p :: * -> * -> *).
(Choice p, Applicative m) =>
p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a))
_Free = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {f :: * -> *} {a} {f :: * -> *}.
Free f a -> Either (Free f a) (f (Free f a))
unfree (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
Free)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
where
unfree :: Free f a -> Either (Free f a) (f (Free f a))
unfree (Free f (Free f a)
x) = forall a b. b -> Either a b
Right f (Free f a)
x
unfree (Pure a
x) = forall a b. a -> Either a b
Left (forall (f :: * -> *) a. a -> Free f a
Pure a
x)
{-# INLINE unfree #-}
{-# INLINE _Free #-}
#if __GLASGOW_HASKELL__ < 707
instance Typeable1 f => Typeable1 (Free f) where
typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where
f :: Free f a -> f a
f = undefined
freeTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
freeTyCon = mkTyCon "Control.Monad.Free.Free"
#else
freeTyCon = mkTyCon3 "free" "Control.Monad.Free" "Free"
#endif
{-# NOINLINE freeTyCon #-}
instance
( Typeable1 f, Typeable a
, Data a, Data (f (Free f a))
) => Data (Free f a) 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 _ = freeDataType
dataCast1 f = gcast1 f
pureConstr, freeConstr :: Constr
pureConstr = mkConstr freeDataType "Pure" [] Prefix
freeConstr = mkConstr freeDataType "Free" [] Prefix
{-# NOINLINE pureConstr #-}
{-# NOINLINE freeConstr #-}
freeDataType :: DataType
freeDataType = mkDataType "Control.Monad.Free.FreeF" [pureConstr, freeConstr]
{-# NOINLINE freeDataType #-}
#endif