mirror of
https://github.com/marcosh/crem.git
synced 2024-10-26 20:09:49 +03:00
new cart example
This commit is contained in:
parent
a3c86c16cc
commit
4b7b5b0895
@ -110,6 +110,11 @@ library
|
|||||||
library crem-examples
|
library crem-examples
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Crem.Example.BooleanStateMachine
|
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.LockDoor
|
||||||
Crem.Example.OneState
|
Crem.Example.OneState
|
||||||
Crem.Example.PlusOneUpToFour
|
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