Decider can be rebuilt out of its own outputs

spec/Crem/DeciderSpec.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Crem.DeciderSpec where
+
+import "crem" Crem.BaseMachine (InitialState (..))
+import "crem" Crem.Decider
+import "crem" Crem.Example.Uno
+import Crem.StateMachine (StateMachineT (..), run)
+import Data.Functor.Identity (Identity)
+import "hspec" Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec =
+  describe "Decider" $ do
+    describe "unoDecider" $ do
+      it "is able to rebuild from a list of events" $ do
+        let
+          unoInitialDecider :: Decider UnoTopology Command (Either GameError Event)
+          unoInitialDecider = unoDecider (InitialState UnoInitialState)
+
+          rebuiltDecider :: Decider UnoTopology Command (Either GameError Event)
+          rebuiltDecider =
+            rebuildDecider
+              [ Right $
+                  GameStarted
+                    (InitialData (PlayerCount 3) (DigitCard Three Yellow))
+                    (PlayerId 0)
+              , Right $
+                  CardPlayed
+                    (PlayData (PlayerId 0) (DigitCard Six Yellow))
+              ]
+              unoInitialDecider
+
+          inProgressDecider :: Decider UnoTopology Command (Either GameError Event)
+          inProgressDecider =
+            unoDecider
+              ( InitialState $
+                  UnoStartedState $
+                    StateData
+                      { topCard = DigitCard Six Yellow
+                      , currentPlayer = Player (PlayerId 0) (PlayerCount 3) Clockwise
+                      }
+              )
+
+          command :: Command
+          command =
+            PlayCard $
+              PlayData
+                { playerId = PlayerId 1
+                , card = DigitCard Six Blue
+                }
+         in
+          (fst <$> run @Identity (Basic $ deciderMachine rebuiltDecider) command)
+            `shouldBe` (fst <$> run (Basic $ deciderMachine inProgressDecider) command)

spec/Crem/StateMachineSpec.hs

@@ -1,11 +1,11 @@
 module Crem.StateMachineSpec where
 
+import "base" Control.Category qualified
 import Crem.Example.BooleanStateMachine (booleanStateMachine)
 import Crem.Example.LockDoor
 import Crem.Example.PlusOneUpToFour (plus1UpTo4)
 import Crem.Example.Switch (switchMachine)
 import "crem" Crem.StateMachine
-import "base" Control.Category qualified
 import "base" Data.Functor.Identity (Identity (..))
 import "base" Data.List (singleton)
 import "profunctors" Data.Profunctor (rmap)
@@ -15,13 +15,6 @@ import "hspec" Test.Hspec (Expectation, Spec, describe, it, shouldBe)
 shouldOutput :: (Eq b, Show b) => Identity (b, c) -> b -> Expectation
 shouldOutput (Identity (output, _)) expectedOutput = output `shouldBe` expectedOutput
 
-shouldHaveTheSameOutputAs
-  :: (Eq b, Show b)
-  => (b, c)
-  -> (b, c)
-  -> Expectation
-shouldHaveTheSameOutputAs (b1, _) (b2, _) = b1 `shouldBe` b2
-
 spec :: Spec
 spec =
   describe "StateMachine" $ do

src/Crem/Decider.hs

@@ -2,8 +2,9 @@
 
 module Crem.Decider where
 
-import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState)
+import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState (..))
 import Crem.Topology (AllowedTransition, Topology)
+import Data.Foldable (foldl')
 import "base" Data.Kind (Type)
 
 -- | The [Decider pattern](https://thinkbeforecoding.com/post/2021/12/17/functional-event-sourcing-decider)
@@ -38,6 +39,7 @@ data
     => state finalVertex
     -> EvolutionResult topology state initialVertex output
 
+-- | translate a `Decider` into a `BaseMachine`
 deciderMachine
   :: Decider topology input output
   -> BaseMachine topology input output
@@ -52,3 +54,30 @@ deciderMachine (Decider deciderInitialState' decide' evolve') =
             EvolutionResult finalState ->
               ActionResult $ pure (output, finalState)
     }
+
+-- | rebuild a `Decider` from a list of outputs
+--
+-- This is the main selling point of a `Decider` over a generic `StateMachine`,
+-- since it allows it to be rebuilt from its outputs.
+rebuildDecider
+  :: [output]
+  -> Decider topology input output
+  -> Decider topology input output
+rebuildDecider outputs decider =
+  foldl' rebuildDeciderStep decider outputs
+  where
+    rebuildDeciderStep
+      :: Decider topology input output
+      -> output
+      -> Decider topology input output
+    rebuildDeciderStep (Decider (InitialState initialState') decide' evolve') output =
+      let
+        evolveResult = evolve' initialState' output
+       in
+        case evolveResult of
+          EvolutionResult evolvedState ->
+            Decider
+              { deciderInitialState = InitialState evolvedState
+              , decide = decide'
+              , evolve = evolve'
+              }

src/Crem/Example/Uno.hs

@@ -1,10 +1,16 @@
 {-# LANGUAGE DataKinds #-}
+{-# HLINT ignore "Redundant id" #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies
+{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunrecognised-pragmas
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Redundant id" #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
 -- | Porting of https://github.com/thinkbeforecoding/UnoCore/blob/solution/Uno/Game.fs
 module Crem.Example.Uno where
@@ -19,7 +25,7 @@ import Prelude qualified (id)
 -- * Domain
 
 newtype PlayerCount = PlayerCount Int
-  deriving newtype (Eq, Ord)
+  deriving newtype (Eq, Ord, Show)
 
 data Digit
   = Zero
@@ -32,20 +38,20 @@ data Digit
   | Seven
   | Eigth
   | Nine
-  deriving stock (Eq)
+  deriving stock (Eq, Show)
 
 data Colour
   = Red
   | Green
   | Blue
   | Yellow
-  deriving stock (Eq)
+  deriving stock (Eq, Show)
 
 data Card
   = DigitCard Digit Colour
   | Skip Colour
   | Kickback Colour
-  deriving stock (Eq)
+  deriving stock (Eq, Show)
 
 colour :: Card -> Colour
 colour (DigitCard _ c) = c
@@ -55,7 +61,6 @@ colour (Kickback c) = c
 sameColour :: Card -> Card -> Bool
 sameColour card1 card2 =
   colour card1 == colour card2
-
 data CardValue
   = DigitValue Digit
   | SkipValue
@@ -72,7 +77,7 @@ sameValue card1 card2 =
   value card1 == value card2
 
 newtype PlayerId = PlayerId Int
-  deriving stock (Eq)
+  deriving newtype (Eq, Show)
 
 data Direction
   = Clockwise
@@ -134,15 +139,20 @@ data InitialData = InitialData
   { players :: PlayerCount
   , firstCard :: Card
   }
+  deriving stock (Eq, Show)
 
 data PlayData = PlayData
   { playerId :: PlayerId
   , card :: Card
   }
+  deriving stock (Eq, Show)
 
 data Command
   = StartGame InitialData
   | PlayCard PlayData
+  deriving stock (Show)
+
+-- deriving (Arbitrary) via (GenericArbitrary Command)
 
 data Event
   = GameStarted InitialData PlayerId
@@ -150,6 +160,7 @@ data Event
   | CardPlayedAndTurnBegan PlayData PlayerId
   | WrongCardPlayed PlayData
   | PlayerPlayedAtWrongTurn PlayData
+  deriving stock (Eq, Show)
 
 -- * Topology
 
@@ -158,6 +169,7 @@ $( singletons
       data UnoVertex
         = Initial
         | Started
+        deriving stock (Eq, Show, Enum, Bounded)
 
       unoTopology :: Topology UnoVertex
       unoTopology = Topology [(Initial, [Started])]
@@ -181,13 +193,21 @@ data GameError
   = TooFewPlayers
   | GameAlreadyStarted
   | GameNotStarted
+  deriving stock (Eq, Show)
 
 -- * Machine
 
-unoDecider :: Decider UnoTopology Command (Either GameError Event)
-unoDecider =
+-- | A decider with the logic of the Uno game
+--
+-- It emits one event for every transition, not a list of events, because an
+-- event represents a state transition and a state machine perform one single
+-- state transition at every step
+unoDecider
+  :: InitialState UnoState
+  -> Decider UnoTopology Command (Either GameError Event)
+unoDecider initialState =
   Decider
-    { deciderInitialState = InitialState UnoInitialState
+    { deciderInitialState = initialState
     , decide = \command state ->
         case (state, command) of
           (_, StartGame initialData)