move examples into the main package

src/CRM/Example/BooleanStateMachine.hs

@@ -2,8 +2,8 @@
 
 module CRM.Example.BooleanStateMachine where
 
-import "crm" CRM.BaseMachine
-import "crm" CRM.StateMachine
+import CRM.BaseMachine
+import CRM.StateMachine
 import "singletons-base" Data.Singletons.Base.TH
 
 booleanStateMachine

src/CRM/Example/LockDoor.hs

@@ -9,8 +9,8 @@
 
 module CRM.Example.LockDoor where
 
-import "crm" CRM.BaseMachine
-import "crm" CRM.Topology
+import CRM.BaseMachine
+import CRM.Topology
 import "singletons-base" Data.Singletons.Base.TH
 
 $( singletons

src/CRM/Example/OneState.hs

@@ -3,8 +3,8 @@
 
 module CRM.Example.OneState where
 
-import "crm" CRM.BaseMachine
-import "crm" CRM.Topology
+import CRM.BaseMachine
+import CRM.Topology
 import "singletons-base" Data.Singletons.Base.TH
 
 oneVertexMachine :: BaseMachine (TrivialTopology @()) () ()

src/CRM/Example/PlusOneUpToFour.hs

@@ -2,7 +2,7 @@
 
 module CRM.Example.PlusOneUpToFour where
 
-import "crm" CRM.StateMachine (StateMachine, stateless)
+import CRM.StateMachine (StateMachine, stateless)
 
 plus1UpTo4 :: StateMachine Int [Int]
 plus1UpTo4 =

src/CRM/Example/RiskManager/Aggregate.hs

@@ -7,9 +7,9 @@
 
 module CRM.Example.RiskManager.Aggregate where
 
-import "crm" CRM.BaseMachine
+import CRM.BaseMachine
 import CRM.Example.RiskManager.Domain
-import "crm" CRM.Topology
+import CRM.Topology
 import "singletons-base" Data.Singletons.Base.TH
 
 $( singletons

src/CRM/Example/RiskManager/Application.hs

@@ -4,7 +4,7 @@ import CRM.Example.RiskManager.Aggregate (riskAggregate)
 import CRM.Example.RiskManager.Domain (RiskCommand, RiskEvent)
 import CRM.Example.RiskManager.Policy (riskPolicy)
 import CRM.Example.RiskManager.Projection (ReceivedData, riskProjection)
-import "crm" CRM.StateMachine
+import CRM.StateMachine
 import "base" Data.List (singleton)
 import "base" Data.Maybe (maybeToList)
 import "profunctors" Data.Profunctor (rmap)

src/CRM/Example/RiskManager/Policy.hs

@@ -1,7 +1,7 @@
 module CRM.Example.RiskManager.Policy where
 
 import CRM.Example.RiskManager.Domain
-import "crm" CRM.StateMachine
+import CRM.StateMachine
 
 riskPolicy :: StateMachine RiskEvent (Maybe RiskCommand)
 riskPolicy =

src/CRM/Example/RiskManager/Projection.hs

@@ -9,9 +9,9 @@
 
 module CRM.Example.RiskManager.Projection where
 
-import "crm" CRM.BaseMachine
+import CRM.BaseMachine
 import CRM.Example.RiskManager.Domain
-import "crm" CRM.Topology
+import CRM.Topology
 import "base" Data.Monoid (Last (..))
 import "singletons-base" Data.Singletons.Base.TH
 import "base" GHC.Generics (Generic)

src/CRM/Example/Switch.hs

@@ -7,8 +7,8 @@
 
 module CRM.Example.Switch where
 
-import "crm" CRM.BaseMachine
-import "crm" CRM.Topology
+import CRM.BaseMachine
+import CRM.Topology
 import "singletons-base" Data.Singletons.Base.TH
 
 $( singletons

src/CRM/Example/TheHobbit.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE DataKinds #-}
+{-# 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 #-}
+
+module CRM.Example.TheHobbit where
+
+import CRM.BaseMachine
+import CRM.Topology
+import "base" Data.Semigroup
+import "singletons-base" Data.Singletons.Base.TH
+
+data HobbitCommand
+  = GoEast
+  | GoWest
+  | GoNorth
+  | GoSouth
+  | Wait
+  | GetKey
+  | UnlockDoor
+  deriving stock (Eq, Read, Show)
+
+newtype HobbitMessage = HobbitMessage {getMessage :: String}
+  deriving (Semigroup) via (Last HobbitMessage)
+
+instance Monoid HobbitMessage where
+  mempty = HobbitMessage ""
+
+$( singletons
+    [d|
+      data HobbitVertex
+        = TunnelLikeHall
+        | Lonelands
+        | TrollsClearing
+        | Rivendell
+        | MistyMountain
+        | TrollsPath
+        | TrollsCave
+        deriving stock (Eq, Show)
+
+      hobbitTopology :: Topology HobbitVertex
+      hobbitTopology =
+        Topology
+          [ (TunnelLikeHall, [Lonelands])
+          , (Lonelands, [TunnelLikeHall, TrollsClearing])
+          , (TrollsClearing, [Rivendell, TrollsPath])
+          , (Rivendell, [TrollsClearing, MistyMountain])
+          , (MistyMountain, [Rivendell])
+          , (TrollsPath, [TrollsClearing, TrollsCave])
+          , (TrollsCave, [TrollsPath])
+          ]
+      |]
+ )
+
+data KeyState
+  = NoKey
+  | DayDawned
+  | GotKey
+  | DoorUnlocked
+  deriving stock (Eq)
+
+data HobbitState (vertex :: HobbitVertex) where
+  TunnelLikeHallState :: HobbitState 'TunnelLikeHall
+  LonelandsState :: HobbitState 'Lonelands
+  TrollsClearingState :: KeyState -> HobbitState 'TrollsClearing
+  RivendellState :: KeyState -> HobbitState 'Rivendell
+  MistyMountainState :: KeyState -> HobbitState 'MistyMountain
+  TrollsPathState :: KeyState -> HobbitState 'TrollsPath
+  TrollsCaveState :: HobbitState 'TrollsCave
+
+stateMessage :: HobbitState vertex -> HobbitMessage
+stateMessage TunnelLikeHallState =
+  HobbitMessage
+    "You are in a tunnel-like hall.\n\
+    \You can only go east to the Lonelands"
+stateMessage LonelandsState =
+  HobbitMessage
+    "You are in the lonelands.\n\
+    \You can either go west to a tunnel-like hall\n\
+    \or go east to the Trolls clearing"
+stateMessage (TrollsClearingState keyState) =
+  if keyState == DayDawned
+    then
+      HobbitMessage
+        "You are in the Trolls clearing.\n\
+        \You could go north to the Trolls path,\n\
+        \you can go east to Rivendell\n\
+        \or you could get the key for the TrollsCave"
+    else
+      HobbitMessage
+        "You are in the Trolls clearing.\n\
+        \You could go north to the Trolls path,\n\
+        \you can go east to Rivendell"
+stateMessage (RivendellState _) =
+  HobbitMessage
+    "You are in Rivendell.\n\
+    \You could either go west to the Trolls clearing\n\
+    \or go east to the Misty mountains\n"
+stateMessage (MistyMountainState _) =
+  HobbitMessage
+    "You are in the Misty mountains.\n\
+    \You can only go east to Rivendell"
+stateMessage (TrollsPathState keyState) =
+  case keyState of
+    NoKey ->
+      HobbitMessage
+        "You are in the Trolls path.\n\
+        \You can go south to the Trolls clearing\n\
+        \or you can wait a bit"
+    DayDawned ->
+      HobbitMessage
+        "You are in the Trolls path.\n\
+        \You can go south to the Trolls clearing\n\
+        \or you can wait some more"
+    GotKey ->
+      HobbitMessage
+        "You are in the Trolls path.\n\
+        \You can go south to the Trolls clearing,\n\
+        \you can unlock the door to the Trolls cave\n\
+        \or you can wait some more"
+    DoorUnlocked ->
+      HobbitMessage
+        "You are in the Trolls path.\n\
+        \You can go south to the Trolls clearing\n\
+        \or you can go north to the Trolls cave"
+stateMessage TrollsCaveState =
+  HobbitMessage
+    "Welcome to the Trolls cave!\n\
+    \Now you can go back south to the Trolls path"
+
+hobbitResult
+  :: (Applicative m, AllowedTransition HobbitTopology initialVertex finalVertex)
+  => HobbitState finalVertex
+  -> ActionResult m HobbitTopology HobbitState initialVertex HobbitMessage
+hobbitResult hobbitState = pureResult (stateMessage hobbitState) hobbitState
+
+hobbitMachine :: HobbitState vertex -> BaseMachine HobbitTopology HobbitCommand HobbitMessage
+hobbitMachine initialState =
+  BaseMachineT
+    { initialState = InitialState initialState
+    , action = \case
+        TunnelLikeHallState -> \case
+          GoEast -> hobbitResult LonelandsState
+          _ -> hobbitResult TunnelLikeHallState
+        LonelandsState -> \case
+          GoEast -> hobbitResult $ TrollsClearingState NoKey
+          GoWest -> hobbitResult TunnelLikeHallState
+          _ -> hobbitResult LonelandsState
+        TrollsClearingState keyState -> \case
+          GoEast -> hobbitResult $ RivendellState NoKey
+          GoNorth -> hobbitResult $ TrollsPathState keyState
+          GetKey ->
+            if keyState == DayDawned
+              then hobbitResult $ TrollsClearingState GotKey
+              else hobbitResult $ TrollsClearingState keyState
+          _ -> hobbitResult $ TrollsClearingState keyState
+        RivendellState keyState -> \case
+          GoEast -> hobbitResult $ MistyMountainState keyState
+          GoWest -> hobbitResult $ TrollsClearingState keyState
+          _ -> hobbitResult $ RivendellState keyState
+        MistyMountainState keyState -> \case
+          GoWest -> hobbitResult $ RivendellState keyState
+          _ -> hobbitResult $ MistyMountainState keyState
+        TrollsPathState keyState -> \case
+          GoSouth -> hobbitResult $ TrollsClearingState keyState
+          GoNorth ->
+            if keyState == DoorUnlocked
+              then hobbitResult TrollsCaveState
+              else hobbitResult $ TrollsPathState keyState
+          Wait ->
+            if keyState == NoKey
+              then hobbitResult $ TrollsPathState DayDawned
+              else hobbitResult $ TrollsPathState keyState
+          UnlockDoor ->
+            if keyState == GotKey
+              then hobbitResult $ TrollsPathState DoorUnlocked
+              else hobbitResult $ TrollsPathState keyState
+          _ -> hobbitResult (TrollsPathState keyState)
+        TrollsCaveState -> \case
+          GoSouth -> hobbitResult $ TrollsPathState DoorUnlocked
+          _ -> hobbitResult TrollsCaveState
+    }