module GHC.Data.Graph.Directed.Internal where

import GHC.Prelude
import GHC.Utils.Outputable

import Data.Array
import qualified Data.Graph as G
import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation
import Data.Tree

data Graph node = Graph {
    forall node. Graph node -> IntGraph
gr_int_graph      :: IntGraph,
    forall node. Graph node -> Vertex -> node
gr_vertex_to_node :: Vertex -> node,
    forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex :: node -> Maybe Vertex
}

data Edge node = Edge node node

------------------------------------------------------------
-- Nodes and Edges
------------------------------------------------------------

verticesG :: Graph node -> [node]
verticesG :: forall node. Graph node -> [node]
verticesG Graph node
graph = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) ([Vertex] -> [node]) -> [Vertex] -> [node]
forall a b. (a -> b) -> a -> b
$ IntGraph -> [Vertex]
G.vertices (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)

edgesG :: Graph node -> [Edge node]
edgesG :: forall node. Graph node -> [Edge node]
edgesG Graph node
graph = (Edge -> Edge node) -> [Edge] -> [Edge node]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
v1, Vertex
v2) -> node -> node -> Edge node
forall node. node -> node -> Edge node
Edge (Vertex -> node
v2n Vertex
v1) (Vertex -> node
v2n Vertex
v2)) ([Edge] -> [Edge node]) -> [Edge] -> [Edge node]
forall a b. (a -> b) -> a -> b
$ IntGraph -> [Edge]
G.edges (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
  where v2n :: Vertex -> node
v2n = Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph

------------------------------------------------------------
-- Showing Graphs
------------------------------------------------------------

instance Outputable node => Outputable (Graph node) where
    ppr :: Graph node -> SDoc
ppr Graph node
graph = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
                  SDoc -> Vertex -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Vertices:") Vertex
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((node -> SDoc) -> [node] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map node -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([node] -> [SDoc]) -> [node] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Graph node -> [node]
forall node. Graph node -> [node]
verticesG Graph node
graph)),
                  SDoc -> Vertex -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Edges:") Vertex
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Edge node -> SDoc) -> [Edge node] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Edge node -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Edge node] -> [SDoc]) -> [Edge node] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Graph node -> [Edge node]
forall node. Graph node -> [Edge node]
edgesG Graph node
graph))
                ]

instance Outputable node => Outputable (Edge node) where
    ppr :: Edge node -> SDoc
ppr (Edge node
from node
to) = node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
from 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
<+> node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
to

{-
************************************************************************
*                                                                      *
*      IntGraphs
*                                                                      *
************************************************************************
-}

type IntGraph = G.Graph

------------------------------------------------------------
-- Depth first search numbering
------------------------------------------------------------

-- Data.Tree has flatten for Tree, but nothing for Forest
preorderF           :: Forest a -> [a]
preorderF :: forall a. Forest a -> [a]
preorderF Forest a
ts         = (Tree a -> [a]) -> Forest a -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [a]
forall a. Tree a -> [a]
flatten Forest a
ts

------------------------------------------------------------
-- Finding reachable vertices
------------------------------------------------------------

-- This generalizes reachable which was found in Data.Graph
reachable    :: IntGraph -> [Vertex] -> [Vertex]
reachable :: IntGraph -> [Vertex] -> [Vertex]
reachable IntGraph
g [Vertex]
vs = Forest Vertex -> [Vertex]
forall a. Forest a -> [a]
preorderF (IntGraph -> [Vertex] -> Forest Vertex
G.dfs IntGraph
g [Vertex]
vs)

scc :: IntGraph -> [SCC Vertex]
scc :: IntGraph -> [SCC Vertex]
scc IntGraph
graph = (Tree Vertex -> SCC Vertex) -> Forest Vertex -> [SCC Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Tree Vertex -> SCC Vertex
decode Forest Vertex
forest
  where
    forest :: Forest Vertex
forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex
G.scc IntGraph
graph

    decode :: Tree Vertex -> SCC Vertex
decode (Node Vertex
v []) | Vertex -> Bool
mentions_itself Vertex
v = [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex
v]
                       | Bool
otherwise         = Vertex -> SCC Vertex
forall vertex. vertex -> SCC vertex
AcyclicSCC Vertex
v
    decode Tree Vertex
other = [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC (Tree Vertex -> [Vertex] -> [Vertex]
forall {a}. Tree a -> [a] -> [a]
dec Tree Vertex
other [])
      where dec :: Tree a -> [a] -> [a]
dec (Node a
v [Tree a]
ts) [a]
vs = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (Tree a -> [a] -> [a]) -> [a] -> [Tree a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [a] -> [a]
dec [a]
vs [Tree a]
ts
    mentions_itself :: Vertex -> Bool
mentions_itself Vertex
v = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (IntGraph
graph IntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v)