new cart example

crem.cabal

@@ -110,6 +110,11 @@ library
 library crem-examples
   exposed-modules:
       Crem.Example.BooleanStateMachine
+      Crem.Example.Cart.Aggregate
+      Crem.Example.Cart.Application
+      Crem.Example.Cart.Domain
+      Crem.Example.Cart.Policy
+      Crem.Example.Cart.Projection
       Crem.Example.LockDoor
       Crem.Example.OneState
       Crem.Example.PlusOneUpToFour

examples/Crem/Example/Cart/Aggregate.hs

@@ -0,0 +1,62 @@
+{-# 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 #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
+
+module Crem.Example.Cart.Aggregate where
+
+import Crem.BaseMachine
+import Crem.Example.Cart.Domain
+import Crem.Render.RenderableVertices
+import Crem.StateMachine
+import Crem.Topology
+import "singletons-base" Data.Singletons.Base.TH
+
+$( singletons
+    [d|
+      data CartVertex
+        = WaitingForPayment
+        | InitiatingPayment
+        | PaymentComplete
+        deriving stock (Eq, Show, Enum, Bounded)
+
+      cartTopology :: Topology CartVertex
+      cartTopology =
+        Topology
+          [ (WaitingForPayment, [InitiatingPayment])
+          , (InitiatingPayment, [PaymentComplete])
+          , (PaymentComplete, [])
+          ]
+      |]
+ )
+
+deriving via AllVertices CartVertex instance RenderableVertices CartVertex
+
+data CartState (cartVertex :: CartVertex) where
+  WaitingForPaymentState :: CartState WaitingForPayment
+  InitiatingPaymentState :: CartState InitiatingPayment
+  PaymentCompleteState :: CartState PaymentComplete
+
+cartBasic :: BaseMachine CartTopology CartCommand [CartEvent]
+cartBasic =
+  BaseMachineT
+    { initialState = InitialState WaitingForPaymentState
+    , action = \case
+        WaitingForPaymentState -> \case
+          PayCart -> pureResult [CartPaymentInitiated] InitiatingPaymentState
+          MarkCartAsPaid -> pureResult [] WaitingForPaymentState
+        InitiatingPaymentState -> \case
+          PayCart -> pureResult [] InitiatingPaymentState
+          MarkCartAsPaid -> pureResult [CartPaymentCompleted] PaymentCompleteState
+        PaymentCompleteState -> \_ -> pureResult [] PaymentCompleteState
+    }
+
+cart :: StateMachine CartCommand [CartEvent]
+cart = Basic cartBasic

examples/Crem/Example/Cart/Application.hs

@@ -0,0 +1,13 @@
+module Crem.Example.Cart.Application where
+
+import Crem.Example.Cart.Aggregate
+import Crem.Example.Cart.Domain
+import Crem.Example.Cart.Policy
+import Crem.Example.Cart.Projection
+import Crem.StateMachine
+
+writeModel :: StateMachine CartCommand [CartEvent]
+writeModel = Feedback cart paymentGateway
+
+application :: StateMachine CartCommand [String]
+application = Kleisli writeModel cartState

examples/Crem/Example/Cart/Domain.hs

@@ -0,0 +1,9 @@
+module Crem.Example.Cart.Domain where
+
+data CartCommand
+  = PayCart
+  | MarkCartAsPaid
+
+data CartEvent
+  = CartPaymentInitiated
+  | CartPaymentCompleted

examples/Crem/Example/Cart/Policy.hs

@@ -0,0 +1,9 @@
+module Crem.Example.Cart.Policy where
+
+import Crem.Example.Cart.Domain
+import Crem.StateMachine
+
+paymentGateway :: StateMachine CartEvent [CartCommand]
+paymentGateway = stateless $ \case
+  CartPaymentInitiated -> [MarkCartAsPaid] -- in this word payments always succeed
+  CartPaymentCompleted -> []

examples/Crem/Example/Cart/Projection.hs

@@ -0,0 +1,9 @@
+module Crem.Example.Cart.Projection where
+
+import Crem.Example.Cart.Domain
+import Crem.StateMachine
+
+cartState :: StateMachine CartEvent [String]
+cartState = stateless $ \case
+  CartPaymentInitiated -> ["initiated"]
+  CartPaymentCompleted -> ["completed"]