-- | 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 :: forall k color cls.
(Outputable k, Outputable color) =>
Graph k cls color -> SDoc
dumpGraph Graph k cls color
graph
        =  forall doc. IsLine doc => String -> doc
text String
"Graph"
        forall doc. IsDoc doc => doc -> doc -> doc
$$ forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph) (forall doc. IsDoc doc => [doc] -> doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 :: forall k color cls.
(Outputable k, Outputable color) =>
Node k cls color -> SDoc
dumpNode Node k cls color
node
        =  forall doc. IsLine doc => String -> doc
text String
"Node " forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall k cls color. Node k cls color -> k
nodeId Node k cls color
node)
        forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsLine doc => String -> doc
text String
"conflicts "
                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => Int -> doc
int (forall a. UniqSet a -> Int
sizeUniqSet forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node))
                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
" = "
                forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node)

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

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

        forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsLine doc => doc
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 :: forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(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   = forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM forall a b. (a -> b) -> a -> b
$ 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   forall doc. IsDoc doc => [doc] -> doc
vcat
                (  [ forall doc. IsLine doc => String -> doc
text String
"graph G {" ]
                forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (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
                forall a. [a] -> [a] -> [a]
++ (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall k cls color.
(Uniquable k, Outputable k) =>
UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc)
dotNodeEdges forall a. UniqSet a
emptyUniqSet [Node k cls color]
nodes)
                forall a. [a] -> [a] -> [a]
++ [ forall doc. IsLine doc => String -> doc
text String
"}"
                   , forall doc. IsLine doc => doc
space ])


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

dotNode :: 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
node
 = let  name :: SDoc
name    = forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> k
nodeId Node k cls color
node
        cls :: SDoc
cls     = forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node

        excludes :: SDoc
excludes
                = forall doc. IsLine doc => [doc] -> doc
hcat forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate forall doc. IsLine doc => doc
space
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> forall doc. IsLine doc => String -> doc
text String
"-" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr color
n)
                forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet forall a b. (a -> b) -> a -> b
$ 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
                = forall doc. IsLine doc => [doc] -> doc
hcat forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate forall doc. IsLine doc => doc
space
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> forall doc. IsLine doc => String -> doc
text String
"+" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr color
n)
                forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node

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

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

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

                | Bool
otherwise
                = forall doc. IsLine doc => String -> doc
text String
"\\n(" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
"spill?" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
")"

        label :: SDoc
label   =  SDoc
name forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
" :: " forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
cls
                forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
expref
                forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
color

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


        pout :: SDoc
pout    = forall doc. IsLine doc => String -> doc
text String
"node [label=" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
doubleQuotes SDoc
label forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
space forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pcolorC forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
"]"
                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
space forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
doubleQuotes SDoc
name
                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
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 :: forall k cls color.
(Uniquable k, Outputable k) =>
UniqSet k -> Node k cls color -> (UniqSet k, Maybe SDoc)
dotNodeEdges UniqSet k
visited Node k cls color
node
        | forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet (forall k cls color. Node k cls color -> k
nodeId Node k cls color
node) UniqSet k
visited
        = ( UniqSet k
visited
          , forall a. Maybe a
Nothing)

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

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

                out :: SDoc
out     =  forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
dconflicts
                        forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
dcoalesces

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

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

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