2 -- | Pretty printing of graphs.
5 -- The above warning supression flag is a temporary kludge.
6 -- While working on this module you are encouraged to remove it and fix
7 -- any warnings in the module. See
8 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
28 -- | Pretty print a graph in a somewhat human readable format.
30 :: (Outputable k, Outputable cls, Outputable color)
31 => Graph k cls color -> SDoc
35 $$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
38 = text "Node " <> ppr (nodeId node)
40 <> parens (int (sizeUniqSet $ nodeConflicts node))
42 <> ppr (nodeConflicts node)
45 <> parens (int (sizeUniqSet $ nodeExclusions node))
47 <> ppr (nodeExclusions node)
50 <> parens (int (sizeUniqSet $ nodeCoalesce node))
52 <> ppr (nodeCoalesce node)
58 -- | Pretty print a graph in graphviz .dot format.
59 -- Conflicts get solid edges.
60 -- Coalescences get dashed edges.
63 , Outputable k, Outputable cls, Outputable color)
64 => (color -> SDoc) -- | What graphviz color to use for each node color
65 -- It's usually safe to return X11 style colors here,
66 -- ie "red", "green" etc or a hex triplet #aaff55 etc
68 -> Graph k cls color -> SDoc
70 dotGraph colorMap triv graph
71 = let nodes = eltsUFM $ graphMap graph
73 ( [ text "graph G {" ]
74 ++ map (dotNode colorMap triv) nodes
75 ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
79 dotNode colorMap triv node
80 = let name = ppr $ nodeId node
81 cls = ppr $ nodeClass node
84 = hcat $ punctuate space
85 $ map (\n -> text "-" <> ppr n)
86 $ uniqSetToList $ nodeExclusions node
89 = hcat $ punctuate space
90 $ map (\n -> text "+" <> ppr n)
93 expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
95 else text "\\n" <> (excludes <+> preferences)
97 -- if the node has been colored then show that,
98 -- otherwise indicate whether it looks trivially colorable.
100 | Just c <- nodeColor node
101 = text "\\n(" <> ppr c <> text ")"
103 | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
104 = text "\\n(" <> text "triv" <> text ")"
107 = text "\\n(" <> text "spill?" <> text ")"
109 label = name <> text " :: " <> cls
113 pcolorC = case nodeColor node of
114 Nothing -> text "style=filled fillcolor=white"
115 Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
118 pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
119 <> space <> doubleQuotes name
125 -- | Nodes in the graph are doubly linked, but we only want one edge for each
126 -- conflict if the graphviz graph. Traverse over the graph, but make sure
127 -- to only print the edges for each node once.
129 dotNodeEdges visited node
130 | elementOfUniqSet (nodeId node) visited
136 = map (dotEdgeConflict (nodeId node))
138 $ minusUniqSet (nodeConflicts node) visited
141 = map (dotEdgeCoalesce (nodeId node))
143 $ minusUniqSet (nodeCoalesce node) visited
145 out = vcat dconflicts
148 in ( addOneToUniqSet visited (nodeId node)
151 dotEdgeConflict u1 u2
152 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> text ";"
154 dotEdgeCoalesce u1 u2
155 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> space <> text "[ style = dashed ];"