-- | 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
        =  String -> SDoc
text String
"Graph"
        SDoc -> SDoc -> SDoc
$$ 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) ([SDoc] -> SDoc
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
        =  String -> SDoc
text String
"Node " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (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 (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))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (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 (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))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (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 (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))
                SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (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 :: 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   [SDoc] -> SDoc
vcat
                (  [ String -> SDoc
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]
++ [ 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 :: 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
                = [SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> String -> SDoc
text String
"-" SDoc -> SDoc -> SDoc
<> 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
                = [SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\color
n -> String -> SDoc
text String
"+" SDoc -> SDoc -> SDoc
<> 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 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        <- forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
node
                = String -> SDoc
text String
"\\n(" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr color
c SDoc -> SDoc -> SDoc
<> String -> SDoc
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)
                = 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 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 :: 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     =  [SDoc] -> SDoc
vcat [SDoc]
dconflicts
                        SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
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
                        = SDoc -> SDoc
doubleQuotes (forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" -- " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (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 (forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" -- " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (forall a. Outputable a => a -> SDoc
ppr a
u2)
                        SDoc -> SDoc -> SDoc
<> SDoc
space SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[ style = dashed ];"