1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
-- | Pretty printing of graphs.
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
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
:: (Outputable k, Outputable cls, Outputable color)
=> Node k cls color -> SDoc
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 :: ( Uniquable k
, Outputable k, Outputable cls, Outputable color)
=> (color -> SDoc)
-> Triv k cls color
-> Node k cls color -> SDoc
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
:: ( Uniquable k
, Outputable k, Outputable cls, Outputable color)
=> UniqSet k
-> Node k cls color
-> (UniqSet k, Maybe SDoc)
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)
where 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 ];"
|
