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
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
dotGraph
:: ( Uniquable k
, Outputable k, Outputable cls, Outputable color)
=> (color -> SDoc)
-> 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
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
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)
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
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
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
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 ];"