-- | 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 :: (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 ];"