{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Once you defined a `StateMachineT`, you can render its topology as a
-- directed graph using a [Mermaid](https://mermaid.js.org/#/) state diagram
module Crem.Render.Render where

import Crem.BaseMachine
import Crem.Graph
import Crem.Render.RenderableVertices
import Crem.StateMachine
import Crem.Topology
import "base" Data.List (intersperse)
import "base" Data.String (IsString)
import "singletons-base" Data.Singletons (Demote, SingI, SingKind, demote)
import "text" Data.Text (Text, null, pack)
import Prelude hiding (null)

-- | `Mermaid` is just a @newtype@ around @Text@ to specialize it to Mermaid
-- diagrams
newtype Mermaid = Mermaid {Mermaid -> Text
getText :: Text}
  deriving newtype (Mermaid -> Mermaid -> Bool
(Mermaid -> Mermaid -> Bool)
-> (Mermaid -> Mermaid -> Bool) -> Eq Mermaid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mermaid -> Mermaid -> Bool
== :: Mermaid -> Mermaid -> Bool
$c/= :: Mermaid -> Mermaid -> Bool
/= :: Mermaid -> Mermaid -> Bool
Eq, Int -> Mermaid -> ShowS
[Mermaid] -> ShowS
Mermaid -> String
(Int -> Mermaid -> ShowS)
-> (Mermaid -> String) -> ([Mermaid] -> ShowS) -> Show Mermaid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mermaid -> ShowS
showsPrec :: Int -> Mermaid -> ShowS
$cshow :: Mermaid -> String
show :: Mermaid -> String
$cshowList :: [Mermaid] -> ShowS
showList :: [Mermaid] -> ShowS
Show)

-- | Notice that we joining two non-empty mermaid diagrams, a newline will be
-- added
instance Semigroup Mermaid where
  (<>) :: Mermaid -> Mermaid -> Mermaid
  (Mermaid Text
"") <> :: Mermaid -> Mermaid -> Mermaid
<> Mermaid
m = Mermaid
m
  Mermaid
m <> (Mermaid Text
"") = Mermaid
m
  (Mermaid Text
t1) <> (Mermaid Text
t2) = Text -> Mermaid
Mermaid (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2)

-- | A `MachineLabel` is just a newtype around `Text` to represents label which
-- will be attached to every leaf of the tree defined by the constructors of
-- `StateMachineT`
newtype MachineLabel = MachineLabel {MachineLabel -> Text
getLabel :: Text}
  deriving newtype (MachineLabel -> MachineLabel -> Bool
(MachineLabel -> MachineLabel -> Bool)
-> (MachineLabel -> MachineLabel -> Bool) -> Eq MachineLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MachineLabel -> MachineLabel -> Bool
== :: MachineLabel -> MachineLabel -> Bool
$c/= :: MachineLabel -> MachineLabel -> Bool
/= :: MachineLabel -> MachineLabel -> Bool
Eq, Int -> MachineLabel -> ShowS
[MachineLabel] -> ShowS
MachineLabel -> String
(Int -> MachineLabel -> ShowS)
-> (MachineLabel -> String)
-> ([MachineLabel] -> ShowS)
-> Show MachineLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MachineLabel -> ShowS
showsPrec :: Int -> MachineLabel -> ShowS
$cshow :: MachineLabel -> String
show :: MachineLabel -> String
$cshowList :: [MachineLabel] -> ShowS
showList :: [MachineLabel] -> ShowS
Show, String -> MachineLabel
(String -> MachineLabel) -> IsString MachineLabel
forall a. (String -> a) -> IsString a
$cfromString :: String -> MachineLabel
fromString :: String -> MachineLabel
IsString)

-- | We can render a `Graph` as a Mermaid state diagram
renderStateDiagram :: (RenderableVertices a, Show a) => Graph a -> Mermaid
renderStateDiagram :: forall a. (RenderableVertices a, Show a) => Graph a -> Mermaid
renderStateDiagram Graph a
graph =
  Text -> Mermaid
Mermaid Text
"stateDiagram-v2\n" Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Graph a -> Mermaid
forall a. (RenderableVertices a, Show a) => Graph a -> Mermaid
renderGraph Graph a
graph

-- | Prepends a `MachineLabel` to the `Show` output, as a `Text`
labelVertex :: Show a => MachineLabel -> a -> Text
labelVertex :: forall a. Show a => MachineLabel -> a -> Text
labelVertex MachineLabel
label =
  let
    prefix :: Text
prefix =
      if Text -> Bool
null (MachineLabel -> Text
getLabel MachineLabel
label)
        then Text
""
        else MachineLabel -> Text
getLabel MachineLabel
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
   in
    (Text
prefix <>) (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Render all the vertices of a graph after labelling all of them
renderLabelledVertices
  :: forall a
   . (Show a, RenderableVertices a)
  => MachineLabel
  -> Graph a
  -> Mermaid
renderLabelledVertices :: forall a.
(Show a, RenderableVertices a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledVertices MachineLabel
label Graph a
_ =
  Text -> Mermaid
Mermaid (Text -> Mermaid) -> ([Text] -> Text) -> [Text] -> Mermaid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
"\n" ([Text] -> Mermaid) -> [Text] -> Mermaid
forall a b. (a -> b) -> a -> b
$ MachineLabel -> a -> Text
forall a. Show a => MachineLabel -> a -> Text
labelVertex MachineLabel
label (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([a]
forall a. RenderableVertices a => [a]
vertices :: [a])

-- | Render all vertices with no label
renderVertices :: forall a. (Show a, RenderableVertices a) => Graph a -> Mermaid
renderVertices :: forall a. (Show a, RenderableVertices a) => Graph a -> Mermaid
renderVertices = MachineLabel -> Graph a -> Mermaid
forall a.
(Show a, RenderableVertices a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledVertices MachineLabel
""

-- | Render all the edges of a graph after labelling all of them
renderLabelledEdges :: Show a => MachineLabel -> Graph a -> Mermaid
renderLabelledEdges :: forall a. Show a => MachineLabel -> Graph a -> Mermaid
renderLabelledEdges MachineLabel
label (Graph [(a, a)]
l) =
  Text -> Mermaid
Mermaid (Text -> Mermaid) -> ([Text] -> Text) -> [Text] -> Mermaid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
"\n" ([Text] -> Mermaid) -> [Text] -> Mermaid
forall a b. (a -> b) -> a -> b
$
    (\(a
a1, a
a2) -> MachineLabel -> a -> Text
forall a. Show a => MachineLabel -> a -> Text
labelVertex MachineLabel
label a
a1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> a -> Text
forall a. Show a => MachineLabel -> a -> Text
labelVertex MachineLabel
label a
a2) ((a, a) -> Text) -> [(a, a)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, a)]
l

-- | Render all edges with no label
renderEdges :: Show a => Graph a -> Mermaid
renderEdges :: forall a. Show a => Graph a -> Mermaid
renderEdges = MachineLabel -> Graph a -> Mermaid
forall a. Show a => MachineLabel -> Graph a -> Mermaid
renderLabelledEdges MachineLabel
""

-- | Join the outputs of `renderLabelledVertices` and `renderLabelledEdges` to
-- render an entire `Graph`
renderLabelledGraph
  :: (RenderableVertices a, Show a)
  => MachineLabel
  -> Graph a
  -> Mermaid
renderLabelledGraph :: forall a.
(RenderableVertices a, Show a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledGraph MachineLabel
label Graph a
graph =
  MachineLabel -> Graph a -> Mermaid
forall a.
(Show a, RenderableVertices a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledVertices MachineLabel
label Graph a
graph Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Graph a -> Mermaid
forall a. Show a => MachineLabel -> Graph a -> Mermaid
renderLabelledEdges MachineLabel
label Graph a
graph

-- | Render a `Graph` with no labels
renderGraph :: (RenderableVertices a, Show a) => Graph a -> Mermaid
renderGraph :: forall a. (RenderableVertices a, Show a) => Graph a -> Mermaid
renderGraph = MachineLabel -> Graph a -> Mermaid
forall a.
(RenderableVertices a, Show a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledGraph MachineLabel
""

-- | Turn a `Topology` into a `Graph`
topologyAsGraph :: Topology v -> Graph v
topologyAsGraph :: forall v. Topology v -> Graph v
topologyAsGraph (Topology [(v, [v])]
edges) = [(v, v)] -> Graph v
forall a. [(a, a)] -> Graph a
Graph ([(v, v)] -> Graph v) -> [(v, v)] -> Graph v
forall a b. (a -> b) -> a -> b
$ [(v, [v])]
edges [(v, [v])] -> ((v, [v]) -> [(v, v)]) -> [(v, v)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (v, [v]) -> [(v, v)]
forall v. (v, [v]) -> [(v, v)]
edgify
  where
    edgify :: (v, [v]) -> [(v, v)]
    edgify :: forall v. (v, [v]) -> [(v, v)]
edgify (v
v, [v]
vs) = (v
v,) (v -> (v, v)) -> [v] -> [(v, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vs

-- | Interpret a `BaseMachine` as a `Graph` using the information contained in
-- its topology.
--
-- This is the point where we make usage of the machinery provided by the
-- [singletons](https://hackage.haskell.org/package/singletons) library, which
-- require us to impose the constraints we have on @vertex@ and @topology@
baseMachineAsGraph
  :: forall vertex topology input output m
   . ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI topology
     )
  => BaseMachineT m (topology :: Topology vertex) input output
  -> Graph vertex
baseMachineAsGraph :: forall vertex (topology :: Topology vertex) input output
       (m :: * -> *).
(Demote vertex ~ vertex, SingKind vertex, SingI topology) =>
BaseMachineT m topology input output -> Graph vertex
baseMachineAsGraph BaseMachineT m topology input output
_ = Topology vertex -> Graph vertex
forall v. Topology v -> Graph v
topologyAsGraph (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Topology vertex).
(SingKind (Topology vertex), SingI a) =>
Demote (Topology vertex)
demote @topology)

-- | Render an `UntypedGraph` to the Mermaid format
renderUntypedStateDiagram :: UntypedGraph -> Mermaid
renderUntypedStateDiagram :: UntypedGraph -> Mermaid
renderUntypedStateDiagram (UntypedGraph Graph a
graph) = Graph a -> Mermaid
forall a. (RenderableVertices a, Show a) => Graph a -> Mermaid
renderStateDiagram Graph a
graph

-- | Render an `UntypedGraph`
renderUntypedGraph :: UntypedGraph -> Mermaid
renderUntypedGraph :: UntypedGraph -> Mermaid
renderUntypedGraph (UntypedGraph Graph a
graph) = Graph a -> Mermaid
forall a. (RenderableVertices a, Show a) => Graph a -> Mermaid
renderGraph Graph a
graph

-- | Interpret a `StateMachine` as an `UntypedGraph` using the information
-- contained in its structure and in the topology of its basic components
machineAsGraph :: StateMachineT m input output -> UntypedGraph
machineAsGraph :: forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph (Basic BaseMachineT m topology input output
baseMachine) =
  Graph vertex -> UntypedGraph
forall a.
(RenderableVertices a, Eq a, Show a) =>
Graph a -> UntypedGraph
UntypedGraph (BaseMachineT m topology input output -> Graph vertex
forall vertex (topology :: Topology vertex) input output
       (m :: * -> *).
(Demote vertex ~ vertex, SingKind vertex, SingI topology) =>
BaseMachineT m topology input output -> Graph vertex
baseMachineAsGraph BaseMachineT m topology input output
baseMachine)
machineAsGraph (Sequential StateMachineT m input b
machine1 StateMachineT m b output
machine2) =
  UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
    UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m input b -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m input b
machine1)
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m b output -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m b output
machine2)
machineAsGraph (Parallel StateMachineT m a b
machine1 StateMachineT m c d
machine2) =
  UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
    UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m a b -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m a b
machine1)
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m c d -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m c d
machine2)
machineAsGraph (Alternative StateMachineT m a b
machine1 StateMachineT m c d
machine2) =
  UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
    UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m a b -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m a b
machine1)
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m c d -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m c d
machine2)
machineAsGraph (Feedback StateMachineT m input (n b)
machine1 StateMachineT m b (n input)
machine2) =
  UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
    UntypedGraph -> UntypedGraph
untypedTransitiveClosureGraph (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
      UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph
        (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m input (n b) -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m input (n b)
machine1)
        (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m b (n input) -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m b (n input)
machine2)
machineAsGraph (Kleisli StateMachineT m input (n b)
machine1 StateMachineT m b (n c)
machine2) =
  UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$
    UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m input (n b) -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m input (n b)
machine1)
      (UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ UntypedGraph -> UntypedGraph
untypedTransitiveClosureGraph (UntypedGraph -> UntypedGraph) -> UntypedGraph -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ StateMachineT m b (n c) -> UntypedGraph
forall (m :: * -> *) input output.
StateMachineT m input output -> UntypedGraph
machineAsGraph StateMachineT m b (n c)
machine2)