{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Free 'FMonad'
module FMonad.FFree where

import Data.Functor.Day (Day (..), day, dap)
import FFunctor
import FMonad
import FStrong

-- | The free 'FMonad' for a @'FFunctor' ff@.  
data FFree ff g x = FPure (g x) | FFree (ff (FFree ff g) x)

deriving instance (Show (g a), Show (ff (FFree ff g) a)) => Show (FFree ff g a)

deriving instance (Eq (g a), Eq (ff (FFree ff g) a)) => Eq (FFree ff g a)

deriving instance (Ord (g a), Ord (ff (FFree ff g) a)) => Ord (FFree ff g a)

deriving instance (Functor g, Functor (ff (FFree ff g))) => Functor (FFree ff g)

deriving instance (Foldable g, Foldable (ff (FFree ff g))) => Foldable (FFree ff g)

deriving instance (Traversable g, Traversable (ff (FFree ff g))) => Traversable (FFree ff g)

instance (FFunctor ff) => FFunctor (FFree ff) where
  ffmap :: forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> FFree ff g x -> FFree ff h x
ffmap g ~> h
gh (FPure g x
gx) = h x -> FFree ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure (g x -> h x
g ~> h
gh g x
gx)
  ffmap g ~> h
gh (FFree ff (FFree ff g) x
fmx) = ff (FFree ff h) x -> FFree ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree ((FFree ff g ~> FFree ff h)
-> ff (FFree ff g) x -> ff (FFree ff h) x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap ((g ~> h) -> FFree ff g x -> FFree ff h x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> FFree ff g x -> FFree ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> h x
g ~> h
gh) ff (FFree ff g) x
fmx)

instance (FFunctor ff) => FMonad (FFree ff) where
  fpure :: forall (g :: * -> *). Functor g => g ~> FFree ff g
fpure = g x -> FFree ff g x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure
  fbind :: forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> FFree ff h) -> FFree ff g a -> FFree ff h a
fbind g ~> FFree ff h
k (FPure g a
gx) = g a -> FFree ff h a
g ~> FFree ff h
k g a
gx
  fbind g ~> FFree ff h
k (FFree ff (FFree ff g) a
fmmx) = ff (FFree ff h) a -> FFree ff h a
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree ((FFree ff g ~> FFree ff h)
-> ff (FFree ff g) a -> ff (FFree ff h) a
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap ((g ~> FFree ff h) -> FFree ff g x -> FFree ff h x
forall (g :: * -> *) (h :: * -> *) a.
(Functor g, Functor h) =>
(g ~> FFree ff h) -> FFree ff g a -> FFree ff h a
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) a.
(FMonad ff, Functor g, Functor h) =>
(g ~> ff h) -> ff g a -> ff h a
fbind g x -> FFree ff h x
g ~> FFree ff h
k) ff (FFree ff g) a
fmmx)

instance (FStrong ff) => FStrong (FFree ff) where
  fstrength :: forall (g :: * -> *) (h :: * -> *).
Functor g =>
Day (FFree ff g) h ~> FFree ff (Day g h)
fstrength (Day FFree ff g b
ffg h c
h b -> c -> x
op) = case FFree ff g b
ffg of
    FPure g b
g -> Day g h x -> FFree ff (Day g h) x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure (g b -> h c -> (b -> c -> x) -> Day g h x
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day g b
g h c
h b -> c -> x
op)
    FFree ff (FFree ff g) b
ffr -> ff (FFree ff (Day g h)) x -> FFree ff (Day g h) x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree ((Day (FFree ff g) h ~> FFree ff (Day g h))
-> ff (Day (FFree ff g) h) x -> ff (FFree ff (Day g h)) x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap Day (FFree ff g) h x -> FFree ff (Day g h) x
Day (FFree ff g) h ~> FFree ff (Day g h)
forall (g :: * -> *) (h :: * -> *).
Functor g =>
Day (FFree ff g) h ~> FFree ff (Day g h)
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *).
(FStrong ff, Functor g) =>
Day (ff g) h ~> ff (Day g h)
fstrength (ff (Day (FFree ff g) h) x -> ff (FFree ff (Day g h)) x)
-> ff (Day (FFree ff g) h) x -> ff (FFree ff (Day g h)) x
forall a b. (a -> b) -> a -> b
$ Day (ff (FFree ff g)) h x -> ff (Day (FFree ff g) h) x
Day (ff (FFree ff g)) h ~> ff (Day (FFree ff g) h)
forall (g :: * -> *) (h :: * -> *).
Functor g =>
Day (ff g) h ~> ff (Day g h)
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *).
(FStrong ff, Functor g) =>
Day (ff g) h ~> ff (Day g h)
fstrength (ff (FFree ff g) b
-> h c -> (b -> c -> x) -> Day (ff (FFree ff g)) h x
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day ff (FFree ff g) b
ffr h c
h b -> c -> x
op))

fffmap :: forall ff gg h.
     (FFunctor ff, FFunctor gg, Functor h)
  => (forall h'. (Functor h') => ff h' ~> gg h')
  -> (FFree ff h ~> FFree gg h)
fffmap :: forall (ff :: (* -> *) -> * -> *) (gg :: (* -> *) -> * -> *)
       (h :: * -> *).
(FFunctor ff, FFunctor gg, Functor h) =>
(forall (h' :: * -> *). Functor h' => ff h' ~> gg h')
-> FFree ff h ~> FFree gg h
fffmap forall (h' :: * -> *). Functor h' => ff h' ~> gg h'
_ (FPure h x
hx) = h x -> FFree gg h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure h x
hx
fffmap forall (h' :: * -> *). Functor h' => ff h' ~> gg h'
t (FFree ff (FFree ff h) x
ffm) = gg (FFree gg h) x -> FFree gg h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree (gg (FFree gg h) x -> FFree gg h x)
-> gg (FFree gg h) x -> FFree gg h x
forall a b. (a -> b) -> a -> b
$ (FFree ff h ~> FFree gg h)
-> gg (FFree ff h) x -> gg (FFree gg h) x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> gg g x -> gg h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap ((forall (h' :: * -> *). Functor h' => ff h' ~> gg h')
-> FFree ff h ~> FFree gg h
forall (ff :: (* -> *) -> * -> *) (gg :: (* -> *) -> * -> *)
       (h :: * -> *).
(FFunctor ff, FFunctor gg, Functor h) =>
(forall (h' :: * -> *). Functor h' => ff h' ~> gg h')
-> FFree ff h ~> FFree gg h
fffmap ff h' x -> gg h' x
ff h' ~> gg h'
forall (h' :: * -> *). Functor h' => ff h' ~> gg h'
t) (ff (FFree ff h) x -> gg (FFree ff h) x
ff (FFree ff h) ~> gg (FFree ff h)
forall (h' :: * -> *). Functor h' => ff h' ~> gg h'
t ff (FFree ff h) x
ffm)

-- | Iteratively fold a @FFree@ term down, given a way to fold one layer of @ff@. 
iter :: forall ff g. (FFunctor ff, Functor g) => (ff g ~> g) -> FFree ff g ~> g
iter :: forall (ff :: (* -> *) -> * -> *) (g :: * -> *).
(FFunctor ff, Functor g) =>
(ff g ~> g) -> FFree ff g ~> g
iter ff g ~> g
step = FFree ff g x -> g x
FFree ff g ~> g
go
  where
    go :: FFree ff g ~> g
    go :: FFree ff g ~> g
go (FPure g x
gx) = g x
gx
    go (FFree ff (FFree ff g) x
fmx) = ff g x -> g x
ff g ~> g
step ((FFree ff g ~> g) -> ff (FFree ff g) x -> ff g x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap FFree ff g x -> g x
FFree ff g ~> g
go ff (FFree ff g) x
fmx)

-- | Fold a @FFree@ term to another @FMonad mm@.
foldFFree :: forall ff mm g. (FFunctor ff, FMonad mm, Functor g) => (forall h. Functor h => ff h ~> mm h) -> FFree ff g ~> mm g
foldFFree :: forall (ff :: (* -> *) -> * -> *) (mm :: (* -> *) -> * -> *)
       (g :: * -> *).
(FFunctor ff, FMonad mm, Functor g) =>
(forall (h :: * -> *). Functor h => ff h ~> mm h)
-> FFree ff g ~> mm g
foldFFree forall (h :: * -> *). Functor h => ff h ~> mm h
toMM = FFree ff g x -> mm g x
FFree ff g ~> mm g
go
  where
    go :: FFree ff g ~> mm g
    go :: FFree ff g ~> mm g
go (FPure g x
gx) = g x -> mm g x
g ~> mm g
forall (g :: * -> *). Functor g => g ~> mm g
forall (ff :: (* -> *) -> * -> *) (g :: * -> *).
(FMonad ff, Functor g) =>
g ~> ff g
fpure g x
gx
    go (FFree ff (FFree ff g) x
ftx) = mm (mm g) x -> mm g x
mm (mm g) ~> mm g
forall (ff :: (* -> *) -> * -> *) (g :: * -> *).
(FMonad ff, Functor g) =>
ff (ff g) ~> ff g
fjoin ((FFree ff g ~> mm g) -> mm (FFree ff g) x -> mm (mm g) x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> mm g x -> mm h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap FFree ff g x -> mm g x
FFree ff g ~> mm g
go (ff (FFree ff g) x -> mm (FFree ff g) x
ff (FFree ff g) ~> mm (FFree ff g)
forall (h :: * -> *). Functor h => ff h ~> mm h
toMM ff (FFree ff g) x
ftx))

-- | @retract = 'foldFFree' id@
retract :: (FMonad ff, Functor g) => FFree ff g ~> ff g
retract :: forall (ff :: (* -> *) -> * -> *) (g :: * -> *).
(FMonad ff, Functor g) =>
FFree ff g ~> ff g
retract = (forall (h :: * -> *). Functor h => ff h ~> ff h)
-> FFree ff g ~> ff g
forall (ff :: (* -> *) -> * -> *) (mm :: (* -> *) -> * -> *)
       (g :: * -> *).
(FFunctor ff, FMonad mm, Functor g) =>
(forall (h :: * -> *). Functor h => ff h ~> mm h)
-> FFree ff g ~> mm g
foldFFree ff h x -> ff h x
forall a. a -> a
forall (h :: * -> *). Functor h => ff h ~> ff h
id

instance (FStrong ff, Applicative g) => Applicative (FFree ff g) where
  pure :: forall a. a -> FFree ff g a
pure = g a -> FFree ff g a
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure (g a -> FFree ff g a) -> (a -> g a) -> a -> FFree ff g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  FPure g (a -> b)
gx <*> :: forall a b. FFree ff g (a -> b) -> FFree ff g a -> FFree ff g b
<*> FFree ff g a
y = (Day g g ~> g) -> FFree ff (Day g g) b -> FFree ff g b
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> FFree ff g x -> FFree ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap Day g g x -> g x
Day g g ~> g
forall (f :: * -> *) a. Applicative f => Day f f a -> f a
dap (FFree ff (Day g g) b -> FFree ff g b)
-> FFree ff (Day g g) b -> FFree ff g b
forall a b. (a -> b) -> a -> b
$ Day g (FFree ff g) b -> FFree ff (Day g g) b
Day g (FFree ff g) ~> FFree ff (Day g g)
forall (ff :: (* -> *) -> * -> *) (h :: * -> *) (g :: * -> *).
(FStrong ff, Functor h) =>
Day g (ff h) ~> ff (Day g h)
fstrength' (g (a -> b) -> FFree ff g a -> Day g (FFree ff g) b
forall (f :: * -> *) a b (g :: * -> *).
f (a -> b) -> g a -> Day f g b
day g (a -> b)
gx FFree ff g a
y)
  FFree ff (FFree ff g) (a -> b)
ffr <*> FFree ff g a
y = ff (FFree ff g) b -> FFree ff g b
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree (ff (FFree ff g) b -> FFree ff g b)
-> ff (FFree ff g) b -> FFree ff g b
forall a b. (a -> b) -> a -> b
$ ff (FFree ff g) (a -> b) -> FFree ff g a -> ff (FFree ff g) b
forall (ff :: (* -> *) -> * -> *) (h :: * -> *) a b.
(FStrong ff, Applicative h) =>
ff h (a -> b) -> h a -> ff h b
innerAp ff (FFree ff g) (a -> b)
ffr FFree ff g a
y

-- | Lift a single layer of @ff@ into @FFree ff@
liftF :: (FFunctor ff, Functor g) => ff g ~> FFree ff g
liftF :: forall (ff :: (* -> *) -> * -> *) (g :: * -> *).
(FFunctor ff, Functor g) =>
ff g ~> FFree ff g
liftF ff g x
fgx = ff (FFree ff g) x -> FFree ff g x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
ff (FFree ff g) x -> FFree ff g x
FFree ((g ~> FFree ff g) -> ff g x -> ff (FFree ff g) x
forall (g :: * -> *) (h :: * -> *) x.
(Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) (h :: * -> *) x.
(FFunctor ff, Functor g, Functor h) =>
(g ~> h) -> ff g x -> ff h x
ffmap g x -> FFree ff g x
g ~> FFree ff g
forall (ff :: (* -> *) -> * -> *) (g :: * -> *) x.
g x -> FFree ff g x
FPure ff g x
fgx)