1 2-- | Pretty printing of graphs. 3 4module GraphPpr ( 5 dumpGraph, 6 dotGraph 7) 8where 9 10import GhcPrelude 11 12import GraphBase 13 14import Outputable 15import Unique 16import UniqSet 17import UniqFM 18 19import Data.List (mapAccumL) 20import Data.Maybe 21 22 23-- | Pretty print a graph in a somewhat human readable format. 24dumpGraph 25 :: (Outputable k, Outputable color) 26 => Graph k cls color -> SDoc 27 28dumpGraph graph 29 = text "Graph" 30 $$ pprUFM (graphMap graph) (vcat . map dumpNode) 31 32dumpNode 33 :: (Outputable k, Outputable color) 34 => Node k cls color -> SDoc 35 36dumpNode node 37 = text "Node " <> ppr (nodeId node) 38 $$ text "conflicts " 39 <> parens (int (sizeUniqSet $ nodeConflicts node)) 40 <> text " = " 41 <> ppr (nodeConflicts node) 42 43 $$ text "exclusions " 44 <> parens (int (sizeUniqSet $ nodeExclusions node)) 45 <> text " = " 46 <> ppr (nodeExclusions node) 47 48 $$ text "coalesce " 49 <> parens (int (sizeUniqSet $ nodeCoalesce node)) 50 <> text " = " 51 <> ppr (nodeCoalesce node) 52 53 $$ space 54 55 56 57-- | Pretty print a graph in graphviz .dot format. 58-- Conflicts get solid edges. 59-- Coalescences get dashed edges. 60dotGraph 61 :: ( Uniquable k 62 , Outputable k, Outputable cls, Outputable color) 63 => (color -> SDoc) -- ^ What graphviz color to use for each node color 64 -- It's usually safe to return X11 style colors here, 65 -- ie "red", "green" etc or a hex triplet #aaff55 etc 66 -> Triv k cls color 67 -> Graph k cls color -> SDoc 68 69dotGraph colorMap triv graph 70 = let nodes = nonDetEltsUFM $ graphMap graph 71 -- See Note [Unique Determinism and code generation] 72 in vcat 73 ( [ text "graph G {" ] 74 ++ map (dotNode colorMap triv) nodes 75 ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) 76 ++ [ text "}" 77 , space ]) 78 79 80dotNode :: ( Outputable k, Outputable cls, Outputable color) 81 => (color -> SDoc) 82 -> Triv k cls color 83 -> Node k cls color -> SDoc 84 85dotNode colorMap triv node 86 = let name = ppr $ nodeId node 87 cls = ppr $ nodeClass node 88 89 excludes 90 = hcat $ punctuate space 91 $ map (\n -> text "-" <> ppr n) 92 $ nonDetEltsUniqSet $ nodeExclusions node 93 -- See Note [Unique Determinism and code generation] 94 95 preferences 96 = hcat $ punctuate space 97 $ map (\n -> text "+" <> ppr n) 98 $ nodePreference node 99 100 expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] 101 then empty 102 else text "\\n" <> (excludes <+> preferences) 103 104 -- if the node has been colored then show that, 105 -- otherwise indicate whether it looks trivially colorable. 106 color 107 | Just c <- nodeColor node 108 = text "\\n(" <> ppr c <> text ")" 109 110 | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) 111 = text "\\n(" <> text "triv" <> text ")" 112 113 | otherwise 114 = text "\\n(" <> text "spill?" <> text ")" 115 116 label = name <> text " :: " <> cls 117 <> expref 118 <> color 119 120 pcolorC = case nodeColor node of 121 Nothing -> text "style=filled fillcolor=white" 122 Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) 123 124 125 pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" 126 <> space <> doubleQuotes name 127 <> text ";" 128 129 in pout 130 131 132-- | Nodes in the graph are doubly linked, but we only want one edge for each 133-- conflict if the graphviz graph. Traverse over the graph, but make sure 134-- to only print the edges for each node once. 135 136dotNodeEdges 137 :: ( Uniquable k 138 , Outputable k) 139 => UniqSet k 140 -> Node k cls color 141 -> (UniqSet k, Maybe SDoc) 142 143dotNodeEdges visited node 144 | elementOfUniqSet (nodeId node) visited 145 = ( visited 146 , Nothing) 147 148 | otherwise 149 = let dconflicts 150 = map (dotEdgeConflict (nodeId node)) 151 $ nonDetEltsUniqSet 152 -- See Note [Unique Determinism and code generation] 153 $ minusUniqSet (nodeConflicts node) visited 154 155 dcoalesces 156 = map (dotEdgeCoalesce (nodeId node)) 157 $ nonDetEltsUniqSet 158 -- See Note [Unique Determinism and code generation] 159 $ minusUniqSet (nodeCoalesce node) visited 160 161 out = vcat dconflicts 162 $$ vcat dcoalesces 163 164 in ( addOneToUniqSet visited (nodeId node) 165 , Just out) 166 167 where dotEdgeConflict u1 u2 168 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) 169 <> text ";" 170 171 dotEdgeCoalesce u1 u2 172 = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) 173 <> space <> text "[ style = dashed ];" 174