    -- | 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
    $$ 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 :: 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
    <> 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 :: 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 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 :: * -> *) 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
    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    = 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 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
    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 :: 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
                            -- 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 ];"