From 4b7b5b08956a5d19da8494f768e64d8eb70c0f1f Mon Sep 17 00:00:00 2001 From: Marco Perone Date: Thu, 25 May 2023 10:37:59 +0200 Subject: [PATCH] new cart example --- crem.cabal | 5 ++ examples/Crem/Example/Cart/Aggregate.hs | 62 +++++++++++++++++++++++ examples/Crem/Example/Cart/Application.hs | 13 +++++ examples/Crem/Example/Cart/Domain.hs | 9 ++++ examples/Crem/Example/Cart/Policy.hs | 9 ++++ examples/Crem/Example/Cart/Projection.hs | 9 ++++ 6 files changed, 107 insertions(+) create mode 100644 examples/Crem/Example/Cart/Aggregate.hs create mode 100644 examples/Crem/Example/Cart/Application.hs create mode 100644 examples/Crem/Example/Cart/Domain.hs create mode 100644 examples/Crem/Example/Cart/Policy.hs create mode 100644 examples/Crem/Example/Cart/Projection.hs diff --git a/crem.cabal b/crem.cabal index 7420b00..75c4b58 100644 --- a/crem.cabal +++ b/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 diff --git a/examples/Crem/Example/Cart/Aggregate.hs b/examples/Crem/Example/Cart/Aggregate.hs new file mode 100644 index 0000000..2a503cb --- /dev/null +++ b/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 diff --git a/examples/Crem/Example/Cart/Application.hs b/examples/Crem/Example/Cart/Application.hs new file mode 100644 index 0000000..47ce549 --- /dev/null +++ b/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 diff --git a/examples/Crem/Example/Cart/Domain.hs b/examples/Crem/Example/Cart/Domain.hs new file mode 100644 index 0000000..dc66634 --- /dev/null +++ b/examples/Crem/Example/Cart/Domain.hs @@ -0,0 +1,9 @@ +module Crem.Example.Cart.Domain where + +data CartCommand + = PayCart + | MarkCartAsPaid + +data CartEvent + = CartPaymentInitiated + | CartPaymentCompleted diff --git a/examples/Crem/Example/Cart/Policy.hs b/examples/Crem/Example/Cart/Policy.hs new file mode 100644 index 0000000..b6dcb77 --- /dev/null +++ b/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 -> [] diff --git a/examples/Crem/Example/Cart/Projection.hs b/examples/Crem/Example/Cart/Projection.hs new file mode 100644 index 0000000..d4827e3 --- /dev/null +++ b/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"]