crem (empty) → 0.1.0.0
raw patch · 35 files changed
+3530/−0 lines, 35 filesdep +basedep +cremdep +doctest-parallel
Dependencies added: base, crem, doctest-parallel, hspec, profunctors, singletons-base, text
Files
- CHANGELOG.md +12/−0
- LICENSE +9/−0
- crem.cabal +474/−0
- doctest/Main.hs +15/−0
- examples/Crem/Example/BooleanStateMachine.hs +25/−0
- examples/Crem/Example/LockDoor.hs +76/−0
- examples/Crem/Example/OneState.hs +15/−0
- examples/Crem/Example/PlusOneUpToFour.hs +9/−0
- examples/Crem/Example/RiskManager/Aggregate.hs +76/−0
- examples/Crem/Example/RiskManager/Application.hs +32/−0
- examples/Crem/Example/RiskManager/Domain.hs +54/−0
- examples/Crem/Example/RiskManager/Policy.hs +25/−0
- examples/Crem/Example/RiskManager/Projection.hs +81/−0
- examples/Crem/Example/Switch.hs +36/−0
- examples/Crem/Example/TheHobbit.hs +192/−0
- examples/Crem/Example/TriangularMachine.hs +22/−0
- examples/Crem/Example/TwoSwitchesGate.lhs +243/−0
- examples/Crem/Example/Uno.hs +290/−0
- hobbit-game/Main.hs +27/−0
- hobbit-map/Main.hs +21/−0
- spec/Crem/DeciderSpec.hs +54/−0
- spec/Crem/GraphSpec.hs +27/−0
- spec/Crem/Render/RenderFlowSpec.hs +118/−0
- spec/Crem/Render/RenderSpec.hs +112/−0
- spec/Crem/RiskManagerSpec.hs +229/−0
- spec/Crem/StateMachineSpec.hs +118/−0
- spec/Spec.hs +1/−0
- src/Crem/BaseMachine.hs +257/−0
- src/Crem/Decider.hs +100/−0
- src/Crem/Graph.hs +89/−0
- src/Crem/Render/Render.hs +155/−0
- src/Crem/Render/RenderFlow.hs +106/−0
- src/Crem/Render/RenderableVertices.hs +105/−0
- src/Crem/StateMachine.hs +217/−0
- src/Crem/Topology.hs +108/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [PVP](https://pvp.haskell.org/).++## [0.1.0.0] - 2023-03-17++### Added++- 🎉 everything's new! first release!
+ LICENSE view
@@ -0,0 +1,9 @@+MIT License++Copyright © 2023-present Tweag I/O Limited++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ crem.cabal view
@@ -0,0 +1,474 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: crem+version: 0.1.0.0+synopsis: Compositional representable executable machines+description: `crem` stands for __c__ompositional __r__epresentable __e__xecutable __m__achines. It allows creating state machines (Mealy machines in fact), compose them to build bigger machines out of smaller ones and then run them and draw their flow and their state space.+category: Machines, Control, State Machines+homepage: https://github.com/tweag/crem+bug-reports: https://github.com/tweag/crem/issues+author: Marco Perone+maintainer: marco.perone@tweag.io+copyright: 2022 Tweag I/O+license: MIT+license-file: LICENSE+build-type: Simple+tested-with:+ GHC ==9.0.2+ , GHC ==9.2.7+ , GHC ==9.4.4+ , GHC ==9.6.1+extra-source-files:+ CHANGELOG.md++flag errors+ description: enable -Werror+ manual: True+ default: False++library+ exposed-modules:+ Crem.BaseMachine+ Crem.Decider+ Crem.Graph+ Crem.Render.Render+ Crem.Render.RenderableVertices+ Crem.Render.RenderFlow+ Crem.StateMachine+ Crem.Topology+ hs-source-dirs:+ src+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module+ build-depends:+ base >=4.15 && <4.19+ , profunctors >=3.2 && <5.7+ , singletons-base >=3.0 && <3.3+ , text >=1.2 && <2.1+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror++library crem-examples+ exposed-modules:+ Crem.Example.BooleanStateMachine+ Crem.Example.LockDoor+ Crem.Example.OneState+ Crem.Example.PlusOneUpToFour+ Crem.Example.RiskManager.Aggregate+ Crem.Example.RiskManager.Application+ Crem.Example.RiskManager.Domain+ Crem.Example.RiskManager.Policy+ Crem.Example.RiskManager.Projection+ Crem.Example.Switch+ Crem.Example.TheHobbit+ Crem.Example.TriangularMachine+ Crem.Example.TwoSwitchesGate+ Crem.Example.Uno+ hs-source-dirs:+ examples+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module+ build-depends:+ base >=4.15 && <4.19+ , crem+ , profunctors+ , singletons-base+ , text+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror++executable hobbit-game+ main-is: Main.hs+ hs-source-dirs:+ hobbit-game+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module+ build-depends:+ base >=4.15 && <4.19+ , crem+ , crem-examples+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror++executable hobbit-map+ main-is: Main.hs+ hs-source-dirs:+ hobbit-map+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module+ build-depends:+ base >=4.15 && <4.19+ , crem+ , crem-examples+ , text+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror++test-suite crem-doctests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ doctest+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module -threaded -Wno-unused-packages+ build-depends:+ base >=4.15 && <4.19+ , crem+ , crem-examples+ , doctest-parallel >=0.2.3 && <0.4+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror++test-suite crem-spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Crem.DeciderSpec+ Crem.GraphSpec+ Crem.Render.RenderFlowSpec+ Crem.Render.RenderSpec+ Crem.RiskManagerSpec+ Crem.StateMachineSpec+ hs-source-dirs:+ spec+ default-extensions:+ DerivingStrategies+ LambdaCase+ PackageImports+ ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ base >=4.15 && <4.19+ , crem+ , crem-examples+ , hspec >=2.7 && <2.11+ , profunctors+ , singletons-base+ default-language: Haskell2010+ if impl(ghc >= 9.2)+ ghc-options: -Wno-missing-kind-signatures+ default-language: GHC2021+ else+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ ImportQualifiedPost+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances+ if flag(errors)+ ghc-options: -Werror
+ doctest/Main.hs view
@@ -0,0 +1,15 @@+module Main where++import "base" System.Environment (getArgs)+import "doctest-parallel" Test.DocTest+import "doctest-parallel" Test.DocTest.Helpers++main :: IO ()+main = do+ args <- getArgs+ cremPackage <- findCabalPackage "crem"+ cremLib <- extractCabalLibrary cremPackage+ cremExamplesLib <- extractSpecificCabalLibrary (Just "crem-examples") cremPackage+ let+ wholeCremLib = mergeLibraries [cremLib, cremExamplesLib]+ mainFromLibrary wholeCremLib args
+ examples/Crem/Example/BooleanStateMachine.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE GADTs #-}++module Crem.Example.BooleanStateMachine where++import Crem.BaseMachine+import Crem.StateMachine+import "singletons-base" Data.Singletons.Base.TH++booleanStateMachine+ :: forall a+ . SBool a+ -> StateMachine Int Int+booleanStateMachine initialState =+ unrestrictedMachine @Bool+ ( \state input -> case state of+ SFalse ->+ if even input+ then pureResult (input + 1) SFalse+ else pureResult (input * 3) STrue+ STrue ->+ if even input+ then pureResult (input - 1) STrue+ else pureResult (input * 5) SFalse+ )+ (InitialState initialState)
+ examples/Crem/Example/LockDoor.hs view
@@ -0,0 +1,76 @@+{-# 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+ }
+ examples/Crem/Example/OneState.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Crem.Example.OneState where++import Crem.BaseMachine+import Crem.Topology+import "singletons-base" Data.Singletons.Base.TH++oneVertexMachine :: BaseMachine (TrivialTopology @()) () ()+oneVertexMachine =+ BaseMachineT+ { initialState = InitialState STuple0+ , action = \STuple0 _ -> pureResult () STuple0+ }
+ examples/Crem/Example/PlusOneUpToFour.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE GADTs #-}++module Crem.Example.PlusOneUpToFour where++import Crem.StateMachine (StateMachine, stateless)++plus1UpTo4 :: StateMachine Int [Int]+plus1UpTo4 =+ stateless (\i -> [i + 1 | i < 5])
+ examples/Crem/Example/RiskManager/Aggregate.hs view
@@ -0,0 +1,76 @@+{-# 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.RiskManager.Aggregate where++import Crem.BaseMachine+import Crem.Example.RiskManager.Domain+import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)+import Crem.Topology+import "singletons-base" Data.Singletons.Base.TH++$( singletons+ [d|+ data AggregateVertex+ = NoDataVertex+ | CollectedUserDataVertex+ | CollectedLoanDetailsFirstVertex+ | ReceivedCreditBureauDataFirstVertex+ | CollectedAllDataVertex+ deriving stock (Eq, Show, Enum, Bounded)++ aggregateTopology :: Topology AggregateVertex+ aggregateTopology =+ Topology+ [ (NoDataVertex, [CollectedUserDataVertex])+ , (CollectedUserDataVertex, [CollectedLoanDetailsFirstVertex, ReceivedCreditBureauDataFirstVertex])+ , (CollectedLoanDetailsFirstVertex, [CollectedAllDataVertex])+ , (ReceivedCreditBureauDataFirstVertex, [CollectedAllDataVertex])+ , (CollectedAllDataVertex, [])+ ]+ |]+ )++deriving via AllVertices AggregateVertex instance RenderableVertices AggregateVertex++data AggregateState (vertex :: AggregateVertex) where+ NoData :: AggregateState 'NoDataVertex+ CollectedUserData :: UserData -> AggregateState 'CollectedUserDataVertex+ CollectedLoanDetailsFirst :: UserData -> LoanDetails -> AggregateState 'CollectedLoanDetailsFirstVertex+ ReceivedCreditBureauDataFirst :: UserData -> CreditBureauData -> AggregateState 'ReceivedCreditBureauDataFirstVertex+ CollectedAllData :: UserData -> LoanDetails -> CreditBureauData -> AggregateState 'CollectedAllDataVertex++riskAggregate :: BaseMachine AggregateTopology RiskCommand (Maybe RiskEvent)+riskAggregate =+ BaseMachineT+ { initialState = InitialState NoData+ , action = \case+ NoData -> \case+ RegisterUserData ud -> pureResult (Just $ UserDataRegistered ud) (CollectedUserData ud)+ _ -> pureResult Nothing NoData+ CollectedUserData ud -> \case+ RegisterUserData ud' -> pureResult (Just $ UserDataRegistered ud') (CollectedUserData ud')+ ProvideLoanDetails ld -> pureResult (Just $ LoanDetailsProvided ld) (CollectedLoanDetailsFirst ud ld)+ ProvideCreditBureauData cbd -> pureResult (Just $ CreditBureauDataReceived cbd) (ReceivedCreditBureauDataFirst ud cbd)+ CollectedLoanDetailsFirst ud ld -> \case+ RegisterUserData ud' -> pureResult (Just $ UserDataRegistered ud') (CollectedLoanDetailsFirst ud' ld)+ ProvideLoanDetails ld' -> pureResult (Just $ LoanDetailsProvided ld') (CollectedLoanDetailsFirst ud ld')+ ProvideCreditBureauData cbd -> pureResult (Just $ CreditBureauDataReceived cbd) (CollectedAllData ud ld cbd)+ ReceivedCreditBureauDataFirst ud cbd -> \case+ RegisterUserData ud' -> pureResult (Just $ UserDataRegistered ud') (ReceivedCreditBureauDataFirst ud' cbd)+ ProvideLoanDetails ld -> pureResult (Just $ LoanDetailsProvided ld) (CollectedAllData ud ld cbd)+ ProvideCreditBureauData cbd' -> pureResult (Just $ CreditBureauDataReceived cbd') (ReceivedCreditBureauDataFirst ud cbd')+ CollectedAllData ud ld cbd -> \case+ RegisterUserData ud' -> pureResult (Just $ UserDataRegistered ud') (CollectedAllData ud' ld cbd)+ ProvideLoanDetails ld' -> pureResult (Just $ LoanDetailsProvided ld') (CollectedAllData ud ld' cbd)+ ProvideCreditBureauData cbd' -> pureResult (Just $ CreditBureauDataReceived cbd') (CollectedAllData ud ld cbd')+ }
+ examples/Crem/Example/RiskManager/Application.hs view
@@ -0,0 +1,32 @@+module Crem.Example.RiskManager.Application where++import Crem.Example.RiskManager.Aggregate (riskAggregate)+import Crem.Example.RiskManager.Domain (RiskCommand, RiskEvent)+import Crem.Example.RiskManager.Policy (riskPolicy)+import Crem.Example.RiskManager.Projection (ReceivedData, riskProjection)+import Crem.StateMachine+import "base" Data.List (singleton)+import "base" Data.Maybe (maybeToList)+import "profunctors" Data.Profunctor (rmap)+import Prelude hiding ((.))++aggregate :: StateMachine RiskCommand [RiskEvent]+aggregate = rmap maybeToList $ Basic riskAggregate++policy :: StateMachine RiskEvent [RiskCommand]+policy = rmap maybeToList riskPolicy++writeModel :: StateMachine RiskCommand [RiskEvent]+writeModel = Feedback aggregate policy++projection :: StateMachine RiskEvent ReceivedData+projection = Basic riskProjection++readModel :: StateMachine RiskEvent [ReceivedData]+readModel = rmap singleton projection++whole :: StateMachine RiskCommand [ReceivedData]+whole = Kleisli writeModel readModel++riskApplication :: StateMachine RiskCommand ReceivedData+riskApplication = rmap mconcat whole
+ examples/Crem/Example/RiskManager/Domain.hs view
@@ -0,0 +1,54 @@+module Crem.Example.RiskManager.Domain where++import "base" Data.String (IsString)++newtype Name = Name String+ deriving newtype (Eq, Show, IsString)++newtype Surname = Surname String+ deriving newtype (Eq, Show, IsString)++newtype TaxCode = TaxCode String+ deriving newtype (Eq, Show, IsString)++data UserData = UserData+ { name :: Name+ , surname :: Surname+ , taxCode :: TaxCode+ }+ deriving stock (Eq, Show)++newtype Amount = EuroCents Int+ deriving newtype (Eq, Show)++newtype InstalmentsNumber = InstalmentsNumber Int+ deriving newtype (Eq, Show)++data LoanDetails = LoanDetails+ { amount :: Amount+ , instalments :: InstalmentsNumber+ }+ deriving stock (Eq, Show)++newtype MissedPaymentDeadlines = MissedPaymentDeadlines Int+ deriving newtype (Eq, Show)++data CreditBureauData = CreditBureauData+ { missedPaymentDeadlines :: MissedPaymentDeadlines+ , arrears :: Amount+ }+ deriving stock (Eq, Show)++-- ** State machine data types++data RiskCommand+ = RegisterUserData UserData+ | ProvideLoanDetails LoanDetails+ | ProvideCreditBureauData CreditBureauData+ deriving stock (Eq, Show)++data RiskEvent+ = UserDataRegistered UserData+ | LoanDetailsProvided LoanDetails+ | CreditBureauDataReceived CreditBureauData+ deriving stock (Eq, Show)
+ examples/Crem/Example/RiskManager/Policy.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Crem.Example.RiskManager.Policy where++import Crem.Example.RiskManager.Domain+import Crem.StateMachine++riskPolicy :: StateMachine RiskEvent (Maybe RiskCommand)+riskPolicy =+ stateless+ ( \case+ UserDataRegistered ud -> ProvideCreditBureauData <$> creditBureauDataForUser ud+ LoanDetailsProvided _ -> Nothing+ CreditBureauDataReceived _ -> Nothing+ )+ where+ creditBureauDataForUser :: UserData -> Maybe CreditBureauData+ creditBureauDataForUser (UserData name _ _) =+ if name == "Marco"+ then+ Just $+ CreditBureauData+ (MissedPaymentDeadlines 2)+ (EuroCents 100000)+ else Nothing
+ examples/Crem/Example/RiskManager/Projection.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# 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.RiskManager.Projection where++import Crem.BaseMachine+import Crem.Example.RiskManager.Domain+import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)+import Crem.Topology+import "base" Data.Monoid (Last (..))+import "base" GHC.Generics (Generic)+import "singletons-base" Data.Singletons.Base.TH++data ReceivedData = ReceivedData+ { receivedUserData :: Maybe UserData+ , receivedLoanDetails :: Maybe LoanDetails+ , receivedCreditBureauData :: Maybe CreditBureauData+ }+ deriving stock (Eq, Show, Generic)++instance Semigroup ReceivedData where+ (<>) :: ReceivedData -> ReceivedData -> ReceivedData+ r1 <> r2 =+ ReceivedData+ { receivedUserData =+ getLast $ Last (receivedUserData r1) <> Last (receivedUserData r2)+ , receivedLoanDetails =+ getLast $ Last (receivedLoanDetails r1) <> Last (receivedLoanDetails r2)+ , receivedCreditBureauData =+ getLast $ Last (receivedCreditBureauData r1) <> Last (receivedCreditBureauData r2)+ }++instance Monoid ReceivedData where+ mempty :: ReceivedData+ mempty =+ ReceivedData+ { receivedUserData = Nothing+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }++$( singletons+ [d|+ data ProjectionVertex+ = SingleProjectionVertex+ deriving stock (Eq, Show, Enum, Bounded)++ projectionTopology :: Topology ProjectionVertex+ projectionTopology =+ Topology []+ |]+ )++deriving via AllVertices ProjectionVertex instance RenderableVertices ProjectionVertex++data ProjectionState (vertex :: ProjectionVertex) where+ SingleProjectionState :: ReceivedData -> ProjectionState 'SingleProjectionVertex++riskProjection :: BaseMachine ProjectionTopology RiskEvent ReceivedData+riskProjection =+ BaseMachineT+ { initialState = InitialState (SingleProjectionState mempty)+ , action = \(SingleProjectionState receivedData) input ->+ let+ newReceivedData = case input of+ UserDataRegistered ud -> receivedData {receivedUserData = Just ud}+ LoanDetailsProvided ld -> receivedData {receivedLoanDetails = Just ld}+ CreditBureauDataReceived cbd -> receivedData {receivedCreditBureauData = Just cbd}+ in+ pureResult newReceivedData (SingleProjectionState newReceivedData)+ }
+ examples/Crem/Example/Switch.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}+{-# 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 #-}++module Crem.Example.Switch where++import Crem.BaseMachine+import Crem.Topology+import "singletons-base" Data.Singletons.Base.TH++$( singletons+ [d|+ -- topology with a two vertices and one edge from each vertex to the+ -- other+ switchTopology :: Topology Bool+ switchTopology =+ Topology+ [ (True, [False])+ , (False, [True])+ ]+ |]+ )++switchMachine :: SBool a -> BaseMachine SwitchTopology () ()+switchMachine initialState =+ BaseMachineT+ { initialState = InitialState initialState+ , action = \case+ SFalse -> \case+ () -> pureResult () STrue+ STrue -> \case+ () -> pureResult () SFalse+ }
+ examples/Crem/Example/TheHobbit.hs view
@@ -0,0 +1,192 @@+{-# 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.TheHobbit where++import Crem.BaseMachine+import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)+import Crem.Topology+import "base" Data.Semigroup+import "singletons-base" Data.Singletons.Base.TH++data HobbitCommand+ = GoEast+ | GoWest+ | GoNorth+ | GoSouth+ | Wait+ | GetKey+ | UnlockDoor+ deriving stock (Eq, Read, Show)++newtype HobbitMessage = HobbitMessage {getMessage :: String}+ deriving (Semigroup) via (Last HobbitMessage)++instance Monoid HobbitMessage where+ mempty = HobbitMessage ""++$( singletons+ [d|+ data HobbitVertex+ = TunnelLikeHall+ | Lonelands+ | TrollsClearing+ | Rivendell+ | MistyMountain+ | TrollsPath+ | TrollsCave+ deriving stock (Eq, Show, Enum, Bounded)++ hobbitTopology :: Topology HobbitVertex+ hobbitTopology =+ Topology+ [ (TunnelLikeHall, [Lonelands])+ , (Lonelands, [TunnelLikeHall, TrollsClearing])+ , (TrollsClearing, [Rivendell, TrollsPath])+ , (Rivendell, [TrollsClearing, MistyMountain])+ , (MistyMountain, [Rivendell])+ , (TrollsPath, [TrollsClearing, TrollsCave])+ , (TrollsCave, [TrollsPath])+ ]+ |]+ )++deriving via AllVertices HobbitVertex instance RenderableVertices HobbitVertex++data KeyState+ = NoKey+ | DayDawned+ | GotKey+ | DoorUnlocked+ deriving stock (Eq)++data HobbitState (vertex :: HobbitVertex) where+ TunnelLikeHallState :: HobbitState 'TunnelLikeHall+ LonelandsState :: HobbitState 'Lonelands+ TrollsClearingState :: KeyState -> HobbitState 'TrollsClearing+ RivendellState :: KeyState -> HobbitState 'Rivendell+ MistyMountainState :: KeyState -> HobbitState 'MistyMountain+ TrollsPathState :: KeyState -> HobbitState 'TrollsPath+ TrollsCaveState :: HobbitState 'TrollsCave++stateMessage :: HobbitState vertex -> HobbitMessage+stateMessage TunnelLikeHallState =+ HobbitMessage+ "You are in a tunnel-like hall.\n\+ \You can only go east to the Lonelands"+stateMessage LonelandsState =+ HobbitMessage+ "You are in the lonelands.\n\+ \You can either go west to a tunnel-like hall\n\+ \or go east to the Trolls clearing"+stateMessage (TrollsClearingState keyState) =+ if keyState == DayDawned+ then+ HobbitMessage+ "You are in the Trolls clearing.\n\+ \You could go north to the Trolls path,\n\+ \you can go east to Rivendell\n\+ \or you could get the key for the TrollsCave"+ else+ HobbitMessage+ "You are in the Trolls clearing.\n\+ \You could go north to the Trolls path,\n\+ \you can go east to Rivendell"+stateMessage (RivendellState _) =+ HobbitMessage+ "You are in Rivendell.\n\+ \You could either go west to the Trolls clearing\n\+ \or go east to the Misty mountains\n"+stateMessage (MistyMountainState _) =+ HobbitMessage+ "You are in the Misty mountains.\n\+ \You can only go east to Rivendell"+stateMessage (TrollsPathState keyState) =+ case keyState of+ NoKey ->+ HobbitMessage+ "You are in the Trolls path.\n\+ \You can go south to the Trolls clearing\n\+ \or you can wait a bit"+ DayDawned ->+ HobbitMessage+ "You are in the Trolls path.\n\+ \You can go south to the Trolls clearing\n\+ \or you can wait some more"+ GotKey ->+ HobbitMessage+ "You are in the Trolls path.\n\+ \You can go south to the Trolls clearing,\n\+ \you can unlock the door to the Trolls cave\n\+ \or you can wait some more"+ DoorUnlocked ->+ HobbitMessage+ "You are in the Trolls path.\n\+ \You can go south to the Trolls clearing\n\+ \or you can go north to the Trolls cave"+stateMessage TrollsCaveState =+ HobbitMessage+ "Welcome to the Trolls cave!\n\+ \Now you can go back south to the Trolls path"++hobbitResult+ :: (Applicative m, AllowedTransition HobbitTopology initialVertex finalVertex)+ => HobbitState finalVertex+ -> ActionResult m HobbitTopology HobbitState initialVertex HobbitMessage+hobbitResult hobbitState = pureResult (stateMessage hobbitState) hobbitState++hobbitMachine :: HobbitState vertex -> BaseMachine HobbitTopology HobbitCommand HobbitMessage+hobbitMachine initialState =+ BaseMachineT+ { initialState = InitialState initialState+ , action = \case+ TunnelLikeHallState -> \case+ GoEast -> hobbitResult LonelandsState+ _ -> hobbitResult TunnelLikeHallState+ LonelandsState -> \case+ GoEast -> hobbitResult $ TrollsClearingState NoKey+ GoWest -> hobbitResult TunnelLikeHallState+ _ -> hobbitResult LonelandsState+ TrollsClearingState keyState -> \case+ GoEast -> hobbitResult $ RivendellState NoKey+ GoNorth -> hobbitResult $ TrollsPathState keyState+ GetKey ->+ if keyState == DayDawned+ then hobbitResult $ TrollsClearingState GotKey+ else hobbitResult $ TrollsClearingState keyState+ _ -> hobbitResult $ TrollsClearingState keyState+ RivendellState keyState -> \case+ GoEast -> hobbitResult $ MistyMountainState keyState+ GoWest -> hobbitResult $ TrollsClearingState keyState+ _ -> hobbitResult $ RivendellState keyState+ MistyMountainState keyState -> \case+ GoWest -> hobbitResult $ RivendellState keyState+ _ -> hobbitResult $ MistyMountainState keyState+ TrollsPathState keyState -> \case+ GoSouth -> hobbitResult $ TrollsClearingState keyState+ GoNorth ->+ if keyState == DoorUnlocked+ then hobbitResult TrollsCaveState+ else hobbitResult $ TrollsPathState keyState+ Wait ->+ if keyState == NoKey+ then hobbitResult $ TrollsPathState DayDawned+ else hobbitResult $ TrollsPathState keyState+ UnlockDoor ->+ if keyState == GotKey+ then hobbitResult $ TrollsPathState DoorUnlocked+ else hobbitResult $ TrollsPathState keyState+ _ -> hobbitResult (TrollsPathState keyState)+ TrollsCaveState -> \case+ GoSouth -> hobbitResult $ TrollsPathState DoorUnlocked+ _ -> hobbitResult TrollsCaveState+ }
+ examples/Crem/Example/TriangularMachine.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Crem.Example.TriangularMachine where++import Crem.BaseMachine (InitialState (..), pureResult)+import Crem.StateMachine (StateMachine, unrestrictedMachine)++data TriangularState (a :: ()) where+ OnlyState :: Int -> TriangularState '()++triangular :: StateMachine Int Int+triangular =+ unrestrictedMachine+ ( \case+ OnlyState state ->+ \input ->+ pureResult+ (state + input)+ (OnlyState $ state + 1)+ )+ (InitialState (OnlyState 0))
+ examples/Crem/Example/TwoSwitchesGate.lhs view
@@ -0,0 +1,243 @@+> {-# 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.TwoSwitchesGate where+>+> import "crem" Crem.BaseMachine+> import "crem" Crem.Render.Render+> import "crem" Crem.Render.RenderableVertices (AllVertices(..), RenderableVertices)+> import "crem" Crem.Render.RenderFlow+> import "crem" Crem.StateMachine+> import "crem" Crem.Topology+> import "base" Data.Functor.Identity+> import "profunctors" Data.Profunctor+> import "singletons-base" Data.Singletons.Base.TH+> import "text" Data.Text (pack)++We would like to implement a gate opening mechanism controlled by two switches. We would like the gate to open only when the two switches are on.++We would like to implement this by composing several small state machines: one for every switch, one for making sure that we actually receive the right message from both switches, and one for actually opening the gate.++Let's start with the switch.++The first thing we need to do is to define the topology of our machine, meaning the allowed transitions in its state space.++For a switch, there are only two states. Either the switch is on or it is off.++Moreover, we want those switches to be usable only once, and therefore we want to forbid the transition from the `on`` to the `off` position. In other terms, we allow only to go from the `off` position to the `on` position.++> $( singletons+> [d|+> data SwitchVertex+> = SwitchIsOn+> | SwitchIsOff+> deriving stock (Eq, Show, Bounded, Enum)+>+> switchTopology :: Topology SwitchVertex+> switchTopology = Topology+> [(SwitchIsOff, [ SwitchIsOn ])]+> |]+> )++Notice that we need to wrap this in `singletons` because we will soon need to use this data type as a kind, to store information in the type of our state machines.++We need also an instance of `RenderableVertices SwitchVertex` to decide which vertices to render for our machine. To obtain that, we use `deriving via` together with the `AllVertices` newtype.++> deriving via AllVertices SwitchVertex instance RenderableVertices SwitchVertex++Next we need to define which data every vertex of our topology should contain. To express that we use a generalized algebraid data type indexed with `SwitchVertex`++> data SwitchState (vertex :: SwitchVertex) where+> OnState :: SwitchState 'SwitchIsOn+> OffState :: SwitchState 'SwitchIsOff++In this case, for every vertex there is just one possible state.++At this point we need to define which inputs our machine should handle and which outputs it should emit. In the case there is only one meaningful input, the request of turning on the switch, and one meaningful output, the notification that the switch has been turned on.++> data SwitchInput = TurnOn+>+> data SwitchOutput = TurnedOn+> deriving stock Show+>+> instance Semigroup SwitchOutput where+> TurnedOn <> TurnedOn = TurnedOn++At this point we can actually implement our switch as a `BaseMachine`++> switch :: () -> BaseMachine SwitchTopology SwitchInput SwitchOutput+> switch _ =+> BaseMachineT+> { initialState = InitialState OffState+> , action = \case+> OnState -> \_ -> pureResult TurnedOn OnState+> OffState -> \_ -> pureResult TurnedOn OnState+> }++We start from the `OffState` and every time we receive a request to turn the switch on, we return a message informing the external world that the switch in turned on and we update the state accordingly if needed.++Since we need two separate switches, we can create them by invoking the `switch` function twice++> switch1 :: BaseMachine SwitchTopology SwitchInput SwitchOutput+> switch1 = switch ()+>+> switch2 :: BaseMachine SwitchTopology SwitchInput SwitchOutput+> switch2 = switch ()++This concludes the implementation of our switch machine. Next, we would like to implement a machine which receives as inputs the output of two switches and emits a message whenever both the switches have been turned on.++Again, we need to start thinking about the topology of our machine. Since we need to track the state of the two switches, we will have four vertices++> $( singletons+> [d|+> data BothVertex+> = NoSwitchOn+> | OnlyFirstSwitchOn+> | OnlySecondSwitchOn+> | BothSwitchesOn+> deriving (Eq, Show, Enum, Bounded)+>+> bothTopology :: Topology BothVertex+> bothTopology = Topology+> [ (NoSwitchOn, [OnlyFirstSwitchOn, OnlySecondSwitchOn])+> , (OnlyFirstSwitchOn, [BothSwitchesOn])+> , (OnlySecondSwitchOn, [BothSwitchesOn])+> ]+> |]+> )+>+> deriving via AllVertices BothVertex instance RenderableVertices BothVertex++The topology again constrains the machine with the invariant the we can only turn on switches.++Next we need to define the state space, assigning a data type to every vertex in the topology. In this case we don't have the need to attach data to our vertices so we can simply define++> data BothState (vertex :: BothVertex) where+> NoSwitchOnState :: BothState 'NoSwitchOn+> OnlyFirstSwitchOnState :: BothState 'OnlyFirstSwitchOn+> OnlySecondSwitchOnState :: BothState 'OnlySecondSwitchOn+> BothSwitchesOnState :: BothState 'BothSwitchesOn++Before defining the logic of the machine, we need to define its inputs and outputs. Since we would like it to monitor the outputs of both switches, its input type could be++> type BothInput = Either SwitchOutput SwitchOutput++Its output instead will be a potential message to actually open the gate++> data OpenGate = OpenGate+>+> type BothOutput = Maybe OpenGate++and eventually we can define the logic of our state machine++> bothMachine :: BaseMachine BothTopology BothInput BothOutput+> bothMachine =+> BaseMachineT+> { initialState = InitialState NoSwitchOnState+> , action = \case+> NoSwitchOnState -> \case+> Left _ -> pureResult Nothing OnlyFirstSwitchOnState+> Right _ -> pureResult Nothing OnlySecondSwitchOnState+> OnlyFirstSwitchOnState -> \case+> Left _ -> pureResult Nothing OnlyFirstSwitchOnState+> Right _ -> pureResult (Just OpenGate) BothSwitchesOnState+> OnlySecondSwitchOnState -> \case+> Left _ -> pureResult (Just OpenGate) BothSwitchesOnState+> Right _ -> pureResult Nothing OnlySecondSwitchOnState+> BothSwitchesOnState -> \_ -> pureResult Nothing BothSwitchesOnState+> }++The last machine that we need is one representing the actual gate. Since the logic is exactly the same as the one of the switches, we can actually reuse what we defined above++> gate :: BaseMachine SwitchTopology SwitchInput SwitchOutput+> gate = switch ()++Now we have all the machines we wanted and we need to connect them appropriately.++We have the two switches which produce a `SwitchOutput` and the `bothMachine` which accepts inputs of type `Either SwitchOutput SwitchOutput`.++We need to pair up the two switches, first, and then connect them to the `bothMachine`. We need to pair the two switches in a way that allows us to decide whether to run one or the other: this is exactly what the `Alternative` constructor of the `StateMachineT` data type allows us to do.++> switches :: StateMachine (Either SwitchInput SwitchInput) (Either SwitchOutput SwitchOutput)+> switches = Basic switch1 `Alternative` Basic switch2++Notice that we had to wrap our `switch` machines with `Basic` to turn them into `StateMachine`s, which is the more composable type used by `Alternative`.++Now we have the output of `switches` which coincides with the input of `bothMachine`, and therefore we can pass every output we get from `switches` to `bothMachine`. We use the `Sequential` constractor exactly for this++> bothSwitches :: StateMachine (Either SwitchInput SwitchInput) BothOutput+> bothSwitches = switches `Sequential` Basic bothMachine++Now we have a machine which emits `BothOutput = Maybe OpenGate`. Our `gate` machine on the other hand accepts inputs of type `SwitchInput`. To connect those, we need to do some adjusting.++First, we can translate an `OpenGate` into a `SwitchInput`++> openGateToSwitchInput :: OpenGate -> SwitchInput+> openGateToSwitchInput OpenGate = TurnOn++and we can use this function to adapt our `gate` machine so that it accepts `OpenGate` as input.++> gate' :: BaseMachine SwitchTopology OpenGate SwitchOutput+> gate' = lmap openGateToSwitchInput gate++Still `bothSwitches` emits values of type `Maybe OpenGate`. We could lift our `gate'` machine to `Maybe OpenGate` inputs using the `maybeM` combinator.++> maybeGate :: BaseMachine SwitchTopology (Maybe OpenGate) (Maybe SwitchOutput)+> maybeGate = maybeM gate'++At this point we could conclude our composition, joining together `bothMachine` and `maybeGate`++> gateMachine :: StateMachine (Either SwitchInput SwitchInput) (Maybe SwitchOutput)+> gateMachine = bothSwitches `Sequential` Basic maybeGate++Now we have a single machine which describes out whole flow.++Now, there are two things which we could do with `gateMachine`.++The first thing is actually executing it. To do it we can use the `runMultiple` function.++We can try to to turn on both switches and verify that the gate actually opened++> -- |+> -- >>> openedGate+> -- Just TurnedOn+> openedGate :: Maybe SwitchOutput+> openedGate = fst . runIdentity $ runMultiple gateMachine [Left TurnOn, Right TurnOn]++Or we can turn just the first switch several times without opening the gate++> -- |+> -- >>> closedGate+> -- Nothing+> closedGate :: Maybe SwitchOutput+> closedGate = fst . runIdentity $ runMultiple gateMachine [Left TurnOn, Left TurnOn, Left TurnOn]++The other thing we can do is actually rendering a diagram representing how the `gateMachine` works.++The best rendering we can get displays the flow of the machine and the state space for every step of the flow++> -- |+> -- >>> gateFlow+> -- Right "state switch1 {\nswitch1_SwitchIsOn\nswitch1_SwitchIsOff\nswitch1_SwitchIsOff --> switch1_SwitchIsOn\n}\nstate switch2 {\nswitch2_SwitchIsOn\nswitch2_SwitchIsOff\nswitch2_SwitchIsOff --> switch2_SwitchIsOn\n}\nstate fork_choice_switch1switch2 <<choice>>\nstate join_choice_switch1switch2 <<choice>>\nfork_choice_switch1switch2 --> switch1\nfork_choice_switch1switch2 --> switch2\nswitch1 --> join_choice_switch1switch2\nswitch2 --> join_choice_switch1switch2\nstate both {\nboth_NoSwitchOn\nboth_OnlyFirstSwitchOn\nboth_OnlySecondSwitchOn\nboth_BothSwitchesOn\nboth_NoSwitchOn --> both_OnlyFirstSwitchOn\nboth_NoSwitchOn --> both_OnlySecondSwitchOn\nboth_OnlyFirstSwitchOn --> both_BothSwitchesOn\nboth_OnlySecondSwitchOn --> both_BothSwitchesOn\n}\njoin_choice_switch1switch2 --> both\nstate gate {\ngate_SwitchIsOn\ngate_SwitchIsOff\ngate_SwitchIsOff --> gate_SwitchIsOn\n}\nboth --> gate"+> gateFlow :: Either String Mermaid+> gateFlow = (\(mermaid, _, _) -> mermaid) <$>+> renderFlow+> (BinaryLabel+> (BinaryLabel+> (BinaryLabel+> (LeafLabel . MachineLabel . pack $ "switch1")+> (LeafLabel . MachineLabel . pack $ "switch2"))+> (LeafLabel . MachineLabel . pack $ "both"))+> (LeafLabel . MachineLabel . pack $ "gate"))+> (gateMachine @Identity)++The result is a diagram which looks like [this](https://mermaid.live/edit#pako:eNqNVN9vgjAQ_lfIPYORCgjE-LBsS_aw-eDbQkI6KMKU1kDd5oz_-0qhcwyr8tAf331333G99gAJSwmEUHPMyX2BVxUurQ8UUQkY9WfBk9w2DhE1xNdt46Wcn-oF1eBZpjUYljU_G-jYF0V9UaQRRTpRpBFF50UzVq3jJGdFQuIuO5XHbNbi87kiv7OC3kC-EPNPEW7kNWfSnUYD6lNQPHSdJ3_mjfFc1bpZxy-srZAqtAQXdLN_LKqaa2xLkjCanjHeiaGFSd0znGRkoldVdHyt8iDYyU-b1DCg3kn0zoVGUG6qzKtm6MrcrAf93AdVM_9HZdyBv0hFHqMyggklqUpcpOJuS9EIeE5KEkEolimu1hEIN8HbbVPh8JAWnFUQZnhTExPwjrPlniYQ8mpHFKl7H35ZW0xfGevtITzAF4RWYAfeaDwOpp7rIdeEPYROgEaub6PA95GY3KMJ39I7GE0dx5-4E9vxJv50LOhEpvPcvk3yiTr-AO8tobo) where you can clearly see the overall structure of the machine we created, and for every step of the flow the state space of the basic state machine governing that step.
+ examples/Crem/Example/Uno.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE DataKinds #-}+{-# HLINT ignore "Redundant id" #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# 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--Wunrecognised-pragmas+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+-- 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 #-}++-- | Porting of https://github.com/thinkbeforecoding/UnoCore/blob/solution/Uno/Game.fs+module Crem.Example.Uno where++import Crem.BaseMachine (InitialState (..))+import Crem.Decider (Decider (..), EvolutionResult (..))+import Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)+import Crem.Topology+import "singletons-base" Data.Singletons.Base.TH+import Prelude hiding (id, init, reverse)+import Prelude qualified (id)++-- * Domain++newtype PlayerCount = PlayerCount Int+ deriving newtype (Eq, Ord, Show)++data Digit+ = Zero+ | One+ | Two+ | Three+ | Four+ | Five+ | Six+ | Seven+ | Eigth+ | Nine+ deriving stock (Eq, Show)++data Colour+ = Red+ | Green+ | Blue+ | Yellow+ deriving stock (Eq, Show)++data Card+ = DigitCard Digit Colour+ | Skip Colour+ | Kickback Colour+ deriving stock (Eq, Show)++colour :: Card -> Colour+colour (DigitCard _ c) = c+colour (Skip c) = c+colour (Kickback c) = c++sameColour :: Card -> Card -> Bool+sameColour card1 card2 =+ colour card1 == colour card2+data CardValue+ = DigitValue Digit+ | SkipValue+ | KickbackValue+ deriving stock (Eq)++value :: Card -> CardValue+value (DigitCard d _) = DigitValue d+value (Skip _) = SkipValue+value (Kickback _) = KickbackValue++sameValue :: Card -> Card -> Bool+sameValue card1 card2 =+ value card1 == value card2++newtype PlayerId = PlayerId Int+ deriving newtype (Eq, Show)++data Direction+ = Clockwise+ | CounterClockwise++reverseDirection :: Direction -> Direction+reverseDirection Clockwise = CounterClockwise+reverseDirection CounterClockwise = Clockwise++data Player = Player+ { id :: PlayerId+ , count :: PlayerCount+ , direction :: Direction+ }++init :: PlayerId -> PlayerCount -> Player+init playerId count =+ Player+ { id = playerId+ , count = count+ , direction = Clockwise+ }++next :: Player -> Player+next (Player (PlayerId id) (PlayerCount count) direction) =+ case direction of+ Clockwise ->+ Player+ { id = PlayerId $ (id + 1) `mod` count+ , count = PlayerCount count+ , direction+ }+ CounterClockwise ->+ Player+ { id = PlayerId $ (id - 1) `mod` count+ , count = PlayerCount count+ , direction+ }++skip :: Player -> Player+skip = next . next++reverse :: Player -> Player+reverse (Player id count direction) =+ Player id count $ reverseDirection direction++nextPlayer :: Card -> Player -> Player+nextPlayer card player = case card of+ DigitCard _ _ -> next player+ Skip _ -> skip player+ Kickback _ -> next . reverse $ player++set :: PlayerId -> Player -> Player+set playerId player = player {id = playerId}++-- * Commands and events++data InitialData = InitialData+ { players :: PlayerCount+ , firstCard :: Card+ }+ deriving stock (Eq, Show)++data PlayData = PlayData+ { playerId :: PlayerId+ , card :: Card+ }+ deriving stock (Eq, Show)++data Command+ = StartGame InitialData+ | PlayCard PlayData+ deriving stock (Show)++-- deriving (Arbitrary) via (GenericArbitrary Command)++data Event+ = GameStarted InitialData PlayerId+ | CardPlayed PlayData+ | CardPlayedAndTurnBegan PlayData PlayerId+ | WrongCardPlayed PlayData+ | PlayerPlayedAtWrongTurn PlayData+ deriving stock (Eq, Show)++-- * Topology++$( singletons+ [d|+ data UnoVertex+ = Initial+ | Started+ deriving stock (Eq, Show, Enum, Bounded)++ unoTopology :: Topology UnoVertex+ unoTopology = Topology [(Initial, [Started])]+ |]+ )++deriving via AllVertices UnoVertex instance RenderableVertices UnoVertex++-- * State++data StateData = StateData+ { topCard :: Card+ , currentPlayer :: Player+ }++data UnoState (vertex :: UnoVertex) where+ UnoInitialState :: UnoState 'Initial+ UnoStartedState :: StateData -> UnoState 'Started++-- * Errors++data GameError+ = TooFewPlayers+ | GameAlreadyStarted+ | GameNotStarted+ deriving stock (Eq, Show)++-- * Machine++-- | A decider with the logic of the Uno game+--+-- It emits one event for every transition, not a list of events, because an+-- event represents a state transition and a state machine perform one single+-- state transition at every step+unoDecider+ :: InitialState UnoState+ -> Decider UnoTopology Command (Either GameError Event)+unoDecider initialState =+ Decider+ { deciderInitialState = initialState+ , decide = \command state ->+ case (state, command) of+ (_, StartGame initialData)+ | players initialData < PlayerCount 2 ->+ Left TooFewPlayers+ (UnoStartedState _, StartGame _) ->+ Left GameAlreadyStarted+ (_, StartGame initialData) ->+ Right $+ GameStarted+ initialData+ ( id $+ nextPlayer+ (firstCard initialData)+ (init (PlayerId 0) $ players initialData)+ )+ (UnoInitialState, PlayCard _) ->+ Left GameNotStarted+ (UnoStartedState stateData, PlayCard playData)+ | id (currentPlayer stateData) /= playerId playData ->+ if sameColour (topCard stateData) (card playData) && sameValue (topCard stateData) (card playData)+ then Right $ CardPlayed playData+ else Right $ PlayerPlayedAtWrongTurn playData+ (UnoStartedState stateData, PlayCard playData) ->+ if sameColour (topCard stateData) (card playData) || sameValue (topCard stateData) (card playData)+ then+ Right $+ CardPlayedAndTurnBegan+ playData+ ( id $+ nextPlayer+ (card playData)+ (currentPlayer stateData)+ )+ else Right $ WrongCardPlayed playData+ , evolve = \state eitherErrorEvent ->+ case eitherErrorEvent of+ Left _ -> EvolutionResult state+ Right event -> case (state, event) of+ (UnoInitialState, GameStarted initialData playerId) ->+ initialResult initialData playerId+ (UnoStartedState _, GameStarted initialData playerId) ->+ initialResult initialData playerId+ (UnoStartedState stateData, CardPlayed playData) ->+ playResult stateData playData Nothing+ (UnoStartedState stateData, CardPlayedAndTurnBegan playData playerId) ->+ playResult stateData playData (Just playerId)+ _ -> EvolutionResult state+ }+ where+ initialResult+ :: AllowedTransition UnoTopology initialVertex 'Started+ => InitialData+ -> PlayerId+ -> EvolutionResult UnoTopology UnoState initialVertex (Either GameError Event)+ initialResult initialData playerId =+ EvolutionResult $+ UnoStartedState $+ StateData+ { topCard = firstCard initialData+ , currentPlayer = init playerId $ players initialData+ }++ playResult+ :: StateData+ -> PlayData+ -> Maybe PlayerId+ -> EvolutionResult UnoTopology UnoState 'Started (Either GameError Event)+ playResult stateData playData maybePlayerId =+ EvolutionResult $+ UnoStartedState $+ StateData+ { topCard = card playData+ , currentPlayer = maybe Prelude.id set maybePlayerId $ currentPlayer stateData+ }
+ hobbit-game/Main.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}++module Main where++import "base" Data.Functor.Identity+import "crem" Crem.Example.TheHobbit+import "crem" Crem.StateMachine++main :: IO ()+main = do+ putStrLn "Welcome to the Hobbit adventure game!"+ let+ initialState :: HobbitState 'TunnelLikeHall+ initialState = TunnelLikeHallState++ initialMessage :: String+ initialMessage = getMessage $ stateMessage initialState+ putStrLn initialMessage+ loop (Basic $ hobbitMachine initialState)+ where+ loop :: StateMachineT Identity HobbitCommand HobbitMessage -> IO ()+ loop machine = do+ command <- readLn+ let+ (message, machine') = runIdentity $ run machine command+ putStrLn $ getMessage message+ loop machine'
+ hobbit-map/Main.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}++module Main where++import "base" Data.Functor.Identity+import "crem" Crem.BaseMachine+import "crem" Crem.Example.TheHobbit+import "crem" Crem.Render.Render+import "text" Data.Text.IO qualified as Text++main :: IO ()+main = do+ let+ initialState :: HobbitState 'TunnelLikeHall+ initialState = TunnelLikeHallState++ machine :: BaseMachineT Identity HobbitTopology HobbitCommand HobbitMessage+ machine = hobbitMachine initialState++ (Mermaid mermaid) = renderStateDiagram . baseMachineAsGraph $ machine+ Text.putStrLn mermaid
+ spec/Crem/DeciderSpec.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Crem.DeciderSpec where++import Crem.StateMachine (StateMachineT (..), run)+import "base" Data.Functor.Identity (Identity)+import "crem" Crem.BaseMachine (InitialState (..))+import "crem" Crem.Decider+import "crem" Crem.Example.Uno+import "hspec" Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec =+ describe "Decider" $ do+ describe "unoDecider" $ do+ it "is able to rebuild from a list of events" $ do+ let+ unoInitialDecider :: Decider UnoTopology Command (Either GameError Event)+ unoInitialDecider = unoDecider (InitialState UnoInitialState)++ rebuiltDecider :: Decider UnoTopology Command (Either GameError Event)+ rebuiltDecider =+ rebuildDecider+ [ Right $+ GameStarted+ (InitialData (PlayerCount 3) (DigitCard Three Yellow))+ (PlayerId 0)+ , Right $+ CardPlayed+ (PlayData (PlayerId 0) (DigitCard Six Yellow))+ ]+ unoInitialDecider++ inProgressDecider :: Decider UnoTopology Command (Either GameError Event)+ inProgressDecider =+ unoDecider+ ( InitialState $+ UnoStartedState $+ StateData+ { topCard = DigitCard Six Yellow+ , currentPlayer = Player (PlayerId 0) (PlayerCount 3) Clockwise+ }+ )++ command :: Command+ command =+ PlayCard $+ PlayData+ { playerId = PlayerId 1+ , card = DigitCard Six Blue+ }+ in+ (fst <$> run @Identity (Basic $ deciderMachine rebuiltDecider) command)+ `shouldBe` (fst <$> run (Basic $ deciderMachine inProgressDecider) command)
+ spec/Crem/GraphSpec.hs view
@@ -0,0 +1,27 @@+module Crem.GraphSpec where++import "crem" Crem.Graph+import "hspec" Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec =+ describe "Graph" $ do+ describe "productGraph" $ do+ it "computes correctly the product of two graphs" $+ do+ productGraph+ (Graph [(1 :: Int, 1), (1, 2)])+ (Graph [('a', 'b'), ('c', 'd')])+ `shouldBe` Graph+ [ ((1, 'a'), (1, 'b'))+ , ((1, 'c'), (1, 'd'))+ , ((1, 'a'), (2, 'b'))+ , ((1, 'c'), (2, 'd'))+ ]++ describe "transitiveClosureGraph" $ do+ it "computes correctly the transitive closure of a graph" $+ do+ transitiveClosureGraph+ (Graph [(1 :: Int, 2), (2, 3), (1, 4)])+ `shouldBe` Graph [(2, 3), (1, 2), (1, 4), (1, 3)]
+ spec/Crem/Render/RenderFlowSpec.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}++module Crem.Render.RenderFlowSpec where++import "base" Data.Functor.Identity (Identity)+import "base" Data.List (singleton)+import "crem" Crem.Example.LockDoor (SLockDoorVertex (..), lockDoorMachine)+import "crem" Crem.Example.RiskManager.Application (riskApplication)+import "crem" Crem.Render.Render (MachineLabel (..), Mermaid (..), baseMachineAsGraph, renderLabelledGraph)+import "crem" Crem.Render.RenderFlow (TreeMetadata (..), renderFlow)+import "crem" Crem.StateMachine (StateMachineT (..), stateless)+import "hspec" Test.Hspec++spec :: Spec+spec =+ describe "RenderFlow" $ do+ describe "renderFlow" $ do+ it "renders correctly a base machine" $ do+ renderFlow @Identity (LeafLabel "lockMachine") (Basic $ lockDoorMachine SIsLockClosed)+ `shouldBe` Right+ ( Mermaid "state lockMachine {"+ <> ( renderLabelledGraph "lockMachine" . baseMachineAsGraph @_ @_ @_ @_ @Identity $+ lockDoorMachine SIsLockClosed+ )+ <> Mermaid "}"+ , MachineLabel "lockMachine"+ , MachineLabel "lockMachine"+ )++ it "renders correctly a Sequential machine" $ do+ renderFlow+ @Identity+ (BinaryLabel (LeafLabel "show") (LeafLabel "length"))+ ( Sequential+ (stateless $ show @Int)+ (stateless length)+ )+ `shouldBe` Right+ ( Mermaid "state show {\nshow_()\n}\nstate length {\nlength_()\n}\nshow --> length"+ , MachineLabel "show"+ , MachineLabel "length"+ )++ it "renders correctly a Parallel machine" $ do+ renderFlow+ @Identity+ (BinaryLabel (LeafLabel "foo") (LeafLabel "bar"))+ ( Parallel+ (stateless $ show @Int)+ (stateless $ length @[] @String)+ )+ `shouldBe` Right+ ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nstate fork_foobar <<fork>>\nstate join_foobar <<join>>\nfork_foobar --> foo\nfork_foobar --> bar\nfoo --> join_foobar\nbar --> join_foobar"+ , MachineLabel "fork_foobar"+ , MachineLabel "join_foobar"+ )++ it "renders correctly an Alternative machine" $ do+ renderFlow+ @Identity+ (BinaryLabel (LeafLabel "foo") (LeafLabel "bar"))+ ( Alternative+ (stateless $ show @Int)+ (stateless $ length @[] @String)+ )+ `shouldBe` Right+ ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nstate fork_choice_foobar <<choice>>\nstate join_choice_foobar <<choice>>\nfork_choice_foobar --> foo\nfork_choice_foobar --> bar\nfoo --> join_choice_foobar\nbar --> join_choice_foobar"+ , MachineLabel "fork_choice_foobar"+ , MachineLabel "join_choice_foobar"+ )++ it "renders correctly a Feedback machine" $ do+ renderFlow+ @Identity+ (BinaryLabel (LeafLabel "foo") (LeafLabel "bar"))+ ( Feedback+ (stateless $ singleton @Int)+ (stateless $ singleton @Int)+ )+ `shouldBe` Right+ ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nfoo --> bar: []\nbar --> foo: []"+ , MachineLabel "foo"+ , MachineLabel "foo"+ )++ it "renders correctly a Kleisli machine" $ do+ renderFlow+ @Identity+ (BinaryLabel (LeafLabel "show") (LeafLabel "length"))+ ( Kleisli+ (stateless $ singleton @Int)+ (stateless $ singleton @Int)+ )+ `shouldBe` Right+ ( Mermaid "state show {\nshow_()\n}\nstate length {\nlength_()\n}\nshow --> length: []"+ , MachineLabel "show"+ , MachineLabel "length"+ )++ it "renders correctly the RiskManager machine" $ do+ renderFlow+ @Identity+ ( BinaryLabel+ ( BinaryLabel+ ( BinaryLabel+ (LeafLabel "aggregate")+ (LeafLabel "policy")+ )+ (LeafLabel "projection")+ )+ (LeafLabel "mconcat")+ )+ riskApplication+ `shouldBe` Right+ ( Mermaid "state aggregate {\naggregate_NoDataVertex\naggregate_CollectedUserDataVertex\naggregate_CollectedLoanDetailsFirstVertex\naggregate_ReceivedCreditBureauDataFirstVertex\naggregate_CollectedAllDataVertex\naggregate_NoDataVertex --> aggregate_CollectedUserDataVertex\naggregate_CollectedUserDataVertex --> aggregate_CollectedLoanDetailsFirstVertex\naggregate_CollectedUserDataVertex --> aggregate_ReceivedCreditBureauDataFirstVertex\naggregate_CollectedLoanDetailsFirstVertex --> aggregate_CollectedAllDataVertex\naggregate_ReceivedCreditBureauDataFirstVertex --> aggregate_CollectedAllDataVertex\n}\nstate policy {\npolicy_()\n}\naggregate --> policy: []\npolicy --> aggregate: []\nstate projection {\nprojection_SingleProjectionVertex\n}\naggregate --> projection: []\nstate mconcat {\nmconcat_()\n}\nprojection --> mconcat"+ , "aggregate"+ , "mconcat"+ )
+ spec/Crem/Render/RenderSpec.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Crem.Render.RenderSpec where++import Crem.Example.LockDoor+import Crem.Example.OneState+import Crem.Example.Switch+import Crem.Topology (trivialTopology)+import Data.Functor.Identity+import Data.Singletons.Base.TH+import "base" Data.List (intersperse)+import "crem" Crem.Graph+import "crem" Crem.Render.Render+import "crem" Crem.StateMachine+import "hspec" Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec =+ describe "Render" $ do+ describe "renderMermaid" $ do+ it "should render correctly a graph" $ do+ renderGraph (Graph [(LT, LT), (LT, EQ), (LT, GT), (EQ, GT), (GT, LT)])+ `shouldBe` Mermaid+ ( mconcat $+ intersperse+ "\n"+ [ "LT"+ , "EQ"+ , "GT"+ , "LT --> LT"+ , "LT --> EQ"+ , "LT --> GT"+ , "EQ --> GT"+ , "GT --> LT"+ ]+ )++ describe "topologyAsGraph" $ do+ it "should render the topology with a single vertex" $ do+ topologyAsGraph (trivialTopology @())+ `shouldBe` Graph []++ it "should render the switch topology" $ do+ topologyAsGraph switchTopology+ `shouldBe` Graph+ [ (True, False)+ , (False, True)+ ]++ it "should render the lockDoor topology" $ do+ topologyAsGraph lockDoorTopology+ `shouldBe` Graph+ [ (IsLockOpen, IsLockClosed)+ , (IsLockClosed, IsLockOpen)+ , (IsLockClosed, IsLockLocked)+ , (IsLockLocked, IsLockClosed)+ ]++ describe "baseMachineAsGraph" $ do+ it "should render the machine with a single vertex" $ do+ baseMachineAsGraph (oneVertexMachine @Identity)+ `shouldBe` Graph []++ it "should render the switch machine" $ do+ baseMachineAsGraph (switchMachine SFalse @Identity)+ `shouldBe` Graph+ [ (True, False)+ , (False, True)+ ]++ it "should render the lockDoor machine" $ do+ baseMachineAsGraph (lockDoorMachine SIsLockClosed @Identity)+ `shouldBe` Graph+ [ (IsLockOpen, IsLockClosed)+ , (IsLockClosed, IsLockOpen)+ , (IsLockClosed, IsLockLocked)+ , (IsLockLocked, IsLockClosed)+ ]++ describe "machineAsGraph" $ do+ it "should render the basic machine with a single vertex" $ do+ renderUntypedGraph (machineAsGraph (Basic $ oneVertexMachine @Identity))+ `shouldBe` Mermaid "()"++ it "should render the basic switch machine" $ do+ renderUntypedGraph (machineAsGraph (Basic $ switchMachine SFalse @Identity))+ `shouldBe` Mermaid+ ( mconcat $+ intersperse+ "\n"+ [ "False"+ , "True"+ , "True --> False"+ , "False --> True"+ ]+ )++ it "should render the basic lockDoor machine" $ do+ renderUntypedGraph (machineAsGraph (Basic $ lockDoorMachine SIsLockClosed @Identity))+ `shouldBe` Mermaid+ ( mconcat $+ intersperse+ "\n"+ [ "IsLockOpen"+ , "IsLockClosed"+ , "IsLockLocked"+ , "IsLockOpen --> IsLockClosed"+ , "IsLockClosed --> IsLockOpen"+ , "IsLockClosed --> IsLockLocked"+ , "IsLockLocked --> IsLockClosed"+ ]+ )
+ spec/Crem/RiskManagerSpec.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE OverloadedStrings #-}++module Crem.RiskManagerSpec where++import Crem.Example.RiskManager.Application+import Crem.Example.RiskManager.Domain+import Crem.Example.RiskManager.Projection (ReceivedData (..))+import Crem.StateMachineSpec (shouldOutput)+import "crem" Crem.StateMachine (run, runMultiple)+import "hspec" Test.Hspec (Spec, describe, it)++myUserData :: UserData+myUserData =+ UserData+ { name = "Marco"+ , surname = "Perone"+ , taxCode = "ABCDEF12T34J987H"+ }++notMyUserData :: UserData+notMyUserData =+ UserData+ { name = "Gigi"+ , surname = "Zucon"+ , taxCode = "ABCDEF12T34J987H"+ }++loanDetails :: LoanDetails+loanDetails =+ LoanDetails+ { amount = EuroCents 10000+ , instalments = InstalmentsNumber 10+ }++otherLoanDetails :: LoanDetails+otherLoanDetails =+ LoanDetails+ { amount = EuroCents 20000+ , instalments = InstalmentsNumber 5+ }++creditBureauData :: CreditBureauData+creditBureauData =+ CreditBureauData+ { missedPaymentDeadlines = MissedPaymentDeadlines 2+ , arrears = EuroCents 100000+ }++spec :: Spec+spec =+ describe "RiskManager" $ do+ describe "aggregate" $ do+ it "emits a registered event when a registration command is received" $ do+ run aggregate (RegisterUserData myUserData)+ `shouldOutput` [UserDataRegistered myUserData]++ it "emits two registered events when two registration commands are received" $ do+ runMultiple aggregate [RegisterUserData myUserData, RegisterUserData notMyUserData]+ `shouldOutput` [UserDataRegistered myUserData, UserDataRegistered notMyUserData]++ it "does not emit anything when a loan details command is received" $ do+ run aggregate (ProvideLoanDetails loanDetails)+ `shouldOutput` []++ it "emits a loan details event when a registration command and a loan detail command are received" $ do+ runMultiple aggregate [RegisterUserData myUserData, ProvideLoanDetails loanDetails]+ `shouldOutput` [UserDataRegistered myUserData, LoanDetailsProvided loanDetails]++ describe "policy" $ do+ it "emits a credit bureau command when a user registration event is received for a user named Marco" $ do+ run policy (UserDataRegistered myUserData)+ `shouldOutput` [ProvideCreditBureauData creditBureauData]++ it "emits no command when a user registration event is received for a user not named Marco" $ do+ run policy (UserDataRegistered notMyUserData)+ `shouldOutput` []++ it "emits two credit bureau command when two user registration events are received" $ do+ runMultiple policy [UserDataRegistered myUserData, UserDataRegistered myUserData]+ `shouldOutput` [ ProvideCreditBureauData creditBureauData+ , ProvideCreditBureauData creditBureauData+ ]++ it "emits one credit bureau command when two user registration events are received but only one for a user named Marco" $ do+ runMultiple policy [UserDataRegistered myUserData, UserDataRegistered notMyUserData]+ `shouldOutput` [ProvideCreditBureauData creditBureauData]++ runMultiple policy [UserDataRegistered notMyUserData, UserDataRegistered myUserData]+ `shouldOutput` [ProvideCreditBureauData creditBureauData]++ it "emits no command when two user registration events are received for a user not named Marco" $ do+ runMultiple policy [UserDataRegistered notMyUserData, UserDataRegistered notMyUserData]+ `shouldOutput` []++ it "emits no command when a loan details event is registered" $ do+ run policy (LoanDetailsProvided loanDetails)+ `shouldOutput` []++ it "emits no command when a credit bureau data is registered" $ do+ run policy (CreditBureauDataReceived creditBureauData)+ `shouldOutput` []++ describe "writeModel" $ do+ it "emits a registered event when a registration command is received" $ do+ run writeModel (RegisterUserData myUserData)+ `shouldOutput` [ UserDataRegistered myUserData+ , CreditBureauDataReceived creditBureauData+ ]++ it "emits two registered events when two registration command are received" $ do+ runMultiple writeModel [RegisterUserData myUserData, RegisterUserData myUserData]+ `shouldOutput` [ UserDataRegistered myUserData+ , CreditBureauDataReceived creditBureauData+ , UserDataRegistered myUserData+ , CreditBureauDataReceived creditBureauData+ ]++ describe "riskProjection" $ do+ it "registers one user when a registration event is received" $ do+ run projection (UserDataRegistered myUserData)+ `shouldOutput` ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }++ it "updates the user data when two registration events are received" $ do+ runMultiple projection [UserDataRegistered myUserData, UserDataRegistered notMyUserData]+ `shouldOutput` ReceivedData+ { receivedUserData = Just notMyUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }++ describe "readModel" $ do+ it "registers one user when a registration event is received" $ do+ run readModel (UserDataRegistered myUserData)+ `shouldOutput` [ ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }+ ]++ it "registers two users when two registration events are received" $ do+ runMultiple readModel [UserDataRegistered myUserData, UserDataRegistered notMyUserData]+ `shouldOutput` [ ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }+ , ReceivedData+ { receivedUserData = Just notMyUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }+ ]++ describe "whole" $ do+ it "registers one user when a registration command is received" $ do+ run whole (RegisterUserData myUserData)+ `shouldOutput` [ ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }+ , ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Just creditBureauData+ }+ ]++ it "registers two users when two registration commands are received" $ do+ runMultiple whole [RegisterUserData myUserData, RegisterUserData notMyUserData]+ `shouldOutput` [ ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Nothing+ }+ , ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Just creditBureauData+ }+ , ReceivedData+ { receivedUserData = Just notMyUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Just creditBureauData+ }+ ]++ describe "riskApplication" $ do+ it "registers one user" $ do+ run riskApplication (RegisterUserData myUserData)+ `shouldOutput` ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Just creditBureauData+ }++ it "updates the user data" $ do+ runMultiple riskApplication [RegisterUserData notMyUserData, RegisterUserData myUserData]+ `shouldOutput` ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Nothing+ , receivedCreditBureauData = Just creditBureauData+ }++ it "collects the user data and the loan details" $ do+ runMultiple riskApplication [RegisterUserData myUserData, ProvideLoanDetails loanDetails]+ `shouldOutput` ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Just loanDetails+ , receivedCreditBureauData = Just creditBureauData+ }++ it "updates the loan details" $ do+ runMultiple+ riskApplication+ [ RegisterUserData myUserData+ , ProvideLoanDetails loanDetails+ , ProvideLoanDetails otherLoanDetails+ ]+ `shouldOutput` ReceivedData+ { receivedUserData = Just myUserData+ , receivedLoanDetails = Just otherLoanDetails+ , receivedCreditBureauData = Just creditBureauData+ }
+ spec/Crem/StateMachineSpec.hs view
@@ -0,0 +1,118 @@+module Crem.StateMachineSpec where++import Crem.Example.BooleanStateMachine (booleanStateMachine)+import Crem.Example.LockDoor+import Crem.Example.PlusOneUpToFour (plus1UpTo4)+import Crem.Example.Switch (switchMachine)+import "base" Control.Category qualified+import "base" Data.Functor.Identity (Identity (..))+import "base" Data.List (singleton)+import "crem" Crem.StateMachine+import "hspec" Test.Hspec (Expectation, Spec, describe, it, shouldBe)+import "profunctors" Data.Profunctor (rmap)+import "singletons-base" Data.Singletons.Base.TH++shouldOutput :: (Eq b, Show b) => Identity (b, c) -> b -> Expectation+shouldOutput (Identity (output, _)) expectedOutput = output `shouldBe` expectedOutput++spec :: Spec+spec =+ describe "StateMachine" $ do+ describe "run" $ do+ describe "switch machine" $ do+ it "outputs () when the state is False" $ do+ run (Basic $ switchMachine SFalse) () `shouldOutput` ()++ it "outputs () when the state is True" $ do+ run (Basic $ switchMachine STrue) () `shouldOutput` ()++ describe "lock door machine" $ do+ it "outputs Opened when it is closed and receive an Open command" $ do+ run (Basic $ lockDoorMachine SIsLockClosed) LockOpen `shouldOutput` LockOpened++ it "outputs NoOp when it is closed and receive a Close command" $ do+ run (Basic $ lockDoorMachine SIsLockClosed) LockClose `shouldOutput` LockNoOp++ it "outputs Locked when it is closed and receive a Lock command" $ do+ run (Basic $ lockDoorMachine SIsLockClosed) LockLock `shouldOutput` LockLocked++ it "outputs NoOp when it is closed and receive an Unlock command" $ do+ run (Basic $ lockDoorMachine SIsLockClosed) LockUnlock `shouldOutput` LockNoOp++ it "outputs NoOp when it is open and receive an Open command" $ do+ run (Basic $ lockDoorMachine SIsLockOpen) LockOpen `shouldOutput` LockNoOp++ it "outputs Closed when it is open and receive a Close command" $ do+ run (Basic $ lockDoorMachine SIsLockOpen) LockClose `shouldOutput` LockClosed++ it "outputs NoOp when it is open and receive a Lock command" $ do+ run (Basic $ lockDoorMachine SIsLockOpen) LockLock `shouldOutput` LockNoOp++ it "outputs NoOp when it is open and receive an Unlock command" $ do+ run (Basic $ lockDoorMachine SIsLockOpen) LockUnlock `shouldOutput` LockNoOp++ it "outputs NoOp when it is locked and receive an Open command" $ do+ run (Basic $ lockDoorMachine SIsLockLocked) LockOpen `shouldOutput` LockNoOp++ it "outputs NoOp when it is locked and receive a Close command" $ do+ run (Basic $ lockDoorMachine SIsLockLocked) LockClose `shouldOutput` LockNoOp++ it "outputs NoOp when it is locked and receive a Lock command" $ do+ run (Basic $ lockDoorMachine SIsLockLocked) LockLock `shouldOutput` LockNoOp++ it "outputs Unlocked when it is locked and receive an Unlock command" $ do+ run (Basic $ lockDoorMachine SIsLockLocked) LockUnlock `shouldOutput` LockUnlocked++ it "outputs Locked when it is open and receive a Close and a Lock command" $ do+ let+ runOnce :: StateMachineT Identity LockDoorCommand LockDoorEvent+ runOnce = runIdentity $ snd <$> run (Basic $ lockDoorMachine SIsLockOpen @Identity) LockClose+ run runOnce LockLock `shouldOutput` LockLocked++ it "outputs Opened when it is locked and receive a Unlock and an Open command" $ do+ let+ runOnce :: StateMachineT Identity LockDoorCommand LockDoorEvent+ runOnce = runIdentity $ snd <$> run (Basic $ lockDoorMachine SIsLockLocked @Identity) LockUnlock+ run runOnce LockOpen `shouldOutput` LockOpened++ describe "boolean state machine" $ do+ it "outputs 1 when it is in a False state and receives a 0" $ do+ run (booleanStateMachine SFalse) 0 `shouldOutput` 1++ it "outputs 3 when it is in a False state and receives a 1" $ do+ run (booleanStateMachine SFalse) 1 `shouldOutput` 3++ it "outputs -1 when it is in a True state and receives a 0" $ do+ run (booleanStateMachine STrue) 0 `shouldOutput` (-1)++ it "outputs 5 when it is in a True state and receives a 1" $ do+ run (booleanStateMachine STrue) 1 `shouldOutput` 5++ -- describe "cotabulate and cosieve are each other inverses" $ do+ -- prop "cotabulate . cosieve = id" $ do+ -- forAll (arbitrary @Int) $ do+ -- \input ->+ -- run (booleanStateMachine SFalse) input+ -- `shouldHaveTheSameOutputAs` run (cotabulate . cosieve $ booleanStateMachine SFalse) input++ -- prop "cosieve . cotabulate = id" $ do+ -- let+ -- nonEmptyFunction :: NonEmpty Int -> Int+ -- nonEmptyFunction = sum+ -- forAll (fromList <$> (arbitrary @[Int] `suchThat` (not . null))) $ do+ -- \input ->+ -- nonEmptyFunction input+ -- `shouldBe` (cosieve . cotabulate @StateMachine $ nonEmptyFunction) input++ describe "Feedback constructor runs correctly" $ do+ describe "with the plus1UpTo4 machine" $ do+ let+ echo :: StateMachine a [a]+ echo = rmap singleton Control.Category.id++ it "runs correctly on a single input" $ do+ run (Feedback echo plus1UpTo4) 1 `shouldOutput` [1, 2, 3, 4, 5]+ run (Feedback echo plus1UpTo4) 5 `shouldOutput` [5]++ it "processes correctly multiple inputs" $ do+ runMultiple (Feedback echo plus1UpTo4) [1, 1] `shouldOutput` [1, 2, 3, 4, 5, 1, 2, 3, 4, 5]
+ spec/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/Crem/BaseMachine.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE DataKinds #-}++-- | A `BaseMachine` is a Mealy machine constrained by a provided `Topology` of+-- allowed transitions.+module Crem.BaseMachine where++import Crem.Topology+import "base" Data.Bifunctor (Bifunctor (..), first)+import "base" Data.Functor.Identity (Identity (..))+import "base" Data.Kind (Type)+import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))+import "singletons-base" Data.Singletons.Base.TH (STuple0 (..))++-- * Specifying state machines++-- | A @BaseMachineT m topology input output@ describes a state machine with+-- allowed transitions constrained by a given @topology@.+-- A state machine is composed by an `initialState` and an `action`, which+-- defines the @output@ and the new @state@ given the current @state@ and an+-- @input@.+-- The @m@ parameter describes the context where the `action` of the machine is+-- executed+data+ BaseMachineT+ m+ (topology :: Topology vertex)+ (input :: Type)+ (output :: Type) = forall state.+ BaseMachineT+ { initialState :: InitialState state+ , action+ :: forall initialVertex+ . state initialVertex+ -> input+ -> ActionResult m topology state initialVertex output+ }++-- | A `BaseMachine` is an effectful machine for every possible monad @m@.+-- Needing to work for every monad, in fact it can not perform any kind of+-- effect and needs to be pure in nature.+type BaseMachine+ (topology :: Topology vertex)+ (input :: Type)+ (output :: Type) =+ forall m. Monad m => BaseMachineT m topology input output++-- * Hoist++-- | Allows to change the context @m@ where the machine operates to another+-- context @n@, provided we have a [natural transformation](https://stackoverflow.com/a/58364172/2718064)+-- from @m@ to @n@+baseHoist+ :: (forall x. m x -> n x)+ -> BaseMachineT m topology a b+ -> BaseMachineT n topology a b+baseHoist f (BaseMachineT initialState action) =+ BaseMachineT+ initialState+ ((hoistResult f .) . action)++instance Functor m => Profunctor (BaseMachineT m topology) where+ lmap :: (a -> b) -> BaseMachineT m topology b c -> BaseMachineT m topology a c+ lmap f (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = (. f) . action+ }++ rmap :: (b -> c) -> BaseMachineT m topology a b -> BaseMachineT m topology a c+ rmap f (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = ((f <$>) .) . action+ }++instance Functor m => Strong (BaseMachineT m topology) where+ first' :: BaseMachineT m topology a b -> BaseMachineT m topology (a, c) (b, c)+ first' (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \state (a, c) -> (,c) <$> action state a+ }++ second' :: BaseMachineT m topology a b -> BaseMachineT m topology (c, a) (c, b)+ second' (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \state (c, a) -> (c,) <$> action state a+ }++instance Applicative m => Choice (BaseMachineT m topology) where+ left' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either a c) (Either b c)+ left' (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \state -> \case+ Left a -> Left <$> action state a+ Right c -> ActionResult $ pure (Right c, state)+ }++ right' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either c a) (Either c b)+ right' (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \state -> \case+ Left c -> ActionResult $ pure (Left c, state)+ Right a -> Right <$> action state a+ }++-- | A value of type @InitialState state@ describes the initial state of a+-- state machine, describing the initial @vertex@ in the @topology@ and the+-- actual initial data of type @state vertex@+data InitialState (state :: vertex -> Type) where+ InitialState :: state vertex -> InitialState state++-- | The result of an action of the state machine.+-- An @ActionResult m topology state initialVertex output@ contains an @output@+-- and a @state finalVertex@, where the transition from @initialVertex@ to+-- @finalVertex@ is allowed by the machine @topology@+data+ ActionResult+ m+ (topology :: Topology vertex)+ (state :: vertex -> Type)+ (initialVertex :: vertex)+ (output :: Type)+ where+ ActionResult+ :: AllowedTransition topology initialVertex finalVertex+ => m (output, state finalVertex)+ -> ActionResult m topology state initialVertex output++-- | Allows to change the computational context of an `ActionResult` from @m@+-- to @n@, given we have a [natural transformation](https://stackoverflow.com/a/58364172/2718064)+-- from @m@ to @n@.+hoistResult+ :: (forall x. m x -> n x)+ -> ActionResult m topology state initialVertex output+ -> ActionResult n topology state initialVertex output+hoistResult f (ActionResult outputStatePair) = ActionResult $ f outputStatePair++instance Functor m => Functor (ActionResult m topology state initialVertex) where+ fmap+ :: (a -> b)+ -> ActionResult m topology state initialVertex a+ -> ActionResult m topology state initialVertex b+ fmap f (ActionResult outputStatePair) =+ ActionResult $ first f <$> outputStatePair++-- | Create an `ActionResult` without performing any side effect in the @m@+-- context+pureResult+ :: (Applicative m, AllowedTransition topology initialVertex finalVertex)+ => output+ -> state finalVertex+ -> ActionResult m topology state initialVertex output+pureResult output state = ActionResult . pure $ (output, state)++-- | This is fairly similar to `sequenceA` from `Data.Traversable` and in fact+-- it does the same job, with the slight difference that `sequenceA` would+-- return @f (ActionResult Identity topology state initialVertex output)@+sequence+ :: Functor f+ => ActionResult Identity topology state initialVertex (f output)+ -> ActionResult f topology state initialVertex output+sequence (ActionResult (Identity (outputs, state))) =+ ActionResult $ (,state) <$> outputs++-- ** Lift machines++-- | Lift a @BaseMachineT@ to operate with `Maybe` inputs and outputs. If the+-- input is a `Nothing`, then the output will be a `Nothing`. If the input is a+-- `Just`, then the machine will be used to compute the output.+maybeM+ :: Applicative m+ => BaseMachineT m topology a b+ -> BaseMachineT m topology (Maybe a) (Maybe b)+maybeM (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \initialState' -> \case+ Nothing -> pureResult Nothing initialState'+ Just a -> Just <$> action initialState' a+ }++-- | Lift a @BaseMachineT@ to operate with `Either` inputs and outputs. If the+-- input is a `Left`, then the output will be that `Left`. If the input is a+-- `Right`, then the machine will be used to compute the output.+eitherM+ :: Applicative m+ => BaseMachineT m topology a b+ -> BaseMachineT m topology (Either e a) (Either e b)+eitherM (BaseMachineT initialState action) =+ BaseMachineT+ { initialState = initialState+ , action = \initialState' -> \case+ Left e -> pureResult (Left e) initialState'+ Right a -> Right <$> action initialState' a+ }++-- ** Stateless machines++-- | `statelessBaseT` transforms its input to its output and never changes its+-- state+statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b+statelessBaseT f =+ BaseMachineT+ { initialState = InitialState STuple0+ , action = \state input ->+ ActionResult $ (,state) <$> f input+ }++-- | `statelessBase` transforms its input to its output and never changes its+-- state, without performing any side effect+statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b+statelessBase f = statelessBaseT (pure . f)++-- ** Identity machine++-- | The `identity` machine simply outputs its input and never changes its+-- state.+identity :: BaseMachine (TrivialTopology @()) a a+identity = statelessBase id++-- ** Unrestricted machines++-- | a machine modelled with explicit state, where every transition is allowed+unrestrictedBaseMachineT+ :: (forall initialVertex. state initialVertex -> a -> ActionResult m (AllowAllTopology @vertex) state initialVertex b)+ -> InitialState (state :: vertex -> Type)+ -> BaseMachineT m (AllowAllTopology @vertex) a b+unrestrictedBaseMachineT action initialState =+ BaseMachineT+ { initialState = initialState+ , action = action+ }++-- ** Run a machine++-- | Given an @input@, run the machine to get an output and a new version of+-- the machine+runBaseMachineT+ :: Functor m+ => BaseMachineT m topology input output+ -> input+ -> m (output, BaseMachineT m topology input output)+runBaseMachineT (BaseMachineT (InitialState initialState) action) input =+ case action initialState input of+ ActionResult outputStatePair ->+ second+ ( \finalState ->+ BaseMachineT+ { initialState = InitialState finalState+ , action = action+ }+ )+ <$> outputStatePair
+ src/Crem/Decider.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DataKinds #-}++-- | The [Decider pattern](https://thinkbeforecoding.com/post/2021/12/17/functional-event-sourcing-decider)+-- allows to easily describe an [aggregate](https://www.domainlanguage.com/wp-content/uploads/2016/05/DDD_Reference_2015-03.pdf)+-- in functional terms+--+-- In terms of Mealy machines, a `Decider` is a machine where the next state is+-- computed from the previous state and the output+module Crem.Decider where++import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState (..))+import Crem.Topology (AllowedTransition, Topology)+import Data.Foldable (foldl')+import "base" Data.Kind (Type)++-- | A @Decider topology input output@ is a Decider which receives inputs of+-- type @input@ and emits outputs of type @output@, where allowed transitions+-- are constrained by the provided @topology@.+--+-- Being used to describe the domain logic of an aggregate, a `Decider` is+-- always pure.+--+-- It is defined by:+--+-- * its `deciderInitialState`+-- * a `decide` function, which says how to compute the @output@ out of the+-- @input@ and the current state+-- * an `evolve` function, which allows us to specify the next state from the+-- current state and the @output@+data+ Decider+ (topology :: Topology vertex)+ input+ output = forall state.+ Decider+ { deciderInitialState :: InitialState state+ , decide :: forall vertex'. input -> state vertex' -> output+ , evolve+ :: forall initialVertex+ . state initialVertex+ -> output+ -> EvolutionResult topology state initialVertex output+ }++-- | A smart wrapper over the machine state, which allows to enforce that only+-- transitions allowed by the @topology@ are actually performed.+data+ EvolutionResult+ (topology :: Topology vertex)+ (state :: vertex -> Type)+ (initialVertex :: vertex)+ output+ where+ EvolutionResult+ :: AllowedTransition topology initialVertex finalVertex+ => state finalVertex+ -> EvolutionResult topology state initialVertex output++-- | translate a `Decider` into a `BaseMachine`+deciderMachine+ :: Decider topology input output+ -> BaseMachine topology input output+deciderMachine (Decider deciderInitialState' decide' evolve') =+ BaseMachineT+ { initialState = deciderInitialState'+ , action = \state input ->+ let+ output = decide' input state+ in+ case evolve' state output of+ EvolutionResult finalState ->+ ActionResult $ pure (output, finalState)+ }++-- | rebuild a `Decider` from a list of outputs+--+-- This is the main selling point of a `Decider` over a generic `Crem.StateMachine`,+-- since it allows rebuilding a machine from its outputs.+rebuildDecider+ :: [output]+ -> Decider topology input output+ -> Decider topology input output+rebuildDecider outputs decider =+ foldl' rebuildDeciderStep decider outputs+ where+ rebuildDeciderStep+ :: Decider topology input output+ -> output+ -> Decider topology input output+ rebuildDeciderStep (Decider (InitialState initialState') decide' evolve') output =+ let+ evolveResult = evolve' initialState' output+ in+ case evolveResult of+ EvolutionResult evolvedState ->+ Decider+ { deciderInitialState = InitialState evolvedState+ , decide = decide'+ , evolve = evolve'+ }
+ src/Crem/Graph.hs view
@@ -0,0 +1,89 @@+-- | A simple data structure to describe a directed graph+module Crem.Graph where++import Crem.Render.RenderableVertices (RenderableVertices (..))+import "base" Data.List (nub)++-- * Graph++-- | A graph is just a list of edges between vertices of type @a@+newtype Graph a = Graph [(a, a)]+ deriving stock (Eq, Show)++-- | The product graph.+-- It has as vertices the product of the set of vertices of the initial graph.+-- It has as edge from @(a1, b1)@ to @(a2, b2)@ if and only if there is an edge+-- from @a1@ to @a2@ and an edge from @b1@ to @b2@+--+-- >>> productGraph (Graph [('a', 'b')]) (Graph [('c', 'd')])+-- Graph [(('a','c'),('b','d'))]+productGraph :: Graph a -> Graph b -> Graph (a, b)+productGraph (Graph edges1) (Graph edges2) =+ Graph $+ ( \((initialEdge1, finalEdge1), (initialEdge2, finalEdge2)) ->+ ((initialEdge1, initialEdge2), (finalEdge1, finalEdge2))+ )+ <$> [(edge1, edge2) | edge1 <- edges1, edge2 <- edges2]++-- | Computes all the possible paths in the input graph and considers them as+-- edges. Notice that the current implementation is removing duplicates+transitiveClosureGraph :: Eq a => Graph a -> Graph a+transitiveClosureGraph graph@(Graph edges) =+ Graph $+ foldr+ ( \a edgesSoFar ->+ edgesSoFar <> pathsFrom graph a+ )+ []+ (nub $ fst <$> edges)+ where+ edgesFrom :: Eq a => Graph a -> a -> [(a, a)]+ edgesFrom (Graph edges') a = filter ((== a) . fst) edges'++ pathsFrom :: forall a. Eq a => Graph a -> a -> [(a, a)]+ pathsFrom g a =+ let+ edgesFromAToB = edgesFrom g a+ pathsFromBToC = edgesFromAToB >>= pathsFrom g . snd+ edgesFromAToC = (a,) . snd <$> pathsFromBToC+ in+ edgesFromAToB <> edgesFromAToC++-- | Add all the identity edges to a graph+addIdentityEdges :: RenderableVertices a => Graph a -> Graph a+addIdentityEdges (Graph edges) = Graph $ edges <> ((\a -> (a, a)) <$> vertices)++-- | Remove all the edges which start and end at the same vertex+removeIdentityEdges :: Eq a => Graph a -> Graph a+removeIdentityEdges (Graph edges) = Graph $ filter (uncurry (/=)) edges++-- * UntypedGraph++-- | A data type to represent a graph which is not tracking the vertex type+data UntypedGraph+ = forall a. (RenderableVertices a, Eq a, Show a) => UntypedGraph (Graph a)++instance Show UntypedGraph where+ show :: UntypedGraph -> String+ show (UntypedGraph graph) = show graph++-- | Same as @productGraph@ but for @UntypedGraph@+untypedProductGraph :: UntypedGraph -> UntypedGraph -> UntypedGraph+untypedProductGraph (UntypedGraph graph1) (UntypedGraph graph2) =+ UntypedGraph (productGraph graph1 graph2)++-- | Same as @transitiveClosureGraph@ but for @UntypedGraph@+untypedTransitiveClosureGraph :: UntypedGraph -> UntypedGraph+untypedTransitiveClosureGraph (UntypedGraph graph) =+ UntypedGraph (transitiveClosureGraph graph)++-- | Add all identity edges to an @UntypedGraph@+untypedAddIdentityEdges :: UntypedGraph -> UntypedGraph+untypedAddIdentityEdges (UntypedGraph graph) =+ UntypedGraph $ addIdentityEdges graph++-- | Remove all the edges which start and end at the same vertex from an+-- @UntypedGraph@+untypedRemoveIdentityEdges :: UntypedGraph -> UntypedGraph+untypedRemoveIdentityEdges (UntypedGraph graph) =+ UntypedGraph $ removeIdentityEdges graph
+ src/Crem/Render/Render.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Once you defined a `StateMachineT`, you can render its topology as a+-- directed graph using a [Mermaid](https://mermaid.js.org/#/) state diagram+module Crem.Render.Render where++import Crem.BaseMachine+import Crem.Graph+import Crem.Render.RenderableVertices+import Crem.StateMachine+import Crem.Topology+import "base" Data.List (intersperse)+import "base" Data.String (IsString)+import "singletons-base" Data.Singletons (Demote, SingI, SingKind, demote)+import "text" Data.Text (Text, null, pack)+import Prelude hiding (null)++-- | `Mermaid` is just a @newtype@ around @Text@ to specialize it to Mermaid+-- diagrams+newtype Mermaid = Mermaid {getText :: Text}+ deriving newtype (Eq, Show)++-- | Notice that we joining two non-empty mermaid diagrams, a newline will be+-- added+instance Semigroup Mermaid where+ (<>) :: Mermaid -> Mermaid -> Mermaid+ (Mermaid "") <> m = m+ m <> (Mermaid "") = m+ (Mermaid t1) <> (Mermaid t2) = Mermaid (t1 <> "\n" <> t2)++-- | A `MachineLabel` is just a newtype around `Text` to represents label which+-- will be attached to every leaf of the tree defined by the constructors of+-- `StateMachineT`+newtype MachineLabel = MachineLabel {getLabel :: Text}+ deriving newtype (Eq, Show, IsString)++-- | We can render a `Graph` as a Mermaid state diagram+renderStateDiagram :: (RenderableVertices a, Show a) => Graph a -> Mermaid+renderStateDiagram graph =+ Mermaid "stateDiagram-v2\n" <> renderGraph graph++-- | Prepends a `MachineLabel` to the `Show` output, as a `Text`+labelVertex :: Show a => MachineLabel -> a -> Text+labelVertex label =+ let+ prefix =+ if null (getLabel label)+ then ""+ else getLabel label <> "_"+ in+ (prefix <>) . pack . show++-- | Render all the vertices of a graph after labelling all of them+renderLabelledVertices+ :: forall a+ . (Show a, RenderableVertices a)+ => MachineLabel+ -> Graph a+ -> Mermaid+renderLabelledVertices label _ =+ Mermaid . mconcat . intersperse "\n" $ labelVertex label <$> (vertices :: [a])++-- | Render all vertices with no label+renderVertices :: forall a. (Show a, RenderableVertices a) => Graph a -> Mermaid+renderVertices = renderLabelledVertices ""++-- | Render all the edges of a graph after labelling all of them+renderLabelledEdges :: Show a => MachineLabel -> Graph a -> Mermaid+renderLabelledEdges label (Graph l) =+ Mermaid . mconcat . intersperse "\n" $+ (\(a1, a2) -> labelVertex label a1 <> " --> " <> labelVertex label a2) <$> l++-- | Render all edges with no label+renderEdges :: Show a => Graph a -> Mermaid+renderEdges = renderLabelledEdges ""++-- | Join the outputs of `renderLabelledVertices` and `renderLabelledEdges` to+-- render an entire `Graph`+renderLabelledGraph+ :: (RenderableVertices a, Show a)+ => MachineLabel+ -> Graph a+ -> Mermaid+renderLabelledGraph label graph =+ renderLabelledVertices label graph <> renderLabelledEdges label graph++-- | Render a `Graph` with no labels+renderGraph :: (RenderableVertices a, Show a) => Graph a -> Mermaid+renderGraph = renderLabelledGraph ""++-- | Turn a `Topology` into a `Graph`+topologyAsGraph :: Topology v -> Graph v+topologyAsGraph (Topology edges) = Graph $ edges >>= edgify+ where+ edgify :: (v, [v]) -> [(v, v)]+ edgify (v, vs) = (v,) <$> vs++-- | Interpret a `BaseMachine` as a `Graph` using the information contained in+-- its topology.+--+-- This is the point where we make usage of the machinery provided by the+-- [singletons](https://hackage.haskell.org/package/singletons) library, which+-- require us to impose the constraints we have on @vertex@ and @topology@+baseMachineAsGraph+ :: forall vertex topology input output m+ . ( Demote vertex ~ vertex+ , SingKind vertex+ , SingI topology+ )+ => BaseMachineT m (topology :: Topology vertex) input output+ -> Graph vertex+baseMachineAsGraph _ = topologyAsGraph (demote @topology)++-- | Render an `UntypedGraph` to the Mermaid format+renderUntypedStateDiagram :: UntypedGraph -> Mermaid+renderUntypedStateDiagram (UntypedGraph graph) = renderStateDiagram graph++-- | Render an `UntypedGraph`+renderUntypedGraph :: UntypedGraph -> Mermaid+renderUntypedGraph (UntypedGraph graph) = renderGraph graph++-- | Interpret a `StateMachine` as an `UntypedGraph` using the information+-- contained in its structure and in the topology of its basic components+machineAsGraph :: StateMachineT m input output -> UntypedGraph+machineAsGraph (Basic baseMachine) =+ UntypedGraph (baseMachineAsGraph baseMachine)+machineAsGraph (Sequential machine1 machine2) =+ untypedRemoveIdentityEdges $+ untypedProductGraph+ (untypedAddIdentityEdges $ machineAsGraph machine1)+ (untypedAddIdentityEdges $ machineAsGraph machine2)+machineAsGraph (Parallel machine1 machine2) =+ untypedRemoveIdentityEdges $+ untypedProductGraph+ (untypedAddIdentityEdges $ machineAsGraph machine1)+ (untypedAddIdentityEdges $ machineAsGraph machine2)+machineAsGraph (Alternative machine1 machine2) =+ untypedRemoveIdentityEdges $+ untypedProductGraph+ (untypedAddIdentityEdges $ machineAsGraph machine1)+ (untypedAddIdentityEdges $ machineAsGraph machine2)+machineAsGraph (Feedback machine1 machine2) =+ untypedRemoveIdentityEdges $+ untypedTransitiveClosureGraph $+ untypedProductGraph+ (untypedAddIdentityEdges $ machineAsGraph machine1)+ (untypedAddIdentityEdges $ machineAsGraph machine2)+machineAsGraph (Kleisli machine1 machine2) =+ untypedRemoveIdentityEdges $+ untypedProductGraph+ (untypedAddIdentityEdges $ machineAsGraph machine1)+ (untypedAddIdentityEdges $ untypedTransitiveClosureGraph $ machineAsGraph machine2)
+ src/Crem/Render/RenderFlow.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Rendering just the state space of a state machine might be sometimes+-- limiting.+--+-- Given that the `StateMachineT` data type encodes a lot of information on the+-- structure of a machine, we can actually use it to render a more informative+-- flow.+module Crem.Render.RenderFlow where++import Crem.Render.Render+import Crem.StateMachine++-- | A tree-like structure which could be used to attach metadata to any+-- similar tree-like structure with only leaves and nodes with exactly two+-- child.+data TreeMetadata a+ = LeafLabel a+ | BinaryLabel (TreeMetadata a) (TreeMetadata a)+ deriving stock (Show)++-- | Given a `StateMachineT` and a `TreeMetadata` of @MachineLabel@s, we can+-- create a flow representation of our machine.+--+-- For every leaf it will render the state space, while for every other node,+-- it will render the flow between the composed machines.+--+-- More details available in [\/docs\/how-to-render-a-machine.md](https://github.com/tweag/crem/tree/main/docs/how-to-render-a-machine.md)+renderFlow :: TreeMetadata MachineLabel -> StateMachineT m input output -> Either String (Mermaid, MachineLabel, MachineLabel)+renderFlow (LeafLabel label) (Basic machine) =+ Right+ ( Mermaid ("state " <> getLabel label <> " {")+ <> renderLabelledGraph label (baseMachineAsGraph machine)+ <> Mermaid "}"+ , label+ , label+ )+renderFlow (BinaryLabel leftLabels rightLabels) (Sequential machine1 machine2) = do+ (leftMermaid, leftLabelIn, leftLabelOut) <- renderFlow leftLabels machine1+ (rightMermaid, rightLabelIn, rightLabelOut) <- renderFlow rightLabels machine2+ Right+ ( leftMermaid+ <> rightMermaid+ <> Mermaid (getLabel leftLabelOut <> " --> " <> getLabel rightLabelIn)+ , leftLabelIn+ , rightLabelOut+ )+renderFlow (BinaryLabel upperLabels lowerLabels) (Parallel machine1 machine2) = do+ (upperMermaid, upperLabelIn, upperLabelOut) <- renderFlow upperLabels machine1+ (lowerMermaid, lowerLabelIn, lowerLabelOut) <- renderFlow lowerLabels machine2+ let+ inLabel = "fork_" <> getLabel upperLabelIn <> getLabel lowerLabelIn+ outLabel = "join_" <> getLabel upperLabelOut <> getLabel lowerLabelOut+ Right+ ( upperMermaid+ <> lowerMermaid+ <> Mermaid ("state " <> inLabel <> " <<fork>>")+ <> Mermaid ("state " <> outLabel <> " <<join>>")+ <> Mermaid (inLabel <> " --> " <> getLabel upperLabelIn)+ <> Mermaid (inLabel <> " --> " <> getLabel lowerLabelIn)+ <> Mermaid (getLabel upperLabelOut <> " --> " <> outLabel)+ <> Mermaid (getLabel lowerLabelOut <> " --> " <> outLabel)+ , MachineLabel inLabel+ , MachineLabel outLabel+ )+renderFlow (BinaryLabel upperLabels lowerLabels) (Alternative machine1 machine2) = do+ (upperMermaid, upperLabelIn, upperLabelOut) <- renderFlow upperLabels machine1+ (lowerMermaid, lowerLabelIn, lowerLabelOut) <- renderFlow lowerLabels machine2+ let+ inLabel = "fork_choice_" <> getLabel upperLabelIn <> getLabel lowerLabelIn+ outLabel = "join_choice_" <> getLabel upperLabelOut <> getLabel lowerLabelOut+ Right+ ( upperMermaid+ <> lowerMermaid+ <> Mermaid ("state " <> inLabel <> " <<choice>>")+ <> Mermaid ("state " <> outLabel <> " <<choice>>")+ <> Mermaid (inLabel <> " --> " <> getLabel upperLabelIn)+ <> Mermaid (inLabel <> " --> " <> getLabel lowerLabelIn)+ <> Mermaid (getLabel upperLabelOut <> " --> " <> outLabel)+ <> Mermaid (getLabel lowerLabelOut <> " --> " <> outLabel)+ , MachineLabel inLabel+ , MachineLabel outLabel+ )+renderFlow (BinaryLabel forwardLabels backwardsLabels) (Feedback machine1 machine2) = do+ (forwardMermaid, forwardLabelIn, forwardLabelOut) <- renderFlow forwardLabels machine1+ (backwardMermaid, backawardLabelIn, backwardLabelOut) <- renderFlow backwardsLabels machine2+ Right+ ( forwardMermaid+ <> backwardMermaid+ <> Mermaid (getLabel forwardLabelOut <> " --> " <> getLabel backawardLabelIn <> ": []")+ <> Mermaid (getLabel backwardLabelOut <> " --> " <> getLabel forwardLabelIn <> ": []")+ , forwardLabelIn+ , forwardLabelOut+ )+renderFlow (BinaryLabel leftLabels rightLabels) (Kleisli machine1 machine2) = do+ (leftMermaid, leftLabelIn, leftLabelOut) <- renderFlow leftLabels machine1+ (rightMermaid, rightLabelIn, rightLabelOut) <- renderFlow rightLabels machine2+ Right+ ( leftMermaid+ <> rightMermaid+ <> Mermaid (getLabel leftLabelOut <> " --> " <> getLabel rightLabelIn <> ": []")+ , leftLabelIn+ , rightLabelOut+ )+renderFlow labels _ = Left $ "Labels structure " <> show labels <> " does not match machine structure" -- TODO: this sucks
+ src/Crem/Render/RenderableVertices.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE UndecidableInstances #-}++-- | The `RenderableVertices` class describes which values of type @a@ should+-- be rendered when drawing a graph (or a topology) with vertices of type @a@+module Crem.Render.RenderableVertices where++import "base" Data.Functor.Const (Const (..))+import "base" Data.Functor.Identity (Identity (..))+import "base" Data.Monoid (Dual (..), Product (..), Sum (..))+import "base" Data.Ord (Down (..))+import "base" Data.Proxy (Proxy (..))+import "base" Data.Semigroup (All (..), Any (..), First (..), Last (..), Max (..), Min (..))+import "base" Data.Void (Void)++-- | The `RenderableVertices` class is implemented just as a list of elements+-- of type @a@.+class RenderableVertices a where+ vertices :: [a]++-- | This is a newtype to be used with `deriving via`. If @a@ has instances for+-- `Enum` and `Bounded`, then `AllVertices a` has an instance of+-- `RenderableVertices` which lists all the terms of type @a@.+newtype AllVertices a = AllVertices a++instance (Enum a, Bounded a) => RenderableVertices (AllVertices a) where+ vertices :: [AllVertices a]+ vertices = AllVertices <$> [minBound .. maxBound]++instance RenderableVertices Void where+ vertices :: [Void]+ vertices = []++deriving via AllVertices () instance RenderableVertices ()++deriving via AllVertices Bool instance RenderableVertices Bool++deriving newtype instance RenderableVertices All++deriving newtype instance RenderableVertices Any++deriving via AllVertices Ordering instance RenderableVertices Ordering++instance RenderableVertices a => RenderableVertices (Maybe a) where+ vertices :: [Maybe a]+ vertices =+ Nothing : (Just <$> vertices)++deriving newtype instance RenderableVertices a => RenderableVertices (Min a)++deriving newtype instance RenderableVertices a => RenderableVertices (Max a)++deriving newtype instance RenderableVertices a => RenderableVertices (First a)++deriving newtype instance RenderableVertices a => RenderableVertices (Last a)++deriving newtype instance RenderableVertices a => RenderableVertices (Identity a)++deriving newtype instance RenderableVertices a => RenderableVertices (Dual a)++deriving newtype instance RenderableVertices a => RenderableVertices (Sum a)++deriving newtype instance RenderableVertices a => RenderableVertices (Down a)++deriving newtype instance RenderableVertices a => RenderableVertices (Product a)++instance RenderableVertices (Proxy a) where+ vertices :: [Proxy a]+ vertices = [Proxy]++deriving newtype instance RenderableVertices a => RenderableVertices (Const a b)++instance (RenderableVertices a, RenderableVertices b) => RenderableVertices (Either a b) where+ vertices :: [Either a b]+ vertices =+ (Left <$> vertices)+ <> (Right <$> vertices)++instance (RenderableVertices a, RenderableVertices b) => RenderableVertices (a, b) where+ vertices :: [(a, b)]+ vertices = [(a, b) | a <- vertices, b <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c) => RenderableVertices (a, b, c) where+ vertices :: [(a, b, c)]+ vertices = [(a, b, c) | a <- vertices, b <- vertices, c <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c, RenderableVertices d) => RenderableVertices (a, b, c, d) where+ vertices :: [(a, b, c, d)]+ vertices = [(a, b, c, d) | a <- vertices, b <- vertices, c <- vertices, d <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c, RenderableVertices d, RenderableVertices e) => RenderableVertices (a, b, c, d, e) where+ vertices :: [(a, b, c, d, e)]+ vertices = [(a, b, c, d, e) | a <- vertices, b <- vertices, c <- vertices, d <- vertices, e <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c, RenderableVertices d, RenderableVertices e, RenderableVertices f) => RenderableVertices (a, b, c, d, e, f) where+ vertices :: [(a, b, c, d, e, f)]+ vertices = [(a, b, c, d, e, f) | a <- vertices, b <- vertices, c <- vertices, d <- vertices, e <- vertices, f <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c, RenderableVertices d, RenderableVertices e, RenderableVertices f, RenderableVertices g) => RenderableVertices (a, b, c, d, e, f, g) where+ vertices :: [(a, b, c, d, e, f, g)]+ vertices = [(a, b, c, d, e, f, g) | a <- vertices, b <- vertices, c <- vertices, d <- vertices, e <- vertices, f <- vertices, g <- vertices]++instance (RenderableVertices a, RenderableVertices b, RenderableVertices c, RenderableVertices d, RenderableVertices e, RenderableVertices f, RenderableVertices g, RenderableVertices h) => RenderableVertices (a, b, c, d, e, f, g, h) where+ vertices :: [(a, b, c, d, e, f, g, h)]+ vertices = [(a, b, c, d, e, f, g, h) | a <- vertices, b <- vertices, c <- vertices, d <- vertices, e <- vertices, f <- vertices, g <- vertices, h <- vertices]
+ src/Crem/StateMachine.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++-- | This is the main module of the whole library. It defines the central+-- `StateMachineT` type, which allows us to create composable state machines.+module Crem.StateMachine where++import Crem.BaseMachine as BaseMachine+import Crem.Render.RenderableVertices (RenderableVertices)+import Crem.Topology (AllowAllTopology, Topology)+import "base" Control.Arrow (Arrow (arr, first), ArrowChoice (left))+import "base" Control.Category (Category (..))+import "base" Data.Bifunctor (Bifunctor (second), bimap)+import "base" Data.Foldable (foldlM)+import "base" Data.Kind (Type)+import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))+import "singletons-base" Data.Singletons (Demote, SingI, SingKind)+import Prelude hiding ((.))++-- | A `StateMachineT` is an effectful [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)+-- with inputs of type @input@ and outputs of type @output@+--+-- Effects are described by the context @m@ in which the action of the machine+-- is executed+--+-- `StateMachineT` is a tree, where leaves are `BaseMachineT` and other nodes+-- describe how to combine the subtrees to obtain more complex machines.+--+-- Please refer to https://github.com/tweag/crem/blob/main/docs/how-to-create-a-machine.md+-- for a more complete discussion on the various constructors.+data StateMachineT m input output where+ -- | `Basic` allows to interpret a `BaseMachineT` as a `StateMachineT`,+ -- making the @topology@ type variable existential+ Basic+ :: forall m vertex (topology :: Topology vertex) input output+ . ( Demote vertex ~ vertex+ , SingKind vertex+ , SingI topology+ , Eq vertex+ , Show vertex+ , RenderableVertices vertex+ )+ => BaseMachineT m topology input output+ -> StateMachineT m input output+ -- | `Sequential` adds categorical composition for `StateMachineT`+ Sequential+ :: StateMachineT m a b+ -> StateMachineT m b c+ -> StateMachineT m a c+ -- | `Parallel` allows to process two machine simultaneously+ Parallel+ :: StateMachineT m a b+ -> StateMachineT m c d+ -> StateMachineT m (a, c) (b, d)+ -- | `Alternative` allows to process one out of two machines depending on the+ -- input+ Alternative+ :: StateMachineT m a b+ -> StateMachineT m c d+ -> StateMachineT m (Either a c) (Either b d)+ -- | `Feedback` allows to compose two machine going in oppositive directions+ -- and run them in a loop+ Feedback+ :: (Foldable n, Monoid (n a), Monoid (n b))+ => StateMachineT m a (n b)+ -> StateMachineT m b (n a)+ -> StateMachineT m a (n b)+ -- | `Kleisli` allows to compose sequentially machines which emit multiple+ -- outputs+ Kleisli+ :: (Foldable n, Monoid (n c))+ => StateMachineT m a (n b)+ -> StateMachineT m b (n c)+ -> StateMachineT m a (n c)++-- | A `StateMachine` is an effectful machine for every possible monad @m@.+-- Needing to work for every monad, in fact it can not perform any kind of+-- effect and needs to be pure in nature.+type StateMachine a b = forall m. Monad m => StateMachineT m a b++-- * Hoist++-- | Allows to change the context @m@ where the machine operates to another+-- context @n@, provided we have a [natural transformation](https://stackoverflow.com/a/58364172/2718064)+-- from @m@ to @n@+hoist :: (forall x. m x -> n x) -> StateMachineT m a b -> StateMachineT n a b+hoist f machine = case machine of+ Basic baseMachine -> Basic $ baseHoist f baseMachine+ Sequential machine1 machine2 -> Sequential (hoist f machine1) (hoist f machine2)+ Parallel machine1 machine2 -> Parallel (hoist f machine1) (hoist f machine2)+ Alternative machine1 machine2 -> Alternative (hoist f machine1) (hoist f machine2)+ Feedback machine1 machine2 -> Feedback (hoist f machine1) (hoist f machine2)+ Kleisli machine1 machine2 -> Kleisli (hoist f machine1) (hoist f machine2)++-- | a state machine which does not rely on state+statelessT :: Applicative m => (a -> m b) -> StateMachineT m a b+statelessT f = Basic $ statelessBaseT f++-- | a state machine which does not rely on state and does not perform side+-- effects+stateless :: Applicative m => (a -> b) -> StateMachineT m a b+stateless f = statelessT (pure . f)++-- | a machine modelled with explicit state, where every transition is allowed+unrestrictedMachine+ :: ( Demote vertex ~ vertex+ , SingKind vertex+ , SingI (AllowAllTopology @vertex)+ , Eq vertex+ , Show vertex+ , RenderableVertices vertex+ )+ => ( forall initialVertex+ . state initialVertex+ -> a+ -> ActionResult m (AllowAllTopology @vertex) state initialVertex b+ )+ -> InitialState (state :: vertex -> Type)+ -> StateMachineT m a b+unrestrictedMachine action state = Basic $ unrestrictedBaseMachineT action state++-- * Category++instance Monad m => Category (StateMachineT m) where+ id :: StateMachineT m a a+ id = Basic identity++ (.) :: StateMachineT m b c -> StateMachineT m a b -> StateMachineT m a c+ (.) = flip Sequential++-- * Profunctor++instance Applicative m => Profunctor (StateMachineT m) where+ lmap :: (a -> b) -> StateMachineT m b c -> StateMachineT m a c+ lmap f (Basic baseMachine) = Basic $ lmap f baseMachine+ lmap f (Sequential machine1 machine2) = Sequential (lmap f machine1) machine2+ lmap f machine = Sequential (stateless f) machine++ rmap :: (b -> c) -> StateMachineT m a b -> StateMachineT m a c+ rmap f (Basic baseMachine) = Basic $ rmap f baseMachine+ rmap f (Sequential machine1 machine2) = Sequential machine1 (rmap f machine2)+ rmap f machine = Sequential machine (stateless f)++-- * Strong++instance Monad m => Strong (StateMachineT m) where+ first' :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)+ first' = flip Parallel Control.Category.id++ second' :: StateMachineT m a b -> StateMachineT m (c, a) (c, b)+ second' = Parallel Control.Category.id++-- * Choice++-- | An instance of `Choice` allows us to have parallel composition of state+-- machines, meaning that we can pass two inputs to two state machines and get+-- out the outputs of both+instance Monad m => Choice (StateMachineT m) where+ left' :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)+ left' = flip Alternative Control.Category.id++ right' :: StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)+ right' = Alternative Control.Category.id++-- * Arrow++instance Monad m => Arrow (StateMachineT m) where+ arr :: (a -> b) -> StateMachineT m a b+ arr = stateless++ first :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)+ first = first'++-- * ArrowChoice++instance Monad m => ArrowChoice (StateMachineT m) where+ left :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)+ left = left'++-- * Run a state machine++-- | Given an @input@, run the machine to get an output and a new version of+-- the machine+run :: Monad m => StateMachineT m a b -> a -> m (b, StateMachineT m a b)+run (Basic baseMachine) a = second Basic <$> runBaseMachineT baseMachine a+run (Sequential machine1 machine2) a = do+ (output1, machine1') <- run machine1 a+ (output2, machine2') <- run machine2 output1+ pure (output2, Sequential machine1' machine2')+run (Parallel machine1 machine2) a = do+ (output1, machine1') <- run machine1 (fst a)+ (output2, machine2') <- run machine2 (snd a)+ pure ((output1, output2), Parallel machine1' machine2')+run (Alternative machine1 machine2) a =+ case a of+ Left a1 -> bimap Left (`Alternative` machine2) <$> run machine1 a1+ Right a2 -> bimap Right (machine1 `Alternative`) <$> run machine2 a2+run (Feedback machine1 machine2) a = do+ (bs, machine1') <- run machine1 a+ (as, machine2') <- runMultiple machine2 bs+ first (bs <>) <$> runMultiple (Feedback machine1' machine2') as+run (Kleisli machine1 machine2) a = do+ (bs, machine1') <- run machine1 a+ (cs, machine2') <- runMultiple machine2 bs+ pure (cs, Kleisli machine1' machine2')++-- | process multiple inputs in one go, accumulating the results in a monoid+runMultiple+ :: (Monad m, Foldable f, Monoid b)+ => StateMachineT m a b+ -> f a+ -> m (b, StateMachineT m a b)+runMultiple machine =+ foldlM+ (\(b, machine') a -> first (b <>) <$> run machine' a)+ (mempty, machine)
+ src/Crem/Topology.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- 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 #-}++-- | A `Topology` is a list of allowed transition for a state machine.+-- We are using it to enforce that only allowed transitions could be performed.+module Crem.Topology+ ( Topology (..)+ , TopologySym0+ , STopology (..)+ , AllowTransition (..)+ , AllowedTransition (..)+ , trivialTopology+ , sTrivialTopology+ , TrivialTopology+ , allowAllTopology+ , sAllowAllTopology+ , AllowAllTopology+ )+where++import "singletons-base" Data.Singletons.Base.TH+import "singletons-base" Prelude.Singletons++-- * Topology++-- | A `Topology` is a description of the topology of a state machine+-- It contains the collection of allowed transitions.+-- Since we are using this information at the type level, and then we want to+-- bring it down to the value level, we wrap it in `singletons`+$( singletons+ [d|+ newtype Topology vertex = Topology+ {edges :: [(vertex, [vertex])]}+ |]+ )++-- ** AllowedTransition++-- | An value of type of @AllowedTransition topology initial final@ is a proof+-- that the @topology@ allows transitions from the @initial@ to the @final@+-- state+data AllowTransition (topology :: Topology vertex) (initial :: vertex) (final :: vertex) where+ -- | We always allow an edge from a vertex to itself+ AllowIdentityEdge :: AllowTransition topology a a+ -- | If @a@ is the start and @b@ is the end of the first edge,+ -- then @map@ contains an edge from @a@ to @b@+ AllowFirstEdge :: AllowTransition ('Topology ('(a, b ': l1) ': l2)) a b+ -- | If we know that we have an edge from @a@ to @b@ in a topology,+ -- then we also have an edge from @a@ to @b@ if we add another edge out of @a@+ AllowAddingEdge+ :: AllowTransition ('Topology ('(a, l1) ': l2)) a b+ -> AllowTransition ('Topology ('(a, x ': l1) ': l2)) a b+ -- | If we know that we have an edge from @a@ to @b@ in @map@,+ -- then we also have an edge from @a@ to @b@ if we add another vertex+ AllowAddingVertex+ :: AllowTransition ('Topology map) a b+ -> AllowTransition ('Topology (x ': map)) a b++-- | The `AllowedTransition` type class enables to automatically perform proof search+-- for a `AllowTransition` term.+-- It has an instance for every constructor of `AllowTransition`+class AllowedTransition (topology :: Topology vertex) (initial :: vertex) (final :: vertex) where+ allowsTransition :: AllowTransition topology initial final++instance {-# INCOHERENT #-} AllowedTransition ('Topology ('(a, b ': l1) ': l2)) a b where+ allowsTransition = AllowFirstEdge++instance {-# INCOHERENT #-} AllowedTransition ('Topology ('(a, l1) ': l2)) a b => AllowedTransition ('Topology ('(a, x ': l1) ': l2)) a b where+ allowsTransition =+ AllowAddingEdge (allowsTransition :: AllowTransition ('Topology ('(a, l1) ': l2)) a b)++instance {-# INCOHERENT #-} AllowedTransition ('Topology map) a b => AllowedTransition ('Topology (x ': map)) a b where+ allowsTransition =+ AllowAddingVertex (allowsTransition :: AllowTransition ('Topology map) a b)++instance {-# INCOHERENT #-} AllowedTransition topology a a where+ allowsTransition = AllowIdentityEdge++-- ** Trivial topology++-- | The trivial topology only allows identity transitions.+-- Given a type @a@ for vertices, only trivial transitions, i.e. staying+-- at the same vertex, are allowed+$( singletons+ [d|+ trivialTopology :: Topology a+ trivialTopology = Topology []+ |]+ )++-- ** Allow all topology++-- | Given a type @a@ for vertices, every transition from one vertex to+-- any other is allowed+$( singletons+ [d|+ allowAllTopology :: (Bounded a, Enum a) => Topology a+ allowAllTopology = Topology [(a, [minBound .. maxBound]) | a <- [minBound .. maxBound]]+ |]+ )