{-# LANGUAGE DataKinds #-}

-- | The [Decider pattern](https://thinkbeforecoding.com/post/2021/12/17/functional-event-sourcing-decider)
-- allows to easily describe an [aggregate](https://www.domainlanguage.com/wp-content/uploads/2016/05/DDD_Reference_2015-03.pdf)
-- in functional terms
--
-- In terms of Mealy machines, a `Decider` is a machine where the next state is
-- computed from the previous state and the output
module Crem.Decider where

import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState (..))
import Crem.Topology (AllowedTransition, Topology)
import Data.Foldable (foldl')
import "base" Data.Kind (Type)

-- | A @Decider topology input output@ is a Decider which receives inputs of
-- type @input@ and emits outputs of type @output@, where allowed transitions
-- are constrained by the provided @topology@.
--
-- Being used to describe the domain logic of an aggregate, a `Decider` is
-- always pure.
--
-- It is defined by:
--
--   * its `deciderInitialState`
--   * a `decide` function, which says how to compute the @output@ out of the
-- @input@ and the current state
--   * an `evolve` function, which allows us to specify the next state from the
-- current state and the @output@
data
  Decider
    (topology :: Topology vertex)
    input
    output = forall state.
  Decider
  { ()
deciderInitialState :: InitialState state
  , ()
decide :: forall vertex'. input -> state vertex' -> output
  , ()
evolve
      :: forall initialVertex
       . state initialVertex
      -> output
      -> EvolutionResult topology state initialVertex output
  }

-- | A smart wrapper over the machine state, which allows to enforce that only
-- transitions allowed by the @topology@ are actually performed.
data
  EvolutionResult
    (topology :: Topology vertex)
    (state :: vertex -> Type)
    (initialVertex :: vertex)
    output
  where
  EvolutionResult
    :: AllowedTransition topology initialVertex finalVertex
    => state finalVertex
    -> EvolutionResult topology state initialVertex output

-- | translate a `Decider` into a `BaseMachine`
deciderMachine
  :: Decider topology input output
  -> BaseMachine topology input output
deciderMachine :: forall {vertex} (topology :: Topology vertex) input output.
Decider topology input output -> BaseMachine topology input output
deciderMachine (Decider InitialState state
deciderInitialState' forall (vertex' :: vertex). input -> state vertex' -> output
decide' forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve') =
  BaseMachineT
    { initialState :: InitialState state
initialState = InitialState state
deciderInitialState'
    , action :: forall (initialVertex :: vertex).
state initialVertex
-> input -> ActionResult m topology state initialVertex output
action = \state initialVertex
state input
input ->
        let
          output :: output
output = input -> state initialVertex -> output
forall (vertex' :: vertex). input -> state vertex' -> output
decide' input
input state initialVertex
state
         in
          case state initialVertex
-> output -> EvolutionResult topology state initialVertex output
forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve' state initialVertex
state output
output of
            EvolutionResult state finalVertex
finalState ->
              m (output, state finalVertex)
-> ActionResult m topology state initialVertex output
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (finalVertex :: vertex) (m :: * -> *)
       output (state :: vertex -> *).
AllowedTransition topology initialVertex finalVertex =>
m (output, state finalVertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (output, state finalVertex)
 -> ActionResult m topology state initialVertex output)
-> m (output, state finalVertex)
-> ActionResult m topology state initialVertex output
forall a b. (a -> b) -> a -> b
$ (output, state finalVertex) -> m (output, state finalVertex)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (output
output, state finalVertex
finalState)
    }

-- | rebuild a `Decider` from a list of outputs
--
-- This is the main selling point of a `Decider` over a generic `Crem.StateMachine`,
-- since it allows rebuilding a machine from its outputs.
rebuildDecider
  :: [output]
  -> Decider topology input output
  -> Decider topology input output
rebuildDecider :: forall {vertex} output (topology :: Topology vertex) input.
[output]
-> Decider topology input output -> Decider topology input output
rebuildDecider [output]
outputs Decider topology input output
decider =
  (Decider topology input output
 -> output -> Decider topology input output)
-> Decider topology input output
-> [output]
-> Decider topology input output
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Decider topology input output
-> output -> Decider topology input output
forall {vertex} (topology :: Topology vertex) input output.
Decider topology input output
-> output -> Decider topology input output
rebuildDeciderStep Decider topology input output
decider [output]
outputs
  where
    rebuildDeciderStep
      :: Decider topology input output
      -> output
      -> Decider topology input output
    rebuildDeciderStep :: forall {vertex} (topology :: Topology vertex) input output.
Decider topology input output
-> output -> Decider topology input output
rebuildDeciderStep (Decider (InitialState state vertex1
initialState') forall (vertex' :: vertex). input -> state vertex' -> output
decide' forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve') output
output =
      let
        evolveResult :: EvolutionResult topology state vertex1 output
evolveResult = state vertex1
-> output -> EvolutionResult topology state vertex1 output
forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve' state vertex1
initialState' output
output
       in
        case EvolutionResult topology state vertex1 output
evolveResult of
          EvolutionResult state finalVertex
evolvedState ->
            Decider
              { deciderInitialState :: InitialState state
deciderInitialState = state finalVertex -> InitialState state
forall {vertex} (state :: vertex -> *) (vertex1 :: vertex).
state vertex1 -> InitialState state
InitialState state finalVertex
evolvedState
              , decide :: forall (vertex' :: vertex). input -> state vertex' -> output
decide = input -> state vertex' -> output
forall (vertex' :: vertex). input -> state vertex' -> output
decide'
              , evolve :: forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve = state initialVertex
-> output -> EvolutionResult topology state initialVertex output
forall (initialVertex :: vertex).
state initialVertex
-> output -> EvolutionResult topology state initialVertex output
evolve'
              }