{- |
    Module      :  $Header$
    Description :  Computation of strongly connected components
    Copyright   :  (c) 2000, 2002 - 2003 Wolfgang Lux
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   At various places in the compiler we had to partition a list of
   declarations into strongly connected components. The function
   'scc' computes this relation in two steps. First, the list is
   topologically sorted downwards using the 'defs' relation.
   Then the resulting list is sorted upwards using the 'uses' relation
   and partitioned into the connected components. Both relations
   are computed within this module using the bound and free names of each
   declaration.

   In order to avoid useless recomputations, the code in the module first
   decorates the declarations with their bound and free names and a
   unique number. The latter is only used to provide a trivial ordering
   so that the declarations can be used as set elements.
-}

module Base.SCC (scc) where

import qualified Data.Set as Set (empty, member, insert)

data Node a b = Node { Node a b -> Int
key :: Int, Node a b -> [b]
bvs :: [b], Node a b -> [b]
fvs :: [b], Node a b -> a
node :: a }

instance Eq (Node a b) where
  n1 :: Node a b
n1 == :: Node a b -> Node a b -> Bool
== n2 :: Node a b
n2 = Node a b -> Int
forall a b. Node a b -> Int
key Node a b
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Node a b -> Int
forall a b. Node a b -> Int
key Node a b
n2

instance Ord (Node b a) where
  n1 :: Node b a
n1 compare :: Node b a -> Node b a -> Ordering
`compare` n2 :: Node b a
n2 = Node b a -> Int
forall a b. Node a b -> Int
key Node b a
n1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Node b a -> Int
forall a b. Node a b -> Int
key Node b a
n2

-- |Computation of strongly connected components
scc :: Eq b => (a -> [b]) -- ^entities defined by node
            -> (a -> [b]) -- ^entities used by node
            -> [a]        -- ^list of nodes
            -> [[a]]      -- ^strongly connected components
scc :: (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc bvs' :: a -> [b]
bvs' fvs' :: a -> [b]
fvs' = ([Node a b] -> [a]) -> [[Node a b]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ((Node a b -> a) -> [Node a b] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Node a b -> a
forall a b. Node a b -> a
node) ([[Node a b]] -> [[a]]) -> ([a] -> [[Node a b]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node a b] -> [[Node a b]]
forall b a. Eq b => [Node a b] -> [[Node a b]]
tsort' ([Node a b] -> [[Node a b]])
-> ([a] -> [Node a b]) -> [a] -> [[Node a b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node a b] -> [Node a b]
forall b a. Eq b => [Node a b] -> [Node a b]
tsort ([Node a b] -> [Node a b])
-> ([a] -> [Node a b]) -> [a] -> [Node a b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> Node a b) -> [Int] -> [a] -> [Node a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> a -> Node a b
wrap [0 ..]
  where wrap :: Int -> a -> Node a b
wrap i :: Int
i n :: a
n = Int -> [b] -> [b] -> a -> Node a b
forall a b. Int -> [b] -> [b] -> a -> Node a b
Node Int
i (a -> [b]
bvs' a
n) (a -> [b]
fvs' a
n) a
n

tsort :: Eq b => [Node a b] -> [Node a b]
tsort :: [Node a b] -> [Node a b]
tsort xs :: [Node a b]
xs = (Set (Node a b), [Node a b]) -> [Node a b]
forall a b. (a, b) -> b
snd ([Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs Set (Node a b)
forall a. Set a
Set.empty []) where
  dfs :: [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [] marks :: Set (Node a b)
marks stack :: [Node a b]
stack = (Set (Node a b)
marks,[Node a b]
stack)
  dfs (x :: Node a b
x : xs' :: [Node a b]
xs') marks :: Set (Node a b)
marks stack :: [Node a b]
stack
    | Node a b
x Node a b -> Set (Node a b) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Node a b)
marks = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs' Set (Node a b)
marks [Node a b]
stack
    | Bool
otherwise = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs' Set (Node a b)
marks' (Node a b
x Node a b -> [Node a b] -> [Node a b]
forall a. a -> [a] -> [a]
: [Node a b]
stack')
    where (marks' :: Set (Node a b)
marks',stack' :: [Node a b]
stack') = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs (Node a b -> [Node a b]
forall a. Node a b -> [Node a b]
defs Node a b
x) (Node a b
x Node a b -> Set (Node a b) -> Set (Node a b)
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (Node a b)
marks) [Node a b]
stack
          defs :: Node a b -> [Node a b]
defs x1 :: Node a b
x1 = (Node a b -> Bool) -> [Node a b] -> [Node a b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> Bool) -> [b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node a b -> [b]
forall a b. Node a b -> [b]
fvs Node a b
x1) ([b] -> Bool) -> (Node a b -> [b]) -> Node a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node a b -> [b]
forall a b. Node a b -> [b]
bvs) [Node a b]
xs

tsort' :: Eq b => [Node a b] -> [[Node a b]]
tsort' :: [Node a b] -> [[Node a b]]
tsort' xs :: [Node a b]
xs = (Set (Node a b), [[Node a b]]) -> [[Node a b]]
forall a b. (a, b) -> b
snd ([Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs Set (Node a b)
forall a. Set a
Set.empty []) where
  dfs :: [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [] marks :: Set (Node a b)
marks stack :: [[Node a b]]
stack = (Set (Node a b)
marks,[[Node a b]]
stack)
  dfs (x :: Node a b
x : xs' :: [Node a b]
xs') marks :: Set (Node a b)
marks stack :: [[Node a b]]
stack
    | Node a b
x Node a b -> Set (Node a b) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Node a b)
marks = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs' Set (Node a b)
marks [[Node a b]]
stack
    | Bool
otherwise = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs' Set (Node a b)
marks' ((Node a b
x Node a b -> [Node a b] -> [Node a b]
forall a. a -> [a] -> [a]
: [[Node a b]] -> [Node a b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Node a b]]
stack') [Node a b] -> [[Node a b]] -> [[Node a b]]
forall a. a -> [a] -> [a]
: [[Node a b]]
stack)
    where (marks' :: Set (Node a b)
marks',stack' :: [[Node a b]]
stack') = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs (Node a b -> [Node a b]
forall a. Node a b -> [Node a b]
uses Node a b
x) (Node a b
x Node a b -> Set (Node a b) -> Set (Node a b)
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (Node a b)
marks) []
          uses :: Node a b -> [Node a b]
uses x1 :: Node a b
x1 = (Node a b -> Bool) -> [Node a b] -> [Node a b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> Bool) -> [b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node a b -> [b]
forall a b. Node a b -> [b]
bvs Node a b
x1) ([b] -> Bool) -> (Node a b -> [b]) -> Node a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node a b -> [b]
forall a b. Node a b -> [b]
fvs) [Node a b]
xs