/compiler/utils/GraphPpr.hs

-- | 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 color)
        => Graph k cls color -> SDoc

dumpGraph graph
        =  text "Graph"
        $$ pprUFM (graphMap graph) (vcat . map dumpNode)

dumpNode
        :: (Outputable k, 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   = nonDetEltsUFM $ graphMap graph
                  -- See Note [Unique Determinism and code generation]
   in   vcat
                (  [ text "graph G {" ]
                ++ map (dotNode colorMap triv) nodes
                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
                ++ [ text "}"
                   , space ])


dotNode :: ( 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)
                $ nonDetEltsUFM $ nodeExclusions node
                -- See Note [Unique Determinism and code generation]

        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)
        => 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))
                        $ nonDetEltsUFM
                        -- See Note [Unique Determinism and code generation]
                        $ minusUniqSet (nodeConflicts node) visited

                dcoalesces
                        = map (dotEdgeCoalesce (nodeId node))
                        $ nonDetEltsUFM
                        -- See Note [Unique Determinism and code generation]
                        $ 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 ];"