{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
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)
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)
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)
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
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
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])
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
""
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
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
""
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
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
""
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
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)
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
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
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)