{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Crem.Render.RenderFlow where
import Crem.Render.Render
import Crem.StateMachine
data TreeMetadata a
= LeafLabel a
| BinaryLabel (TreeMetadata a) (TreeMetadata a)
deriving stock (Int -> TreeMetadata a -> ShowS
[TreeMetadata a] -> ShowS
TreeMetadata a -> String
(Int -> TreeMetadata a -> ShowS)
-> (TreeMetadata a -> String)
-> ([TreeMetadata a] -> ShowS)
-> Show (TreeMetadata a)
forall a. Show a => Int -> TreeMetadata a -> ShowS
forall a. Show a => [TreeMetadata a] -> ShowS
forall a. Show a => TreeMetadata a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TreeMetadata a -> ShowS
showsPrec :: Int -> TreeMetadata a -> ShowS
$cshow :: forall a. Show a => TreeMetadata a -> String
show :: TreeMetadata a -> String
$cshowList :: forall a. Show a => [TreeMetadata a] -> ShowS
showList :: [TreeMetadata a] -> ShowS
Show)
renderFlow :: TreeMetadata MachineLabel -> StateMachineT m input output -> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow :: forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow (LeafLabel MachineLabel
label) (Basic BaseMachineT m topology input output
machine) =
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Text -> Mermaid
Mermaid (Text
"state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" {")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Graph vertex -> Mermaid
forall a.
(RenderableVertices a, Show a) =>
MachineLabel -> Graph a -> Mermaid
renderLabelledGraph MachineLabel
label (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
machine)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid Text
"}"
, MachineLabel
label
, MachineLabel
label
)
renderFlow (BinaryLabel TreeMetadata MachineLabel
leftLabels TreeMetadata MachineLabel
rightLabels) (Sequential StateMachineT m input b
machine1 StateMachineT m b output
machine2) = do
(Mermaid
leftMermaid, MachineLabel
leftLabelIn, MachineLabel
leftLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m input b
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
leftLabels StateMachineT m input b
machine1
(Mermaid
rightMermaid, MachineLabel
rightLabelIn, MachineLabel
rightLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m b output
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
rightLabels StateMachineT m b output
machine2
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Mermaid
leftMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Mermaid
rightMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
leftLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
rightLabelIn)
, MachineLabel
leftLabelIn
, MachineLabel
rightLabelOut
)
renderFlow (BinaryLabel TreeMetadata MachineLabel
upperLabels TreeMetadata MachineLabel
lowerLabels) (Parallel StateMachineT m a b
machine1 StateMachineT m c d
machine2) = do
(Mermaid
upperMermaid, MachineLabel
upperLabelIn, MachineLabel
upperLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m a b
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
upperLabels StateMachineT m a b
machine1
(Mermaid
lowerMermaid, MachineLabel
lowerLabelIn, MachineLabel
lowerLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m c d
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
lowerLabels StateMachineT m c d
machine2
let
inLabel :: Text
inLabel = Text
"fork_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelIn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelIn
outLabel :: Text
outLabel = Text
"join_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelOut
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Mermaid
upperMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Mermaid
lowerMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
"state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <<fork>>")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
"state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <<join>>")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelIn)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelIn)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
upperLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
lowerLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel)
, Text -> MachineLabel
MachineLabel Text
inLabel
, Text -> MachineLabel
MachineLabel Text
outLabel
)
renderFlow (BinaryLabel TreeMetadata MachineLabel
upperLabels TreeMetadata MachineLabel
lowerLabels) (Alternative StateMachineT m a b
machine1 StateMachineT m c d
machine2) = do
(Mermaid
upperMermaid, MachineLabel
upperLabelIn, MachineLabel
upperLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m a b
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
upperLabels StateMachineT m a b
machine1
(Mermaid
lowerMermaid, MachineLabel
lowerLabelIn, MachineLabel
lowerLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m c d
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
lowerLabels StateMachineT m c d
machine2
let
inLabel :: Text
inLabel = Text
"fork_choice_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelIn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelIn
outLabel :: Text
outLabel = Text
"join_choice_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelOut
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Mermaid
upperMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Mermaid
lowerMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
"state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <<choice>>")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
"state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <<choice>>")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
upperLabelIn)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (Text
inLabel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
lowerLabelIn)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
upperLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel)
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
lowerLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outLabel)
, Text -> MachineLabel
MachineLabel Text
inLabel
, Text -> MachineLabel
MachineLabel Text
outLabel
)
renderFlow (BinaryLabel TreeMetadata MachineLabel
forwardLabels TreeMetadata MachineLabel
backwardsLabels) (Feedback StateMachineT m input (n b)
machine1 StateMachineT m b (n input)
machine2) = do
(Mermaid
forwardMermaid, MachineLabel
forwardLabelIn, MachineLabel
forwardLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m input (n b)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
forwardLabels StateMachineT m input (n b)
machine1
(Mermaid
backwardMermaid, MachineLabel
backawardLabelIn, MachineLabel
backwardLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m b (n input)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
backwardsLabels StateMachineT m b (n input)
machine2
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Mermaid
forwardMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Mermaid
backwardMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
forwardLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
backawardLabelIn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": []")
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
backwardLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
forwardLabelIn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": []")
, MachineLabel
forwardLabelIn
, MachineLabel
forwardLabelOut
)
renderFlow (BinaryLabel TreeMetadata MachineLabel
leftLabels TreeMetadata MachineLabel
rightLabels) (Kleisli StateMachineT m input (n b)
machine1 StateMachineT m b (n c)
machine2) = do
(Mermaid
leftMermaid, MachineLabel
leftLabelIn, MachineLabel
leftLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m input (n b)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
leftLabels StateMachineT m input (n b)
machine1
(Mermaid
rightMermaid, MachineLabel
rightLabelIn, MachineLabel
rightLabelOut) <- TreeMetadata MachineLabel
-> StateMachineT m b (n c)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall (m :: * -> *) input output.
TreeMetadata MachineLabel
-> StateMachineT m input output
-> Either String (Mermaid, MachineLabel, MachineLabel)
renderFlow TreeMetadata MachineLabel
rightLabels StateMachineT m b (n c)
machine2
(Mermaid, MachineLabel, MachineLabel)
-> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. b -> Either a b
Right
( Mermaid
leftMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Mermaid
rightMermaid
Mermaid -> Mermaid -> Mermaid
forall a. Semigroup a => a -> a -> a
<> Text -> Mermaid
Mermaid (MachineLabel -> Text
getLabel MachineLabel
leftLabelOut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MachineLabel -> Text
getLabel MachineLabel
rightLabelIn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": []")
, MachineLabel
leftLabelIn
, MachineLabel
rightLabelOut
)
renderFlow TreeMetadata MachineLabel
labels StateMachineT m input output
_ = String -> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. a -> Either a b
Left (String -> Either String (Mermaid, MachineLabel, MachineLabel))
-> String -> Either String (Mermaid, MachineLabel, MachineLabel)
forall a b. (a -> b) -> a -> b
$ String
"Labels structure " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TreeMetadata MachineLabel -> String
forall a. Show a => a -> String
show TreeMetadata MachineLabel
labels String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not match machine structure"