module Control.Monad.Freer.Church (
Free(..), reFree
, liftFree, interpretFree, retractFree, hoistFree
, foldFree, foldFree', foldFreeC
, Free1(.., DoneF1, MoreF1)
, reFree1, toFree
, liftFree1, interpretFree1, retractFree1, hoistFree1
, free1Comp, matchFree1
, foldFree1, foldFree1', foldFree1C
, Comp(.., Comp, unComp), comp
) where
import Control.Applicative
import Control.Monad
import Control.Natural
import Data.Foldable
import Data.Functor
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Coyoneda
import Data.Pointed
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import GHC.Generics
import Text.Read
import qualified Control.Monad.Free as M
newtype Free f a = Free
{ runFree :: forall r. (a -> r) -> (forall s. f s -> (s -> r) -> r) -> r
}
instance Functor (Free f) where
fmap f x = Free $ \p b -> runFree x (p . f) b
instance Apply (Free f) where
(<.>) = ap
instance Applicative (Free f) where
pure = return
(<*>) = (<.>)
instance Pointed (Free f) where
point = pure
instance Bind (Free f) where
x >>- f = Free $ \p b -> runFree x (\y -> runFree (f y) p b) b
instance Monad (Free f) where
return x = Free $ \p _ -> p x
(>>=) = (>>-)
instance M.MonadFree f (Free f) where
wrap x = Free $ \p b -> b x $ \y -> runFree y p b
instance Foldable f => Foldable (Free f) where
foldMap f = foldFreeC f fold
instance Traversable f => Traversable (Free f) where
traverse f = foldFree (fmap pure . f )
(fmap M.wrap . sequenceA)
instance (Functor f, Eq1 f) => Eq1 (Free f) where
liftEq eq x y = liftEq @(M.Free f) eq (reFree x) (reFree y)
instance (Functor f, Ord1 f) => Ord1 (Free f) where
liftCompare c x y = liftCompare @(M.Free f) c (reFree x) (reFree y)
instance (Functor f, Eq1 f, Eq a) => Eq (Free f a) where
(==) = eq1
instance (Functor f, Ord1 f, Ord a) => Ord (Free f a) where
compare = compare1
instance (Functor f, Show1 f) => Show1 (Free f) where
liftShowsPrec sp sl d x = case reFree x of
M.Pure y -> showsUnaryWith sp "pure" d y
M.Free ys -> showsUnaryWith (liftShowsPrec sp' sl') "wrap" d ys
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Functor f, Show1 f, Show a) => Show (Free f a) where
showsPrec = liftShowsPrec showsPrec showList
instance (Functor f, Read1 f) => Read1 (Free f) where
liftReadsPrec rp rl = go
where
go = readsData $
readsUnaryWith rp "pure" pure
<> readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "wrap" M.wrap
instance (Functor f, Read1 f, Read a) => Read (Free f a) where
readPrec = readPrec1
readListPrec = readListPrecDefault
readList = readListDefault
reFree
:: (M.MonadFree f m, Functor f)
=> Free f a
-> m a
reFree = foldFree pure M.wrap
liftFree :: f ~> Free f
liftFree x = Free $ \p b -> b x p
interpretFree :: Monad g => (f ~> g) -> Free f ~> g
interpretFree f = foldFree' pure ((>>=) . f)
retractFree :: Monad f => Free f ~> f
retractFree = foldFree' pure (>>=)
hoistFree :: (f ~> g) -> Free f ~> Free g
hoistFree f x = Free $ \p b -> runFree x p (b . f)
foldFree'
:: (a -> r)
-> (forall s. f s -> (s -> r) -> r)
-> Free f a
-> r
foldFree' f g x = runFree x f g
foldFreeC
:: (a -> r)
-> (Coyoneda f r -> r)
-> Free f a
-> r
foldFreeC f g = foldFree' f (\y n -> g (Coyoneda n y))
foldFree
:: Functor f
=> (a -> r)
-> (f r -> r)
-> Free f a
-> r
foldFree f g = foldFreeC f (g . lowerCoyoneda)
newtype Free1 f a = Free1
{ runFree1 :: forall r. (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> r
}
instance Functor (Free1 f) where
fmap f x = Free1 $ \p b -> runFree1 x (\y c -> p y (f . c)) b
instance Apply (Free1 f) where
(<.>) = apDefault
instance Bind (Free1 f) where
x >>- f = Free1 $ \p b ->
runFree1 x (\y c -> b y ((\q -> runFree1 q p b) . f . c)) b
instance Foldable f => Foldable (Free1 f) where
foldMap f = foldFree1C (foldMap f) fold
instance Traversable f => Traversable (Free1 f) where
traverse f = foldFree1 (fmap DoneF1 . traverse f)
(fmap MoreF1 . sequenceA )
instance Foldable1 f => Foldable1 (Free1 f) where
foldMap1 f = foldFree1C (foldMap1 f) fold1
instance Traversable1 f => Traversable1 (Free1 f) where
traverse1 f = foldFree1 (fmap DoneF1 . traverse1 f)
(fmap MoreF1 . sequence1 )
instance (Functor f, Eq1 f) => Eq1 (Free1 f) where
liftEq eq x y = liftEq @(Free f) eq (toFree x) (toFree y)
instance (Functor f, Ord1 f) => Ord1 (Free1 f) where
liftCompare c x y = liftCompare @(Free f) c (toFree x) (toFree y)
instance (Functor f, Eq1 f, Eq a) => Eq (Free1 f a) where
(==) = eq1
instance (Functor f, Ord1 f, Ord a) => Ord (Free1 f a) where
compare = compare1
instance (Functor f, Show1 f) => Show1 (Free1 f) where
liftShowsPrec sp sl d = \case
DoneF1 x -> showsUnaryWith (liftShowsPrec sp sl ) "DoneF1" d x
MoreF1 x -> showsUnaryWith (liftShowsPrec sp' sl') "MoreF1" d x
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Functor f, Show1 f, Show a) => Show (Free1 f a) where
showsPrec = liftShowsPrec showsPrec showList
instance (Functor f, Read1 f) => Read1 (Free1 f) where
liftReadsPrec rp rl = go
where
go = readsData $
readsUnaryWith (liftReadsPrec rp rl) "DoneF1" DoneF1
<> readsUnaryWith (liftReadsPrec go (liftReadList rp rl)) "MoreF1" MoreF1
instance (Functor f, Read1 f, Read a) => Read (Free1 f a) where
readPrec = readPrec1
readListPrec = readListPrecDefault
readList = readListDefault
pattern DoneF1 :: Functor f => f a -> Free1 f a
pattern DoneF1 x <- (matchFree1 -> L1 x)
where
DoneF1 x = liftFree1 x
pattern MoreF1 :: Functor f => f (Free1 f a) -> Free1 f a
pattern MoreF1 x <- (matchFree1 -> R1 (Comp x))
where
MoreF1 x = liftFree1 x >>- id
{-# COMPLETE DoneF1, MoreF1 #-}
reFree1
:: (M.MonadFree f m, Functor f)
=> Free1 f a
-> m a
reFree1 = foldFree1 (M.wrap . fmap pure) M.wrap
toFree :: Free1 f ~> Free f
toFree x = Free $ \p b -> runFree1 x (\y c -> b y (p . c)) b
hoistFree1 :: (f ~> g) -> Free1 f ~> Free1 g
hoistFree1 f x = Free1 $ \p b -> runFree1 x (p . f) (b . f)
free1Comp :: Free1 f ~> Comp f (Free f)
free1Comp = foldFree1' (\y c -> y :>>= (pure . c)) $ \y n ->
y :>>= \z -> case n z of
q :>>= m -> liftFree q >>= m
liftFree1 :: f ~> Free1 f
liftFree1 x = Free1 $ \p _ -> p x id
retractFree1 :: Bind f => Free1 f ~> f
retractFree1 = foldFree1' (<&>) (>>-)
interpretFree1 :: Bind g => (f ~> g) -> Free1 f ~> g
interpretFree1 f = foldFree1' (\y c -> c <$> f y)
(\y n -> f y >>- n)
matchFree1 :: forall f. Functor f => Free1 f ~> f :+: Comp f (Free1 f)
matchFree1 = foldFree1 L1 (R1 . Comp . fmap shuffle)
where
shuffle :: f :+: Comp f (Free1 f) ~> Free1 f
shuffle (L1 y ) = liftFree1 y
shuffle (R1 (y :>>= n)) = liftFree1 y >>- n
foldFree1'
:: (forall s. f s -> (s -> a) -> r)
-> (forall s. f s -> (s -> r) -> r)
-> Free1 f a
-> r
foldFree1' f g x = runFree1 x f g
foldFree1C
:: (Coyoneda f a -> r)
-> (Coyoneda f r -> r)
-> Free1 f a
-> r
foldFree1C f g = foldFree1' (\y c -> f (Coyoneda c y))
(\y n -> g (Coyoneda n y))
foldFree1
:: Functor f
=> (f a -> r)
-> (f r -> r)
-> Free1 f a
-> r
foldFree1 f g = foldFree1C (f . lowerCoyoneda)
(g . lowerCoyoneda)
data Comp f g a =
forall x. f x :>>= (x -> g a)
instance Functor g => Functor (Comp f g) where
fmap f (x :>>= h) = x :>>= (fmap f . h)
instance (Applicative f, Applicative g) => Applicative (Comp f g) where
pure x = pure () :>>= (pure . const x)
(x :>>= f) <*> (y :>>= g) = ((,) <$> x <*> y)
:>>= (\(x', y') -> f x' <*> g y')
liftA2 h (x :>>= f) (y :>>= g)
= ((,) <$> x <*> y)
:>>= (\(x', y') -> liftA2 h (f x') (g y'))
instance (Foldable f, Foldable g) => Foldable (Comp f g) where
foldMap f (x :>>= h) = foldMap (foldMap f . h) x
instance (Traversable f, Traversable g) => Traversable (Comp f g) where
traverse f (x :>>= h) = (:>>= id)
<$> traverse (traverse f . h) x
instance (Alternative f, Alternative g) => Alternative (Comp f g) where
empty = empty :>>= id
(x :>>= f) <|> (y :>>= g) = ((f <$> x) <|> (g <$> y)) :>>= id
instance (Functor f, Show1 f, Show1 g) => Show1 (Comp f g) where
liftShowsPrec sp sl d (Comp x) =
showsUnaryWith (liftShowsPrec sp' sl') "Comp" d x
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Functor f, Show1 f, Show1 g, Show a) => Show (Comp f g a) where
showsPrec = liftShowsPrec showsPrec showList
instance (Functor f, Read1 f, Read1 g) => Read1 (Comp f g) where
liftReadPrec rp rl = readData $
readUnaryWith (liftReadPrec rp' rl') "Comp" Comp
where
rp' = liftReadPrec rp rl
rl' = liftReadListPrec rp rl
instance (Functor f, Read1 f, Read1 g, Read a) => Read (Comp f g a) where
readPrec = readPrec1
readListPrec = readListPrecDefault
readList = readListDefault
instance (Functor f, Eq1 f, Eq1 g) => Eq1 (Comp f g) where
liftEq eq (Comp x) (Comp y) = liftEq (liftEq eq) x y
instance (Functor f, Ord1 f, Ord1 g) => Ord1 (Comp f g) where
liftCompare c (Comp x) (Comp y) = liftCompare (liftCompare c) x y
instance (Functor f, Eq1 f, Eq1 g, Eq a) => Eq (Comp f g a) where
(==) = eq1
instance (Functor f, Ord1 f, Ord1 g, Ord a) => Ord (Comp f g a) where
compare = compare1
comp :: f (g a) -> Comp f g a
comp = (:>>= id)
pattern Comp :: Functor f => f (g a) -> Comp f g a
pattern Comp { unComp } <- ((\case x :>>= f -> f <$> x)->unComp)
where
Comp x = comp x
{-# COMPLETE Comp #-}