82 lines
3.3 KiB
Haskell
82 lines
3.3 KiB
Haskell
module Tessera.Graph where
|
|
|
|
import Tessera.Matrix (Key (..))
|
|
import Tessera.Tree
|
|
|
|
data Rendered = Rendered
|
|
{ renderedNext :: Int
|
|
, renderedRoot :: Int
|
|
, renderedNodes :: [(Int, String, String)]
|
|
, renderedEdges :: [(Int, Int, String)]
|
|
}
|
|
|
|
buildGraph :: Tree -> Rendered
|
|
buildGraph tree =
|
|
let (next, root, nodes, edges) = go tree 0
|
|
in Rendered next root nodes edges
|
|
where
|
|
go node next = case node of
|
|
Success index ->
|
|
(next + 1, next, [(next, "clause " ++ show index, "success")], [])
|
|
Failure ->
|
|
(next + 1, next, [(next, "fail", "failure")], [])
|
|
Bind occurrence name inner ->
|
|
let (next', root', nodes', edges') = go inner (next + 1)
|
|
in (next', next, (next, "bind " ++ renderPath (occurrencePath occurrence) ++ " " ++ name, "bind") : nodes', (next, root', "bind") : edges')
|
|
Switch occurrence branches fallback ->
|
|
let (afterBranches, branchRoots, branchNodes, branchEdges) = goBranches branches (next + 1) [] [] []
|
|
(afterFallback, fallbackRoots, fallbackNodes, fallbackEdges) = case fallback of
|
|
Nothing -> (afterBranches, [], [], [])
|
|
Just defaultTree ->
|
|
let (finalNext, root', nodes', edges') = go defaultTree afterBranches
|
|
in (finalNext, [(root', "default")], nodes', edges')
|
|
node = (next, "switch " ++ renderPath (occurrencePath occurrence), "switch")
|
|
edges = [(next, r, l) | (r, l) <- branchRoots] ++ [(next, r, l) | (r, l) <- fallbackRoots]
|
|
in (afterFallback, next, node : branchNodes ++ fallbackNodes, edges ++ branchEdges ++ fallbackEdges)
|
|
|
|
goBranches [] next roots nodes edges = (next, reverse roots, nodes, edges)
|
|
goBranches ((key, subtree) : rest) next roots nodes edges =
|
|
let (next', root', nodes', edges') = go subtree next
|
|
in goBranches rest next' ((root', renderKey key) : roots) (nodes ++ nodes') (edges ++ edges')
|
|
|
|
renderPath :: [Int] -> String
|
|
renderPath [] = "root"
|
|
renderPath [x] = show x
|
|
renderPath (x : rest) = show x ++ "." ++ renderPath rest
|
|
|
|
renderKey :: Key -> String
|
|
renderKey key = case key of
|
|
KeyCon name -> name
|
|
KeyInt n -> show n
|
|
KeyBool b -> if b then "True" else "False"
|
|
KeyTuple n -> "tuple/" ++ show n
|
|
|
|
renderDot :: Tree -> String
|
|
renderDot tree = unlines (header ++ map renderNode (renderedNodes graph) ++ map renderEdge (renderedEdges graph) ++ ["}"])
|
|
where
|
|
graph = buildGraph tree
|
|
header =
|
|
[ "digraph tessera {"
|
|
, " graph [bgcolor=\"white\", rankdir=TB, nodesep=0.35, ranksep=0.5];"
|
|
, " node [shape=box, style=\"rounded,filled\", color=\"#444444\", fontcolor=\"#1c1c1a\", fillcolor=\"#ffffff\", fontname=\"Helvetica\", fontsize=11];"
|
|
, " edge [color=\"#666666\", fontcolor=\"#333333\", fontname=\"Helvetica\", fontsize=10];"
|
|
]
|
|
renderNode (identifier, label, kind) =
|
|
" n" ++ show identifier ++ " [label=\"" ++ escape label ++ "\"" ++ fillFor kind ++ "];"
|
|
renderEdge (from, to, label) =
|
|
" n" ++ show from ++ " -> n" ++ show to ++ " [label=\"" ++ escape label ++ "\"];"
|
|
fillFor kind = case kind of
|
|
"success" -> ", fillcolor=\"#e7efe4\""
|
|
"failure" -> ", fillcolor=\"#f4e6e4\""
|
|
"switch" -> ", fillcolor=\"#f7f7f5\""
|
|
_ -> ""
|
|
|
|
escape :: String -> String
|
|
escape = concatMap escapeChar
|
|
where
|
|
escapeChar c = case c of
|
|
'"' -> "\\\""
|
|
'\\' -> "\\\\"
|
|
'\n' -> "\\n"
|
|
_ -> [c]
|