-- | Pretty printing of graphs.

module GHC.Data.Graph.Ppr
   ( dumpGraph
   , dotGraph
   )
where

import GHC.Prelude

import GHC.Data.Graph.Base

import GHC.Utils.Outputable
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM

import Data.List (mapAccumL)
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 k cls color -> SDoc
dumpGraph Graph k cls color
graph
        =  String -> SDoc
text String
"Graph"
        SDoc -> SDoc -> SDoc
$$ UniqFM k (Node k cls color) -> ([Node k cls color] -> SDoc) -> SDoc
forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (Graph k cls color -> UniqFM k (Node k cls color)
forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph) ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([Node k cls color] -> [SDoc]) -> [Node k cls color] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node k cls color -> SDoc) -> [Node k cls color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> SDoc
forall k color cls.
(Outputable k, Outputable color) =>
Node k cls color -> SDoc
dumpNode)

dumpNode
        :: (Outputable k, Outputable color)
        => Node k cls color -> SDoc

dumpNode :: Node k cls color -> SDoc
dumpNode Node k cls color
node
        =  String -> SDoc
text String
"Node " SDoc -> SDoc -> SDoc
<> k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"conflicts "
                SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int (UniqSet k -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet k -> Int) -> UniqSet k -> Int
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> UniqSet k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node)

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"exclusions "
                SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int (UniqSet color -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet color -> Int) -> UniqSet color -> Int
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> UniqSet color -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"coalesce "
                SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int (UniqSet k -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet k -> Int) -> UniqSet k -> Int
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> UniqSet k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)

        SDoc -> SDoc -> SDoc
$$ SDoc
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 :: (color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
dotGraph color -> SDoc
colorMap Triv k cls color
triv Graph k cls color
graph
 = let  nodes :: [Node k cls color]
nodes   = UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ Graph k cls color -> UniqFM k (Node k cls color)
forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph
                  -- See Note [Unique Determinism and code generation]
   in   [SDoc] -> SDoc
vcat
                (  [ String -> SDoc
text String
"graph G {" ]
                [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ (Node k cls color -> SDoc) -> [Node k cls color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((color -> SDoc) -> Triv k cls color -> Node k cls color -> SDoc
forall k cls color.
(Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Node k cls color -> SDoc
dotNode color -> SDoc
colorMap Triv k cls color
triv) [Node k cls color]
nodes
                [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ ([Maybe SDoc] -> [SDoc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SDoc] -> [SDoc]) -> [Maybe SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (UniqSet k, [Maybe SDoc]) -> [Maybe SDoc]
forall a b. (a, b) -> b
snd ((UniqSet k, [Maybe SDoc]) -> [Maybe SDoc])
-> (UniqSet k, [Maybe SDoc]) -> [Maybe SDoc]
forall a b. (a -> b) -> a -> b
$ (UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc))
-> UniqSet k -> [Node k cls color] -> (UniqSet k, [Maybe SDoc])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc)
forall k cls color.
(Uniquable k, Outputable k) =>
UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc)
dotNodeEdges UniqSet k
forall a. UniqSet a
emptyUniqSet [Node k cls color]
nodes)
                [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ String -> SDoc
text String
"}"
                   , SDoc
space ])


dotNode :: ( Outputable k, Outputable cls, Outputable color)
        => (color -> SDoc)
        -> Triv k cls color
        -> Node k cls color -> SDoc

dotNode :: (color -> SDoc) -> Triv k cls color -> Node k cls color -> SDoc
dotNode color -> SDoc
colorMap Triv k cls color
triv Node k cls color
node
 = let  name :: SDoc
name    = k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (k -> SDoc) -> k -> SDoc
forall a b. (a -> b) -> a -> b
$ Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node
        cls :: SDoc
cls     = cls -> SDoc
forall a. Outputable a => a -> SDoc
ppr (cls -> SDoc) -> cls -> SDoc
forall a b. (a -> b) -> a -> b
$ Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node

        excludes :: SDoc
excludes
                = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space
                ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (color -> SDoc) -> [color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> String -> SDoc
text String
"-" SDoc -> SDoc -> SDoc
<> color -> SDoc
forall a. Outputable a => a -> SDoc
ppr color
n)
                ([color] -> [SDoc]) -> [color] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqSet color -> [color]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet color -> [color]) -> UniqSet color -> [color]
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node
                -- See Note [Unique Determinism and code generation]

        preferences :: SDoc
preferences
                = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space
                ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (color -> SDoc) -> [color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> String -> SDoc
text String
"+" SDoc -> SDoc -> SDoc
<> color -> SDoc
forall a. Outputable a => a -> SDoc
ppr color
n)
                ([color] -> [SDoc]) -> [color] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node

        expref :: SDoc
expref  = if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node), [color] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)]
                        then SDoc
empty
                        else String -> SDoc
text String
"\\n" SDoc -> SDoc -> SDoc
<> (SDoc
excludes SDoc -> SDoc -> SDoc
<+> SDoc
preferences)

        -- if the node has been colored then show that,
        --      otherwise indicate whether it looks trivially colorable.
        color :: SDoc
color
                | Just color
c        <- Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
node
                = String -> SDoc
text String
"\\n(" SDoc -> SDoc -> SDoc
<> color -> SDoc
forall a. Outputable a => a -> SDoc
ppr color
c SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")"

                | Triv k cls color
triv (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)
                = String -> SDoc
text String
"\\n(" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"triv" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")"

                | Bool
otherwise
                = String -> SDoc
text String
"\\n(" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"spill?" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")"

        label :: SDoc
label   =  SDoc
name SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" :: " SDoc -> SDoc -> SDoc
<> SDoc
cls
                SDoc -> SDoc -> SDoc
<> SDoc
expref
                SDoc -> SDoc -> SDoc
<> SDoc
color

        pcolorC :: SDoc
pcolorC = case Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
node of
                        Maybe color
Nothing -> String -> SDoc
text String
"style=filled fillcolor=white"
                        Just color
c  -> String -> SDoc
text String
"style=filled fillcolor=" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (color -> SDoc
colorMap color
c)


        pout :: SDoc
pout    = String -> SDoc
text String
"node [label=" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes SDoc
label SDoc -> SDoc -> SDoc
<> SDoc
space SDoc -> SDoc -> SDoc
<> SDoc
pcolorC SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"]"
                SDoc -> SDoc -> SDoc
<> SDoc
space SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes SDoc
name
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
";"

 in     SDoc
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 :: UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc)
dotNodeEdges UniqSet k
visited Node k cls color
node
        | k -> UniqSet k -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node) UniqSet k
visited
        = ( UniqSet k
visited
          , Maybe SDoc
forall a. Maybe a
Nothing)

        | Bool
otherwise
        = let   dconflicts :: [SDoc]
dconflicts
                        = (k -> SDoc) -> [k] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (k -> k -> SDoc
forall a a. (Outputable a, Outputable a) => a -> a -> SDoc
dotEdgeConflict (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node))
                        ([k] -> [SDoc]) -> [k] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
                        -- See Note [Unique Determinism and code generation]
                        (UniqSet k -> [k]) -> UniqSet k -> [k]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) UniqSet k
visited

                dcoalesces :: [SDoc]
dcoalesces
                        = (k -> SDoc) -> [k] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (k -> k -> SDoc
forall a a. (Outputable a, Outputable a) => a -> a -> SDoc
dotEdgeCoalesce (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node))
                        ([k] -> [SDoc]) -> [k] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
                        -- See Note [Unique Determinism and code generation]
                        (UniqSet k -> [k]) -> UniqSet k -> [k]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node) UniqSet k
visited

                out :: SDoc
out     =  [SDoc] -> SDoc
vcat [SDoc]
dconflicts
                        SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat [SDoc]
dcoalesces

          in    ( UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet k
visited (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node)
                , SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
out)

        where   dotEdgeConflict :: a -> a -> SDoc
dotEdgeConflict a
u1 a
u2
                        = SDoc -> SDoc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" -- " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u2)
                        SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
";"

                dotEdgeCoalesce :: a -> a -> SDoc
dotEdgeCoalesce a
u1 a
u2
                        = SDoc -> SDoc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" -- " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u2)
                        SDoc -> SDoc -> SDoc
<> SDoc
space SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[ style = dashed ];"