render all vertices of a machine

package.yaml

@@ -114,7 +114,6 @@ tests:
       - hspec
       - profunctors
       - singletons-base
-      - text
     when:
     - condition: false
       other-modules: Paths_crm

spec/CRM/Render/RenderFlowSpec.hs

@@ -1,9 +1,9 @@
-module CRM.RenderFlowSpec where
+module CRM.Render.RenderFlowSpec where
 
 import "crm" CRM.Example.LockDoor (SLockDoorVertex (..), lockDoorMachine)
 import "crm" CRM.Example.RiskManager.Application (riskApplication)
-import "crm" CRM.Render (Mermaid (..), baseMachineAsGraph, renderGraph)
-import "crm" CRM.RenderFlow (MachineLabel (..), TreeMetadata (..), renderFlow)
+import "crm" CRM.Render.Render (MachineLabel (..), Mermaid (..), baseMachineAsGraph, renderLabelledGraph)
+import "crm" CRM.Render.RenderFlow (TreeMetadata (..), renderFlow)
 import "crm" CRM.StateMachine (StateMachineT (..), stateless)
 import "base" Data.Functor.Identity (Identity)
 import "base" Data.List (singleton)
@@ -17,7 +17,7 @@ spec =
         renderFlow @Identity (LeafLabel "lockMachine") (Basic $ lockDoorMachine SIsLockClosed)
           `shouldBe` Right
             ( Mermaid "state lockMachine {"
-                <> ( renderGraph . baseMachineAsGraph @_ @_ @_ @_ @Identity $
+                <> ( renderLabelledGraph "lockMachine" . baseMachineAsGraph @_ @_ @_ @_ @Identity $
                       lockDoorMachine SIsLockClosed
                    )
                 <> Mermaid "}"
@@ -34,7 +34,7 @@ spec =
               (stateless length)
           )
           `shouldBe` Right
-            ( Mermaid "state show {\n\n}\nstate length {\n\n}\nshow --> length"
+            ( Mermaid "state show {\nshow_()\n}\nstate length {\nlength_()\n}\nshow --> length"
             , MachineLabel "show"
             , MachineLabel "length"
             )
@@ -48,7 +48,7 @@ spec =
               (stateless $ length @[] @String)
           )
           `shouldBe` Right
-            ( Mermaid "state foo {\n\n}\nstate bar {\n\n}\nstate fork_foobar <<fork>>\nstate join_foobar <<join>>\nfork_foobar --> foo\nfork_foobar --> bar\nfoo --> join_foobar\nbar --> join_foobar"
+            ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nstate fork_foobar <<fork>>\nstate join_foobar <<join>>\nfork_foobar --> foo\nfork_foobar --> bar\nfoo --> join_foobar\nbar --> join_foobar"
             , MachineLabel "fork_foobar"
             , MachineLabel "join_foobar"
             )
@@ -62,7 +62,7 @@ spec =
               (stateless $ length @[] @String)
           )
           `shouldBe` Right
-            ( Mermaid "state foo {\n\n}\nstate bar {\n\n}\nstate fork_choice_foobar <<choice>>\nstate join_choice_foobar <<choice>>\nfork_choice_foobar --> foo\nfork_choice_foobar --> bar\nfoo --> join_choice_foobar\nbar --> join_choice_foobar"
+            ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nstate fork_choice_foobar <<choice>>\nstate join_choice_foobar <<choice>>\nfork_choice_foobar --> foo\nfork_choice_foobar --> bar\nfoo --> join_choice_foobar\nbar --> join_choice_foobar"
             , MachineLabel "fork_choice_foobar"
             , MachineLabel "join_choice_foobar"
             )
@@ -76,7 +76,7 @@ spec =
               (stateless $ singleton @Int)
           )
           `shouldBe` Right
-            ( Mermaid "state foo {\n\n}\nstate bar {\n\n}\nfoo --> bar\nbar --> foo"
+            ( Mermaid "state foo {\nfoo_()\n}\nstate bar {\nbar_()\n}\nfoo --> bar\nbar --> foo"
             , MachineLabel "foo"
             , MachineLabel "foo"
             )
@@ -90,7 +90,7 @@ spec =
               (stateless $ singleton @Int)
           )
           `shouldBe` Right
-            ( Mermaid "state show {\n\n}\nstate length {\n\n}\nshow --> length"
+            ( Mermaid "state show {\nshow_()\n}\nstate length {\nlength_()\n}\nshow --> length"
             , MachineLabel "show"
             , MachineLabel "length"
             )
@@ -110,7 +110,7 @@ spec =
           )
           riskApplication
           `shouldBe` Right
-            ( Mermaid "state aggregate {\nNoDataVertex --> CollectedUserDataVertex\nCollectedUserDataVertex --> CollectedLoanDetailsFirstVertex\nCollectedUserDataVertex --> ReceivedCreditBureauDataFirstVertex\nCollectedLoanDetailsFirstVertex --> CollectedAllDataVertex\nReceivedCreditBureauDataFirstVertex --> CollectedAllDataVertex\n\n}\nstate policy {\n\n}\naggregate --> policy\npolicy --> aggregate\nstate projection {\n\n}\naggregate --> projection\nstate mconcat {\n\n}\nprojection --> mconcat"
+            ( Mermaid "state aggregate {\naggregate_NoDataVertex\naggregate_CollectedUserDataVertex\naggregate_CollectedLoanDetailsFirstVertex\naggregate_ReceivedCreditBureauDataFirstVertex\naggregate_CollectedAllDataVertex\naggregate_NoDataVertex --> aggregate_CollectedUserDataVertex\naggregate_CollectedUserDataVertex --> aggregate_CollectedLoanDetailsFirstVertex\naggregate_CollectedUserDataVertex --> aggregate_ReceivedCreditBureauDataFirstVertex\naggregate_CollectedLoanDetailsFirstVertex --> aggregate_CollectedAllDataVertex\naggregate_ReceivedCreditBureauDataFirstVertex --> aggregate_CollectedAllDataVertex\n}\nstate policy {\npolicy_()\n}\naggregate --> policy\npolicy --> aggregate\nstate projection {\nprojection_SingleProjectionVertex\n}\naggregate --> projection\nstate mconcat {\nmconcat_()\n}\nprojection --> mconcat"
             , "aggregate"
             , "mconcat"
             )

spec/CRM/Render/RenderSpec.hs

@@ -1,15 +1,15 @@
-module CRM.RenderSpec where
+module CRM.Render.RenderSpec where
 
 import CRM.Example.LockDoor
 import CRM.Example.OneState
 import CRM.Example.Switch
 import "crm" CRM.Graph
-import "crm" CRM.Render
+import "crm" CRM.Render.Render
 import "crm" CRM.StateMachine
 import CRM.Topology (trivialTopology)
 import Data.Functor.Identity
+import "base" Data.List (intersperse)
 import Data.Singletons.Base.TH
-import "text" Data.Text as Text (unlines)
 import "hspec" Test.Hspec (Spec, describe, it, shouldBe)
 
 spec :: Spec
@@ -17,15 +17,20 @@ spec =
   describe "Render" $ do
     describe "renderMermaid" $ do
       it "should render correctly a graph" $ do
-        renderGraph (Graph [(1 :: Int, 1), (1, 2), (1, 3), (2, 3), (3, 1)])
+        renderGraph (Graph [(LT, LT), (LT, EQ), (LT, GT), (EQ, GT), (GT, LT)])
           `shouldBe` Mermaid
-            ( Text.unlines
-                [ "1 --> 1"
-                , "1 --> 2"
-                , "1 --> 3"
-                , "2 --> 3"
-                , "3 --> 1"
-                ]
+            ( mconcat $
+                intersperse
+                  "\n"
+                  [ "LT"
+                  , "EQ"
+                  , "GT"
+                  , "LT --> LT"
+                  , "LT --> EQ"
+                  , "LT --> GT"
+                  , "EQ --> GT"
+                  , "GT --> LT"
+                  ]
             )
 
     describe "topologyAsGraph" $ do
@@ -73,27 +78,33 @@ spec =
     describe "machineAsGraph" $ do
       it "should render the basic machine with a single vertex" $ do
         renderUntypedGraph (machineAsGraph (Basic $ oneVertexMachine @Identity))
-          `shouldBe` Mermaid
-            ( Text.unlines
-                []
-            )
+          `shouldBe` Mermaid "()"
 
       it "should render the basic switch machine" $ do
         renderUntypedGraph (machineAsGraph (Basic $ switchMachine SFalse @Identity))
           `shouldBe` Mermaid
-            ( Text.unlines
-                [ "True --> False"
-                , "False --> True"
-                ]
+            ( mconcat $
+                intersperse
+                  "\n"
+                  [ "False"
+                  , "True"
+                  , "True --> False"
+                  , "False --> True"
+                  ]
             )
 
       it "should render the basic lockDoor machine" $ do
         renderUntypedGraph (machineAsGraph (Basic $ lockDoorMachine SIsLockClosed @Identity))
           `shouldBe` Mermaid
-            ( Text.unlines
-                [ "IsLockOpen --> IsLockClosed"
-                , "IsLockClosed --> IsLockOpen"
-                , "IsLockClosed --> IsLockLocked"
-                , "IsLockLocked --> IsLockClosed"
-                ]
+            ( mconcat $
+                intersperse
+                  "\n"
+                  [ "IsLockOpen"
+                  , "IsLockClosed"
+                  , "IsLockLocked"
+                  , "IsLockOpen --> IsLockClosed"
+                  , "IsLockClosed --> IsLockOpen"
+                  , "IsLockClosed --> IsLockLocked"
+                  , "IsLockLocked --> IsLockClosed"
+                  ]
             )

src/CRM/Example/LockDoor.hs

@@ -6,6 +6,8 @@
 {-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
 -- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wmissing-deriving-strategies
 {-# OPTIONS_GHC -Wno-missing-deriving-strategies #-}
+-- https://downloads.haskell.org/ghc/latest/docs/users_guide/using-warnings.html#ghc-flag--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
 module CRM.Example.LockDoor where
 
@@ -19,7 +21,7 @@ $( singletons
         = IsLockOpen
         | IsLockClosed
         | IsLockLocked
-        deriving stock (Eq, Show)
+        deriving stock (Eq, Show, Enum, Bounded)
 
       lockDoorTopology :: Topology LockDoorVertex
       lockDoorTopology =

src/CRM/Example/RiskManager/Aggregate.hs

@@ -4,6 +4,8 @@
 {-# 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--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
 module CRM.Example.RiskManager.Aggregate where
 
@@ -20,7 +22,7 @@ $( singletons
         | CollectedLoanDetailsFirstVertex
         | ReceivedCreditBureauDataFirstVertex
         | CollectedAllDataVertex
-        deriving stock (Eq, Show)
+        deriving stock (Eq, Show, Enum, Bounded)
 
       aggregateTopology :: Topology AggregateVertex
       aggregateTopology =

src/CRM/Example/RiskManager/Projection.hs

@@ -6,6 +6,8 @@
 {-# 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--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
 module CRM.Example.RiskManager.Projection where
 
@@ -48,7 +50,7 @@ $( singletons
     [d|
       data ProjectionVertex
         = SingleProjectionVertex
-        deriving stock (Eq, Show)
+        deriving stock (Eq, Show, Enum, Bounded)
 
       projectionTopology :: Topology ProjectionVertex
       projectionTopology =

src/CRM/Example/TheHobbit.hs

@@ -5,6 +5,8 @@
 {-# 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--Wunused-type-patterns
+{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
 module CRM.Example.TheHobbit where
 
@@ -39,7 +41,7 @@ $( singletons
         | MistyMountain
         | TrollsPath
         | TrollsCave
-        deriving stock (Eq, Show)
+        deriving stock (Eq, Show, Enum, Bounded)
 
       hobbitTopology :: Topology HobbitVertex
       hobbitTopology =

src/CRM/Graph.hs

@@ -1,5 +1,6 @@
 module CRM.Graph where
 
+import CRM.Render.RenderableVertices (RenderableVertices)
 import "base" Data.List (nub)
 
 -- * Graph
@@ -51,7 +52,7 @@ transitiveClosureGraph graph@(Graph edges) =
 -- * UntypedGraph
 
 -- A data type to represent a graph which is not tracking the vertex type
-data UntypedGraph = forall a. (Eq a, Show a) => UntypedGraph (Graph a)
+data UntypedGraph = forall a. (RenderableVertices a, Eq a, Show a) => UntypedGraph (Graph a)
 
 instance Show UntypedGraph where
   show :: UntypedGraph -> String

src/CRM/Render/Render.hs

@@ -2,31 +2,76 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module CRM.Render where
+module CRM.Render.Render where
 
 import CRM.BaseMachine
 import CRM.Graph
+import CRM.Render.RenderableVertices
 import CRM.StateMachine
 import CRM.Topology
+import "base" Data.List (intersperse)
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind, demote)
-import "text" Data.Text (Text, pack)
+import "base" Data.String (IsString)
+import "text" Data.Text (Text, null, pack)
+import Prelude hiding (null)
 
 newtype Mermaid = Mermaid {getText :: Text}
   deriving newtype (Eq, Show)
 
 instance Semigroup Mermaid where
   (<>) :: Mermaid -> Mermaid -> Mermaid
+  (Mermaid "") <> m = m
+  m <> (Mermaid "") = m
   (Mermaid t1) <> (Mermaid t2) = Mermaid (t1 <> "\n" <> t2)
 
+newtype MachineLabel = MachineLabel {getLabel :: Text}
+  deriving newtype (Eq, Show, IsString)
+
 -- | We can render a `Graph a` as [mermaid](https://mermaid.js.org/) state diagram
-renderStateDiagram :: Show a => Graph a -> Mermaid
+renderStateDiagram :: (RenderableVertices a, Show a) => Graph a -> Mermaid
 renderStateDiagram graph =
   Mermaid "stateDiagram-v2\n" <> renderGraph graph
 
-renderGraph :: Show a => Graph a -> Mermaid
-renderGraph (Graph l) =
-  Mermaid $
-    foldMap (\(a1, a2) -> pack (show a1) <> " --> " <> pack (show a2) <> "\n") l
+labelVertex :: Show a => MachineLabel -> a -> Text
+labelVertex label =
+  let
+    prefix =
+      if null (getLabel label)
+        then ""
+        else getLabel label <> "_"
+   in
+    (prefix <>) . pack . show
+
+renderLabelledVertices
+  :: forall a
+   . (Show a, RenderableVertices a)
+  => MachineLabel
+  -> Graph a
+  -> Mermaid
+renderLabelledVertices label _ =
+  Mermaid . mconcat . intersperse "\n" $ labelVertex label <$> (vertices :: [a])
+
+renderVertices :: forall a. (Show a, RenderableVertices a) => Graph a -> Mermaid
+renderVertices = renderLabelledVertices ""
+
+renderLabelledEdges :: Show a => MachineLabel -> Graph a -> Mermaid
+renderLabelledEdges label (Graph l) =
+  Mermaid . mconcat . intersperse "\n" $
+    (\(a1, a2) -> labelVertex label a1 <> " --> " <> labelVertex label a2) <$> l
+
+renderEdges :: Show a => Graph a -> Mermaid
+renderEdges = renderLabelledEdges ""
+
+renderLabelledGraph
+  :: (RenderableVertices a, Show a)
+  => MachineLabel
+  -> Graph a
+  -> Mermaid
+renderLabelledGraph label graph =
+  renderLabelledVertices label graph <> renderLabelledEdges label graph
+
+renderGraph :: (RenderableVertices a, Show a) => Graph a -> Mermaid
+renderGraph = renderLabelledGraph ""
 
 -- | Turn a `Topology` into a `Graph`
 topologyAsGraph :: Topology v -> Graph v
@@ -39,7 +84,10 @@ topologyAsGraph (Topology edges) = Graph $ edges >>= edgify
 -- its topology
 baseMachineAsGraph
   :: forall vertex topology input output m
-   . (Demote vertex ~ vertex, SingKind vertex, SingI topology)
+   . ( Demote vertex ~ vertex
+     , SingKind vertex
+     , SingI topology
+     )
   => BaseMachineT m (topology :: Topology vertex) input output
   -> Graph vertex
 baseMachineAsGraph _ = topologyAsGraph (demote @topology)

src/CRM/Render/RenderFlow.hs

@@ -1,14 +1,9 @@
 {-# LANGUAGE GADTs #-}
 
-module CRM.RenderFlow where
+module CRM.Render.RenderFlow where
 
-import CRM.Render
+import CRM.Render.Render
 import CRM.StateMachine
-import "base" Data.String (IsString)
-import "text" Data.Text
-
-newtype MachineLabel = MachineLabel {getLabel :: Text}
-  deriving newtype (Eq, Show, IsString)
 
 data TreeMetadata a
   = LeafLabel a
@@ -19,7 +14,7 @@ renderFlow :: TreeMetadata MachineLabel -> StateMachineT m input output -> Eithe
 renderFlow (LeafLabel label) (Basic machine) =
   Right
     ( Mermaid ("state " <> getLabel label <> " {")
-        <> renderGraph (baseMachineAsGraph machine)
+        <> renderLabelledGraph label (baseMachineAsGraph machine)
         <> Mermaid "}"
     , label
     , label

src/CRM/Render/RenderableVertices.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module CRM.Render.RenderableVertices where
+
+class RenderableVertices a where
+  vertices :: [a]
+
+instance {-# OVERLAPPABLE #-} (Enum a, Bounded a) => RenderableVertices a where
+  vertices :: [a]
+  vertices = [minBound .. maxBound]
+
+instance RenderableVertices a => RenderableVertices (Maybe a) where
+  vertices :: [Maybe a]
+  vertices =
+    Nothing : (Just <$> vertices)
+
+instance (RenderableVertices a, RenderableVertices b) => RenderableVertices (Either a b) where
+  vertices :: [Either a b]
+  vertices =
+    (Left <$> vertices)
+      <> (Right <$> vertices)
+
+instance (RenderableVertices a, RenderableVertices b) => RenderableVertices (a, b) where
+  vertices :: [(a, b)]
+  vertices = [(a, b) | a <- vertices, b <- vertices]

src/CRM/StateMachine.hs

@@ -5,12 +5,13 @@
 module CRM.StateMachine where
 
 import CRM.BaseMachine as BaseMachine
+import CRM.Render.RenderableVertices (RenderableVertices)
 import CRM.Topology
 import "base" Control.Category (Category (..))
 import "base" Data.Bifunctor (Bifunctor (..), bimap)
 import "base" Data.Foldable (foldlM)
 import "base" Data.Kind (Type)
-import "profunctors" Data.Profunctor (Choice {-Costrong (..),-} (..), Profunctor (..), Strong (..))
+import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 import Prelude hiding ((.))
 
@@ -24,6 +25,7 @@ data StateMachineT m input output where
        , SingI topology
        , Eq vertex
        , Show vertex
+       , RenderableVertices vertex
        )
     => BaseMachineT m topology input output
     -> StateMachineT m input output
@@ -77,6 +79,7 @@ unrestrictedMachine
      , SingI (AllowAllTopology @vertex)
      , Eq vertex
      , Show vertex
+     , RenderableVertices vertex
      )
   => ( forall initialVertex
         . state initialVertex