never executed always true always false
    1 
    2 -- | Pretty printing of graphs.
    3 
    4 module GHC.Data.Graph.Ppr
    5    ( dumpGraph
    6    , dotGraph
    7    )
    8 where
    9 
   10 import GHC.Prelude
   11 
   12 import GHC.Data.Graph.Base
   13 
   14 import GHC.Utils.Outputable
   15 import GHC.Types.Unique
   16 import GHC.Types.Unique.Set
   17 import GHC.Types.Unique.FM
   18 
   19 import Data.List (mapAccumL)
   20 import Data.Maybe
   21 
   22 
   23 -- | Pretty print a graph in a somewhat human readable format.
   24 dumpGraph
   25         :: (Outputable k, Outputable color)
   26         => Graph k cls color -> SDoc
   27 
   28 dumpGraph graph
   29         =  text "Graph"
   30         $$ pprUFM (graphMap graph) (vcat . map dumpNode)
   31 
   32 dumpNode
   33         :: (Outputable k, Outputable color)
   34         => Node k cls color -> SDoc
   35 
   36 dumpNode 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.
   60 dotGraph
   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 
   69 dotGraph 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 
   80 dotNode :: ( Outputable k, Outputable cls, Outputable color)
   81         => (color -> SDoc)
   82         -> Triv k cls color
   83         -> Node k cls color -> SDoc
   84 
   85 dotNode 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 
  136 dotNodeEdges
  137         :: ( Uniquable k
  138            , Outputable k)
  139         => UniqSet k
  140         -> Node k cls color
  141         -> (UniqSet k, Maybe SDoc)
  142 
  143 dotNodeEdges 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 ];"