crem 0.1.0.0 → 0.1.1.0

raw patch · 30 files changed

+1104/−467 lines, 30 filesdep +Cabaldep +ghcdep +machinesdep ~basedep ~doctest-paralleldep ~hspecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Cabal, ghc, machines, nothunks

Dependency ranges changed: base, doctest-parallel, hspec, singletons-base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• README.md +175/−0
• crem.cabal +35/−15
• examples/Crem/Example/Cart/Aggregate.hs +71/−0
• examples/Crem/Example/Cart/Application.hs +13/−0
• examples/Crem/Example/Cart/Domain.hs +9/−0
• examples/Crem/Example/Cart/Policy.hs +9/−0
• examples/Crem/Example/Cart/Projection.hs +13/−0
• examples/Crem/Example/Cart/Shipping.hs +83/−0
• examples/Crem/Example/LockDoor.hs +23/−14
• examples/Crem/Example/RiskManager/Aggregate.hs +29/−18
• examples/Crem/Example/RiskManager/Projection.hs +19/−8
• examples/Crem/Example/Switch.hs +10/−10
• examples/Crem/Example/TheHobbit.hs +50/−54
• examples/Crem/Example/TriangularMachine.hs +2/−0
• examples/Crem/Example/TwoSwitchesGate.hs +259/−0
• examples/Crem/Example/TwoSwitchesGate.lhs +0/−243
• examples/Crem/Example/Uno.hs +20/−9
• hobbit-game/Main.hs +7/−1
• spec/Crem/Render/RenderFlowSpec.hs +1/−1
• spec/Crem/RiskManagerSpec.hs +32/−32
• spec/Crem/StateMachineSpec.hs +76/−0
• src/Crem/BaseMachine.hs +19/−12
• src/Crem/Decider.hs +14/−4
• src/Crem/Graph.hs +9/−5
• src/Crem/Render/Render.hs +13/−3
• src/Crem/Render/RenderFlow.hs +10/−0
• src/Crem/Render/RenderableVertices.hs +13/−11
• src/Crem/StateMachine.hs +35/−10
• src/Crem/Topology.hs +41/−17

@@ -5,6 +5,20 @@ 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.1.0]++### Added++- Minimal documentation on how to play the Hobbit game+- Basic error handling for the Hobbit game+- Added README to `extra-source-files`+- Improved documentation+- Added Cart example+- Format code using Fourmolu 0.12+- Added nothunks instances+- Implemented `AutomatonM` instance for `StateMachineT`+- Support for GHC 9.10+ ## [0.1.0.0] - 2023-03-17  ### Added

@@ -0,0 +1,175 @@+# [crem](https://github.com/tweag/crem)++<img src="https://raw.githubusercontent.com/tweag/crem/main/logo/crem-transparent.png" width="200">++![CI status](https://github.com/tweag/crem/actions/workflows/ci.yml/badge.svg)++`crem` stands for **c**ompositional **r**epresentable **e**xecutable **m**achines.++It allows defining state machines (Mealy machines in fact), composing them to build bigger machines out of smaller ones and then running them and drawing their flow and their state space.++## What can you do with `crem`++### Defining state machines++`crem` allows you to define state machines so that you can enforce which state transitions are actually allowed by your machine.++If you try to implement a machine by running a transition which is not allowed, you will get a compilation error.++More details on how to define a machine at [How to create a machine](/docs/how-to-create-a-machine.md).++### Composing state machines++`crem` allows you to compose machines together to build more complex ones, proving a compositional language to implement state machines.++More details on how to compose machines at [How to compose machines](/docs/how-to-compose-machines.md)++### Rendering a state machine++Thanks to the information on the allowed transitions `crem` collects when you define a machine, it is able to produce a graphical representation of the flow and the state space of your machine.++One example of such an output is++![risk manager flow](https://mermaid.ink/svg/pako:eNqlVF1PwjAU_SvkPmkyCGCBbQ8mCvqkxkj0wSwhzXad1a4lXUdAsv9u9-HcCMgMfepOz73n3PbubsGXAYILsaYaZ4yGikbd1dATHbNysEPDUGGY7bYFnK0KXDzIGdX0BZXG9b7zqeQcfY3Bc4yqJfVOUjFDTRmPb5mK9eGQJ_SRrTCYKgyYvk4U0iQTORJWKV1x_renenmdbvfyxMqa1EMJ29ffLvGpt7TfzyH3R--0hZ1_5E7rzbqUnPmbeqcWyOLsvMH-bepMqOAUJ2WGhn5DQckPY4VJ0VCp0MWciZDjYwXs8bqjXlHrOpEvhU91XaSEdmupOcrSlSywIEIVURaY3ztP4oF-xwg9cM02oOrTA0-khpcsA6N4Y95CKnDfKI_RAppoOd8IH1ytEvwhlSOiYi2peJWy8Q3uFtbgkv6oN7ZtZ0xscjEZWbABdziY9IjjODaZkMFw0HdIasFXHt_vGQrmFu6LkZRPpvQbS36R_g)++More details on how to render a machine at [How to render a machine](/docs/how-to-render-a-machine.md)++### Running a machine++Last but not the least, you can also execute a machine, providing inputs to it and receiving the emitted outputs.++More details on how to run a machine at [How to run a machine](/docs/how-to-run-a-machine.md)++### Want to know more?++Further documentation can be found in the [docs](/docs) folder.++The [examples](/examples) folder contains a lot of examples, from simple machines to complex ones describing entire workflows.++I would recommend to check:++- [TwoSwitchesGate.lhs](/examples/Crem/Example/TwoSwitchesGate.lhs) if you want to see all the code which is needed to use the library with a quite detailed explanation.+- [RiskManager](/examples/Crem/Example/RiskManager/) if you want to see how to use `crem` to [model your domain using state machines](http://marcosh.github.io/post/2021/10/27/ddd-state-machines.html) following the ideas coming from Domain Driven Design.+- [Uno.hs](/examples/Crem/Example/Uno.hs) if you want to see how to structure a card game like [Uno](https://en.wikipedia.org/wiki/Uno_(card_game)), with an implementation ported from [UnoCore](https://github.com/thinkbeforecoding/UnoCore/blob/solution/Uno/Game.fs) by [@thinkb4coding@mastodon.social](https://functional.cafe/@thinkb4coding@mastodon.social).++Be sure to check out also the [spec](/spec) folder, where all the tests of the application are included, to see in practice what you can do with `crem`.++## Development++This is a Haskell Cabal project that uses Nix for development. Nix is optional but recommended.++### environment++A Nix shell is available with all the required tools. To enter the shell, issue++```sh+# default GHC+nix develop++# custom GHC+nix develop .#ghc90+nix develop .#ghc92+```++Or, without flakes:++```sh+# default GHC+nix-shell+```++### GHC version++The project has a default GHC version that is specified in the flake. At the moment that version is 9.0, because the HLS plugin Wingman [currently only builds up to this version](https://github.com/haskell/haskell-language-server/issues/2971).++It is also possible to use other GHC versions to build the project and enter development shells. This allows us to easily test multiple versions.++### Building++In a development shell, you can simply build the project with Cabal:++```sh+cabal build+```++This provides us fast incremental builds, ease of debugging, etc.++Inside the development shell, you can also use the commands++```sh+# just build the project+build-watch++# execute also the tests+test-watch+```++### Haddock documentation++You can generate and see the [Haddock] documentation by running++```sh+cabal haddock --open+```++### Code formatting++Code is formatted using [fourmolu](https://github.com/fourmolu/fourmolu) version 0.12.0.0.++### Cabal flags++We have a `cabal` flag called `errors` which allows enabling `-Werror`. It has a default of `False`, so that warning are not turned into errors.++In development and CI we use the flag `-f errors` so that we can avoid any warning in the library code.++### Changelog++All changes are tracked in the [`Changelog`](CHANGELOG.md).++## Project setup++You can find more details on the project setup on [Setup.md](/Setup.md).++## Known limitations++The project is still in its early stage and not everything is crafted to perfection.++Some known limitations to the current state of the project are:+- `crem` has not been tested on huge state machines. Compilation times might grow very rapidly.+- the topologies which `crem` allows you to define need to be finite, and not particularly big, either. For example, it is not feasible to use `Int` as the type of vertices for a topology.+- in its current state, the `StateMachine` type is not extensible. It has a predefined set of constructors, but maybe there are more which make sense and are not present yet.++Moreover, for current bugs and feature requests, you can check the [open issues](https://github.com/tweag/crem/issues).++## Credits++![tweag logo](./logo/tweag.png)++The initial development of `crem` was funded by [Tweag](https://www.tweag.io/).++## Contributions++Contributions are extremely welcome. If you have any idea on how to improve the library, its code or its documentation, feel free to open an [issue](https://github.com/tweag/crem/issues), create a [pull request](https://github.com/tweag/crem/pulls), or just contact directly one of the maintainers.++## Logo++The `crem` logo was kindly generated by [craiyon](https://www.craiyon.com/).++## Resources++If you want to know a bit more of `crem` and some ideas behind it, here are some additional resources you can check out:++- [Domain modelling with state machines](http://marcosh.github.io/post/2021/10/27/ddd-state-machines.html), the first blog post where I started considering using composable state machines for DDD-like architectures.+- [Composable Haskell state machines with `crem`](https://www.youtube.com/watch?v=cvbOG1I6wrU), if you prefer a video introducing `crem`.+- [State machines with `crem`](https://hackmd.io/@CJO5VbycTsyzjGBytbwezQ/rkJliIjRj#/) the slide deck used for the above presentation.+- [Crem: compositional representable executable machines](https://www.tweag.io/blog/2023-04-13-crem-state-machines/), a blog post explaining the main ideas of `crem`.+- [Domain modelling with state machines](https://www.youtube.com/watch?v=UBnHpnss8Fg), a video describing the main ideas motivating `crem`.+- [Crème de la Crem: Composable Representable Executable Machines](https://dl.acm.org/doi/10.1145/3609025.3609480?cid=99660990271), an academic paper describing the why and the how of `crem` (you can access it by clicking the link in [my blog](http://marcosh.github.io)).++## Projects using Crem++- [monadi-games-club](https://github.com/silky/monadic-games-club)+- [blackjack](https://github.com/beefyhalo/blackjack)+- [elevator](https://github.com/OlaoluwaM/elevator)++If you have a project which is using `Crem`, please let me know, or feel free to open a PR to add it to the list!

@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack  name:           crem-version:        0.1.0.0+version:        0.1.1.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@@ -19,10 +19,13 @@ build-type:     Simple tested-with:     GHC ==9.0.2-  , GHC ==9.2.7-  , GHC ==9.4.4-  , GHC ==9.6.1+  , GHC ==9.2.8+  , GHC ==9.4.8+  , GHC ==9.6.7+  , GHC ==9.8.4+  , GHC ==9.10.3 extra-source-files:+    README.md     CHANGELOG.md  flag errors@@ -46,12 +49,15 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      base >=4.15 && <4.21+    , machines >=0.7.3 && <0.8+    , nothunks >=0.1 && <0.4     , profunctors >=3.2 && <5.7-    , singletons-base >=3.0 && <3.3-    , text >=1.2 && <2.1+    , singletons-base >=3.0 && <3.5+    , text >=1.2 && <2.2   default-language: Haskell2010   if impl(ghc >= 9.2)     ghc-options: -Wno-missing-kind-signatures@@ -109,6 +115,12 @@ library crem-examples   exposed-modules:       Crem.Example.BooleanStateMachine+      Crem.Example.Cart.Aggregate+      Crem.Example.Cart.Application+      Crem.Example.Cart.Domain+      Crem.Example.Cart.Policy+      Crem.Example.Cart.Projection+      Crem.Example.Cart.Shipping       Crem.Example.LockDoor       Crem.Example.OneState       Crem.Example.PlusOneUpToFour@@ -128,9 +140,10 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      base >=4.15 && <4.21     , crem     , profunctors     , singletons-base@@ -197,9 +210,10 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      base >=4.15 && <4.21     , crem     , crem-examples   default-language: Haskell2010@@ -264,9 +278,10 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      base >=4.15 && <4.21     , crem     , crem-examples     , text@@ -333,12 +348,15 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      Cabal+    , base >=4.15 && <4.21     , crem     , crem-examples-    , doctest-parallel >=0.2.3 && <0.4+    , doctest-parallel >=0.2.3 && <0.5+    , ghc   default-language: Haskell2010   if impl(ghc >= 9.2)     ghc-options: -Wno-missing-kind-signatures@@ -409,14 +427,16 @@       DerivingStrategies       LambdaCase       PackageImports+      RoleAnnotations   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+      base >=4.15 && <4.21     , crem     , crem-examples-    , hspec >=2.7 && <2.11+    , hspec >=2.7 && <2.12+    , machines     , profunctors     , singletons-base   default-language: Haskell2010

@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies+{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif++-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}++module Crem.Example.Cart.Aggregate where++import Crem.BaseMachine+import Crem.Example.Cart.Domain+import Crem.Render.RenderableVertices+import Crem.StateMachine+import Crem.Topology+import "singletons-base" Data.Singletons.Base.TH++$( singletons+     [d|+       data CartVertex+         = WaitingForPayment+         | InitiatingPayment+         | PaymentComplete+         deriving stock (Eq, Show, Enum, Bounded)++       cartTopology :: Topology CartVertex+       cartTopology =+         Topology+           [ (WaitingForPayment, [InitiatingPayment])+           , (InitiatingPayment, [PaymentComplete])+           , (PaymentComplete, [])+           ]+       |]+ )++deriving via AllVertices CartVertex instance RenderableVertices CartVertex++data CartState (cartVertex :: CartVertex) where+  WaitingForPaymentState :: CartState WaitingForPayment+  InitiatingPaymentState :: CartState InitiatingPayment+  PaymentCompleteState :: CartState PaymentComplete++cartBasic :: BaseMachine CartTopology CartCommand [CartEvent]+cartBasic =+  BaseMachineT+    { initialState = InitialState WaitingForPaymentState+    , action = \case+        WaitingForPaymentState -> \case+          PayCart -> pureResult [CartPaymentInitiated] InitiatingPaymentState+          MarkCartAsPaid -> pureResult [] WaitingForPaymentState+        InitiatingPaymentState -> \case+          PayCart -> pureResult [] InitiatingPaymentState+          MarkCartAsPaid -> pureResult [CartPaymentCompleted] PaymentCompleteState+        PaymentCompleteState -> \_ -> pureResult [] PaymentCompleteState+    }++cart :: StateMachine CartCommand [CartEvent]+cart = Basic cartBasic

@@ -0,0 +1,13 @@+module Crem.Example.Cart.Application where++import Crem.Example.Cart.Aggregate+import Crem.Example.Cart.Domain+import Crem.Example.Cart.Policy+import Crem.Example.Cart.Projection+import Crem.StateMachine++writeModel :: StateMachine CartCommand [CartEvent]+writeModel = Feedback cart paymentGateway++application :: StateMachine CartCommand [CartView]+application = Kleisli writeModel paymentStatus

@@ -0,0 +1,9 @@+module Crem.Example.Cart.Domain where++data CartCommand+  = PayCart+  | MarkCartAsPaid++data CartEvent+  = CartPaymentInitiated+  | CartPaymentCompleted

@@ -0,0 +1,9 @@+module Crem.Example.Cart.Policy where++import Crem.Example.Cart.Domain+import Crem.StateMachine++paymentGateway :: StateMachine CartEvent [CartCommand]+paymentGateway = stateless $ \case+  CartPaymentInitiated -> [MarkCartAsPaid] -- in this word payments always succeed+  CartPaymentCompleted -> []

@@ -0,0 +1,13 @@+module Crem.Example.Cart.Projection where++import Crem.Example.Cart.Domain+import Crem.StateMachine++data CartView+  = Initiated+  | Completed++paymentStatus :: StateMachine CartEvent [CartView]+paymentStatus = stateless $ \case+  CartPaymentInitiated -> [Initiated]+  CartPaymentCompleted -> [Completed]

@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies+{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif++-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wredundant-constraints+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}++module Crem.Example.Cart.Shipping where++import Crem.BaseMachine+import Crem.Example.Cart.Aggregate+import Crem.Example.Cart.Domain+import Crem.Example.Cart.Projection+import Crem.Render.RenderableVertices+import Crem.StateMachine+import Crem.Topology+import "base" Control.Arrow hiding (Kleisli)+import "profunctors" Data.Profunctor+import "singletons-base" Data.Singletons.Base.TH++data ShippingCommand+  = StartShipping++data ShippingEvent++$( singletons+     [d|+       data ShippingVertex = ShippingVertex+         deriving stock (Eq, Show, Enum, Bounded)++       shippingTopology :: Topology ShippingVertex+       shippingTopology = Topology []+       |]+ )++deriving via AllVertices ShippingVertex instance RenderableVertices ShippingVertex++shippingBasic :: BaseMachine ShippingTopology ShippingCommand [ShippingEvent]+shippingBasic = undefined++shipping :: StateMachine ShippingCommand [ShippingEvent]+shipping = Basic shippingBasic++aggregateWithShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartEvent ShippingEvent]+aggregateWithShipping = rmap (fmap Left ||| fmap Right) $ cart +++ shipping++paymentCompletePolicy :: StateMachine CartEvent [ShippingCommand]+paymentCompletePolicy = stateless $ \case+  CartPaymentInitiated -> []+  CartPaymentCompleted -> [StartShipping]++writeModelWithShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartEvent ShippingEvent]+writeModelWithShipping =+  Feedback+    aggregateWithShipping+    (rmap (fmap Right) paymentCompletePolicy ||| stateless (const []))++data ShippingInfo++shippingInfo :: StateMachine ShippingEvent [ShippingInfo]+shippingInfo = undefined++readModel :: StateMachine (Either CartEvent ShippingEvent) [Either CartView ShippingInfo]+readModel = rmap (fmap Left ||| fmap Right) $ paymentStatus +++ shippingInfo++cartAndShipping :: StateMachine (Either CartCommand ShippingCommand) [Either CartView ShippingInfo]+cartAndShipping = Kleisli writeModelWithShipping readModel

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-}@@ -7,6 +8,14 @@ {-# 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 #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns@@ -20,21 +29,21 @@ import "singletons-base" Data.Singletons.Base.TH  $( singletons-    [d|-      data LockDoorVertex-        = IsLockOpen-        | IsLockClosed-        | IsLockLocked-        deriving stock (Eq, Show, Enum, Bounded)+     [d|+       data LockDoorVertex+         = IsLockOpen+         | IsLockClosed+         | IsLockLocked+         deriving stock (Eq, Show, Enum, Bounded) -      lockDoorTopology :: Topology LockDoorVertex-      lockDoorTopology =-        Topology-          [ (IsLockOpen, [IsLockClosed])-          , (IsLockClosed, [IsLockOpen, IsLockLocked])-          , (IsLockLocked, [IsLockClosed])-          ]-      |]+       lockDoorTopology :: Topology LockDoorVertex+       lockDoorTopology =+         Topology+           [ (IsLockOpen, [IsLockClosed])+           , (IsLockClosed, [IsLockOpen, IsLockLocked])+           , (IsLockLocked, [IsLockClosed])+           ]+       |]  )  deriving via AllVertices LockDoorVertex instance RenderableVertices LockDoorVertex

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-}@@ -5,6 +6,14 @@ {-# LANGUAGE UndecidableInstances #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns@@ -19,25 +28,25 @@ import "singletons-base" Data.Singletons.Base.TH  $( singletons-    [d|-      data AggregateVertex-        = NoDataVertex-        | CollectedUserDataVertex-        | CollectedLoanDetailsFirstVertex-        | ReceivedCreditBureauDataFirstVertex-        | CollectedAllDataVertex-        deriving stock (Eq, Show, Enum, Bounded)+     [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, [])-          ]-      |]+       aggregateTopology :: Topology AggregateVertex+       aggregateTopology =+         Topology+           [ (NoDataVertex, [CollectedUserDataVertex])+           , (CollectedUserDataVertex, [CollectedLoanDetailsFirstVertex, ReceivedCreditBureauDataFirstVertex])+           , (CollectedLoanDetailsFirstVertex, [CollectedAllDataVertex])+           , (ReceivedCreditBureauDataFirstVertex, [CollectedAllDataVertex])+           , (CollectedAllDataVertex, [])+           ]+       |]  )  deriving via AllVertices AggregateVertex instance RenderableVertices AggregateVertex@@ -48,6 +57,8 @@   CollectedLoanDetailsFirst :: UserData -> LoanDetails -> AggregateState 'CollectedLoanDetailsFirstVertex   ReceivedCreditBureauDataFirst :: UserData -> CreditBureauData -> AggregateState 'ReceivedCreditBureauDataFirstVertex   CollectedAllData :: UserData -> LoanDetails -> CreditBureauData -> AggregateState 'CollectedAllDataVertex++type role AggregateState nominal  riskAggregate :: BaseMachine AggregateTopology RiskCommand (Maybe RiskEvent) riskAggregate =

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-}@@ -6,6 +7,14 @@ {-# LANGUAGE UndecidableInstances #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns@@ -50,21 +59,23 @@       }  $( singletons-    [d|-      data ProjectionVertex-        = SingleProjectionVertex-        deriving stock (Eq, Show, Enum, Bounded)+     [d|+       data ProjectionVertex+         = SingleProjectionVertex+         deriving stock (Eq, Show, Enum, Bounded) -      projectionTopology :: Topology ProjectionVertex-      projectionTopology =-        Topology []-      |]+       projectionTopology :: Topology ProjectionVertex+       projectionTopology =+         Topology []+       |]  )  deriving via AllVertices ProjectionVertex instance RenderableVertices ProjectionVertex  data ProjectionState (vertex :: ProjectionVertex) where   SingleProjectionState :: ReceivedData -> ProjectionState 'SingleProjectionVertex++type role ProjectionState nominal  riskProjection :: BaseMachine ProjectionTopology RiskEvent ReceivedData riskProjection =

@@ -12,16 +12,16 @@ 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])-          ]-      |]+     [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 () ()

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-}@@ -5,11 +6,25 @@ {-# LANGUAGE UndecidableInstances #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns {-# OPTIONS_GHC -Wno-unused-type-patterns #-} +-- | This is a small adventure game based on [The Hobbit](https://en.wikipedia.org/wiki/The_Hobbit_(1982_video_game))+-- video game. You can play it by running @cabal run hobbit-game@. It will ask+-- you to enter commands. You need to use the precise names of the constructors+-- for the `HobbitCommand` data type, like `GoEast`, `GoWest` and so on.+-- Moreover, with the @cabal run hobbit-map@ command, you could generate, from+-- the definition of the state machine, a diagram with the map of the game. module Crem.Example.TheHobbit where  import Crem.BaseMachine@@ -35,29 +50,29 @@   mempty = HobbitMessage ""  $( singletons-    [d|-      data HobbitVertex-        = TunnelLikeHall-        | Lonelands-        | TrollsClearing-        | Rivendell-        | MistyMountain-        | TrollsPath-        | TrollsCave-        deriving stock (Eq, Show, Enum, Bounded)+     [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])-          ]-      |]+       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@@ -78,65 +93,46 @@   TrollsPathState :: KeyState -> HobbitState 'TrollsPath   TrollsCaveState :: HobbitState 'TrollsCave +type role HobbitState nominal+ stateMessage :: HobbitState vertex -> HobbitMessage stateMessage TunnelLikeHallState =   HobbitMessage-    "You are in a tunnel-like hall.\n\-    \You can only go east to the Lonelands"+    "You are in a tunnel-like hall.\nYou 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"+    "You are in the lonelands.\nYou can either go west to a tunnel-like hall\nor 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"+        "You are in the Trolls clearing.\nYou could go north to the Trolls path,\nyou can go east to Rivendell\nor 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"+        "You are in the Trolls clearing.\nYou could go north to the Trolls path,\nyou 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"+    "You are in Rivendell.\nYou could either go west to the Trolls clearing\nor go east to the Misty mountains\n" stateMessage (MistyMountainState _) =   HobbitMessage-    "You are in the Misty mountains.\n\-    \You can only go east to Rivendell"+    "You are in the Misty mountains.\nYou 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"+        "You are in the Trolls path.\nYou can go south to the Trolls clearing\nor 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"+        "You are in the Trolls path.\nYou can go south to the Trolls clearing\nor 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"+        "You are in the Trolls path.\nYou can go south to the Trolls clearing,\nyou can unlock the door to the Trolls cave\nor 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"+        "You are in the Trolls path.\nYou can go south to the Trolls clearing\nor 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"+    "Welcome to the Trolls cave!\nNow you can go back south to the Trolls path"  hobbitResult   :: (Applicative m, AllowedTransition HobbitTopology initialVertex finalVertex)

@@ -9,6 +9,8 @@ data TriangularState (a :: ()) where   OnlyState :: Int -> TriangularState '() +type role TriangularState nominal+ triangular :: StateMachine Int Int triangular =   unrestrictedMachine

@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies+{-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}+-- 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 #-}++-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+module Crem.Example.TwoSwitchesGate where++import "base" Data.Functor.Identity+import "crem" Crem.BaseMachine+import "crem" Crem.Render.Render+import "crem" Crem.Render.RenderFlow+import "crem" Crem.Render.RenderableVertices (AllVertices (..), RenderableVertices)+import "crem" Crem.StateMachine+import "crem" Crem.Topology+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++type role SwitchState nominal++-- 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.

@@ -1,243 +0,0 @@-> {-# 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.

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# HLINT ignore "Redundant id" #-} {-# LANGUAGE DeriveAnyClass #-}@@ -7,6 +8,14 @@ {-# LANGUAGE UndecidableInstances #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunrecognised-pragmas {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors@@ -168,15 +177,15 @@ -- * Topology  $( singletons-    [d|-      data UnoVertex-        = Initial-        | Started-        deriving stock (Eq, Show, Enum, Bounded)+     [d|+       data UnoVertex+         = Initial+         | Started+         deriving stock (Eq, Show, Enum, Bounded) -      unoTopology :: Topology UnoVertex-      unoTopology = Topology [(Initial, [Started])]-      |]+       unoTopology :: Topology UnoVertex+       unoTopology = Topology [(Initial, [Started])]+       |]  )  deriving via AllVertices UnoVertex instance RenderableVertices UnoVertex@@ -192,6 +201,8 @@   UnoInitialState :: UnoState 'Initial   UnoStartedState :: StateData -> UnoState 'Started +type role UnoState nominal+ -- * Errors  data GameError@@ -264,7 +275,7 @@     }   where     initialResult-      :: AllowedTransition UnoTopology initialVertex 'Started+      :: (AllowedTransition UnoTopology initialVertex 'Started)       => InitialData       -> PlayerId       -> EvolutionResult UnoTopology UnoState initialVertex (Either GameError Event)

@@ -3,6 +3,7 @@ module Main where  import "base" Data.Functor.Identity+import "base" System.IO.Error import "crem" Crem.Example.TheHobbit import "crem" Crem.StateMachine @@ -18,9 +19,14 @@   putStrLn initialMessage   loop (Basic $ hobbitMachine initialState)   where+    commandLoop :: IO HobbitCommand+    commandLoop = catchIOError readLn . const $ do+      putStrLn "The command you provided is invalid. The valid commands are GoEast, GoWest, GoNorth, GoSouth, Wait, GetKey and UnlockDoor. Please try again."+      commandLoop+     loop :: StateMachineT Identity HobbitCommand HobbitMessage -> IO ()     loop machine = do-      command <- readLn+      command <- commandLoop       let         (message, machine') = runIdentity $ run machine command       putStrLn $ getMessage message

@@ -20,7 +20,7 @@           `shouldBe` Right             ( Mermaid "state lockMachine {"                 <> ( renderLabelledGraph "lockMachine" . baseMachineAsGraph @_ @_ @_ @_ @Identity $-                      lockDoorMachine SIsLockClosed+                       lockDoorMachine SIsLockClosed                    )                 <> Mermaid "}"             , MachineLabel "lockMachine"

@@ -136,58 +136,58 @@       it "registers one user when a registration event is received" $ do         run readModel (UserDataRegistered myUserData)           `shouldOutput` [ ReceivedData-                            { receivedUserData = Just myUserData-                            , receivedLoanDetails = Nothing-                            , receivedCreditBureauData = Nothing-                            }+                             { 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-                            }+                             { receivedUserData = Just myUserData+                             , receivedLoanDetails = Nothing+                             , receivedCreditBureauData = Nothing+                             }                          , ReceivedData-                            { receivedUserData = Just notMyUserData-                            , receivedLoanDetails = Nothing-                            , receivedCreditBureauData = Nothing-                            }+                             { 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-                            }+                             { receivedUserData = Just myUserData+                             , receivedLoanDetails = Nothing+                             , receivedCreditBureauData = Nothing+                             }                          , ReceivedData-                            { receivedUserData = Just myUserData-                            , receivedLoanDetails = Nothing-                            , receivedCreditBureauData = Just creditBureauData-                            }+                             { 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-                            }+                             { receivedUserData = Just myUserData+                             , receivedLoanDetails = Nothing+                             , receivedCreditBureauData = Nothing+                             }                          , ReceivedData-                            { receivedUserData = Just myUserData-                            , receivedLoanDetails = Nothing-                            , receivedCreditBureauData = Just creditBureauData-                            }+                             { receivedUserData = Just myUserData+                             , receivedLoanDetails = Nothing+                             , receivedCreditBureauData = Just creditBureauData+                             }                          , ReceivedData-                            { receivedUserData = Just notMyUserData-                            , receivedLoanDetails = Nothing-                            , receivedCreditBureauData = Just creditBureauData-                            }+                             { receivedUserData = Just notMyUserData+                             , receivedLoanDetails = Nothing+                             , receivedCreditBureauData = Just creditBureauData+                             }                          ]      describe "riskApplication" $ do

@@ -9,6 +9,9 @@ import "base" Data.List (singleton) import "crem" Crem.StateMachine import "hspec" Test.Hspec (Expectation, Spec, describe, it, shouldBe)+import "machines" Data.Machine (runT, source, (~>))+import "machines" Data.Machine.Process (autoT)+import "machines" Data.Machine.Process qualified import "profunctors" Data.Profunctor (rmap) import "singletons-base" Data.Singletons.Base.TH @@ -116,3 +119,76 @@          it "processes correctly multiple inputs" $ do           runMultiple (Feedback echo plus1UpTo4) [1, 1] `shouldOutput` [1, 2, 3, 4, 5, 1, 2, 3, 4, 5]++    describe "AutomatonM instance" $ do+      describe "autoT converts StateMachineT to ProcessT" $ do+        it "processes a single input through a stateless machine" $ do+          let machine = stateless (+ 1) :: StateMachineT Identity Int Int+          let process = autoT machine+          let result = runIdentity $ runT $ source [5] ~> process+          result `shouldBe` [6]++        it "processes multiple inputs through a stateless machine" $ do+          let machine = stateless (* 2) :: StateMachineT Identity Int Int+          let process = autoT machine+          let result = runIdentity $ runT $ source [1, 2, 3, 4] ~> process+          result `shouldBe` [2, 4, 6, 8]++        it "processes inputs through a stateful machine (switch)" $ do+          let machine = Basic $ switchMachine SFalse :: StateMachineT Identity () ()+          let process = autoT machine+          let result = runIdentity $ runT $ source [(), (), ()] ~> process+          result `shouldBe` [(), (), ()]++        it "maintains state across inputs (lock door)" $ do+          let machine = Basic $ lockDoorMachine SIsLockClosed :: StateMachineT Identity LockDoorCommand LockDoorEvent+          let process = autoT machine :: Data.Machine.Process.ProcessT Identity LockDoorCommand LockDoorEvent+          let result = runIdentity $ runT $ source [LockLock, LockUnlock, LockOpen] ~> process+          result `shouldBe` [LockLocked, LockUnlocked, LockOpened]++        it "works with sequential composition" $ do+          let machine1 = stateless (+ 1) :: StateMachineT Identity Int Int+          let machine2 = stateless (* 2) :: StateMachineT Identity Int Int+          let composed = machine2 Control.Category.. machine1 -- Category composition: right-to-left+          let process = autoT composed+          let result = runIdentity $ runT $ source [1, 2, 3] ~> process+          result `shouldBe` [4, 6, 8]++        it "works with parallel composition" $ do+          let machine1 = stateless (+ 1) :: StateMachineT Identity Int Int+          let machine2 = stateless (* 2) :: StateMachineT Identity Int Int+          let parallel = Parallel machine1 machine2+          let process = autoT parallel+          let result = runIdentity $ runT $ source [(1, 10), (2, 20), (3, 30)] ~> process+          result `shouldBe` [(2, 20), (3, 40), (4, 60)]++        it "works with alternative composition (left)" $ do+          let machine1 = stateless (+ 1) :: StateMachineT Identity Int Int+          let machine2 = stateless (* 2) :: StateMachineT Identity Int Int+          let alt = Alternative machine1 machine2+          let process = autoT alt+          let result = runIdentity $ runT $ source [Left 1, Left 2, Left 3] ~> process+          result `shouldBe` [Left 2, Left 3, Left 4]++        it "works with alternative composition (right)" $ do+          let machine1 = stateless (+ 1) :: StateMachineT Identity Int Int+          let machine2 = stateless (* 2) :: StateMachineT Identity Int Int+          let alt = Alternative machine1 machine2+          let process = autoT alt+          let result = runIdentity $ runT $ source [Right 1, Right 2, Right 3] ~> process+          result `shouldBe` [Right 2, Right 4, Right 6]++        it "works with mixed alternative composition" $ do+          let machine1 = stateless (+ 1) :: StateMachineT Identity Int Int+          let machine2 = stateless (* 2) :: StateMachineT Identity Int Int+          let alt = Alternative machine1 machine2+          let process = autoT alt+          let result = runIdentity $ runT $ source [Left 1, Right 5, Left 2] ~> process+          result `shouldBe` [Left 2, Right 10, Left 3]++        it "handles boolean state machine correctly" $ do+          let machine = booleanStateMachine SFalse :: StateMachineT Identity Int Int+          let process = autoT machine :: Data.Machine.Process.ProcessT Identity Int Int+          let result = runIdentity $ runT $ source [0, 1, 0] ~> process+          -- Starting at SFalse: 0 (even) -> 1, stay SFalse; 1 (odd) -> 3, move to STrue; 0 (even) -> -1, stay STrue+          result `shouldBe` [1, 3, -1]

@@ -25,7 +25,8 @@     m     (topology :: Topology vertex)     (input :: Type)-    (output :: Type) = forall state.+    (output :: Type)+  = forall state.   BaseMachineT   { initialState :: InitialState state   , action@@ -35,6 +36,8 @@       -> ActionResult m topology state initialVertex output   } +type role BaseMachineT representational nominal representational nominal+ -- | 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.@@ -42,7 +45,7 @@   (topology :: Topology vertex)   (input :: Type)   (output :: Type) =-  forall m. Monad m => BaseMachineT m topology input output+  forall m. (Monad m) => BaseMachineT m topology input output  -- * Hoist @@ -58,7 +61,7 @@     initialState     ((hoistResult f .) . action) -instance Functor m => Profunctor (BaseMachineT m topology) where+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@@ -73,7 +76,7 @@       , action = ((f <$>) .) . action       } -instance Functor m => Strong (BaseMachineT m topology) where+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@@ -88,7 +91,7 @@       , action = \state (c, a) -> (c,) <$> action state a       } -instance Applicative m => Choice (BaseMachineT m topology) where+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@@ -113,6 +116,8 @@ data InitialState (state :: vertex -> Type) where   InitialState :: state vertex -> InitialState state +type role InitialState representational+ -- | 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@@ -126,10 +131,12 @@     (output :: Type)   where   ActionResult-    :: AllowedTransition topology initialVertex finalVertex+    :: (AllowedTransition topology initialVertex finalVertex)     => m (output, state finalVertex)     -> ActionResult m topology state initialVertex output +type role ActionResult representational nominal nominal nominal nominal+ -- | 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@.@@ -139,7 +146,7 @@   -> ActionResult n topology state initialVertex output hoistResult f (ActionResult outputStatePair) = ActionResult $ f outputStatePair -instance Functor m => Functor (ActionResult m topology state initialVertex) where+instance (Functor m) => Functor (ActionResult m topology state initialVertex) where   fmap     :: (a -> b)     -> ActionResult m topology state initialVertex a@@ -160,7 +167,7 @@ -- it does the same job, with the slight difference that `sequenceA` would -- return @f (ActionResult Identity topology state initialVertex output)@ sequence-  :: Functor f+  :: (Functor f)   => ActionResult Identity topology state initialVertex (f output)   -> ActionResult f topology state initialVertex output sequence (ActionResult (Identity (outputs, state))) =@@ -172,7 +179,7 @@ -- 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+  :: (Applicative m)   => BaseMachineT m topology a b   -> BaseMachineT m topology (Maybe a) (Maybe b) maybeM (BaseMachineT initialState action) =@@ -187,7 +194,7 @@ -- 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+  :: (Applicative m)   => BaseMachineT m topology a b   -> BaseMachineT m topology (Either e a) (Either e b) eitherM (BaseMachineT initialState action) =@@ -202,7 +209,7 @@  -- | `statelessBaseT` transforms its input to its output and never changes its -- state-statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b+statelessBaseT :: (Applicative m) => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b statelessBaseT f =   BaseMachineT     { initialState = InitialState STuple0@@ -240,7 +247,7 @@ -- | Given an @input@, run the machine to get an output and a new version of -- the machine runBaseMachineT-  :: Functor m+  :: (Functor m)   => BaseMachineT m topology input output   -> input   -> m (output, BaseMachineT m topology input output)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}  -- | The [Decider pattern](https://thinkbeforecoding.com/post/2021/12/17/functional-event-sourcing-decider)@@ -10,7 +11,11 @@  import Crem.BaseMachine (ActionResult (..), BaseMachine, BaseMachineT (..), InitialState (..)) import Crem.Topology (AllowedTransition, Topology)-import Data.Foldable (foldl')++#if __GLASGOW_HASKELL__ < 910+import "base" Data.Foldable (foldl')+#endif+ import "base" Data.Kind (Type)  -- | A @Decider topology input output@ is a Decider which receives inputs of@@ -31,7 +36,8 @@   Decider     (topology :: Topology vertex)     input-    output = forall state.+    output+  = forall state.   Decider   { deciderInitialState :: InitialState state   , decide :: forall vertex'. input -> state vertex' -> output@@ -42,6 +48,8 @@       -> EvolutionResult topology state initialVertex output   } +type role Decider nominal representational representational+ -- | A smart wrapper over the machine state, which allows to enforce that only -- transitions allowed by the @topology@ are actually performed. data@@ -49,12 +57,14 @@     (topology :: Topology vertex)     (state :: vertex -> Type)     (initialVertex :: vertex)-    output+    (output :: k)   where   EvolutionResult-    :: AllowedTransition topology initialVertex finalVertex+    :: (AllowedTransition topology initialVertex finalVertex)     => state finalVertex     -> EvolutionResult topology state initialVertex output++type role EvolutionResult nominal representational nominal phantom  -- | translate a `Decider` into a `BaseMachine` deciderMachine

@@ -3,13 +3,17 @@  import Crem.Render.RenderableVertices (RenderableVertices (..)) import "base" Data.List (nub)+import "nothunks" NoThunks.Class (NoThunks (..))  -- * Graph  -- | A graph is just a list of edges between vertices of type @a@ newtype Graph a = Graph [(a, a)]   deriving stock (Eq, Show)+  deriving newtype (NoThunks) +type role Graph representational+ -- | 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@@ -27,7 +31,7 @@  -- | 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 :: (Eq a) => Graph a -> Graph a transitiveClosureGraph graph@(Graph edges) =   Graph $     foldr@@ -37,10 +41,10 @@       []       (nub $ fst <$> edges)   where-    edgesFrom :: Eq a => Graph a -> a -> [(a, a)]+    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 :: forall a. (Eq a) => Graph a -> a -> [(a, a)]     pathsFrom g a =       let         edgesFromAToB = edgesFrom g a@@ -50,11 +54,11 @@         edgesFromAToB <> edgesFromAToC  -- | Add all the identity edges to a graph-addIdentityEdges :: RenderableVertices a => Graph a -> Graph a+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 :: (Eq a) => Graph a -> Graph a removeIdentityEdges (Graph edges) = Graph $ filter (uncurry (/=)) edges  -- * UntypedGraph

@@ -43,7 +43,7 @@   Mermaid "stateDiagram-v2\n" <> renderGraph graph  -- | Prepends a `MachineLabel` to the `Show` output, as a `Text`-labelVertex :: Show a => MachineLabel -> a -> Text+labelVertex :: (Show a) => MachineLabel -> a -> Text labelVertex label =   let     prefix =@@ -68,13 +68,13 @@ renderVertices = renderLabelledVertices ""  -- | Render all the edges of a graph after labelling all of them-renderLabelledEdges :: Show a => MachineLabel -> Graph a -> Mermaid+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 :: (Show a) => Graph a -> Mermaid renderEdges = renderLabelledEdges ""  -- | Join the outputs of `renderLabelledVertices` and `renderLabelledEdges` to@@ -97,6 +97,16 @@   where     edgify :: (v, [v]) -> [(v, v)]     edgify (v, vs) = (v,) <$> vs++baseMachineTopology+  :: forall vertex topology input output m+   . ( Demote vertex ~ vertex+     , SingKind vertex+     , SingI topology+     )+  => BaseMachineT m (topology :: Topology vertex) input output+  -> Topology vertex+baseMachineTopology _ = demote @topology  -- | Interpret a `BaseMachine` as a `Graph` using the information contained in -- its topology.

@@ -11,6 +11,7 @@  import Crem.Render.Render import Crem.StateMachine+import "nothunks" NoThunks.Class (NoThunks (..), allNoThunks)  -- | 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@@ -19,6 +20,15 @@   = LeafLabel a   | BinaryLabel (TreeMetadata a) (TreeMetadata a)   deriving stock (Show)++type role TreeMetadata representational++instance (NoThunks a) => NoThunks (TreeMetadata a) where+  showTypeOf _ = "TreeMetadata"+  wNoThunks ctxt tm =+    case tm of+      LeafLabel x -> noThunks ctxt x+      BinaryLabel x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]  -- | Given a `StateMachineT` and a `TreeMetadata` of @MachineLabel@s, we can -- create a flow representation of our machine.

@@ -23,6 +23,8 @@ -- `RenderableVertices` which lists all the terms of type @a@. newtype AllVertices a = AllVertices a +type role AllVertices representational+ instance (Enum a, Bounded a) => RenderableVertices (AllVertices a) where   vertices :: [AllVertices a]   vertices = AllVertices <$> [minBound .. maxBound]@@ -41,34 +43,34 @@  deriving via AllVertices Ordering instance RenderableVertices Ordering -instance RenderableVertices a => RenderableVertices (Maybe a) where+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 (Min a) -deriving newtype instance RenderableVertices a => RenderableVertices (Max a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Max a) -deriving newtype instance RenderableVertices a => RenderableVertices (First a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (First a) -deriving newtype instance RenderableVertices a => RenderableVertices (Last a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Last a) -deriving newtype instance RenderableVertices a => RenderableVertices (Identity a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Identity a) -deriving newtype instance RenderableVertices a => RenderableVertices (Dual a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Dual a) -deriving newtype instance RenderableVertices a => RenderableVertices (Sum a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Sum a) -deriving newtype instance RenderableVertices a => RenderableVertices (Down a)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Down a) -deriving newtype instance RenderableVertices a => RenderableVertices (Product 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)+deriving newtype instance (RenderableVertices a) => RenderableVertices (Const a b)  instance (RenderableVertices a, RenderableVertices b) => RenderableVertices (Either a b) where   vertices :: [Either a b]

@@ -14,6 +14,9 @@ import "base" Data.Bifunctor (Bifunctor (second), bimap) import "base" Data.Foldable (foldlM) import "base" Data.Kind (Type)+import "machines" Data.Machine.MealyT qualified as Machines+import "machines" Data.Machine.Process qualified as Machines+import "nothunks" NoThunks.Class (NoThunks (..), allNoThunks) import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..)) import "singletons-base" Data.Singletons (Demote, SingI, SingKind) import Prelude hiding ((.))@@ -74,10 +77,23 @@     -> StateMachineT m b (n c)     -> StateMachineT m a (n c) +type role StateMachineT representational nominal nominal++instance NoThunks (StateMachineT m input output) where+  showTypeOf _ = "StateMachineT"+  wNoThunks ctxt sm =+    case sm of+      Basic _ -> return Nothing+      Sequential x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]+      Parallel x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]+      Alternative x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]+      Feedback x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]+      Kleisli x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]+ -- | 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+type StateMachine a b = forall m. (Monad m) => StateMachineT m a b  -- * Hoist @@ -94,12 +110,12 @@   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 :: (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 :: (Applicative m) => (a -> b) -> StateMachineT m a b stateless f = statelessT (pure . f)  -- | a machine modelled with explicit state, where every transition is allowed@@ -122,7 +138,7 @@  -- * Category -instance Monad m => Category (StateMachineT m) where+instance (Monad m) => Category (StateMachineT m) where   id :: StateMachineT m a a   id = Basic identity @@ -131,7 +147,7 @@  -- * Profunctor -instance Applicative m => Profunctor (StateMachineT m) where+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@@ -144,7 +160,7 @@  -- * Strong -instance Monad m => Strong (StateMachineT m) where+instance (Monad m) => Strong (StateMachineT m) where   first' :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)   first' = flip Parallel Control.Category.id @@ -156,7 +172,7 @@ -- | 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+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 @@ -165,7 +181,7 @@  -- * Arrow -instance Monad m => Arrow (StateMachineT m) where+instance (Monad m) => Arrow (StateMachineT m) where   arr :: (a -> b) -> StateMachineT m a b   arr = stateless @@ -174,15 +190,24 @@  -- * ArrowChoice -instance Monad m => ArrowChoice (StateMachineT m) where+instance (Monad m) => ArrowChoice (StateMachineT m) where   left :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)   left = left' +-- * AutomatonM++instance Machines.AutomatonM StateMachineT where+  autoT :: (Monad m) => StateMachineT m a b -> Machines.ProcessT m a b+  autoT = Machines.autoT . go+    where+      go :: (Monad m) => StateMachineT m a b -> Machines.MealyT m a b+      go sm = Machines.MealyT $ fmap (fmap go) . run sm+ -- * 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 :: (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

@@ -1,7 +1,21 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-}++#if __GLASGOW_HASKELL__ >= 908+{-# LANGUAGE TypeAbstractions #-}+#endif+ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 908+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-poly-kind-signatures+{-# OPTIONS_GHC -Wno-missing-poly-kind-signatures #-}+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag-Wmissing-role-annotations+{-# OPTIONS_GHC -Wno-missing-role-annotations #-}+#endif+ -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wredundant-constraints {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunticked-promoted-constructors@@ -26,6 +40,7 @@   ) where +import "nothunks" NoThunks.Class (NoThunks (..)) import "singletons-base" Data.Singletons.Base.TH import "singletons-base" Prelude.Singletons @@ -36,10 +51,10 @@ -- 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])]}-      |]+     [d|+       newtype Topology vertex = Topology+         {edges :: [(vertex, [vertex])]}+       |]  )  -- ** AllowedTransition@@ -61,9 +76,18 @@   -- | 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+    :: AllowTransition ('Topology tmap) a b+    -> AllowTransition ('Topology (x ': tmap)) a b +instance NoThunks (AllowTransition topology initial final) where+  showTypeOf _ = "AllowTransition"+  wNoThunks ctxt at =+    case at of+      AllowIdentityEdge -> return Nothing+      AllowFirstEdge -> return Nothing+      AllowAddingEdge x -> noThunks ctxt x+      AllowAddingVertex x -> noThunks ctxt x+ -- | The `AllowedTransition` type class enables to automatically perform proof search -- for a `AllowTransition` term. -- It has an instance for every constructor of `AllowTransition`@@ -73,13 +97,13 @@ 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+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+instance {-# INCOHERENT #-} (AllowedTransition ('Topology tmap) a b) => AllowedTransition ('Topology (x ': tmap)) a b where   allowsTransition =-    AllowAddingVertex (allowsTransition :: AllowTransition ('Topology map) a b)+    AllowAddingVertex (allowsTransition :: AllowTransition ('Topology tmap) a b)  instance {-# INCOHERENT #-} AllowedTransition topology a a where   allowsTransition = AllowIdentityEdge@@ -90,10 +114,10 @@ -- 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 []-      |]+     [d|+       trivialTopology :: Topology a+       trivialTopology = Topology []+       |]  )  -- ** Allow all topology@@ -101,8 +125,8 @@ -- | 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]]-      |]+     [d|+       allowAllTopology :: (Bounded a, Enum a) => Topology a+       allowAllTopology = Topology [(a, [minBound .. maxBound]) | a <- [minBound .. maxBound]]+       |]  )