-- | Description: makes a pointed functor of any type constructor

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

import Control.Applicative (pure)
import Control.Monad (Monad)
import Data.Function ((&))
import Data.Functor (Functor, (<&>))

data FreePointedFunctor f product =
    Pure product
  | forall x. Map (f x) (x -> product)

deriving instance Functor (FreePointedFunctor f)

run :: Monad effect =>
    (forall x. f x -> effect x) -- ^ How to interpret @f@ actions
    -> FreePointedFunctor f product -> effect product
run :: forall (effect :: * -> *) (f :: * -> *) product.
Monad effect =>
(forall x. f x -> effect x)
-> FreePointedFunctor f product -> effect product
run forall x. f x -> effect x
runEffect = \case
    Pure product
product -> forall (f :: * -> *) a. Applicative f => a -> f a
pure product
product
    Map f x
action x -> product
extract -> forall x. f x -> effect x
runEffect f x
action forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> x -> product
extract

eval ::
    (forall x. f x -> x) -- ^ How to interpret @f@ actions
    -> FreePointedFunctor f product -> product
eval :: forall (f :: * -> *) product.
(forall x. f x -> x) -> FreePointedFunctor f product -> product
eval forall x. f x -> x
evalF = \case
    Pure product
product -> product
product
    Map f x
action x -> product
extract -> forall x. f x -> x
evalF f x
action forall a b. a -> (a -> b) -> b
& x -> product
extract

alter :: (forall x. f x -> FreePointedFunctor f' x)
    -> FreePointedFunctor f product -> FreePointedFunctor f' product
alter :: forall (f :: * -> *) (f' :: * -> *) product.
(forall x. f x -> FreePointedFunctor f' x)
-> FreePointedFunctor f product -> FreePointedFunctor f' product
alter forall x. f x -> FreePointedFunctor f' x
f = \case
    Pure product
product -> forall (f :: * -> *) product.
product -> FreePointedFunctor f product
Pure product
product
    Map f x
action x -> product
extract -> forall x. f x -> FreePointedFunctor f' x
f f x
action forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> x -> product
extract