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