--- /dev/null
+
+-- | Pretty printing of graphs.
+
+module GraphPpr (
+ dumpGraph,
+ dotGraph
+)
+where
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph
+ :: (Outputable k, Outputable cls, Outputable color)
+ => Graph k cls color -> SDoc
+
+dumpGraph graph
+ = text "Graph"
+ $$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
+
+dumpNode node
+ = text "Node " <> ppr (nodeId node)
+ $$ text "conflicts "
+ <> parens (int (sizeUniqSet $ nodeConflicts node))
+ <> text " = "
+ <> ppr (nodeConflicts node)
+
+ $$ text "exclusions "
+ <> parens (int (sizeUniqSet $ nodeExclusions node))
+ <> text " = "
+ <> ppr (nodeExclusions node)
+
+ $$ text "coalesce "
+ <> parens (int (sizeUniqSet $ nodeCoalesce node))
+ <> text " = "
+ <> ppr (nodeCoalesce node)
+
+ $$ space
+
+
+
+-- | Pretty print a graph in graphviz .dot format.
+-- Conflicts get solid edges.
+-- Coalescences get dashed edges.
+dotGraph
+ :: ( Uniquable k
+ , Outputable k, Outputable cls, Outputable color)
+ => (color -> SDoc) -- | What graphviz color to use for each node color
+ -- It's usually safe to return X11 style colors here,
+ -- ie "red", "green" etc or a hex triplet #aaff55 etc
+ -> Triv k cls color
+ -> Graph k cls color -> SDoc
+
+dotGraph colorMap triv graph
+ = let nodes = eltsUFM $ graphMap graph
+ in vcat
+ ( [ text "graph G {" ]
+ ++ map (dotNode colorMap triv) nodes
+ ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+ ++ [ text "}"
+ , space ])
+
+dotNode colorMap triv node
+ = let name = ppr $ nodeId node
+ cls = ppr $ nodeClass node
+
+ excludes
+ = hcat $ punctuate space
+ $ map (\n -> text "-" <> ppr n)
+ $ uniqSetToList $ nodeExclusions node
+
+ preferences
+ = hcat $ punctuate space
+ $ map (\n -> text "+" <> ppr n)
+ $ nodePreference node
+
+ expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
+ then empty
+ else text "\\n" <> (excludes <+> preferences)
+
+ -- if the node has been colored then show that,
+ -- otherwise indicate whether it looks trivially colorable.
+ color
+ | Just c <- nodeColor node
+ = text "\\n(" <> ppr c <> text ")"
+
+ | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+ = text "\\n(" <> text "triv" <> text ")"
+
+ | otherwise
+ = text "\\n(" <> text "spill?" <> text ")"
+
+ label = name <> text " :: " <> cls
+ <> expref
+ <> color
+
+ pcolorC = case nodeColor node of
+ Nothing -> text "style=filled fillcolor=white"
+ Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
+
+
+ pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
+ <> space <> doubleQuotes name
+ <> text ";"
+
+ in pout
+
+
+-- | Nodes in the graph are doubly linked, but we only want one edge for each
+-- conflict if the graphviz graph. Traverse over the graph, but make sure
+-- to only print the edges for each node once.
+
+dotNodeEdges visited node
+ | elementOfUniqSet (nodeId node) visited
+ = ( visited
+ , Nothing)
+
+ | otherwise
+ = let dconflicts
+ = map (dotEdgeConflict (nodeId node))
+ $ uniqSetToList
+ $ minusUniqSet (nodeConflicts node) visited
+
+ dcoalesces
+ = map (dotEdgeCoalesce (nodeId node))
+ $ uniqSetToList
+ $ minusUniqSet (nodeCoalesce node) visited
+
+ out = vcat dconflicts
+ $$ vcat dcoalesces
+
+ in ( addOneToUniqSet visited (nodeId node)
+ , Just out)
+
+dotEdgeConflict u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> text ";"
+
+dotEdgeCoalesce u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> space <> text "[ style = dashed ];"
+