-- | Description: makes a monad of any type constructor

module SupplyChain.Core.FreeMonad
  (
    {- * Type -} FreeMonad (Step, Bind, Pure, Map),
    {- * Running -} run, eval,
    {- * Alteration -} alter,
  )
  where

import Control.Applicative (Applicative (pure, (<*>)))
import Control.Monad (Monad ((>>=)))
import Data.Function ((&), ($), (.))
import Data.Functor (Functor, (<&>))
import SupplyChain.Core.FreePointedFunctor (FreePointedFunctor)

import qualified Control.Monad as Monad
import qualified SupplyChain.Core.FreePointedFunctor as FreePointedFunctor

data FreeMonad f a =
    Step (FreePointedFunctor f a)
  | forall x. Bind (FreeMonad f x) (x -> FreeMonad f a)

pattern Pure :: a -> FreeMonad f a
pattern $bPure :: forall a (f :: * -> *). a -> FreeMonad f a
$mPure :: forall {r} {a} {f :: * -> *}.
FreeMonad f a -> (a -> r) -> ((# #) -> r) -> r
Pure a = Step (FreePointedFunctor.Pure a)

pattern Map :: f x -> (x -> a) -> FreeMonad f a
pattern $bMap :: forall (f :: * -> *) a x. f x -> (x -> a) -> FreeMonad f a
$mMap :: forall {r} {f :: * -> *} {a}.
FreeMonad f a
-> (forall {x}. f x -> (x -> a) -> r) -> ((# #) -> r) -> r
Map action extract = Step (FreePointedFunctor.Map action extract)

{-# complete Pure, Map, Bind #-}

deriving instance Functor (FreeMonad f)

instance Applicative (FreeMonad f) where pure :: forall a. a -> FreeMonad f a
pure = forall a (f :: * -> *). a -> FreeMonad f a
Pure; <*> :: forall a b. FreeMonad f (a -> b) -> FreeMonad f a -> FreeMonad f b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
Monad.ap

instance Monad (FreeMonad f) where >>= :: forall a b. FreeMonad f a -> (a -> FreeMonad f b) -> FreeMonad f b
(>>=) = forall (f :: * -> *) a x.
FreeMonad f x -> (x -> FreeMonad f a) -> FreeMonad f a
Bind

run :: Monad effect =>
    (forall x. f x -> effect x) -- ^ How to interpret @f@ actions
    -> FreeMonad f a -> effect a
run :: forall (effect :: * -> *) (f :: * -> *) a.
Monad effect =>
(forall x. f x -> effect x) -> FreeMonad f a -> effect a
run (forall x. f x -> effect x
runEffect :: forall x. f x -> effect x) = forall x. FreeMonad f x -> effect x
recur
  where
    runPF :: FreePointedFunctor f x -> effect x
    runPF :: forall x. FreePointedFunctor f x -> effect x
runPF = forall (effect :: * -> *) (f :: * -> *) product.
Monad effect =>
(forall x. f x -> effect x)
-> FreePointedFunctor f product -> effect product
FreePointedFunctor.run forall x. f x -> effect x
runEffect

    recur :: FreeMonad f x -> effect x
    recur :: forall x. FreeMonad f x -> effect x
recur = \case
        Step FreePointedFunctor f x
a -> forall x. FreePointedFunctor f x -> effect x
runPF FreePointedFunctor f x
a
        Bind (Step FreePointedFunctor f x
a) x -> FreeMonad f x
b -> forall x. FreePointedFunctor f x -> effect x
runPF FreePointedFunctor f x
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x
x -> forall x. FreeMonad f x -> effect x
recur forall a b. (a -> b) -> a -> b
$ x -> FreeMonad f x
b x
x
        Bind (Bind FreeMonad f x
a x -> FreeMonad f x
b) x -> FreeMonad f x
c -> forall x. FreeMonad f x -> effect x
recur FreeMonad f x
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x
x -> forall x. FreeMonad f x -> effect x
recur forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a x.
FreeMonad f x -> (x -> FreeMonad f a) -> FreeMonad f a
Bind (x -> FreeMonad f x
b x
x) x -> FreeMonad f x
c

eval :: (forall x. f x -> x) -- ^ How to interpret @f@ actions
    -> FreeMonad f a
    -> a
eval :: forall (f :: * -> *) a. (forall x. f x -> x) -> FreeMonad f a -> a
eval (forall x. f x -> x
evalEffect :: forall x. f x -> x) = forall x. FreeMonad f x -> x
recur
  where
    evalPF :: FreePointedFunctor f x -> x
    evalPF :: forall x. FreePointedFunctor f x -> x
evalPF = forall (f :: * -> *) product.
(forall x. f x -> x) -> FreePointedFunctor f product -> product
FreePointedFunctor.eval forall x. f x -> x
evalEffect

    recur :: FreeMonad f x -> x
    recur :: forall x. FreeMonad f x -> x
recur = \case
        Step FreePointedFunctor f x
a -> forall x. FreePointedFunctor f x -> x
evalPF FreePointedFunctor f x
a
        Bind (Step FreePointedFunctor f x
a) x -> FreeMonad f x
b -> forall x. FreePointedFunctor f x -> x
evalPF FreePointedFunctor f x
a forall a b. a -> (a -> b) -> b
& \x
x -> forall x. FreeMonad f x -> x
recur forall a b. (a -> b) -> a -> b
$ x -> FreeMonad f x
b x
x
        Bind (Bind FreeMonad f x
a x -> FreeMonad f x
b) x -> FreeMonad f x
c -> forall x. FreeMonad f x -> x
recur FreeMonad f x
a forall a b. a -> (a -> b) -> b
& \x
x -> forall x. FreeMonad f x -> x
recur forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a x.
FreeMonad f x -> (x -> FreeMonad f a) -> FreeMonad f a
Bind (x -> FreeMonad f x
b x
x) x -> FreeMonad f x
c

alter :: (forall x. f x -> FreeMonad f' x)
    -> FreeMonad f a -> FreeMonad f' a
alter :: forall (f :: * -> *) (f' :: * -> *) a.
(forall x. f x -> FreeMonad f' x)
-> FreeMonad f a -> FreeMonad f' a
alter (forall x. f x -> FreeMonad f' x
f :: forall x. f x -> FreeMonad f' x) = forall x. FreeMonad f x -> FreeMonad f' x
recur
  where
    recur :: FreeMonad f x -> FreeMonad f' x
    recur :: forall x. FreeMonad f x -> FreeMonad f' x
recur = \case
        Pure x
x -> forall a (f :: * -> *). a -> FreeMonad f a
Pure x
x
        Map f x
action x -> x
extract -> forall x. f x -> FreeMonad f' x
f f x
action forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> x -> x
extract
        Bind FreeMonad f x
a x -> FreeMonad f x
b -> forall (f :: * -> *) a x.
FreeMonad f x -> (x -> FreeMonad f a) -> FreeMonad f a
Bind (forall x. FreeMonad f x -> FreeMonad f' x
recur FreeMonad f x
a) (forall x. FreeMonad f x -> FreeMonad f' x
recur forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> FreeMonad f x
b)