From 06520bb54cf352444383155d9d0e2466b99899bc Mon Sep 17 00:00:00 2001
From: sneeker <s@cpl0.zip>
Date: Fri, 14 Feb 2020 12:00:00 +0000
Subject: [PATCH] check match coverage across multiple arguments

---
 src/Tessera/Graph.hs | 81 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 81 insertions(+)
 create mode 100644 src/Tessera/Graph.hs

diff --git a/src/Tessera/Graph.hs b/src/Tessera/Graph.hs
new file mode 100644
index 0000000..8055dcd
--- /dev/null
+++ b/src/Tessera/Graph.hs
@@ -0,0 +1,81 @@
+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]