keiki-0.8.0.0: src/Keiki/Render/Mermaid.hs
-- | Mermaid 'stateDiagram-v2' renderer for 'SymTransducer' values whose
-- vertex type is enumerable.
--
-- The single-transducer entry point is 'toMermaid'; the supporting
-- helpers ('vertexLabel', 'edgeInputName', 'edgeOutputName',
-- 'edgeLabel') are exported so callers can build custom rendering
-- pipelines on top of the same primitives.
--
-- The rendered output is a @stateDiagram-v2@ block as 'Data.Text.Text'.
-- It can be pasted into a Markdown file or Notion page; GitHub renders
-- Mermaid blocks inline so PR reviewers see executable guard and update
-- semantics alongside the topology and source diff.
--
-- The renderer is specialised to @phi ~ 'HsPred' rs ci@ — extracting
-- the input-constructor name from an edge guard requires walking the
-- guard's AST, and 'HsPred' is the only first-class guard AST in the
-- repository. See the Decision Log of
-- @docs/plans/30-mermaid-renderer-for-single-symtransducer-canonical-example-diagrams.md@
-- for the rationale.
--
-- See also:
--
-- * @docs/masterplans/10-mermaid-topology-renderer-for-symtransducer.md@
-- for the initiative motivation.
module Keiki.Render.Mermaid
( toMermaid,
toTopologyMermaid,
toMermaidAlternative,
toMermaidAlternativeWith,
toMermaidAlternativeWithOptions,
toMermaidComposite,
toMermaidCompositeWith,
toMermaidCompositeNested,
toMermaidCompositeNestedWith,
toMermaidCompose3,
toMermaidCompose3With,
toMermaidCompose3Nested,
toMermaidCompose3NestedWith,
toMermaidFeedback1,
toMermaidFeedback1With,
toMermaidAtlas,
toMermaidAtlasWith,
MermaidSection (..),
MermaidSectionKind (..),
MermaidAtlasOptions (..),
AtlasKindDisplay (..),
defaultMermaidAtlasOptions,
toMermaidWith,
toMermaidWithLabels,
MermaidOptions (..),
MermaidGuardMode (..),
MermaidUpdateMode (..),
MermaidLabelLayout (..),
MermaidOutputLayout (..),
MermaidStateLabels (..),
duplicateStateIds,
defaultMermaidOptions,
topologyMermaidOptions,
vertexLabel,
compositeLabel,
compose3Label,
edgeInputName,
edgeOutputName,
edgeLabel,
)
where
import Control.Applicative ((<|>))
import Data.Text (Text)
import Data.Text qualified as T
import Keiki.Composition (Composite (..), WeakenR, feedback1)
import Keiki.Core
( Disjoint,
Edge (..),
HsPred (..),
InCtor (..),
Names,
OutTerm (..),
SymTransducer (..),
Update (..),
WireCtor (..),
)
import Keiki.Generics (Append)
import Keiki.Internal.Slots (indexNName)
import Keiki.Render.Pretty (prettyPred, prettyUpdate)
-- | How an edge's guard predicate is rendered into the @[g: …]@
-- segment.
--
-- * 'MermaidGuardHidden' — no guard segment at all.
-- * 'MermaidGuardStructuralSummary' — the structural constructor-tag
-- walk produced by 'guardSummary', e.g. @PAnd PInCtor PEq@. This is
-- the compact structural alternative to readable guards.
-- * 'MermaidGuardPretty' — the domain-readable rendering produced by
-- 'Keiki.Render.Pretty.prettyPred', e.g.
-- @(ConfirmAccount && ConfirmAccount.confirmCode == confirmCode)@.
data MermaidGuardMode
= MermaidGuardHidden
| MermaidGuardStructuralSummary
| MermaidGuardPretty
deriving stock (Eq, Show)
-- | How an edge's register update is rendered.
--
-- * 'MermaidUpdateHidden' — no update segment at all.
-- * 'MermaidUpdateWrittenSlots' — only the names of written slots,
-- retained as a compact compatibility option.
-- * 'MermaidUpdatePretty' — the complete update produced by
-- 'Keiki.Render.Pretty.prettyUpdate', including right-hand terms.
data MermaidUpdateMode
= MermaidUpdateHidden
| MermaidUpdateWrittenSlots
| MermaidUpdatePretty
deriving stock (Eq, Show)
-- | How dense edge labels are laid out.
--
-- * 'MermaidLabelInline' — the current single-line @[seg; seg]@ form.
-- * 'MermaidLabelMultiline' — the base on line one; each further
-- segment on its own @<br/>@-separated line.
data MermaidLabelLayout
= MermaidLabelInline
| MermaidLabelMultiline
deriving stock (Eq, Show)
-- | How an edge that emits several events renders its output names.
--
-- * 'MermaidOutputSemicolon' — today's length-based default: @;@ for
-- exactly two events, @<br/>@ for three or more.
-- * 'MermaidOutputMultiline' — always one event per line
-- (@<br/>@-joined), regardless of count.
-- * 'MermaidOutputCounted' — a compact @N events@ count for two or
-- more (a single event still renders as its name; an ε-edge stays
-- @ε@).
data MermaidOutputLayout
= MermaidOutputSemicolon
| MermaidOutputMultiline
| MermaidOutputCounted
deriving stock (Eq, Show)
-- | Rendering options for edge semantics and layout.
--
-- 'defaultMermaidOptions' is the readable primary policy: complete guards
-- and updates, multiline labels, and no semantic truncation.
-- 'topologyMermaidOptions' is the explicit compact compatibility policy and
-- reproduces Keiki 0.7's topology-only bytes.
data MermaidOptions = MermaidOptions
{ -- | How the guard segment is rendered.
guardMode :: MermaidGuardMode,
-- | How the register-update segment is rendered.
updateMode :: MermaidUpdateMode,
-- | Inline bracketed segments or multiline @<br/>@ layout.
labelLayout :: MermaidLabelLayout,
-- | When @'Just' k@ and an edge writes @n > k@ slots, show the
-- first @k@ then a single @+{n-k} more@ token. 'Nothing' (the
-- default) disables truncation.
maxInlineWrittenSlots :: Maybe Int,
-- | When @'Just' w@ and the guard segment text exceeds @w@
-- characters, take @w@ characters then append the ellipsis @…@.
-- 'Nothing' (the default) disables truncation.
maxInlineGuardWidth :: Maybe Int,
-- | How a multi-event edge renders its output names. Defaults to
-- 'MermaidOutputSemicolon', which reproduces today's length-based
-- behaviour exactly.
outputLayout :: MermaidOutputLayout
}
-- | The readable primary policy used by every no-options renderer.
defaultMermaidOptions :: MermaidOptions
defaultMermaidOptions =
MermaidOptions
{ guardMode = MermaidGuardPretty,
updateMode = MermaidUpdatePretty,
labelLayout = MermaidLabelMultiline,
maxInlineWrittenSlots = Nothing,
maxInlineGuardWidth = Nothing,
outputLayout = MermaidOutputSemicolon
}
-- | Keiki 0.7's compact topology-only policy. This is intentionally a
-- separate named value rather than an implicit default so callers make the
-- loss of business semantics explicit.
topologyMermaidOptions :: MermaidOptions
topologyMermaidOptions =
MermaidOptions
{ guardMode = MermaidGuardHidden,
updateMode = MermaidUpdateHidden,
labelLayout = MermaidLabelInline,
maxInlineWrittenSlots = Nothing,
maxInlineGuardWidth = Nothing,
outputLayout = MermaidOutputSemicolon
}
-- | Render a 'SymTransducer' to a Mermaid @stateDiagram-v2@ block.
--
-- The vertex type @s@ must derive 'Enum', 'Bounded', and 'Show'. The
-- enumeration walks @[minBound .. maxBound]@; vertex labels come from
-- 'show'. The output begins with @stateDiagram-v2@, followed by an
-- initial-state line (@[*] --> <initial>@), one line per outgoing
-- edge of every vertex, and a final-state line (@<vertex> --> [*]@)
-- for every vertex where 'isFinal' returns 'True'. The readable default
-- adds complete update and guard segments on renderer-owned @<br/>@ lines;
-- use 'toTopologyMermaid' for the compact 'edgeLabel' form.
toMermaid ::
(Enum s, Bounded s, Show s) =>
SymTransducer (HsPred rs ci) rs s ci co ->
Text
toMermaid = toMermaidWith defaultMermaidOptions
-- | Render only topology using Keiki 0.7's compact label policy. Use this
-- when guards and register assignments are intentionally out of scope.
toTopologyMermaid ::
(Enum s, Bounded s, Show s) =>
SymTransducer (HsPred rs ci) rs s ci co ->
Text
toTopologyMermaid = toMermaidWith topologyMermaidOptions
-- | Like 'toMermaid', but takes the complete edge-semantics and layout
-- policy explicitly. @'toMermaidWith' 'defaultMermaidOptions'@ is
-- byte-identical to 'toMermaid'; use 'topologyMermaidOptions' for the
-- Keiki 0.7 topology-only form.
toMermaidWith ::
(Enum s, Bounded s, Show s) =>
MermaidOptions ->
SymTransducer (HsPred rs ci) rs s ci co ->
Text
toMermaidWith opts = renderTopologyWith opts vertexLabel vertexLabel
-- | A pair of per-vertex label functions for 'toMermaidWithLabels'.
--
-- * 'stateId' produces the stable ASCII Mermaid identifier used as a
-- node id and in every transition arrow. It is the caller's
-- responsibility to return a legal Mermaid identifier
-- (@[A-Za-z_][A-Za-z0-9_]*@); keiki uses it verbatim and does not
-- sanitise it.
-- * 'stateDisplayLabel' produces the friendly visible label, which may
-- contain spaces. When the display differs from the id for a vertex,
-- the renderer emits a @state \"<display>\" as <id>@ declaration; when
-- they are equal it emits nothing extra, so feeding identical
-- functions reproduces 'toMermaidWith' byte-for-byte.
data MermaidStateLabels s = MermaidStateLabels
{ stateId :: s -> Text,
stateDisplayLabel :: s -> Text
}
-- | Like 'toMermaidWith', but the caller supplies separate stable
-- identifiers and friendly display labels via 'MermaidStateLabels'
-- instead of deriving both from 'Show'. The @Show s@ constraint is
-- dropped — labels come from the callbacks.
--
-- For every vertex whose display label differs from its id, a
-- @state \"<display>\" as <id>@ declaration line is emitted between the
-- @stateDiagram-v2@ header and the initial-state line; every transition
-- arrow and @[*]@ marker uses the stable id. Vertices whose display
-- equals their id get no declaration. The default 'toMermaid' /
-- 'toMermaidWith' path is unaffected.
toMermaidWithLabels ::
(Bounded s, Enum s) =>
MermaidOptions ->
MermaidStateLabels s ->
SymTransducer (HsPred rs ci) rs s ci co ->
Text
toMermaidWithLabels opts lbls =
renderTopologyWith opts (stateId lbls) (stateDisplayLabel lbls)
-- | Return the ASCII ids that collide: any id produced by 'stateId'
-- for two or more distinct vertices. An empty result means every vertex
-- maps to a unique id. Result order is first-occurrence order.
--
-- Rendering itself stays total (it never throws on a collision); this is
-- the AST-level check a caller runs before trusting a labeled diagram.
-- The sibling validation helpers in "Keiki.Render" detect the same
-- collisions over rendered diagram /text/ and key off the same id token,
-- so the two agree on what an \"id\" is by construction.
duplicateStateIds ::
(Bounded s, Enum s) =>
MermaidStateLabels s ->
SymTransducer (HsPred rs ci) rs s ci co ->
[Text]
duplicateStateIds lbls _t =
let ids = Prelude.map (stateId lbls) [minBound .. maxBound]
in [i | i <- nubInOrder ids, count i ids > (1 :: Int)]
where
count x = length . filter (== x)
nubInOrder =
foldr (\x acc -> if x `elem` acc then acc else x : acc) []
-- | Render a composite 'SymTransducer' (a 'Keiki.Composition.compose'
-- result, vertex type @'Composite' s1 s2@) to a Mermaid
-- @stateDiagram-v2@ block.
--
-- Uses the **flat cross-product** shape: each composite vertex
-- @'Composite' a b@ becomes a single Mermaid identifier
-- @<show a>_<show b>@. The structure is otherwise identical to
-- 'toMermaid' — same initial / final / edge emission rules and readable
-- semantics policy. See EP-31's Decision Log
-- (@docs/plans/31-mermaid-rendering-for-composite-symtransducers.md@)
-- for why the flat shape was chosen over Mermaid's nested-subgraph
-- syntax (Shape B in the plan).
toMermaidComposite ::
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->
Text
toMermaidComposite = toMermaidCompositeWith defaultMermaidOptions
-- | Options-aware variant of 'toMermaidComposite'.
toMermaidCompositeWith ::
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
MermaidOptions ->
SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->
Text
toMermaidCompositeWith opts =
renderTopologyWith opts compositeLabel compositeLabel
-- | Render a right-associative 3-deep
-- @t1 \`'Keiki.Composition.compose'\` (t2 \`'Keiki.Composition.compose'\` t3)@
-- composite (vertex type @'Composite' s1 ('Composite' s2 s3)@) to a
-- Mermaid @stateDiagram-v2@ block in the **flat cross-product** shape.
--
-- Each composite vertex becomes a single Mermaid identifier
-- @\<show s1\>_\<show s2\>_\<show s3\>@ via 'compose3Label'. The
-- structure is otherwise identical to 'toMermaid' /
-- 'toMermaidComposite' — same initial / final / edge emission rules and
-- readable semantics policy. See EP-35's plan
-- (@docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@)
-- for the rationale and for the comparison against the
-- nested-subgraph variant 'toMermaidCompose3Nested'.
toMermaidCompose3 ::
forall rs s1 s2 s3 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
Enum s3,
Bounded s3,
Show s3
) =>
SymTransducer
(HsPred rs ci)
rs
(Composite s1 (Composite s2 s3))
ci
co ->
Text
toMermaidCompose3 = toMermaidCompose3With defaultMermaidOptions
-- | Options-aware variant of 'toMermaidCompose3'.
toMermaidCompose3With ::
forall rs s1 s2 s3 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
Enum s3,
Bounded s3,
Show s3
) =>
MermaidOptions ->
SymTransducer
(HsPred rs ci)
rs
(Composite s1 (Composite s2 s3))
ci
co ->
Text
toMermaidCompose3With opts =
renderTopologyWith opts compose3Label compose3Label
-- | Render a composite 'SymTransducer' (a 'Keiki.Composition.compose'
-- result, vertex type @'Composite' s1 s2@) using the **nested-subgraph**
-- shape (Shape B): each outer @s1@ vertex hosts a
-- @state \<show s1\> { \<inner ids\> }@ block listing every
-- @\<show s1\>_\<show s2\>@ identifier in the column. Cross-cutting
-- transitions remain at the top level using the same flat identifiers
-- 'compositeLabel' produces, so the renderer never relies on
-- Mermaid's @Outer.Inner@ dotted cross-block reference syntax.
--
-- Use this for composites where the cross-product becomes hard to
-- scan as a single line; use 'toMermaidComposite' for tiny composites
-- (1–4 vertices) where outer-state grouping adds visual overhead with
-- no payoff. Both shapes coexist; pick the one that reads best for
-- the composite at hand.
--
-- Note on edge organisation: 'Keiki.Composition.compose' composites
-- have **zero same-outer edges** — every composite edge advances the
-- outer @s1@ component (the composite-edge construction in
-- @Keiki.Composition.composedEdges@ either advances @s1@ on a t1
-- ε-edge or on the synchronised t1+t2 step, never leaves @s1@
-- fixed). The visual benefit of this layout for those composites is
-- structural grouping of vertices, not edge organisation. Composites
-- produced by @Keiki.Composition.alternative@ (which DOES yield
-- same-outer edges) are rendered by a separate
-- @toMermaidAlternative@ entry point — see
-- @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@.
--
-- See EP-32's plan
-- (@docs/plans/32-shape-b-nested-subgraph-mermaid-rendering-for-larger-composites.md@)
-- for the full rationale and the Mermaid-syntax cheatsheet.
toMermaidCompositeNested ::
forall rs s1 s2 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->
Text
toMermaidCompositeNested =
toMermaidCompositeNestedWith defaultMermaidOptions
-- | Options-aware variant of 'toMermaidCompositeNested'.
toMermaidCompositeNestedWith ::
forall rs s1 s2 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
MermaidOptions ->
SymTransducer (HsPred rs ci) rs (Composite s1 s2) ci co ->
Text
toMermaidCompositeNestedWith opts t =
let outers = [minBound .. maxBound] :: [s1]
inners = [minBound .. maxBound] :: [s2]
composites = [minBound .. maxBound] :: [Composite s1 s2]
ind = T.pack " "
ind2 = T.pack " "
arrow = T.pack " --> "
colon = T.pack " : "
header = T.pack "stateDiagram-v2"
initLine =
ind
<> T.pack "[*]"
<> arrow
<> compositeLabel (initial t)
outerBlock o =
T.intercalate (T.pack "\n") $
[ind <> T.pack "state " <> vertexLabel o <> T.pack " {"]
++ [ind2 <> compositeLabel (Composite o i) | i <- inners]
++ [ind <> T.pack "}"]
outerBlocks = [outerBlock o | o <- outers]
edgeLines =
[ ind
<> compositeLabel s
<> arrow
<> compositeLabel (target e)
<> colon
<> edgeLabelWith opts e
| s <- composites,
e <- edgesOut t s
]
finalLines =
[ ind <> compositeLabel s <> arrow <> T.pack "[*]"
| s <- composites,
isFinal t s
]
in T.intercalate
(T.pack "\n")
(header : initLine : outerBlocks ++ edgeLines ++ finalLines)
-- | Render a right-associative 3-deep
-- @t1 \`'Keiki.Composition.compose'\` (t2 \`'Keiki.Composition.compose'\` t3)@
-- composite (vertex type @'Composite' s1 ('Composite' s2 s3)@) using
-- the **one-level nested-subgraph** shape: each outer @s1@ vertex
-- hosts a @state \<show s1\> { \<inner ids\> }@ block listing every
-- @\<show s1\>_\<show s2\>_\<show s3\>@ identifier under that outer.
-- Cross-cutting transitions remain at the top level using the same
-- flat identifiers 'compose3Label' produces, so the renderer never
-- relies on Mermaid's @Outer.Inner@ dotted cross-block reference
-- syntax (the EP-32 lesson, carried forward).
--
-- The nest is intentionally **one level deep**, not two: a two-level
-- nest @state s1 { state s2 { … } }@ would mirror @compose@'s
-- structural shape more faithfully but adds renderer-compat risk
-- (some Mermaid backends parse nested @state@ blocks
-- inconsistently). One-level groups composites by their outer
-- aggregate, which is the readability win the larger 3-deep
-- composites need; if a tighter grouping is later required for a
-- specific use case, a follow-up renderer can add the two-level
-- variant with explicit backend verification.
--
-- See EP-35's plan
-- (@docs/plans/35-mermaid-renderer-for-right-associative-3-deep-compose-composites.md@)
-- for the design record and for the flat counterpart
-- 'toMermaidCompose3'.
toMermaidCompose3Nested ::
forall rs s1 s2 s3 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
Enum s3,
Bounded s3,
Show s3
) =>
SymTransducer
(HsPred rs ci)
rs
(Composite s1 (Composite s2 s3))
ci
co ->
Text
toMermaidCompose3Nested =
toMermaidCompose3NestedWith defaultMermaidOptions
-- | Options-aware variant of 'toMermaidCompose3Nested'.
toMermaidCompose3NestedWith ::
forall rs s1 s2 s3 ci co.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
Enum s3,
Bounded s3,
Show s3
) =>
MermaidOptions ->
SymTransducer
(HsPred rs ci)
rs
(Composite s1 (Composite s2 s3))
ci
co ->
Text
toMermaidCompose3NestedWith opts t =
let outers = [minBound .. maxBound] :: [s1]
inners = [minBound .. maxBound] :: [Composite s2 s3]
composites = [minBound .. maxBound] :: [Composite s1 (Composite s2 s3)]
ind = T.pack " "
ind2 = T.pack " "
arrow = T.pack " --> "
colon = T.pack " : "
header = T.pack "stateDiagram-v2"
initLine =
ind
<> T.pack "[*]"
<> arrow
<> compose3Label (initial t)
outerBlock o =
T.intercalate (T.pack "\n") $
[ind <> T.pack "state " <> vertexLabel o <> T.pack " {"]
++ [ind2 <> compose3Label (Composite o i) | i <- inners]
++ [ind <> T.pack "}"]
outerBlocks = [outerBlock o | o <- outers]
edgeLines =
[ ind
<> compose3Label s
<> arrow
<> compose3Label (target e)
<> colon
<> edgeLabelWith opts e
| s <- composites,
e <- edgesOut t s
]
finalLines =
[ ind <> compose3Label s <> arrow <> T.pack "[*]"
| s <- composites,
isFinal t s
]
in T.intercalate
(T.pack "\n")
(header : initLine : outerBlocks ++ edgeLines ++ finalLines)
-- | Render an 'Keiki.Composition.alternative'-shaped composite as
-- two parallel side-by-side state machines.
--
-- Each component transducer becomes its own
-- @state \<arm-name\> { \<topology\> }@ block listing that arm's edges;
-- both arms share top-level @[*] --> \<initial\>@ initial-state
-- markers and top-level @\<final\> --> [*]@ final-state markers, so
-- the parallel-start / parallel-finish semantics is visible at a
-- glance.
--
-- The runtime composite's vertex space is the cross-product
-- @'Composite' s1 s2@ — but the diagram presents the two arms as
-- independent machines because that mirrors the
-- 'Keiki.Composition.alternative' combinator's actual behaviour:
-- each Either-tagged input advances exactly one arm and leaves the
-- other untouched. The cross-product is implicit; the reader infers
-- "the system's actual state is the combination of both arms'
-- current states."
--
-- Default arm names are @LeftArm@ and @RightArm@. Use
-- 'toMermaidAlternativeWith' to override (e.g. for domain-specific
-- naming such as @EmailArm@ / @PingerArm@).
--
-- Edge labels use the same readable guard/update policy as 'toMermaid'.
-- Because 'Keiki.Composition' lifters preserve @icName@ and @wcName@
-- verbatim, the base label reads naturally even though the runtime input is
-- @'Left' …@ / @'Right' …@. Use 'toMermaidAlternativeWithOptions' with
-- 'topologyMermaidOptions' for the historical compact form.
--
-- See @docs/plans/33-shape-aware-mermaid-renderers-for-alternative-and-feedback1-composites.md@
-- for the full design record.
toMermaidAlternative ::
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->
SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->
Text
toMermaidAlternative =
toMermaidAlternativeWithOptions
defaultMermaidOptions
(T.pack "LeftArm")
(T.pack "RightArm")
-- | The arm-name-overridable variant of 'toMermaidAlternative'. The
-- two 'Text' arguments name the left and right @state … { … }@
-- blocks; pick names that match the user's domain vocabulary.
--
-- The names must be valid Mermaid identifiers
-- (regex @[A-Za-z_][A-Za-z0-9_]*@); the renderer does not validate
-- them.
toMermaidAlternativeWith ::
forall rs1 rs2 s1 s2 ci1 ci2 co1 co2.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
-- | Left arm's state-block name.
Text ->
-- | Right arm's state-block name.
Text ->
SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->
SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->
Text
toMermaidAlternativeWith =
toMermaidAlternativeWithOptions defaultMermaidOptions
-- | Options-aware, arm-name-overridable variant of
-- 'toMermaidAlternative'.
toMermaidAlternativeWithOptions ::
forall rs1 rs2 s1 s2 ci1 ci2 co1 co2.
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2
) =>
MermaidOptions ->
Text ->
Text ->
SymTransducer (HsPred rs1 ci1) rs1 s1 ci1 co1 ->
SymTransducer (HsPred rs2 ci2) rs2 s2 ci2 co2 ->
Text
toMermaidAlternativeWithOptions opts leftName rightName t1 t2 =
let ind = T.pack " "
ind2 = T.pack " "
arrow = T.pack " --> "
colon = T.pack " : "
header = T.pack "stateDiagram-v2"
initLines =
[ ind <> T.pack "[*]" <> arrow <> vertexLabel (initial t1),
ind <> T.pack "[*]" <> arrow <> vertexLabel (initial t2)
]
armBlock ::
forall rs s ci co.
(Enum s, Bounded s, Show s) =>
Text ->
SymTransducer (HsPred rs ci) rs s ci co ->
Text
armBlock name t =
T.intercalate (T.pack "\n") $
[ind <> T.pack "state " <> name <> T.pack " {"]
++ [ ind2
<> vertexLabel s
<> arrow
<> vertexLabel (target e)
<> colon
<> edgeLabelWith opts e
| s <- [minBound .. maxBound],
e <- edgesOut t s
]
++ [ind <> T.pack "}"]
finalLines ::
forall rs s ci co.
(Enum s, Bounded s, Show s) =>
SymTransducer (HsPred rs ci) rs s ci co ->
[Text]
finalLines t =
[ ind <> vertexLabel s <> arrow <> T.pack "[*]"
| s <- [minBound .. maxBound],
isFinal t s
]
in T.intercalate (T.pack "\n") $
[header]
++ initLines
++ [ armBlock leftName t1,
armBlock rightName t2
]
++ finalLines t1
++ finalLines t2
-- | Render a 'Keiki.Composition.feedback1'-shaped composite as a
-- flat 3-deep cross-product diagram.
--
-- The composite's vertex type is
-- @'Composite' s1 ('Composite' s2 s1)@ — outer-t state, then policy
-- state, then inner-t state. Each composite vertex becomes a single
-- Mermaid identifier @\<show s1\>_\<show s2\>_\<show s1\>@. The two
-- copies of @t@ (outer and inner) share the same Haskell vertex
-- type but occupy distinct dimensions of the composite tuple, so
-- they are labelled independently.
--
-- For the cascade structure (@'feedback1' t f =
-- 'compose' t ('compose' f t)@), see @feedback1@'s haddock and the
-- design note at
-- @docs/research/composition-combinators-design.md@. The renderer
-- treats the resulting transducer as a flat enumerable cross-product;
-- it does not inspect the cascade structure beyond decomposing the
-- composite tuple for labelling.
toMermaidFeedback1 ::
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
WeakenR rs1,
WeakenR rs2,
Disjoint (Names rs2) (Names rs1),
Disjoint (Names rs1) (Names (Append rs2 rs1))
) =>
SymTransducer (HsPred rs1 ci) rs1 s1 ci co ->
SymTransducer (HsPred rs2 co) rs2 s2 co ci ->
Text
toMermaidFeedback1 = toMermaidFeedback1With defaultMermaidOptions
-- | Options-aware variant of 'toMermaidFeedback1'.
toMermaidFeedback1With ::
( Enum s1,
Bounded s1,
Show s1,
Enum s2,
Bounded s2,
Show s2,
WeakenR rs1,
WeakenR rs2,
Disjoint (Names rs2) (Names rs1),
Disjoint (Names rs1) (Names (Append rs2 rs1))
) =>
MermaidOptions ->
SymTransducer (HsPred rs1 ci) rs1 s1 ci co ->
SymTransducer (HsPred rs2 co) rs2 s2 co ci ->
Text
toMermaidFeedback1With opts t f =
renderTopologyWith opts feedback1Label feedback1Label (feedback1 t f)
-- | The Mermaid identifier for a 'feedback1' composite vertex.
-- @\<show outer\>_\<show policy\>_\<show inner\>@. Like
-- 'compositeLabel', joined with underscores so the result still
-- matches Mermaid's identifier regex @[A-Za-z_][A-Za-z0-9_]*@.
feedback1Label ::
(Show s1, Show s2) =>
Composite s1 (Composite s2 s1) -> Text
feedback1Label (Composite a (Composite b c)) =
T.pack (show a)
<> T.pack "_"
<> T.pack (show b)
<> T.pack "_"
<> T.pack (show c)
-- | The Mermaid identifier for a right-associative 3-deep
-- @'Composite' s1 ('Composite' s2 s3)@ vertex.
-- @\<show outer\>_\<show middle\>_\<show inner\>@ — joined with
-- underscores so the result still matches Mermaid's identifier regex
-- @[A-Za-z_][A-Za-z0-9_]*@. The default 'Show' for 'Composite' emits
-- @"Composite a (Composite b c)"@ with whitespace and parentheses, which
-- is not a legal Mermaid identifier; this label sidesteps that by
-- destructuring the composite tuple itself and joining the three
-- component shows directly.
--
-- Sibling of 'compositeLabel' (2-deep) and 'feedback1Label' (3-deep
-- with @s1@ recurring at the inner-inner position). 'compose3Label'
-- requires three independent 'Show' constraints because the three
-- component vertex types are unrelated.
compose3Label ::
(Show s1, Show s2, Show s3) =>
Composite s1 (Composite s2 s3) -> Text
compose3Label (Composite a (Composite b c)) =
T.pack (show a)
<> T.pack "_"
<> T.pack (show b)
<> T.pack "_"
<> T.pack (show c)
-- | The shared options-aware rendering core: walk
-- @[minBound .. maxBound]@ and render every transition with
-- 'edgeLabelWith'.
renderTopologyWith ::
(Enum s, Bounded s) =>
MermaidOptions ->
-- | @idOf@: the stable Mermaid identifier for a vertex, used as
-- the node id and in every transition arrow.
(s -> Text) ->
-- | @displayOf@: the visible display label for a vertex, which may
-- contain spaces. When it differs from @idOf@ the renderer emits a
-- @state \"<display>\" as <id>@ declaration line.
(s -> Text) ->
SymTransducer (HsPred rs ci) rs s ci co ->
Text
renderTopologyWith opts idOf displayOf t =
let vertices = [minBound .. maxBound]
header = T.pack "stateDiagram-v2"
ind = T.pack " "
arrow = T.pack " --> "
colon = T.pack " : "
-- A declaration is emitted ONLY when the display differs from
-- the id; when they are equal (the Show-based default) this list
-- is empty, so the default output stays byte-identical.
declLines =
[ ind <> T.pack "state \"" <> displayOf s <> T.pack "\" as " <> idOf s
| s <- vertices,
displayOf s /= idOf s
]
initLine = ind <> T.pack "[*]" <> arrow <> idOf (initial t)
edgeLines =
[ ind
<> idOf s
<> arrow
<> idOf (target e)
<> colon
<> edgeLabelWith opts e
| s <- vertices,
e <- edgesOut t s
]
finalLines =
[ ind <> idOf s <> arrow <> T.pack "[*]"
| s <- vertices,
isFinal t s
]
in T.intercalate
(T.pack "\n")
(header : declLines ++ initLine : edgeLines ++ finalLines)
-- | The Mermaid identifier for a vertex. @'T.pack' . 'show'@ — for
-- every shipped aggregate's vertex type, the data-constructor names
-- already obey Mermaid's identifier regex
-- @[A-Za-z_][A-Za-z0-9_]*@.
vertexLabel :: (Show s) => s -> Text
vertexLabel = T.pack . show
-- | The Mermaid identifier for a composite vertex.
-- @'show' a \<\> "_" \<\> 'show' b@ — joined with an underscore so the
-- result still matches Mermaid's identifier regex
-- @[A-Za-z_][A-Za-z0-9_]*@. (The default 'Show' for 'Composite' emits
-- @"Composite a b"@ with spaces, which is not a legal Mermaid
-- identifier.)
compositeLabel :: (Show s1, Show s2) => Composite s1 s2 -> Text
compositeLabel (Composite a b) =
T.pack (show a) <> T.pack "_" <> T.pack (show b)
-- | Extract the input-constructor name from an edge's guard, walking
-- the 'HsPred' AST for the leftmost 'PInCtor' atom. Returns 'Nothing'
-- if the guard contains no 'PInCtor'.
--
-- Every edge introduced via @"Keiki.Builder".'Keiki.Builder.onCmd'@
-- has a recoverable input-constructor name because the builder wraps
-- each guard in @'PAnd' ('PInCtor' ic) inner@. Hand-written AST edges
-- that omit 'PInCtor' produce 'Nothing'; 'edgeLabel' substitutes
-- @"?"@ in that case.
edgeInputName :: Edge (HsPred rs ci) rs ci co s -> Maybe Text
edgeInputName Edge {guard = g} = walk g
where
walk :: HsPred rs ci -> Maybe Text
walk (PInCtor InCtor {icName = n}) = Just (T.pack n)
walk (PAnd a b) = walk a <|> walk b
walk (POr a b) = walk a <|> walk b
walk (PNot p) = walk p
walk PTop = Nothing
walk PBot = Nothing
walk PLeftArm = Nothing
walk PRightArm = Nothing
walk (PEq _ _) = Nothing
walk (PCmp {}) = Nothing
-- | Extract the output-constructor name(s) from an edge's output
-- list. Returns 'Nothing' for an ε-edge (an edge whose 'output' is
-- @[]@); 'Just' a length-1/2/N rendering otherwise.
--
-- Per EP-19's design note, the rendering uses a length-based
-- switchover:
--
-- * length 1: @e1@ — same as the letter case.
-- * length 2: @e1; e2@ — compact inline separator.
-- * length 3+: @e1\<br/>e2\<br/>…\<br/>eN@ — Mermaid multi-line.
edgeOutputName :: Edge (HsPred rs ci) rs ci co s -> Maybe Text
edgeOutputName = edgeOutputNameWith MermaidOutputSemicolon
-- | The layout-aware output renderer behind 'edgeOutputName'. Returns
-- 'Nothing' for an ε-edge (output @[]@) under every layout, and the lone
-- constructor name for a single-event edge under every layout. For two or
-- more events the chosen 'MermaidOutputLayout' decides the rendering:
--
-- * 'MermaidOutputSemicolon' reproduces 'edgeOutputName''s historical
-- length-based behaviour — @;@ for exactly two, @<br/>@ for three or
-- more.
-- * 'MermaidOutputMultiline' always joins with @<br/>@.
-- * 'MermaidOutputCounted' collapses to @N events@.
--
-- Output order is the transducer's 'output' list order, preserved
-- verbatim.
edgeOutputNameWith ::
MermaidOutputLayout ->
Edge (HsPred rs ci) rs ci co s ->
Maybe Text
edgeOutputNameWith layout Edge {output = outs} = case outs of
[] -> Nothing
[o] -> Just (wcN o)
many -> Just (render layout (Prelude.map wcN many))
where
wcN :: OutTerm rs ci co -> Text
wcN (OPack _ wc _) = escapeSemanticText (T.pack (wcName wc))
render :: MermaidOutputLayout -> [Text] -> Text
render MermaidOutputSemicolon ns
| length ns == 2 = T.intercalate (T.pack "; ") ns
| otherwise = T.intercalate (T.pack "<br/>") ns
render MermaidOutputMultiline ns = T.intercalate (T.pack "<br/>") ns
render MermaidOutputCounted ns = T.pack (show (length ns) <> " events")
-- | The Mermaid edge label for an edge: @<input ctor> / <output ctor>@.
-- A missing input-constructor name (no 'PInCtor' in the guard)
-- becomes @"?"@; a missing output (an ε-edge) becomes @"ε"@. Uses the
-- default 'MermaidOutputSemicolon' output layout, so its behaviour is
-- unchanged from before EP-63.
edgeLabel :: Edge (HsPred rs ci) rs ci co s -> Text
edgeLabel = edgeLabelWithLayout MermaidOutputSemicolon
-- | The output-layout-aware base label behind 'edgeLabel'. Renders
-- @<input ctor> / <output ctor>@ using the supplied 'MermaidOutputLayout'
-- for the output half; 'edgeLabel' delegates to it with
-- 'MermaidOutputSemicolon'.
edgeLabelWithLayout ::
MermaidOutputLayout ->
Edge (HsPred rs ci) rs ci co s ->
Text
edgeLabelWithLayout layout e =
let inp = escapeSemanticText (maybe (T.pack "?") id (edgeInputName e))
out = maybe (T.pack "\x03B5") id (edgeOutputNameWith layout e)
in inp <> T.pack " / " <> out
-- | The options-aware edge label. Semantic text is escaped before this
-- function inserts its own @<br/>@ layout separators, so user/domain text
-- cannot create extra label lines.
edgeLabelWith ::
MermaidOptions ->
Edge (HsPred rs ci) rs ci co s ->
Text
edgeLabelWith opts e@Edge {update = u, guard = g} =
-- The whole edge @e@ is reused for the base label; @u@ and @g@ are
-- bound by the pattern so the existential write-set in @update@ does
-- not escape (the record selector cannot be used as a function for
-- it). This function owns only segment /layout/ and /truncation/ and
-- the output rendering; guard /text/ is produced by
-- 'renderGuardSegment' (EP-61's chokepoint).
let base = edgeLabelWithLayout (outputLayout opts) e
uPart = case renderUpdateSegment opts u of
Just t -> [t]
Nothing -> []
gPart = case renderGuardSegment opts g of
Just t -> [T.pack "g: " <> truncateGuard (maxInlineGuardWidth opts) t]
Nothing -> []
parts = uPart ++ gPart
in case labelLayout opts of
MermaidLabelInline ->
if null parts
then base
else base <> T.pack " [" <> T.intercalate (T.pack "; ") parts <> T.pack "]"
MermaidLabelMultiline ->
T.intercalate (T.pack "<br/>") (base : parts)
-- | Keep the first @k@ slots, replacing the rest with a single
-- @+{n-k} more@ token. 'Nothing' or @n <= k@ leaves the list unchanged.
-- Slot order is preserved.
truncateSlots :: Maybe Int -> [Text] -> [Text]
truncateSlots Nothing xs = xs
truncateSlots (Just k) xs
| length xs > k =
take k xs ++ [T.pack ("+" <> show (length xs - k) <> " more")]
| otherwise = xs
-- | Truncate guard segment text to @w@ characters, appending the
-- ellipsis @…@ (U+2026) when it was longer. 'Nothing' or a text already
-- within @w@ characters is returned unchanged.
truncateGuard :: Maybe Int -> Text -> Text
truncateGuard Nothing t = t
truncateGuard (Just w) t
| T.length t > w = T.take w t <> T.pack "\x2026"
| otherwise = t
-- | Recover the names of the slots an edge's 'Update' writes, by
-- structural recursion over the 'Update' value. 'USet's @KnownSymbol s@
-- constraint (brought into scope by the pattern match) lets
-- 'indexNName' read the slot name off the index; no type-level
-- write-set machinery is needed.
writtenSlots :: Update rs w ci -> [Text]
writtenSlots UKeep = []
writtenSlots (USet ix _) = [T.pack (indexNName ix)]
writtenSlots (UCombine a b) = writtenSlots a ++ writtenSlots b
-- | Produce the update segment text for an edge. Pretty mode retains the
-- complete right-hand expressions; written-slot mode is the compact legacy
-- summary and may use its dedicated truncation option.
renderUpdateSegment :: MermaidOptions -> Update rs w ci -> Maybe Text
renderUpdateSegment opts u =
case updateMode opts of
MermaidUpdateHidden -> Nothing
MermaidUpdateWrittenSlots ->
case truncateSlots
(maxInlineWrittenSlots opts)
(Prelude.map escapeSemanticText (writtenSlots u)) of
[] -> Nothing
xs -> Just (T.pack "w: " <> T.intercalate (T.pack "; ") xs)
MermaidUpdatePretty ->
Just (T.pack "u: " <> escapeSemanticText (prettyUpdate u))
-- | Produce the guard segment text for an edge, or 'Nothing' when no
-- guard segment should appear. Semantic text is escaped here, before label
-- layout is assembled.
renderGuardSegment :: MermaidOptions -> HsPred rs ci -> Maybe Text
renderGuardSegment opts g =
escapeSemanticText <$> case guardMode opts of
MermaidGuardHidden -> Nothing
MermaidGuardStructuralSummary -> Just (guardSummary g)
MermaidGuardPretty -> Just (prettyPred g)
-- | Escape domain-derived label text exactly once into a visible,
-- non-structural alphabet. The documentation backend decodes XML entities
-- before parsing Mermaid and also turns both @<br>@ spellings and literal
-- @\\n@ into line breaks, so entity encoding alone cannot isolate semantic
-- text. Full-width punctuation keeps the value recognizable while preventing
-- parser control. XML entities retain punctuation that the backend can safely
-- decode, full-width angle brackets keep break-tag-like input inert, and
-- control pictures make raw line endings visible rather than structural.
-- Renderer-owned ASCII @<br/>@ is inserted only after this pass. The known
-- opaque marker @<lit>@ is encoded as entities because it cannot be a break
-- tag and should remain visually exact.
escapeSemanticText :: Text -> Text
escapeSemanticText =
T.intercalate (T.pack "<lit>")
. Prelude.map (T.concatMap escapeChar)
. T.splitOn (T.pack "<lit>")
where
escapeChar '\r' = T.pack "\x240D"
escapeChar '\n' = T.pack "\x240A"
escapeChar '\\' = T.pack "\xFF3C"
escapeChar '\'' = T.pack "'"
escapeChar '"' = T.pack """
escapeChar '&' = T.pack "&"
escapeChar '<' = T.pack "\xFF1C"
escapeChar '>' = T.pack "\xFF1E"
escapeChar '|' = T.pack "|"
escapeChar '{' = T.pack "{"
escapeChar '}' = T.pack "}"
escapeChar c = T.singleton c
-- | A structural, total summary of a guard predicate: its constructor
-- tags in left-to-right (prefix) order, with 'PCmp' carrying its 'Cmp'
-- direction. It deliberately does NOT print the operand 'Term's — those
-- can hold opaque Haskell functions ('TApp1'\/'TApp2'), and the
-- input-constructor inside 'PInCtor' carries unprintable match\/build
-- functions. This is the faithful renderable projection of an otherwise
-- unprintable AST.
guardSummary :: HsPred rs ci -> Text
guardSummary = T.intercalate (T.pack " ") . go
where
go :: HsPred rs ci -> [Text]
go PTop = [T.pack "PTop"]
go PBot = [T.pack "PBot"]
go (PAnd a b) = T.pack "PAnd" : go a ++ go b
go (POr a b) = T.pack "POr" : go a ++ go b
go (PNot p) = T.pack "PNot" : go p
go (PEq _ _) = [T.pack "PEq"]
go (PInCtor _) = [T.pack "PInCtor"]
go PLeftArm = [T.pack "PLeftArm"]
go PRightArm = [T.pack "PRightArm"]
go (PCmp c _ _) = [T.pack "PCmp " <> T.pack (show c)]
-- | Assemble several already-rendered Mermaid diagrams into one
-- document, each under a labelled section. Each input pair is
-- @(sectionLabel, renderedDiagram)@ where @renderedDiagram@ is the
-- 'Text' produced by any single-transducer or composite renderer in
-- this module (e.g. 'toMermaid', 'toMermaidComposite'). The label is
-- emitted as a Markdown level-2 heading; the diagram is emitted inside
-- a fenced @mermaid@ code block so it renders inline in GitHub \/
-- Notion \/ Markdown previewers.
--
-- Transducers are heterogeneously typed (each has its own vertex,
-- register, input and output types), so a single list of transducers
-- would not type-check; taking already-rendered 'Text' lets each caller
-- pick the matching renderer for its own transducer. An empty list
-- yields the empty 'Text'.
toMermaidAtlas :: [(Text, Text)] -> Text
toMermaidAtlas sections =
toMermaidAtlasWith
defaultMermaidAtlasOptions
[ MermaidSection
{ sectionId = T.pack ("section-" <> show i),
sectionTitle = title,
sectionKind = CustomDiagram (T.pack ""),
sectionDiagram = diagram
}
| (i, (title, diagram)) <- zip [(0 :: Int) ..] sections
]
-- | What kind of transducer a diagram section depicts. Lets a generated
-- atlas distinguish an aggregate state diagram from a process-manager or
-- workflow diagram. 'CustomDiagram' carries a caller-chosen label for
-- anything outside the three named kinds.
data MermaidSectionKind
= AggregateDiagram
| ProcessManagerDiagram
| WorkflowDiagram
| CustomDiagram Text
deriving stock (Eq, Show)
-- | One section of a diagram atlas. 'sectionDiagram' is already-rendered
-- Mermaid 'Text' (produced by 'toMermaid' \/ 'toMermaidWith' or any other
-- renderer in this module), so the atlas is independent of the
-- transducer's vertex\/register\/input\/output types. 'sectionId' is a
-- stable token suitable for use as a Markdown replacement-marker id (see
-- "Keiki.Render.Markdown").
data MermaidSection = MermaidSection
{ sectionId :: Text,
sectionTitle :: Text,
sectionKind :: MermaidSectionKind,
sectionDiagram :: Text
}
deriving stock (Eq, Show)
-- | How (or whether) to surface a section's 'MermaidSectionKind' in the
-- rendered atlas.
data AtlasKindDisplay
= -- | Do not render the kind at all (default).
KindHidden
| -- | Render the kind as a visible italic line under the heading.
KindAsLabel
| -- | Render the kind as an HTML comment (invisible in previews).
KindAsComment
deriving stock (Eq, Show)
-- | Options for 'toMermaidAtlasWith'. Every field defaults (in
-- 'defaultMermaidAtlasOptions') to a value that reproduces the legacy
-- 'toMermaidAtlas' output byte-for-byte.
data MermaidAtlasOptions = MermaidAtlasOptions
{ -- | Optional top-level heading prepended above all sections. Default 'Nothing'.
atlasTitle :: Maybe Text,
-- | Markdown heading level for each section heading. Default 2 (@## @).
atlasSectionHeadingLevel :: Int,
-- | Whether\/how to show each section's kind. Default 'KindHidden'.
atlasShowSectionKind :: AtlasKindDisplay,
-- | When @'Just' ns@, wrap each section's fenced block in
-- @\<!-- ns: sectionId begin --\>@ \/ @\<!-- ns: sectionId end --\>@
-- markers, so 'Keiki.Render.Markdown.replaceMarkdownDiagramBlock' can
-- later update that block in place. Default 'Nothing'.
atlasWrapMarkers :: Maybe Text,
-- | Fenced-block language tag. Default @"mermaid"@.
atlasFenceLanguage :: Text
}
-- | The default atlas options: no top-level title, heading level 2,
-- hidden kind, no markers, @mermaid@ fence. @'toMermaidAtlasWith'
-- 'defaultMermaidAtlasOptions'@ over sections built from @(title, diagram)@
-- pairs is byte-identical to the legacy 'toMermaidAtlas'.
defaultMermaidAtlasOptions :: MermaidAtlasOptions
defaultMermaidAtlasOptions =
MermaidAtlasOptions
{ atlasTitle = Nothing,
atlasSectionHeadingLevel = 2,
atlasShowSectionKind = KindHidden,
atlasWrapMarkers = Nothing,
atlasFenceLanguage = T.pack "mermaid"
}
-- | Assemble typed diagram sections into one Markdown document. With
-- 'defaultMermaidAtlasOptions' the per-section output is
-- @## {title}\\n\\n```{lang}\\n{diagram}\\n```@ and sections are joined by a
-- blank line, byte-identical to the legacy 'toMermaidAtlas'. Turning on a
-- field adds output (a top-level title, a per-section kind line, or
-- begin/end markers keyed by 'sectionId') without disturbing the rest.
toMermaidAtlasWith :: MermaidAtlasOptions -> [MermaidSection] -> Text
toMermaidAtlasWith opts secs =
let body = T.intercalate (T.pack "\n\n") (map (renderSection opts) secs)
in case atlasTitle opts of
Nothing -> body
Just t
| T.null body -> T.pack "# " <> t
| otherwise -> T.pack "# " <> t <> T.pack "\n\n" <> body
-- | Render one atlas section: a heading, an optional kind line, and the
-- fenced diagram block (optionally wrapped in begin/end markers). The
-- within-section pieces are joined by a blank line.
renderSection :: MermaidAtlasOptions -> MermaidSection -> Text
renderSection opts sec =
let heading =
T.replicate (atlasSectionHeadingLevel opts) (T.pack "#")
<> T.pack " "
<> sectionTitle sec
kindLine = case atlasShowSectionKind opts of
KindHidden -> Nothing
KindAsLabel -> Just (T.pack "_" <> kindText (sectionKind sec) <> T.pack "_")
KindAsComment -> Just (T.pack "<!-- kind: " <> kindText (sectionKind sec) <> T.pack " -->")
fenced =
T.pack "```"
<> atlasFenceLanguage opts
<> T.pack "\n"
<> sectionDiagram sec
<> T.pack "\n```"
block = case atlasWrapMarkers opts of
Nothing -> fenced
Just ns ->
T.pack "<!-- "
<> ns
<> T.pack ": "
<> sectionId sec
<> T.pack " begin -->\n"
<> fenced
<> T.pack "\n<!-- "
<> ns
<> T.pack ": "
<> sectionId sec
<> T.pack " end -->"
in T.intercalate (T.pack "\n\n") (heading : maybe id (:) kindLine [block])
-- | The visible label for a 'MermaidSectionKind', used by
-- 'renderSection' when 'atlasShowSectionKind' is not 'KindHidden'.
kindText :: MermaidSectionKind -> Text
kindText AggregateDiagram = T.pack "Aggregate"
kindText ProcessManagerDiagram = T.pack "Process manager"
kindText WorkflowDiagram = T.pack "Workflow"
kindText (CustomDiagram lbl) = lbl