{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Rendering just the state space of a state machine might be sometimes
-- limiting.
--
-- Given that the `StateMachineT` data type encodes a lot of information on the
-- structure of a machine, we can actually use it to render a more informative
-- flow.
module Crem.Render.RenderFlow where

import Crem.Render.Render
import Crem.StateMachine

-- | 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
-- child.
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)

-- | Given a `StateMachineT` and a `TreeMetadata` of @MachineLabel@s, we can
-- create a flow representation of our machine.
--
-- For every leaf it will render the state space, while for every other node,
-- it will render the flow between the composed machines.
--
-- More details available in [\/docs\/how-to-render-a-machine.md](https://github.com/tweag/crem/tree/main/docs/how-to-render-a-machine.md)
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" -- TODO: this sucks