Aggregate.hs

{-# LANGUAGE CPP #-}
{-# 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 #-}

#if __GLASGOW_HASKELL__ >= 908
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures
{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations
{-# OPTIONS_GHC -Wno-missing-role-annotations #-}
#endif

-- 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