LockDoor.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wall-missed-specialisations
{-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
-- 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.LockDoor where

import Crem.BaseMachine
import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)
import Crem.Topology
import "singletons-base" Data.Singletons.Base.TH

$( singletons
    [d|
      data LockDoorVertex
        = IsLockOpen
        | IsLockClosed
        | IsLockLocked
        deriving stock (Eq, Show, Enum, Bounded)

      lockDoorTopology :: Topology LockDoorVertex
      lockDoorTopology =
        Topology
          [ (IsLockOpen, [IsLockClosed])
          , (IsLockClosed, [IsLockOpen, IsLockLocked])
          , (IsLockLocked, [IsLockClosed])
          ]
      |]
 )

deriving via AllVertices LockDoorVertex instance RenderableVertices LockDoorVertex

data LockDoorCommand
  = LockOpen
  | LockClose
  | LockLock
  | LockUnlock

data LockDoorEvent
  = LockNoOp
  | LockOpened
  | LockClosed
  | LockLocked
  | LockUnlocked
  deriving stock (Eq, Show)

lockDoorMachine :: SLockDoorVertex a -> BaseMachine LockDoorTopology LockDoorCommand LockDoorEvent
lockDoorMachine initialState =
  BaseMachineT
    { initialState = InitialState initialState
    , action = \case
        SIsLockOpen -> \case
          LockOpen -> pureResult LockNoOp SIsLockOpen
          LockClose -> pureResult LockClosed SIsLockClosed
          LockLock -> pureResult LockNoOp SIsLockOpen
          LockUnlock -> pureResult LockNoOp SIsLockOpen
        SIsLockClosed -> \case
          LockOpen -> pureResult LockOpened SIsLockOpen
          LockClose -> pureResult LockNoOp SIsLockClosed
          LockLock -> pureResult LockLocked SIsLockLocked
          LockUnlock -> pureResult LockNoOp SIsLockClosed
        SIsLockLocked -> \case
          LockOpen -> pureResult LockNoOp SIsLockLocked
          LockClose -> pureResult LockNoOp SIsLockLocked
          LockLock -> pureResult LockNoOp SIsLockLocked
          LockUnlock -> pureResult LockUnlocked SIsLockClosed
    }