{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}

-- | We redefine Free here because we prefer undeciable instances
-- to having to derive 'Eq1' and so on.
-- See https://hackage.haskell.org/package/free-5.1.7/docs/Control-Monad-Trans-Free.html
module Unfree
  ( FreeF (..)
  , Free (..)
  , pattern FreeEmbed
  , pattern FreePure
  , substFree
  , liftFree
  , iterFree
  , iterFreeM
  , FreeT (..)
  , liftFreeT
  , iterFreeT
  , hoistFreeT
  , transFreeT
  , joinFreeT
  ) where

import Control.DeepSeq (NFData)
import Control.Monad (ap)
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))
import Data.Hashable (Hashable)
import GHC.Generics (Generic)

-- | The recursive layer of a free functor
data FreeF f a r =
    FreePureF !a
  | FreeEmbedF !(f r)
  deriving stock (FreeF f a r -> FreeF f a r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a r.
(Eq a, Eq (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
/= :: FreeF f a r -> FreeF f a r -> Bool
$c/= :: forall (f :: * -> *) a r.
(Eq a, Eq (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
== :: FreeF f a r -> FreeF f a r -> Bool
$c== :: forall (f :: * -> *) a r.
(Eq a, Eq (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
Eq, FreeF f a r -> FreeF f a r -> Bool
FreeF f a r -> FreeF f a r -> 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} {r}.
(Ord a, Ord (f r)) =>
Eq (FreeF f a r)
forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Ordering
forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> FreeF f a r
min :: FreeF f a r -> FreeF f a r -> FreeF f a r
$cmin :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> FreeF f a r
max :: FreeF f a r -> FreeF f a r -> FreeF f a r
$cmax :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> FreeF f a r
>= :: FreeF f a r -> FreeF f a r -> Bool
$c>= :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
> :: FreeF f a r -> FreeF f a r -> Bool
$c> :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
<= :: FreeF f a r -> FreeF f a r -> Bool
$c<= :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
< :: FreeF f a r -> FreeF f a r -> Bool
$c< :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Bool
compare :: FreeF f a r -> FreeF f a r -> Ordering
$ccompare :: forall (f :: * -> *) a r.
(Ord a, Ord (f r)) =>
FreeF f a r -> FreeF f a r -> Ordering
Ord, Int -> FreeF f a r -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
Int -> FreeF f a r -> ShowS
forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
[FreeF f a r] -> ShowS
forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
FreeF f a r -> String
showList :: [FreeF f a r] -> ShowS
$cshowList :: forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
[FreeF f a r] -> ShowS
show :: FreeF f a r -> String
$cshow :: forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
FreeF f a r -> String
showsPrec :: Int -> FreeF f a r -> ShowS
$cshowsPrec :: forall (f :: * -> *) a r.
(Show a, Show (f r)) =>
Int -> FreeF f a r -> ShowS
Show, forall a b. a -> FreeF f a b -> FreeF f a a
forall a b. (a -> b) -> FreeF f a a -> FreeF f a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) a a b.
Functor f =>
a -> FreeF f a b -> FreeF f a a
forall (f :: * -> *) a a b.
Functor f =>
(a -> b) -> FreeF f a a -> FreeF f a b
<$ :: forall a b. a -> FreeF f a b -> FreeF f a a
$c<$ :: forall (f :: * -> *) a a b.
Functor f =>
a -> FreeF f a b -> FreeF f a a
fmap :: forall a b. (a -> b) -> FreeF f a a -> FreeF f a b
$cfmap :: forall (f :: * -> *) a a b.
Functor f =>
(a -> b) -> FreeF f a a -> FreeF f a b
Functor, forall a. FreeF f a a -> Bool
forall m a. Monoid m => (a -> m) -> FreeF f a a -> m
forall a b. (a -> b -> b) -> b -> FreeF f a a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
forall (f :: * -> *) a a.
(Foldable f, Eq a) =>
a -> FreeF f a a -> Bool
forall (f :: * -> *) a a. (Foldable f, Num a) => FreeF f a a -> a
forall (f :: * -> *) a a. (Foldable f, Ord a) => FreeF f a a -> a
forall (f :: * -> *) a m.
(Foldable f, Monoid m) =>
FreeF f a m -> m
forall (f :: * -> *) a a. Foldable f => FreeF f a a -> Bool
forall (f :: * -> *) a a. Foldable f => FreeF f a a -> Int
forall (f :: * -> *) a a. Foldable f => FreeF f a a -> [a]
forall (f :: * -> *) a a.
Foldable f =>
(a -> a -> a) -> FreeF f a a -> a
forall (f :: * -> *) a m a.
(Foldable f, Monoid m) =>
(a -> m) -> FreeF f a a -> m
forall (f :: * -> *) a b a.
Foldable f =>
(b -> a -> b) -> b -> FreeF f a a -> b
forall (f :: * -> *) a a b.
Foldable f =>
(a -> b -> b) -> b -> FreeF f a a -> b
product :: forall a. Num a => FreeF f a a -> a
$cproduct :: forall (f :: * -> *) a a. (Foldable f, Num a) => FreeF f a a -> a
sum :: forall a. Num a => FreeF f a a -> a
$csum :: forall (f :: * -> *) a a. (Foldable f, Num a) => FreeF f a a -> a
minimum :: forall a. Ord a => FreeF f a a -> a
$cminimum :: forall (f :: * -> *) a a. (Foldable f, Ord a) => FreeF f a a -> a
maximum :: forall a. Ord a => FreeF f a a -> a
$cmaximum :: forall (f :: * -> *) a a. (Foldable f, Ord a) => FreeF f a a -> a
elem :: forall a. Eq a => a -> FreeF f a a -> Bool
$celem :: forall (f :: * -> *) a a.
(Foldable f, Eq a) =>
a -> FreeF f a a -> Bool
length :: forall a. FreeF f a a -> Int
$clength :: forall (f :: * -> *) a a. Foldable f => FreeF f a a -> Int
null :: forall a. FreeF f a a -> Bool
$cnull :: forall (f :: * -> *) a a. Foldable f => FreeF f a a -> Bool
toList :: forall a. FreeF f a a -> [a]
$ctoList :: forall (f :: * -> *) a a. Foldable f => FreeF f a a -> [a]
foldl1 :: forall a. (a -> a -> a) -> FreeF f a a -> a
$cfoldl1 :: forall (f :: * -> *) a a.
Foldable f =>
(a -> a -> a) -> FreeF f a a -> a
foldr1 :: forall a. (a -> a -> a) -> FreeF f a a -> a
$cfoldr1 :: forall (f :: * -> *) a a.
Foldable f =>
(a -> a -> a) -> FreeF f a a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> FreeF f a a -> b
$cfoldl' :: forall (f :: * -> *) a b a.
Foldable f =>
(b -> a -> b) -> b -> FreeF f a a -> b
foldl :: forall b a. (b -> a -> b) -> b -> FreeF f a a -> b
$cfoldl :: forall (f :: * -> *) a b a.
Foldable f =>
(b -> a -> b) -> b -> FreeF f a a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> FreeF f a a -> b
$cfoldr' :: forall (f :: * -> *) a a b.
Foldable f =>
(a -> b -> b) -> b -> FreeF f a a -> b
foldr :: forall a b. (a -> b -> b) -> b -> FreeF f a a -> b
$cfoldr :: forall (f :: * -> *) a a b.
Foldable f =>
(a -> b -> b) -> b -> FreeF f a a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> FreeF f a a -> m
$cfoldMap' :: forall (f :: * -> *) a m a.
(Foldable f, Monoid m) =>
(a -> m) -> FreeF f a a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> FreeF f a a -> m
$cfoldMap :: forall (f :: * -> *) a m a.
(Foldable f, Monoid m) =>
(a -> m) -> FreeF f a a -> m
fold :: forall m. Monoid m => FreeF f a m -> m
$cfold :: forall (f :: * -> *) a m.
(Foldable f, Monoid m) =>
FreeF f a m -> m
Foldable, forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall {f :: * -> *} {a}. Traversable f => Functor (FreeF f a)
forall {f :: * -> *} {a}. Traversable f => Foldable (FreeF f a)
forall (f :: * -> *) a (m :: * -> *) a.
(Traversable f, Monad m) =>
FreeF f a (m a) -> m (FreeF f a a)
forall (f :: * -> *) a (f :: * -> *) a.
(Traversable f, Applicative f) =>
FreeF f a (f a) -> f (FreeF f a a)
forall (f :: * -> *) a (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> FreeF f a a -> m (FreeF f a b)
forall (f :: * -> *) a (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> FreeF f a a -> f (FreeF f a b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FreeF f a a -> f (FreeF f a b)
sequence :: forall (m :: * -> *) a.
Monad m =>
FreeF f a (m a) -> m (FreeF f a a)
$csequence :: forall (f :: * -> *) a (m :: * -> *) a.
(Traversable f, Monad m) =>
FreeF f a (m a) -> m (FreeF f a a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FreeF f a a -> m (FreeF f a b)
$cmapM :: forall (f :: * -> *) a (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> FreeF f a a -> m (FreeF f a b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
FreeF f a (f a) -> f (FreeF f a a)
$csequenceA :: forall (f :: * -> *) a (f :: * -> *) a.
(Traversable f, Applicative f) =>
FreeF f a (f a) -> f (FreeF f a a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FreeF f a a -> f (FreeF f a b)
$ctraverse :: forall (f :: * -> *) a (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> FreeF f a a -> f (FreeF f a b)
Traversable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) a r x. Rep (FreeF f a r) x -> FreeF f a r
forall (f :: * -> *) a r x. FreeF f a r -> Rep (FreeF f a r) x
$cto :: forall (f :: * -> *) a r x. Rep (FreeF f a r) x -> FreeF f a r
$cfrom :: forall (f :: * -> *) a r x. FreeF f a r -> Rep (FreeF f a r) x
Generic)
  deriving anyclass (forall a. (a -> ()) -> NFData a
forall (f :: * -> *) a r.
(NFData a, NFData (f r)) =>
FreeF f a r -> ()
rnf :: FreeF f a r -> ()
$crnf :: forall (f :: * -> *) a r.
(NFData a, NFData (f r)) =>
FreeF f a r -> ()
NFData, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {f :: * -> *} {a} {r}.
(Hashable a, Hashable (f r)) =>
Eq (FreeF f a r)
forall (f :: * -> *) a r.
(Hashable a, Hashable (f r)) =>
Int -> FreeF f a r -> Int
forall (f :: * -> *) a r.
(Hashable a, Hashable (f r)) =>
FreeF f a r -> Int
hash :: FreeF f a r -> Int
$chash :: forall (f :: * -> *) a r.
(Hashable a, Hashable (f r)) =>
FreeF f a r -> Int
hashWithSalt :: Int -> FreeF f a r -> Int
$chashWithSalt :: forall (f :: * -> *) a r.
(Hashable a, Hashable (f r)) =>
Int -> FreeF f a r -> Int
Hashable)

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
g = \case
    FreePureF a
a -> forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF (a -> b
f a
a)
    FreeEmbedF f c
fr -> forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g f c
fr)

instance Foldable f => Bifoldable (FreeF f) where
  bifoldr :: forall a c b.
(a -> c -> c) -> (b -> c -> c) -> c -> FreeF f a b -> c
bifoldr a -> c -> c
f b -> c -> c
g c
z = \case
    FreePureF a
a -> a -> c -> c
f a
a c
z
    FreeEmbedF f b
fr -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr b -> c -> c
g c
z f b
fr

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
g = \case
    FreePureF a
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF (a -> f c
f a
a)
    FreeEmbedF f b
fr -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> f d
g f b
fr)

-- | The free functor. Use patterns 'FreePure' and 'FreeEmbed' to match and construct.
newtype Free f a = Free { forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
unFree :: FreeF f a (Free f a) }

pattern FreePure :: a -> Free f a
pattern $bFreePure :: forall a (f :: * -> *). a -> Free f a
$mFreePure :: forall {r} {a} {f :: * -> *}.
Free f a -> (a -> r) -> ((# #) -> r) -> r
FreePure a = Free (FreePureF a)

pattern FreeEmbed :: f (Free f a) -> Free f a
pattern $bFreeEmbed :: forall (f :: * -> *) a. f (Free f a) -> Free f a
$mFreeEmbed :: forall {r} {f :: * -> *} {a}.
Free f a -> (f (Free f a) -> r) -> ((# #) -> r) -> r
FreeEmbed fr = Free (FreeEmbedF fr)

{-# COMPLETE FreePure, FreeEmbed #-}

deriving newtype instance (Eq (f (Free f a)), Eq a) => Eq (Free f a)
deriving newtype instance (Ord (f (Free f a)), Ord a) => Ord (Free f a)
deriving stock instance (Show (f (Free f a)), Show a) => Show (Free f a)
deriving newtype instance (NFData (f (Free f a)), NFData a) => NFData (Free f a)
deriving newtype instance (Hashable (f (Free f a)), Hashable a) => Hashable (Free f a)

instance Functor f => Functor (Free f) where
  fmap :: forall a b. (a -> b) -> Free f a -> Free f b
fmap a -> b
f = Free f a -> Free f b
go where
    go :: Free f a -> Free f b
go = forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f Free f a -> Free f b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
unFree

instance Functor f => Applicative (Free f) where
  pure :: forall a. a -> Free f a
pure = forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF
  <*> :: forall a b. Free f (a -> b) -> Free f a -> Free f b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor f => Monad (Free f) where
  return :: forall a. a -> Free f a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Free FreeF f a (Free f a)
m >>= :: forall a b. Free f a -> (a -> Free f b) -> Free f b
>>= a -> Free f b
f = case FreeF f a (Free f a)
m of
    FreePureF a
a -> a -> Free f b
f a
a
    FreeEmbedF f (Free f a)
g -> forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
Free (forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (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 -> Free f b
f) f (Free f a)
g))

instance Foldable f => Foldable (Free f) where
  foldr :: forall a b. (a -> b -> b) -> b -> Free f a -> b
foldr a -> b -> b
f b
z0 Free f a
x0 = Free f a -> b -> b
go Free f a
x0 b
z0 where
    go :: Free f a -> b -> b
go Free f a
x b
z = forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr a -> b -> b
f Free f a -> b -> b
go b
z (forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
unFree Free f a
x)

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 = Free f a -> f (Free f b)
go where
    go :: Free f a -> f (Free f b)
go = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Free f a -> f (Free f b)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
unFree

type instance Base (Free f a) = (FreeF f a)

instance Functor f => Recursive (Free f a) where
  project :: Free f a -> Base (Free f a) (Free f a)
project = forall (f :: * -> *) a. Free f a -> FreeF f a (Free f a)
unFree

instance Functor f => Corecursive (Free f a) where
  embed :: Base (Free f a) (Free f a) -> Free f a
embed = forall (f :: * -> *) a. FreeF f a (Free f a) -> Free f a
Free

-- | Fills all the holes in the free functor
substFree :: (Corecursive t, f ~ Base t) => (a -> t) -> Free f a -> t
substFree :: forall t (f :: * -> *) a.
(Corecursive t, f ~ Base t) =>
(a -> t) -> Free f a -> t
substFree a -> t
s = Free f a -> t
go where
  go :: Free f a -> t
go = \case
    FreePure a
a -> a -> t
s a
a
    FreeEmbed f (Free f a)
fr -> forall t. Corecursive t => Base t t -> t
embed (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> t
go f (Free f a)
fr)

-- | A version of lift that can be used with just a Functor for f
liftFree :: Functor f => f a -> Free f a
liftFree :: forall (f :: * -> *) a. Functor f => f a -> Free f a
liftFree = forall (f :: * -> *) a. f (Free f a) -> Free f a
FreeEmbed 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 (f :: * -> *). a -> Free f a
FreePure

-- | Tear down a free monad using iteration
iterFree :: Functor f => (f a -> a) -> Free f a -> a
iterFree :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Free f a -> a
iterFree f a -> a
f = Free f a -> a
go where
  go :: Free f a -> a
go (Free FreeF f a (Free f a)
x) =
    case FreeF f a (Free f a)
x of
      FreePureF a
a -> a
a
      FreeEmbedF f (Free f a)
z -> f a -> a
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> a
go f (Free f a)
z)

-- | Like iterFree for monadic values
iterFreeM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a
iterFreeM :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> Free f a -> m a
iterFreeM f (m a) -> m a
f = Free f a -> m a
go where
  go :: Free f a -> m a
go (Free FreeF f a (Free f a)
x) =
    case FreeF f a (Free f a)
x of
      FreePureF a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      FreeEmbedF f (Free f a)
z -> f (m a) -> m a
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> m a
go f (Free f a)
z)

newtype FreeT f m a = FreeT { forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
unFreeT :: m (FreeF f a (FreeT f m a)) }

deriving newtype instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a)
deriving newtype instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a)
deriving stock instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a)
deriving newtype instance NFData (m (FreeF f a (FreeT f m a))) => NFData (FreeT f m a)
deriving newtype instance Hashable (m (FreeF f a (FreeT f m a))) => Hashable (FreeT f m a)

instance (Functor f, Functor 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 f m a -> FreeT f m b
go where
    go :: FreeT f m a -> FreeT f m b
go = 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f FreeT f m a -> FreeT f m b
go) 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))
unFreeT

instance (Functor f, Monad m) => Applicative (FreeT f m) where
  pure :: forall a. a -> FreeT f m a
pure = 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF
  <*> :: 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

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
  FreeT m (FreeF f a (FreeT f m a))
mm >>= :: 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))
mm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FreePureF a
a -> forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
unFreeT (a -> FreeT f m b
f a
a)
    FreeEmbedF f (FreeT f m a)
z -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (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)
z))

instance (Foldable f, Foldable m) => Foldable (FreeT f m) where
  foldr :: forall a b. (a -> b -> b) -> b -> FreeT f m a -> b
foldr a -> b -> b
f b
z0 FreeT f m a
x0 = FreeT f m a -> b -> b
go FreeT f m a
x0 b
z0 where
    go :: FreeT f m a -> b -> b
go FreeT f m a
x b
z = 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 (forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr a -> b -> b
f FreeT f m a -> b -> b
go)) b
z (forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
unFreeT FreeT f m a
x)

instance (Traversable f, Traversable m) => 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 f m a -> f (FreeT f m b)
go where
    go :: FreeT f m a -> f (FreeT f m b)
go = 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
. 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 FreeT f m a -> f (FreeT f m b)
go) 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))
unFreeT

liftFreeT :: (Functor f, Applicative m) => f a -> FreeT f m a
liftFreeT :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Applicative m) =>
f a -> FreeT f m a
liftFreeT = 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF 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
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF)

iterFreeT :: (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a
iterFreeT :: forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterFreeT f (m a) -> m a
f = FreeT f m a -> m a
go where
  go :: FreeT f m a -> m a
go (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
>>= \case
     FreePureF a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
     FreeEmbedF f (FreeT f m a)
z -> f (m a) -> m a
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m a -> m a
go f (FreeT f m a)
z)

hoistFreeT :: (Functor f, Functor m) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT :: forall (f :: * -> *) (m :: * -> *) (n :: * -> *) b.
(Functor f, Functor m) =>
(forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT forall a. m a -> n a
g = FreeT f m b -> FreeT f n b
go where
  go :: FreeT f m b -> FreeT f n b
go (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
$ forall a. m a -> n a
g forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (FreeF f b (FreeT f m b))
m forall a b. (a -> b) -> a -> b
$ \case
     FreePureF b
a -> forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF b
a
     FreeEmbedF f (FreeT f m b)
z -> forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m b -> FreeT f n b
go f (FreeT f m b)
z)

transFreeT :: (Functor g, Monad m) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT :: forall (g :: * -> *) (m :: * -> *) (f :: * -> *) b.
(Functor g, Monad m) =>
(forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT forall a. f a -> g a
g = FreeT f m b -> FreeT g m b
go where
  go :: FreeT f m b -> FreeT g m b
go (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
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (FreeF f b (FreeT f m b))
m forall a b. (a -> b) -> a -> b
$ \case
     FreePureF b
a -> forall (f :: * -> *) a r. a -> FreeF f a r
FreePureF b
a
     FreeEmbedF f (FreeT f m b)
z -> forall (f :: * -> *) a r. f r -> FreeF f a r
FreeEmbedF (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FreeT f m b -> FreeT g m b
go (forall a. f a -> g a
g f (FreeT f m b)
z))

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 f m a
x = forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
unFreeT FreeT f m a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
   FreePureF a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a (f :: * -> *). a -> Free f a
FreePure a
a)
   FreeEmbedF f (FreeT f m a)
z -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
FreeEmbed (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f) =>
FreeT f m a -> m (Free f a)
joinFreeT f (FreeT f m a)
z)