Crem

Domain events

Events relevant for domain experts

Commands

User intentions/actions/decisions

Read models

Data needed in order to make decisions

Aggregates

Decide what happens on commands

Policies

Reactive logic that takes place after an event

Projections

Aggregate data from events

Aggregates, projections and policies could be implemented as state machines

Aggregates

From commands to events

Projections

From events to read models

Policies

From events to commands

How should we encode a state machine?

Mealy machines

data Mealy state input output = Mealy
  { initialState :: state
  , action :: state -> input -> (state, output)
  }
data Mealy state input output = Mealy
  { initialState :: state
  , action :: state -> input -> (state, output)
  }
data Mealy state input output = Mealy
  { initialState :: state
  , action :: state -> input -> (state, output)
  }

Mealy machines

newtype Mealy input output = Mealy
  { runMealy
      :: input
      -> (output, Mealy input output)
  }
newtype Mealy input output = Mealy
  { runMealy
      :: input
      -> (output, Mealy input output)
  }

Machines are composable

sequential
  :: Mealy a b  
  -> Mealy b c
  -> Mealy a c

%%{init: {'theme':'dark'}}%%
stateDiagram-v2
direction LR
a --> b
b --> c

parallel
  :: Mealy a b
  -> Mealy c d
  -> Mealy (a, c) (b, d)

%%{init: {'theme':'dark'}}%%
stateDiagram-v2
direction LR
state fork <<fork>>
(a,c) --> fork
fork --> a
fork --> c
a --> b
c --> d
state join <<join>>
b --> join
d --> join
join --> (b,d)

alternative
  :: Mealy a b
  -> Mealy c d
  -> Mealy (Either a c) (Either c d)

%%{init: {'theme':'dark'}}%%
stateDiagram-v2
direction LR
eitherac: Either a c
state fork <<choice>>
eitherac --> fork
fork --> a
fork --> c
a --> b
c --> d
state join <<choice>>
b --> join
d --> join
join --> eitherbd
eitherbd: Either b d

feedback
  :: Mealy a [b]
  -> Mealy b [a]
  -> Mealy a [b]

%%{init: {'theme':'dark'}}%%
stateDiagram-v2
direction LR
a --> b: []
b --> a: []

This encoding can only be run

What about documentation?

What about invariant enforcement?

Strengthening the type

data Machine
  (topology :: Topology vertex)
  input
  output

{-# LANGUAGE DataKinds #-}

newtype Topology vertex = Topology
  { edges :: [(vertex, [vertex])] }

Topology

%%{init: {'theme':'dark'}}%%
stateDiagram-v2

NoData --> CollectedUserData
CollectedUserData --> CollectedLoanDetailsFirst
CollectedUserData --> ReceivedCreditBureauDataFirst
CollectedLoanDetailsFirst --> CollectedAllData
ReceivedCreditBureauDataFirst --> CollectedAllData

Adding the Topology in the type

Allows us to enforce execution of allowed transitions

data Machine topology a b =
  forall state. Machine
    { initialState :: InitialState state
    , action
      :: forall initialVertex
       . state initialVertex
      -> a
      -> ActionResult topology state initialVertex b
    }
data Machine topology a b =
  forall state. Machine
    { initialState :: InitialState state
    , action
      :: forall initialVertex
       . state initialVertex
      -> a
      -> ActionResult topology state initialVertex b
    }
data Machine topology a b =
  forall state. Machine
    { initialState :: InitialState state
    , action
      :: forall initialVertex
       . state initialVertex
      -> a
      -> ActionResult topology state initialVertex b
    }
data Machine topology a b =
  forall state. Machine
    { initialState :: InitialState state
    , action
      :: forall initialVertex
       . state initialVertex
      -> a
      -> ActionResult topology state initialVertex b
    }

data ActionResult topology state initial b where
  ActionResult
    :: AllowedTransition topology initial final
    => (b, state final)
    -> ActionResult topology state initial b
data ActionResult topology state initial b where
  ActionResult
    :: AllowedTransition topology initial final
    => (b, state final)
    -> ActionResult topology state initial b
data ActionResult topology state initial b where
  ActionResult
    :: AllowedTransition topology initial final
    => (b, state final)
    -> ActionResult topology state initial b
data ActionResult topology state initial b where
  ActionResult
    :: AllowedTransition topology initial final
    => (b, state final)
    -> ActionResult topology state initial b

Allows us to retrieve information about our state machine without running it

topology
  :: forall vertex topology a b
   . ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI topology
     )
  => Machine (topology :: Topology vertex) a b
  -> Topology vertex
baseMachineTopology _ = demote @topology
topology
  :: forall vertex topology a b
   . ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI topology
     )
  => Machine (topology :: Topology vertex) a b
  -> Topology vertex
baseMachineTopology _ = demote @topology
topology
  :: forall vertex topology a b
   . ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI topology
     )
  => Machine (topology :: Topology vertex) a b
  -> Topology vertex
baseMachineTopology _ = demote @topology
topology
  :: forall vertex topology a b
   . ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI topology
     )
  => Machine (topology :: Topology vertex) a b
  -> Topology vertex
baseMachineTopology _ = demote @topology

But…

Composition becomes harder

sequential
  :: Machine t1 a b  
  -> Machine t2 b c
  -> Machine ??? a c

Requires computation at the type level

Breaks usage of standard typeclasses like Arrow or Category

Can we get the best of both worlds?

data StateMachine input output where

data StateMachine input output where
  Basic
    :: Machine topology input output
    -> StateMachine input output
data StateMachine input output where
  Basic
    :: Machine topology input output
    -> StateMachine input output

foo :: StateMachine input output -> a
foo stateMachine = case stateMachine of
  Basic machine -> _
foo :: StateMachine input output -> a
foo stateMachine = case stateMachine of
  Basic machine -> _

data StateMachine input output where
  ...
  Sequential
    :: StateMachine a b
    -> StateMachine b c
    -> StateMachine a c

data StateMachine input output where
  ...
  Parallel
    :: StateMachine a b
    -> StateMachine c d
    -> StateMachine (a, c) (b, d)

data StateMachine input output where
  ...
  Alternative
    :: StateMachine a b
    -> StateMachine c d
    -> StateMachine (Either a c) (Either b d)

data StateMachine input output where
  ...
  Feedback
    :: StateMachine a [b]
    -> StateMachine b [a]
    -> StateMachine a [b]

%%{init: {'theme':'dark'}}%%
graph TD

A[Alternative] --> B[Parallel]
A --> C[Sequential]
B --> D[Machine 1]
B --> E[Machine 2]
C --> F[Machine 3]
C --> G[Machine 4]

Composable

instance Category StateMachine where
  id = Basic identity
 
  (.) = flip Sequential
instance Category StateMachine where
  id = Basic identity
 
  (.) = flip Sequential
instance Category StateMachine where
  id = Basic identity
 
  (.) = flip Sequential

instance Strong StateMachine where
  second' = Parallel id
instance Strong StateMachine where
  second' = Parallel id

instance Choice StateMachine where
  right' = Alternative id
instance Choice StateMachine where
  right' = Alternative id

Executable

run
  :: StateMachine a b
  -> a
  -> (b, StateMachine a b)

run (Basic machine) input =
  _ -- use the `action`
    -- with `initialState` and `input`
run (Basic machine) input =
  _ -- use the `action`
    -- with `initialState` and `input`

run (Sequential machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 input
    (output2, machine2')
      = run machine2 output1
  in
    ( output2
    , Sequential machine1' machine2'
    )
run (Sequential machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 input
    (output2, machine2')
      = run machine2 output1
  in
    ( output2
    , Sequential machine1' machine2'
    )
run (Sequential machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 input
    (output2, machine2')
      = run machine2 output1
  in
    ( output2
    , Sequential machine1' machine2'
    )
run (Sequential machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 input
    (output2, machine2')
      = run machine2 output1
  in
    ( output2
    , Sequential machine1' machine2'
    )

run (Parallel machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 (fst input)
    (output2, machine2')
      = run machine2 (snd input)
  in
    ( (output1, output2)
    , Parallel machine1' machine2'
    )
run (Parallel machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 (fst input)
    (output2, machine2')
      = run machine2 (snd input)
  in
    ( (output1, output2)
    , Parallel machine1' machine2'
    )
run (Parallel machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 (fst input)
    (output2, machine2')
      = run machine2 (snd input)
  in
    ( (output1, output2)
    , Parallel machine1' machine2'
    )
run (Parallel machine1 machine2) input =
  let
    (output1, machine1')
      = run machine1 (fst input)
    (output2, machine2')
      = run machine2 (snd input)
  in
    ( (output1, output2)
    , Parallel machine1' machine2'
    )

Representable

newtype Mermaid = Mermaid
  {getText :: Text}
 
render :: StateMachine a b -> Mermaid
newtype Mermaid = Mermaid
  {getText :: Text}
 
render :: StateMachine a b -> Mermaid

render (Basic machine)
  = renderTopology (topology machine)
render (Basic machine)
  = renderTopology (topology machine)

render (Sequential machine1 machine2) =
  let
    mermaid1 = render machine1
    mermaid2 = render machine2
  in
       mermaid1
    <> Mermaid " --> "
    <> mermaid2
render (Sequential machine1 machine2) =
  let
    mermaid1 = render machine1
    mermaid2 = render machine2
  in
       mermaid1
    <> Mermaid " --> "
    <> mermaid2
render (Sequential machine1 machine2) =
  let
    mermaid1 = render machine1
    mermaid2 = render machine2
  in
       mermaid1
    <> Mermaid " --> "
    <> mermaid2
render (Sequential machine1 machine2) =
  let
    mermaid1 = render machine1
    mermaid2 = render machine2
  in
       mermaid1
    <> Mermaid " --> "
    <> mermaid2

We can draw our machines

Demo time

The Hobbit code

The Hobbit map

That's all!

Questions and feedback

marcosh.github.io

@marcoshuttle

@marcosh@functional.cafe