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
forall doc. IsLine doc => String -> doc
text String
"Graph"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ UniqFM k (Node k cls color) -> ([Node k cls color] -> SDoc) -> SDoc
forall {k} (key :: k) 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
forall doc. IsDoc doc => [doc] -> doc
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 :: forall k color cls.
(Outputable k, Outputable color) =>
Node k cls color -> SDoc
dumpNode Node k cls color
node
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Node " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"conflicts "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exclusions "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"coalesce "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" = "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
forall doc. IsLine doc => doc
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 = UniqFM k (Node k cls color) -> [Node k cls color]
forall {k} (key :: k) 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
in [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
( [ String -> SDoc
forall doc. IsLine doc => String -> doc
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 :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
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
forall doc. IsLine doc => String -> doc
text String
"}"
, SDoc
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 = 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
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
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
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
preferences :: SDoc
preferences
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
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
forall doc. IsLine doc => String -> doc
text String
"+" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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 a. [a] -> 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
forall doc. IsOutput doc => doc
empty
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\\n" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (SDoc
excludes SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
preferences)
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
forall doc. IsLine doc => String -> doc
text String
"\\n(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> color -> SDoc
forall a. Outputable a => a -> SDoc
ppr color
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"\\n(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"triv" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")"
| Bool
otherwise
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\\n(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"spill?" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")"
label :: SDoc
label = SDoc
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" :: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
cls
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
expref
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
text String
"style=filled fillcolor=white"
Just color
c -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"style=filled fillcolor=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (color -> SDoc
colorMap color
c)
pout :: SDoc
pout = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"node [label=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes SDoc
label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pcolorC SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"]"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes SDoc
name
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
| 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
(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
(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
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
dconflicts
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => doc -> doc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" -- " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u2)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
";"
dotEdgeCoalesce :: a -> a -> SDoc
dotEdgeCoalesce a
u1 a
u2
= SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u1) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" -- " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
u2)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[ style = dashed ];"