Shipping.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--Wredundant-constraints
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- 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.Shipping where

import Crem.BaseMachine
import Crem.Example.Cart.Aggregate
import Crem.Example.Cart.Domain
import Crem.Example.Cart.Projection
import Crem.Render.RenderableVertices
import Crem.StateMachine
import Crem.Topology
import "base" Control.Arrow hiding (Kleisli)
import "profunctors" Data.Profunctor
import "singletons-base" Data.Singletons.Base.TH

data ShippingCommand
  = StartShipping

data ShippingEvent

$( singletons
     [d|
       data ShippingVertex = ShippingVertex
         deriving stock (Eq, Show, Enum, Bounded)

       shippingTopology :: Topology ShippingVertex
       shippingTopology = Topology []
       |]
 )

deriving via AllVertices ShippingVertex instance RenderableVertices ShippingVertex

shippingBasic :: BaseMachine ShippingTopology ShippingCommand [ShippingEvent]
shippingBasic = undefined

shipping :: StateMachine ShippingCommand [ShippingEvent]
shipping = Basic shippingBasic

aggregateWithShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartEvent ShippingEvent]
aggregateWithShipping = rmap (fmap Left ||| fmap Right) $ cart +++ shipping

paymentCompletePolicy :: StateMachine CartEvent [ShippingCommand]
paymentCompletePolicy = stateless $ \case
  CartPaymentInitiated -> []
  CartPaymentCompleted -> [StartShipping]

writeModelWithShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartEvent ShippingEvent]
writeModelWithShipping =
  Feedback
    aggregateWithShipping
    (rmap (fmap Right) paymentCompletePolicy ||| stateless (const []))

data ShippingInfo

shippingInfo :: StateMachine ShippingEvent [ShippingInfo]
shippingInfo = undefined

readModel :: StateMachine (Either CartEvent ShippingEvent) [Either CartView ShippingInfo]
readModel = rmap (fmap Left ||| fmap Right) $ paymentStatus +++ shippingInfo

cartAndShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartView ShippingInfo]
cartAndShipping = Kleisli writeModelWithShipping readModel