{-# 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 x. Free f a -> Rep (Free f a) x)
-> (forall x. Rep (Free f a) x -> Free f a) -> Generic (Free f a)
forall x. Rep (Free f a) x -> Free f a
forall x. Free f a -> Rep (Free f a) x
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 a. Free f a -> Rep1 (Free f) a)
-> (forall a. Rep1 (Free f) a -> Free f a) -> Generic1 (Free f)
forall a. Rep1 (Free f) a -> Free f a
forall a. Free f a -> Rep1 (Free f) 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. 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 :: (a -> b -> Bool) -> Free f a -> Free f b -> Bool
liftEq a -> b -> Bool
eq = Free f a -> Free f b -> Bool
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) = (Free f a -> Free f b -> Bool)
-> f (Free f a) -> f (Free f b) -> Bool
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
(==) = 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 :: (a -> b -> Ordering) -> Free f a -> Free f b -> Ordering
liftCompare a -> b -> Ordering
cmp = Free f a -> Free f b -> Ordering
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) = (Free f a -> Free f b -> Ordering)
-> f (Free f a) -> f (Free f b) -> Ordering
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 = Free f a -> Free f a -> Ordering
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 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Free f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl = Int -> Free f a -> ShowS
forall (f :: * -> *). Show1 f => Int -> Free f a -> ShowS
go
where
go :: Int -> Free f a -> ShowS
go 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
sp String
"Pure" Int
d a
a
go Int
d (Free f (Free f a)
fa) = (Int -> f (Free f a) -> ShowS)
-> String -> Int -> f (Free f a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> Free f a -> ShowS)
-> ([Free f a] -> ShowS) -> Int -> f (Free f a) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> Free f a -> ShowS
go ((Int -> a -> ShowS) -> ([a] -> ShowS) -> [Free f a] -> ShowS
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 = Int -> Free f a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
#ifdef LIFTED_FUNCTOR_CLASSES
instance Read1 f => Read1 (Free f) where
liftReadsPrec :: (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 = (String -> ReadS (Free f a)) -> Int -> ReadS (Free f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Free f a)) -> Int -> ReadS (Free f a))
-> (String -> ReadS (Free f a)) -> Int -> ReadS (Free f a)
forall a b. (a -> b) -> a -> b
$
(Int -> ReadS a)
-> String -> (a -> Free f a) -> String -> ReadS (Free f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"Pure" a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure (String -> ReadS (Free f a))
-> (String -> ReadS (Free f a)) -> String -> ReadS (Free f a)
forall a. Monoid a => a -> a -> a
`mappend`
(Int -> ReadS (f (Free f a)))
-> String
-> (f (Free f a) -> Free f a)
-> String
-> ReadS (Free f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS (Free f a))
-> ReadS [Free f a] -> Int -> ReadS (f (Free f a))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS (Free f a)
go ((Int -> ReadS a) -> ReadS [a] -> ReadS [Free f a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl)) String
"Free" f (Free f a) -> Free f a
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 = Int -> ReadS (Free f a)
forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1
instance Functor f => Functor (Free f) where
fmap :: (a -> b) -> Free f a -> Free f b
fmap a -> b
f = Free f a -> Free f b
forall (f :: * -> *). Functor f => Free f a -> Free f b
go where
go :: Free f a -> Free f b
go (Pure a
a) = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (a -> b
f a
a)
go (Free f (Free f a)
fa) = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Free f a -> Free f b
go (Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
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 <.> :: Free f (a -> b) -> Free f a -> Free f b
<.> Pure a
b = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (a -> b
a a
b)
Pure a -> b
a <.> Free f (Free f a)
fb = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (Free f b) -> Free f b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Free f a -> Free f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
a (Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
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 = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (Free f b) -> Free f b
forall a b. (a -> b) -> a -> b
$ (Free f (a -> b) -> Free f a -> Free f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> Free f a
b) (Free f (a -> b) -> Free f b)
-> f (Free f (a -> b)) -> f (Free f 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 :: a -> Free f a
pure = a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure
{-# INLINE pure #-}
Pure a -> b
a <*> :: Free f (a -> b) -> Free f a -> Free f b
<*> Pure a
b = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (b -> Free f b) -> b -> Free f b
forall a b. (a -> b) -> a -> b
$ a -> b
a a
b
Pure a -> b
a <*> Free f (Free f a)
mb = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (Free f b) -> Free f b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Free f a -> Free f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
a (Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
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 = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (Free f b) -> Free f b
forall a b. (a -> b) -> a -> b
$ (Free f (a -> b) -> Free f a -> Free f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Free f a
b) (Free f (a -> b) -> Free f b)
-> f (Free f (a -> b)) -> f (Free f 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 >>- :: 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 = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((Free f a -> (a -> Free f b) -> Free f b
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- a -> Free f b
f) (Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
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 :: a -> Free f a
return = a -> Free f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
Pure a
a >>= :: 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 = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((Free f a -> (a -> Free f b) -> Free f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Free f b
f) (Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
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 :: (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 (Free f a -> a
forall (f :: * -> *) p. Free f p -> p
impure Free f a
a); impure :: Free f p -> p
impure (Pure p
x) = p
x; impure (Free f (Free f p)
_) = String -> p
forall a. HasCallStack => String -> a
error String
"mfix (Free f): Free"
instance Alternative v => Alternative (Free v) where
empty :: Free v a
empty = v (Free v a) -> Free v a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free v (Free v a)
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
Free v a
a <|> :: Free v a -> Free v a -> Free v a
<|> Free v a
b = v (Free v a) -> Free v a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Free v a -> v (Free v a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Free v a
a v (Free v a) -> v (Free v a) -> v (Free v a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Free v a -> v (Free v 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 :: Free v a
mzero = v (Free v a) -> Free v a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free v (Free v a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE mzero #-}
Free v a
a mplus :: Free v a -> Free v a -> Free v a
`mplus` Free v a
b = v (Free v a) -> Free v a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Free v a -> v (Free v a)
forall (m :: * -> *) a. Monad m => a -> m a
return Free v a
a v (Free v a) -> v (Free v a) -> v (Free v a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Free v a -> v (Free v a)
forall (m :: * -> *) a. Monad m => a -> m a
return Free v a
b)
{-# INLINE mplus #-}
instance MonadTrans Free where
lift :: m a -> Free m a
lift = m (Free m a) -> Free m a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (m (Free m a) -> Free m a)
-> (m a -> m (Free m a)) -> m a -> Free m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Free m a) -> m a -> m (Free m a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Free m a
forall (f :: * -> *) a. a -> Free f a
Pure
{-# INLINE lift #-}
instance Foldable f => Foldable (Free f) where
foldMap :: (a -> m) -> Free f a -> m
foldMap a -> m
f = Free f a -> m
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) = (Free t a -> m) -> t (Free t a) -> m
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 :: (a -> b -> b) -> b -> Free f a -> b
foldr a -> b -> b
f = b -> Free f a -> b
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 -> (Free t a -> b -> b) -> b -> t (Free t a) -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((b -> Free t a -> b) -> Free t a -> b -> b
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' :: (b -> a -> b) -> b -> Free f a -> b
foldl' b -> a -> b
f = b -> Free f a -> b
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 -> (b -> Free t a -> b) -> b -> t (Free t a) -> b
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 :: (a -> m) -> Free f a -> m
foldMap1 a -> m
f = Free f a -> m
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) = (Free t a -> m) -> t (Free t a) -> m
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 :: (a -> f b) -> Free f a -> f (Free f b)
traverse a -> f b
f = Free f a -> f (Free f b)
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) = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (b -> Free f b) -> f b -> f (Free f b)
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) = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (f (Free f b)) -> f (Free f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Free f a -> f (Free f b)) -> f (Free f a) -> f (f (Free 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 :: (a -> f b) -> Free f a -> f (Free f b)
traverse1 a -> f b
f = Free f a -> f (Free f b)
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) = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (b -> Free f b) -> f b -> f (Free f b)
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) = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (f (Free f b)) -> f (Free f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Free f a -> f (Free f b)) -> f (Free f a) -> f (f (Free 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 :: ([i] -> a -> b) -> Free f a -> Free f b
imap [i] -> a -> b
f (Pure a
a) = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (b -> Free f b) -> b -> Free f b
forall a b. (a -> b) -> a -> b
$ [i] -> a -> b
f [] a
a
imap [i] -> a -> b
f (Free f (Free f a)
s) = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (Free f b) -> Free f b
forall a b. (a -> b) -> a -> b
$ (i -> Free f a -> Free f b) -> f (Free f a) -> f (Free f b)
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (\i
i -> ([i] -> a -> b) -> Free f a -> Free f b
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap ([i] -> a -> b
f ([i] -> a -> b) -> ([i] -> [i]) -> [i] -> a -> b
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 :: ([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) = (i -> Free f a -> m) -> f (Free f a) -> m
forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (\i
i -> ([i] -> a -> m) -> Free f a -> m
forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap ([i] -> a -> m
f ([i] -> a -> m) -> ([i] -> [i]) -> [i] -> a -> m
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 :: ([i] -> a -> f b) -> Free f a -> f (Free f b)
itraverse [i] -> a -> f b
f (Pure a
a) = b -> Free f b
forall (f :: * -> *) a. a -> Free f a
Pure (b -> Free f b) -> f b -> f (Free f b)
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) = f (Free f b) -> Free f b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f b) -> Free f b) -> f (f (Free f b)) -> f (Free f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (i -> Free f a -> f (Free f b)) -> f (Free f a) -> f (f (Free 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 -> ([i] -> a -> f b) -> Free f a -> f (Free f b)
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 ([i] -> a -> f b) -> ([i] -> [i]) -> [i] -> a -> f b
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 = m () -> Free m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Free m ()) -> (e -> m ()) -> e -> Free m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
{-# INLINE tell #-}
listen :: Free m a -> Free m (a, e)
listen = m (a, e) -> Free m (a, e)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (a, e) -> Free m (a, e))
-> (Free m a -> m (a, e)) -> Free m a -> Free m (a, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (a, e)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m a -> m (a, e)) -> (Free m a -> m a) -> Free m a -> m (a, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free m a -> m a
forall (f :: * -> *) a. Monad f => Free f a -> f a
retract
{-# INLINE listen #-}
pass :: Free m (a, e -> e) -> Free m a
pass = m a -> Free m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Free m a)
-> (Free m (a, e -> e) -> m a) -> Free m (a, e -> e) -> Free m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, e -> e) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m (a, e -> e) -> m a)
-> (Free m (a, e -> e) -> m (a, e -> e))
-> Free m (a, e -> e)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free m (a, e -> e) -> m (a, e -> e)
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 = m e -> Free m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m e
forall r (m :: * -> *). MonadReader r m => m r
ask
{-# INLINE ask #-}
local :: (e -> e) -> Free m a -> Free m a
local e -> e
f = m a -> Free m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Free m a) -> (Free m a -> m a) -> Free m a -> Free m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> e) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f (m a -> m a) -> (Free m a -> m a) -> Free m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free m a -> m a
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 = m s -> Free 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 -> Free m ()
put s
s = m () -> Free m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (s -> m ()
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 :: e -> Free m a
throwError = m a -> Free m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Free m a) -> (e -> m a) -> e -> Free 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 #-}
catchError :: Free m a -> (e -> Free m a) -> Free m a
catchError Free m a
as e -> Free m a
f = m a -> Free m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Free m a -> m a
forall (f :: * -> *) a. Monad f => Free f a -> f a
retract Free m a
as) (Free m a -> m a
forall (f :: * -> *) a. Monad f => Free f a -> f a
retract (Free m a -> m a) -> (e -> Free m a) -> e -> m a
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 :: ((a -> Free m b) -> Free m a) -> Free m a
callCC (a -> Free m b) -> Free m a
f = m a -> Free m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (((a -> m b) -> m a) -> m a
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (Free m a -> m a
forall (f :: * -> *) a. Monad f => Free f a -> f a
retract (Free m a -> m a) -> ((a -> m b) -> Free m a) -> (a -> m b) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Free m b) -> Free m a
f ((a -> Free m b) -> Free m a)
-> ((a -> m b) -> a -> Free m b) -> (a -> m b) -> Free m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m b -> Free m b) -> (a -> m b) -> a -> Free m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM m b -> Free m b
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 :: f (Free f a) -> Free f a
wrap = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free
{-# INLINE wrap #-}
retract :: Monad f => Free f a -> f a
retract :: Free f a -> f a
retract (Pure a
a) = a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
retract (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
iter :: Functor f => (f a -> a) -> Free f a -> a
iter :: (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 ((f a -> a) -> Free f a -> a
forall (f :: * -> *) a. Functor f => (f a -> a) -> Free f a -> a
iter f a -> a
phi (Free f a -> a) -> f (Free f a) -> f a
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 :: (f (p a) -> p a) -> Free f a -> p a
iterA f (p a) -> p a
_ (Pure a
x) = a -> p a
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 ((f (p a) -> p a) -> Free f a -> p a
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 (Free f a -> p a) -> f (Free f a) -> f (p a)
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 :: (f (m a) -> m a) -> Free f a -> m a
iterM f (m a) -> m a
_ (Pure a
x) = a -> m a
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 ((f (m a) -> m a) -> Free f a -> m a
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 (Free f a -> m a) -> f (Free f a) -> f (m a)
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 a. f a -> g a) -> Free f b -> Free g b
hoistFree forall a. f a -> g a
_ (Pure b
a) = b -> Free g b
forall (f :: * -> *) a. a -> Free f a
Pure b
a
hoistFree forall a. f a -> g a
f (Free f (Free f b)
as) = g (Free g b) -> Free g b
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((forall a. f a -> g a) -> Free f b -> Free g b
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 (Free f b -> Free g b) -> g (Free f b) -> g (Free g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Free f b) -> g (Free 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 x. f x -> m x) -> Free f a -> m a
foldFree forall x. f x -> m x
_ (Pure a
a) = a -> m 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) = f (Free f a) -> m (Free f a)
forall x. f x -> m x
f f (Free f a)
as m (Free f a) -> (Free f a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall x. f x -> m x) -> Free f a -> m a
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 :: Free f a -> FreeT f m a
toFreeT (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.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
FreeT.Pure a
a))
toFreeT (Free f (Free f 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.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 (f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
FreeT.Free ((Free f a -> FreeT f m a) -> f (Free f a) -> f (FreeT f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> FreeT f m a
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 :: Integer -> Free f a -> Free f (Maybe a)
cutoff Integer
n Free f a
_ | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Maybe a -> Free f (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
cutoff Integer
n (Free f (Free f a)
f) = f (Free f (Maybe a)) -> Free f (Maybe a)
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f (Maybe a)) -> Free f (Maybe a))
-> f (Free f (Maybe a)) -> Free f (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Free f a -> Free f (Maybe a))
-> f (Free f a) -> f (Free f (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Free f a -> Free f (Maybe a)
forall (f :: * -> *) a.
Functor f =>
Integer -> Free f a -> Free f (Maybe a)
cutoff (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)) f (Free f a)
f
cutoff Integer
_ Free f a
m = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Free f a -> Free f (Maybe a)
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 :: (b -> Either a (f b)) -> b -> Free f a
unfold b -> Either a (f b)
f = b -> Either a (f b)
f (b -> Either a (f b))
-> (Either a (f b) -> Free f a) -> b -> Free f a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> Free f a) -> (f b -> Free f a) -> Either a (f b) -> Free f a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure (f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f a) -> Free f a)
-> (f b -> f (Free f a)) -> f b -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Free f a) -> f b -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> Either a (f b)) -> b -> Free f a
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 :: (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 (b -> m (Either a (f b)))
-> (Either a (f b) -> m (Free f a)) -> b -> m (Free f a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (a -> m (Free f a))
-> (f b -> m (Free f a)) -> Either a (f b) -> m (Free f a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Free f a -> m (Free f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Free f a -> m (Free f a)) -> (a -> Free f a) -> a -> m (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Free f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) ((f (Free f a) -> Free f a) -> m (f (Free f a)) -> m (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (m (f (Free f a)) -> m (Free f a))
-> (f b -> m (f (Free f a))) -> f b -> m (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> m (Free f a)) -> f b -> m (f (Free f a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((b -> m (Either a (f b))) -> b -> m (Free f a)
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 :: p a (m a) -> p (Free f a) (m (Free f a))
_Pure = (Free f a -> Either (Free f a) a)
-> (Either (Free f a) (m a) -> m (Free f a))
-> p (Either (Free f a) a) (Either (Free f a) (m a))
-> p (Free f a) (m (Free f a))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Free f a -> Either (Free f a) a
forall (f :: * -> *) b. Free f b -> Either (Free f b) b
impure ((Free f a -> m (Free f a))
-> (m a -> m (Free f a)) -> Either (Free f a) (m a) -> m (Free f a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Free f a -> m (Free f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> Free f a) -> m a -> m (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Free f a
forall (f :: * -> *) a. a -> Free f a
Pure)) (p (Either (Free f a) a) (Either (Free f a) (m a))
-> p (Free f a) (m (Free f a)))
-> (p a (m a) -> p (Either (Free f a) a) (Either (Free f a) (m a)))
-> p a (m a)
-> p (Free f a) (m (Free f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (m a) -> p (Either (Free f a) a) (Either (Free f a) (m a))
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) = b -> Either (Free f b) b
forall a b. b -> Either a b
Right b
x
impure Free f b
x = Free f b -> Either (Free f b) b
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 :: p (f (Free f a)) (m (g (Free g a))) -> p (Free f a) (m (Free g a))
_Free = (Free f a -> Either (Free g a) (f (Free f a)))
-> (Either (Free g a) (m (g (Free g a))) -> m (Free g a))
-> p (Either (Free g a) (f (Free f a)))
(Either (Free g a) (m (g (Free g a))))
-> p (Free f a) (m (Free g a))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Free f a -> Either (Free g a) (f (Free f a))
forall (f :: * -> *) a (f :: * -> *).
Free f a -> Either (Free f a) (f (Free f a))
unfree ((Free g a -> m (Free g a))
-> (m (g (Free g a)) -> m (Free g a))
-> Either (Free g a) (m (g (Free g a)))
-> m (Free g a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Free g a -> m (Free g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((g (Free g a) -> Free g a) -> m (g (Free g a)) -> m (Free g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g (Free g a) -> Free g a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free)) (p (Either (Free g a) (f (Free f a)))
(Either (Free g a) (m (g (Free g a))))
-> p (Free f a) (m (Free g a)))
-> (p (f (Free f a)) (m (g (Free g a)))
-> p (Either (Free g a) (f (Free f a)))
(Either (Free g a) (m (g (Free g a)))))
-> p (f (Free f a)) (m (g (Free g a)))
-> p (Free f a) (m (Free g a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (f (Free f a)) (m (g (Free g a)))
-> p (Either (Free g a) (f (Free f a)))
(Either (Free g a) (m (g (Free g a))))
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) = f (Free f a) -> Either (Free f a) (f (Free f a))
forall a b. b -> Either a b
Right f (Free f a)
x
unfree (Pure a
x) = Free f a -> Either (Free f a) (f (Free f a))
forall a b. a -> Either a b
Left (a -> Free f a
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