mirror of
https://github.com/marcosh/crem.git
synced 2024-10-26 11:52:20 +03:00
new cart example
This commit is contained in:
parent
a3c86c16cc
commit
4b7b5b0895
@ -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
|
||||
|
62
examples/Crem/Example/Cart/Aggregate.hs
Normal file
62
examples/Crem/Example/Cart/Aggregate.hs
Normal file
@ -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
|
13
examples/Crem/Example/Cart/Application.hs
Normal file
13
examples/Crem/Example/Cart/Application.hs
Normal file
@ -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
|
9
examples/Crem/Example/Cart/Domain.hs
Normal file
9
examples/Crem/Example/Cart/Domain.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module Crem.Example.Cart.Domain where
|
||||
|
||||
data CartCommand
|
||||
= PayCart
|
||||
| MarkCartAsPaid
|
||||
|
||||
data CartEvent
|
||||
= CartPaymentInitiated
|
||||
| CartPaymentCompleted
|
9
examples/Crem/Example/Cart/Policy.hs
Normal file
9
examples/Crem/Example/Cart/Policy.hs
Normal file
@ -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 -> []
|
9
examples/Crem/Example/Cart/Projection.hs
Normal file
9
examples/Crem/Example/Cart/Projection.hs
Normal file
@ -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"]
|
Loading…
Reference in New Issue
Block a user