module Knuth1 where

import Pretty
import ExecutionPlan
import CommonTypes
import Control.Monad
import Control.Monad.ST
import Data.Maybe
import Data.List
import Data.STRef
import Debug.Trace

import Data.Array (Array)
import qualified Data.Array as Array
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- | Trace a message in the ST monad

traceST :: String -> ST s ()
traceST :: String -> ST s ()
traceST String
s = String -> ST s () -> ST s ()
forall a. String -> a -> a
trace String
s (() -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-------------------------------------------------------------------------------

--         Dependency graph representation

-------------------------------------------------------------------------------


-- Vertices

data AttrType = Inh | Syn | Loc deriving (AttrType -> AttrType -> Bool
(AttrType -> AttrType -> Bool)
-> (AttrType -> AttrType -> Bool) -> Eq AttrType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttrType -> AttrType -> Bool
$c/= :: AttrType -> AttrType -> Bool
== :: AttrType -> AttrType -> Bool
$c== :: AttrType -> AttrType -> Bool
Eq, Eq AttrType
Eq AttrType
-> (AttrType -> AttrType -> Ordering)
-> (AttrType -> AttrType -> Bool)
-> (AttrType -> AttrType -> Bool)
-> (AttrType -> AttrType -> Bool)
-> (AttrType -> AttrType -> Bool)
-> (AttrType -> AttrType -> AttrType)
-> (AttrType -> AttrType -> AttrType)
-> Ord AttrType
AttrType -> AttrType -> Bool
AttrType -> AttrType -> Ordering
AttrType -> AttrType -> AttrType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AttrType -> AttrType -> AttrType
$cmin :: AttrType -> AttrType -> AttrType
max :: AttrType -> AttrType -> AttrType
$cmax :: AttrType -> AttrType -> AttrType
>= :: AttrType -> AttrType -> Bool
$c>= :: AttrType -> AttrType -> Bool
> :: AttrType -> AttrType -> Bool
$c> :: AttrType -> AttrType -> Bool
<= :: AttrType -> AttrType -> Bool
$c<= :: AttrType -> AttrType -> Bool
< :: AttrType -> AttrType -> Bool
$c< :: AttrType -> AttrType -> Bool
compare :: AttrType -> AttrType -> Ordering
$ccompare :: AttrType -> AttrType -> Ordering
$cp1Ord :: Eq AttrType
Ord, Int -> AttrType -> ShowS
[AttrType] -> ShowS
AttrType -> String
(Int -> AttrType -> ShowS)
-> (AttrType -> String) -> ([AttrType] -> ShowS) -> Show AttrType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrType] -> ShowS
$cshowList :: [AttrType] -> ShowS
show :: AttrType -> String
$cshow :: AttrType -> String
showsPrec :: Int -> AttrType -> ShowS
$cshowsPrec :: Int -> AttrType -> ShowS
Show)
data Vertex = VAttr  AttrType Identifier Identifier
            | VChild Identifier
            | VRule  Identifier deriving (Vertex -> Vertex -> Bool
(Vertex -> Vertex -> Bool)
-> (Vertex -> Vertex -> Bool) -> Eq Vertex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Vertex -> Vertex -> Bool
$c/= :: Vertex -> Vertex -> Bool
== :: Vertex -> Vertex -> Bool
$c== :: Vertex -> Vertex -> Bool
Eq, Eq Vertex
Eq Vertex
-> (Vertex -> Vertex -> Ordering)
-> (Vertex -> Vertex -> Bool)
-> (Vertex -> Vertex -> Bool)
-> (Vertex -> Vertex -> Bool)
-> (Vertex -> Vertex -> Bool)
-> (Vertex -> Vertex -> Vertex)
-> (Vertex -> Vertex -> Vertex)
-> Ord Vertex
Vertex -> Vertex -> Bool
Vertex -> Vertex -> Ordering
Vertex -> Vertex -> Vertex
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Vertex -> Vertex -> Vertex
$cmin :: Vertex -> Vertex -> Vertex
max :: Vertex -> Vertex -> Vertex
$cmax :: Vertex -> Vertex -> Vertex
>= :: Vertex -> Vertex -> Bool
$c>= :: Vertex -> Vertex -> Bool
> :: Vertex -> Vertex -> Bool
$c> :: Vertex -> Vertex -> Bool
<= :: Vertex -> Vertex -> Bool
$c<= :: Vertex -> Vertex -> Bool
< :: Vertex -> Vertex -> Bool
$c< :: Vertex -> Vertex -> Bool
compare :: Vertex -> Vertex -> Ordering
$ccompare :: Vertex -> Vertex -> Ordering
$cp1Ord :: Eq Vertex
Ord)

instance Show Vertex where
  show :: Vertex -> String
show (VAttr AttrType
ty Identifier
ch Identifier
at) = AttrType -> String
forall a. Show a => a -> String
show AttrType
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" @" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
ch String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
at
  show (VChild Identifier
ch)      = String
"Child " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
ch
  show (VRule Identifier
ru)       = String
"Rule " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
ru

-- | Check if a vertex is an attribute

isVertexAttr :: Vertex -> Bool
isVertexAttr :: Vertex -> Bool
isVertexAttr (VAttr AttrType
_ Identifier
_ Identifier
_) = Bool
True
isVertexAttr Vertex
_             = Bool
False

-- | Get the child name of an attribute

getAttrChildName :: Vertex -> Identifier
getAttrChildName :: Vertex -> Identifier
getAttrChildName (VAttr AttrType
_ Identifier
n Identifier
_) = Identifier
n

-- | Set the child name of an attribute

setAttrChildName :: Vertex -> Identifier -> Vertex
setAttrChildName :: Vertex -> Identifier -> Vertex
setAttrChildName (VAttr AttrType
t Identifier
_ Identifier
a) Identifier
n = AttrType -> Identifier -> Identifier -> Vertex
VAttr AttrType
t Identifier
n Identifier
a

-- | Get the type of an attribute

getAttrType :: Vertex -> AttrType
getAttrType :: Vertex -> AttrType
getAttrType (VAttr AttrType
t Identifier
_ Identifier
_) = AttrType
t

-- | Get the name of an attribute

getAttrName :: Vertex -> Identifier
getAttrName :: Vertex -> Identifier
getAttrName (VAttr AttrType
_ Identifier
_ Identifier
a) = Identifier
a

-- Edges

type Edge = (Vertex, Vertex)

-- Internal representation of a vertex

type IVertex = Int
type IEdge = (IVertex, IVertex)

-- Representation of the graph

data DependencyGraph s = DependencyGraph { DependencyGraph s -> Map Vertex Int
vertexIMap   :: Map   Vertex  IVertex
                                         , DependencyGraph s -> Array Int Vertex
vertexOMap   :: Array IVertex Vertex
                                         , DependencyGraph s -> Array Int (STRef s (Set Int))
successors   :: Array IVertex (STRef s (Set IVertex))
                                         , DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors :: Array IVertex (STRef s (Set IVertex)) }

-------------------------------------------------------------------------------

--         Dependency graph fuctions

-------------------------------------------------------------------------------


-- | Construct a dependency graph

graphConstruct :: [Vertex] -> ST s (DependencyGraph s)
graphConstruct :: [Vertex] -> ST s (DependencyGraph s)
graphConstruct [Vertex]
vs = do let nv :: Int
nv    = [Vertex] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vertex]
vs
                       let ivs :: [Int]
ivs   = [Int
0..Int
nvInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                       let ivb :: (Int, Int)
ivb   = (Int
0,Int
nvInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                       let vimap :: Map Vertex Int
vimap = [(Vertex, Int)] -> Map Vertex Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Vertex] -> [Int] -> [(Vertex, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex]
vs [Int]
ivs)
                       let vomap :: Array Int Vertex
vomap = (Int, Int) -> [(Int, Vertex)] -> Array Int Vertex
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int, Int)
ivb ([Int] -> [Vertex] -> [(Int, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ivs [Vertex]
vs)
                       [STRef s (Set Int)]
succs <- Int -> ST s (STRef s (Set Int)) -> ST s [STRef s (Set Int)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nv (Set Int -> ST s (STRef s (Set Int))
forall a s. a -> ST s (STRef s a)
newSTRef Set Int
forall a. Set a
Set.empty)
                       [STRef s (Set Int)]
preds <- Int -> ST s (STRef s (Set Int)) -> ST s [STRef s (Set Int)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nv (Set Int -> ST s (STRef s (Set Int))
forall a s. a -> ST s (STRef s a)
newSTRef Set Int
forall a. Set a
Set.empty)
                       let su :: Array Int (STRef s (Set Int))
su    = (Int, Int)
-> [(Int, STRef s (Set Int))] -> Array Int (STRef s (Set Int))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int, Int)
ivb ([Int] -> [STRef s (Set Int)] -> [(Int, STRef s (Set Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ivs [STRef s (Set Int)]
succs)
                       let pr :: Array Int (STRef s (Set Int))
pr    = (Int, Int)
-> [(Int, STRef s (Set Int))] -> Array Int (STRef s (Set Int))
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Int, Int)
ivb ([Int] -> [STRef s (Set Int)] -> [(Int, STRef s (Set Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ivs [STRef s (Set Int)]
preds)
                       let graph :: DependencyGraph s
graph = DependencyGraph :: forall s.
Map Vertex Int
-> Array Int Vertex
-> Array Int (STRef s (Set Int))
-> Array Int (STRef s (Set Int))
-> DependencyGraph s
DependencyGraph { vertexIMap :: Map Vertex Int
vertexIMap   = Map Vertex Int
vimap
                                                   , vertexOMap :: Array Int Vertex
vertexOMap   = Array Int Vertex
vomap
                                                   , successors :: Array Int (STRef s (Set Int))
successors   = Array Int (STRef s (Set Int))
su
                                                   , predecessors :: Array Int (STRef s (Set Int))
predecessors = Array Int (STRef s (Set Int))
pr }
                       DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return DependencyGraph s
graph

-- | Construct a transitivelly closed graph

graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s)
graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s)
graphConstructTRC [Vertex]
vs [Edge]
es = do DependencyGraph s
g <- [Vertex] -> ST s (DependencyGraph s)
forall s. [Vertex] -> ST s (DependencyGraph s)
graphConstruct [Vertex]
vs
                             -- Insert all initial edges

                             DependencyGraph s -> [Edge] -> ST s [Edge]
forall s. DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC DependencyGraph s
g [Edge]
es
                             DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return DependencyGraph s
g

-- | Return all successors of a vertex

graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors DependencyGraph s
g Vertex
v = do Set Int
sucs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! (DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v)
                         Set Vertex -> ST s (Set Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Vertex -> ST s (Set Vertex))
-> Set Vertex -> ST s (Set Vertex)
forall a b. (a -> b) -> a -> b
$ (Int -> Vertex) -> Set Int -> Set Vertex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g) Set Int
sucs

-- | Return all predecessors of a vertex

graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphPredecessors DependencyGraph s
g Vertex
v = do Set Int
sucs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! (DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v)
                           Set Vertex -> ST s (Set Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Vertex -> ST s (Set Vertex))
-> Set Vertex -> ST s (Set Vertex)
forall a b. (a -> b) -> a -> b
$ (Int -> Vertex) -> Set Int -> Set Vertex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g) Set Int
sucs

-- | Check if the graph contains an edge

graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
g (Vertex
v1,Vertex
v2) = do let iv1 :: Int
iv1  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v1
                                 let iv2 :: Int
iv2  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v2
                                 Set Int
sucs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv1
                                 Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Int
iv2 Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
sucs

-- | Insert an edge in the graph

graphInsert :: DependencyGraph s -> Edge -> ST s ()
graphInsert :: DependencyGraph s -> Edge -> ST s ()
graphInsert DependencyGraph s
g (Vertex
v1,Vertex
v2) = do let iv1 :: Int
iv1  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v1
                           let iv2 :: Int
iv2  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v2
                           -- Add v2 to the successors of v1 and v1 to predecessors of v2

                           STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef ((DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv1) ((Set Int -> Set Int) -> ST s ())
-> (Set Int -> Set Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv2
                           STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef ((DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv2) ((Set Int -> Set Int) -> ST s ())
-> (Set Int -> Set Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv1

-- | Insert an edge in a transtive closed graph and return all other edges that were

--   added due to transtivity

graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)]
graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(Int, Set Int)]
graphInsertTRC DependencyGraph s
g (Vertex
v1,Vertex
v2) = do let iv1 :: Int
iv1  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v1
                              let iv2 :: Int
iv2  = DependencyGraph s -> Vertex -> Int
forall s. DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v2
                              -- Read predecessors of v1 and successors of v2

                              Set Int
pred1 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv1
                              Set Int
succ2 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv2
                              -- First insert all edges from v1

                              let rsucc1 :: STRef s (Set Int)
rsucc1 = (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv1
                              Set Int
succ1 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set Int)
rsucc1
                              let add1 :: Set Int
add1 = Set Int
succ2 Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
succ1
                              STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set Int)
rsucc1 (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
add1 (Set Int -> Set Int) -> (Set Int -> Set Int) -> Set Int -> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv2)
                              -- All edges to v2

                              let rpred2 :: STRef s (Set Int)
rpred2 = (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
iv2
                              STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set Int)
rpred2 (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
pred1 (Set Int -> Set Int) -> (Set Int -> Set Int) -> Set Int -> Set Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv1)
                              -- Connect every predecessor of v1 to every successor of v2

                              [(Int, Set Int)]
sucl <- [Int] -> (Int -> ST s (Int, Set Int)) -> ST s [(Int, Set Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
pred1) ((Int -> ST s (Int, Set Int)) -> ST s [(Int, Set Int)])
-> (Int -> ST s (Int, Set Int)) -> ST s [(Int, Set Int)]
forall a b. (a -> b) -> a -> b
$ \Int
pred -> do
                                -- Connect pred to v2 and all successors of v2

                                let rsucc :: STRef s (Set Int)
rsucc = (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
pred
                                Set Int
csucc <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set Int)
rsucc
                                let cadd :: Set Int
cadd = (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv2 Set Int
succ2) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
csucc
                                STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set Int)
rsucc (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
cadd)
                                (Int, Set Int) -> ST s (Int, Set Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
pred, Set Int
cadd)
                              -- Connect every successor of v2 to every predecessor of v1

                              [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
succ2) ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
succ -> do
                                -- Connect succ to v1 and all predecessors of v1

                                let rpred :: STRef s (Set Int)
rpred = (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
succ
                                Set Int
cpred <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set Int)
rpred
                                let cadd :: Set Int
cadd = (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
iv1 Set Int
pred1) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
cpred
                                STRef s (Set Int) -> (Set Int -> Set Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set Int)
rpred (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
cadd)
                              -- Create return

                              [(Int, Set Int)] -> ST s [(Int, Set Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, Set Int)] -> ST s [(Int, Set Int)])
-> [(Int, Set Int)] -> ST s [(Int, Set Int)]
forall a b. (a -> b) -> a -> b
$ (Int
iv1,Set Int
add1) (Int, Set Int) -> [(Int, Set Int)] -> [(Int, Set Int)]
forall a. a -> [a] -> [a]
: [(Int, Set Int)]
sucl

-- | Return all vertices of the graph

graphVertices :: DependencyGraph s -> ST s [Vertex]
graphVertices :: DependencyGraph s -> ST s [Vertex]
graphVertices = [Vertex] -> ST s [Vertex]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vertex] -> ST s [Vertex])
-> (DependencyGraph s -> [Vertex])
-> DependencyGraph s
-> ST s [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Int Vertex -> [Vertex]
forall i e. Array i e -> [e]
Array.elems (Array Int Vertex -> [Vertex])
-> (DependencyGraph s -> Array Int Vertex)
-> DependencyGraph s
-> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap

-- | Return all edges of the graph

graphEdges :: DependencyGraph s -> ST s [Edge]
graphEdges :: DependencyGraph s -> ST s [Edge]
graphEdges DependencyGraph s
g = do let vs :: [Int]
vs = Array Int Vertex -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices (Array Int Vertex -> [Int]) -> Array Int Vertex -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g
                  [[Edge]]
perv <- [Int] -> (Int -> ST s [Edge]) -> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> ST s [Edge]) -> ST s [[Edge]])
-> (Int -> ST s [Edge]) -> ST s [[Edge]]
forall a b. (a -> b) -> a -> b
$ \Int
v -> do
                    let rv :: Vertex
rv = DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g Int
v
                    Set Int
sucs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v
                    let sucl :: [Int]
sucl = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
sucs
                    [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ (Int -> Edge) -> [Int] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Vertex
rv (Vertex -> Edge) -> (Int -> Vertex) -> Int -> Edge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g) [Int]
sucl
                  [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge]]
perv

-- | Insert a list of edges in the graph

graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s ()
graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s ()
graphInsertEdges DependencyGraph s
g [Edge]
ed = (Edge -> ST s ()) -> [Edge] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DependencyGraph s -> Edge -> ST s ()
forall s. DependencyGraph s -> Edge -> ST s ()
graphInsert DependencyGraph s
g) [Edge]
ed

-- | Insert a list of edges in the graph and return all other edges that

--   were added due to transitivity

graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC DependencyGraph s
g [Edge]
ed = do -- rets :: [[(IVertex, Set IVertex)]]

                              [[(Int, Set Int)]]
rets <- (Edge -> ST s [(Int, Set Int)])
-> [Edge] -> ST s [[(Int, Set Int)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DependencyGraph s -> Edge -> ST s [(Int, Set Int)]
forall s. DependencyGraph s -> Edge -> ST s [(Int, Set Int)]
graphInsertTRC DependencyGraph s
g) [Edge]
ed
                              -- Combine all successor sets

                              let f    :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)]
                                  f :: (Int, Set Int) -> [(Int, Int)]
f (Int
v,Set Int
s) = (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Int
v) (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
s)
                              let comb :: [(IVertex, IVertex)]
                                  comb :: [(Int, Int)]
comb = ([(Int, Set Int)] -> [(Int, Int)])
-> [[(Int, Set Int)]] -> [(Int, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Int, Set Int) -> [(Int, Int)])
-> [(Int, Set Int)] -> [(Int, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Set Int) -> [(Int, Int)]
f) [[(Int, Set Int)]]
rets
                              -- Construct edges from this

                              [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Edge) -> [(Int, Int)] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (DependencyGraph s -> (Int, Int) -> Edge
forall s. DependencyGraph s -> (Int, Int) -> Edge
graphGetEdge DependencyGraph s
g) ([(Int, Int)] -> [Edge]) -> [(Int, Int)] -> [Edge]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)]
comb

-- | Check whether the graph is cyclic

graphIsCyclic :: DependencyGraph s -> ST s Bool
graphIsCyclic :: DependencyGraph s -> ST s Bool
graphIsCyclic DependencyGraph s
g = do
  Set Int
s <- DependencyGraph s -> ST s (Set Int)
forall s. DependencyGraph s -> ST s (Set Int)
graphCyclicVertices DependencyGraph s
g
  Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set Int -> Bool
forall a. Set a -> Bool
Set.null Set Int
s

graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex)
graphCyclicVertices :: DependencyGraph s -> ST s (Set Int)
graphCyclicVertices DependencyGraph s
g = do
  [Int]
vs <- [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> ST s [Int]) -> [Int] -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ Array Int Vertex -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices (Array Int Vertex -> [Int]) -> Array Int Vertex -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g
  [Set Int]
sets <- [Int] -> (Int -> ST s (Set Int)) -> ST s [Set Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> ST s (Set Int)) -> ST s [Set Int])
-> (Int -> ST s (Set Int)) -> ST s [Set Int]
forall a b. (a -> b) -> a -> b
$ \Int
v -> do
            Set Int
sucs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v
            let res :: Set Int
res | Int
v Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
sucs = Int -> Set Int
forall a. a -> Set a
Set.singleton Int
v
                    | Bool
otherwise           = Set Int
forall a. Set a
Set.empty
            Set Int -> ST s (Set Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Int
res
  Set Int -> ST s (Set Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Set Int] -> Set Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Int]
sets)

graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt DependencyGraph s
g = ((Int -> Vertex) -> [Int] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g) ([Int] -> [Vertex]) -> (Set Int -> [Int]) -> Set Int -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> [Int]
forall a. Set a -> [a]
Set.elems) (Set Int -> [Vertex]) -> ST s (Set Int) -> ST s [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DependencyGraph s -> ST s (Set Int)
forall s. DependencyGraph s -> ST s (Set Int)
graphCyclicVertices DependencyGraph s
g

-- | Get internal representation of a vertex

graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex
graphGetIVertex :: DependencyGraph s -> Vertex -> Int
graphGetIVertex DependencyGraph s
g Vertex
v = DependencyGraph s -> Map Vertex Int
forall s. DependencyGraph s -> Map Vertex Int
vertexIMap DependencyGraph s
g Map Vertex Int -> Vertex -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Vertex
v

-- | Get external representation of a vertex

graphGetVertex :: DependencyGraph s -> IVertex -> Vertex
graphGetVertex :: DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g Int
v = DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g Array Int Vertex -> Int -> Vertex
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v

-- | Get external representation of an edge

graphGetEdge :: DependencyGraph s -> IEdge -> Edge
graphGetEdge :: DependencyGraph s -> (Int, Int) -> Edge
graphGetEdge DependencyGraph s
g (Int
v1,Int
v2) = (DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g Int
v1, DependencyGraph s -> Int -> Vertex
forall s. DependencyGraph s -> Int -> Vertex
graphGetVertex DependencyGraph s
g Int
v2)

-- | Check if the graph is transitively closed

graphIsTRC :: DependencyGraph s -> ST s Bool
graphIsTRC :: DependencyGraph s -> ST s Bool
graphIsTRC DependencyGraph s
g = do let vs :: [Int]
vs = Array Int Vertex -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices (Array Int Vertex -> [Int]) -> Array Int Vertex -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g
                  [Bool]
bs <- [Int] -> (Int -> ST s Bool) -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> ST s Bool) -> ST s [Bool])
-> (Int -> ST s Bool) -> ST s [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
v -> do
                    Set Int
succs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v
                    [Bool]
bs2 <- [Int] -> (Int -> ST s Bool) -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
succs) ((Int -> ST s Bool) -> ST s [Bool])
-> (Int -> ST s Bool) -> ST s [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
v2 -> do
                      Set Int
succs2 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v2
                      Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Set Int
succs2 Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Int
succs
                    Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs2
                  Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bs

-- | Check consistency of the graph (successor and predecessor sets)

graphCheckConsistency :: DependencyGraph s -> ST s Bool
graphCheckConsistency :: DependencyGraph s -> ST s Bool
graphCheckConsistency DependencyGraph s
g = do let vs :: [Int]
vs = Array Int Vertex -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices (Array Int Vertex -> [Int]) -> Array Int Vertex -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g
                             [Bool]
ret <- [Int] -> (Int -> ST s Bool) -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> ST s Bool) -> ST s [Bool])
-> (Int -> ST s Bool) -> ST s [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
v -> do
                               -- V must appear in every predecessor set of its successors

                               Set Int
succs <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v
                               [Bool]
r1 <- [Int] -> (Int -> ST s Bool) -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
succs) ((Int -> ST s Bool) -> ST s [Bool])
-> (Int -> ST s Bool) -> ST s [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
succ -> do
                                 Set Int
preds2 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
succ
                                 Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
v Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
preds2)
                               -- V must appear in every successor set of its predecessors

                               Set Int
preds <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
v
                               [Bool]
r2 <- [Int] -> (Int -> ST s Bool) -> ST s [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
preds) ((Int -> ST s Bool) -> ST s [Bool])
-> (Int -> ST s Bool) -> ST s [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
pred -> do
                                 Set Int
succs2 <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
successors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
pred
                                 Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
v Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
succs2)
                               Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool]
r1 [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool]
r2
                             Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool]
ret

-- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic)

graphTopSort :: DependencyGraph s -> ST s [Edge]
graphTopSort :: DependencyGraph s -> ST s [Edge]
graphTopSort DependencyGraph s
g = do let vs :: [Int]
vs = Array Int Vertex -> [Int]
forall i e. Ix i => Array i e -> [i]
Array.indices (Array Int Vertex -> [Int]) -> Array Int Vertex -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> Array Int Vertex
forall s. DependencyGraph s -> Array Int Vertex
vertexOMap DependencyGraph s
g
                    [Int]
order <- ([Int] -> Int -> ST s [Int]) -> [Int] -> [Int] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (DependencyGraph s -> [Int] -> Int -> ST s [Int]
forall s. DependencyGraph s -> [Int] -> Int -> ST s [Int]
graphTopSort' DependencyGraph s
g) [] [Int]
vs
                    [Maybe Edge]
mb <- [(Int, Int)]
-> ((Int, Int) -> ST s (Maybe Edge)) -> ST s [Maybe Edge]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
order ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
order)) (((Int, Int) -> ST s (Maybe Edge)) -> ST s [Maybe Edge])
-> ((Int, Int) -> ST s (Maybe Edge)) -> ST s [Maybe Edge]
forall a b. (a -> b) -> a -> b
$ \(Int
v1,Int
v2) -> do
                      let edg :: Edge
edg = DependencyGraph s -> (Int, Int) -> Edge
forall s. DependencyGraph s -> (Int, Int) -> Edge
graphGetEdge DependencyGraph s
g (Int
v2,Int
v1) -- order is actually reverse order

                      Bool
ce <- DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
g Edge
edg
                      if Bool
ce
                        then Maybe Edge -> ST s (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Edge
forall a. Maybe a
Nothing
                        else do DependencyGraph s -> Edge -> ST s ()
forall s. DependencyGraph s -> Edge -> ST s ()
graphInsert DependencyGraph s
g Edge
edg
                                Maybe Edge -> ST s (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Edge -> ST s (Maybe Edge))
-> Maybe Edge -> ST s (Maybe Edge)
forall a b. (a -> b) -> a -> b
$ Edge -> Maybe Edge
forall a. a -> Maybe a
Just Edge
edg
                    [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ [Maybe Edge] -> [Edge]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Edge]
mb

-- | Helper function for graphTopSort

graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex]
graphTopSort' :: DependencyGraph s -> [Int] -> Int -> ST s [Int]
graphTopSort' DependencyGraph s
g [Int]
prev Int
cur | Int
cur Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
prev = [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int]
prev
                         | Bool
otherwise       = do Set Int
pred <- STRef s (Set Int) -> ST s (Set Int)
forall s a. STRef s a -> ST s a
readSTRef (STRef s (Set Int) -> ST s (Set Int))
-> STRef s (Set Int) -> ST s (Set Int)
forall a b. (a -> b) -> a -> b
$ (DependencyGraph s -> Array Int (STRef s (Set Int))
forall s. DependencyGraph s -> Array Int (STRef s (Set Int))
predecessors DependencyGraph s
g) Array Int (STRef s (Set Int)) -> Int -> STRef s (Set Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
cur
                                                [Int]
order <- ([Int] -> Int -> ST s [Int]) -> [Int] -> [Int] -> ST s [Int]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM  (DependencyGraph s -> [Int] -> Int -> ST s [Int]
forall s. DependencyGraph s -> [Int] -> Int -> ST s [Int]
graphTopSort' DependencyGraph s
g) [Int]
prev ([Int] -> ST s [Int]) -> [Int] -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
pred
                                                [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> ST s [Int]) -> [Int] -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ Int
cur Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
order

-------------------------------------------------------------------------------

--         Dependency graph information wrappers

-------------------------------------------------------------------------------


-- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information)

data NontDependencyGraph = NontDependencyGraph { NontDependencyGraph -> [Vertex]
ndgVertices    :: [Vertex]
                                               , NontDependencyGraph -> [Edge]
ndgEdges       :: [Edge] }

-- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals

data ProdDependencyGraph = ProdDependencyGraph { ProdDependencyGraph -> [Vertex]
pdgVertices    :: [Vertex]
                                               , ProdDependencyGraph -> [Edge]
pdgEdges       :: [Edge]
                                               , ProdDependencyGraph -> ERules
pdgRules       :: ERules
                                               , ProdDependencyGraph -> EChildren
pdgChilds      :: EChildren
                                               , ProdDependencyGraph -> Identifier
pdgProduction  :: Identifier
                                               , ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap    :: [(Identifier, Identifier)]
                                               , ProdDependencyGraph -> [Type]
pdgConstraints :: [Type]
                                               , ProdDependencyGraph -> [Identifier]
pdgParams      :: [Identifier] }


-- | Represent all information from the dependency graphs for a nonterminal

data NontDependencyInformation = NontDependencyInformation { NontDependencyInformation -> Identifier
ndiNonterminal :: Identifier
                                                           , NontDependencyInformation -> [Identifier]
ndiParams      :: [Identifier]
                                                           , NontDependencyInformation -> [Identifier]
ndiInh         :: [Identifier]
                                                           , NontDependencyInformation -> [Identifier]
ndiSyn         :: [Identifier]
                                                           , NontDependencyInformation -> NontDependencyGraph
ndiDepGraph    :: NontDependencyGraph
                                                           , NontDependencyInformation -> [ProdDependencyGraph]
ndiProds       :: [ProdDependencyGraph]
                                                           , NontDependencyInformation -> Bool
ndiRecursive   :: Bool
                                                           , NontDependencyInformation -> HigherOrderInfo
ndiHoInfo      :: HigherOrderInfo
                                                           , NontDependencyInformation -> ClassContext
ndiClassCtxs   :: ClassContext
                                                           }

--- Monadic versions of these records, for use with the ST monad


-- | Monadic wrapper of NontDependencyGraph

data NontDependencyGraphM s = NontDependencyGraphM { NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph :: DependencyGraph s
                                                   , NontDependencyGraphM s -> NontDependencyGraph
ndgmOrig     :: NontDependencyGraph }

-- | Monadic wrapper of ProdDependencyGraph

data ProdDependencyGraphM s = ProdDependencyGraphM { ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph   :: DependencyGraph s
                                                   , ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig       :: ProdDependencyGraph }


-- | Monadic wrapper of NontDependencyInformation

data NontDependencyInformationM s = NontDependencyInformationM { NontDependencyInformationM s -> NontDependencyInformation
ndimOrig        :: NontDependencyInformation
                                                               , NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph    :: NontDependencyGraphM s
                                                               , NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds       :: [ProdDependencyGraphM s] }


-- | Convert a NontDependencyGraph to the corresponding monadic version

mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s)
mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s)
mkNontDependencyGraphM NontDependencyGraph
ndg = do DependencyGraph s
g <- [Vertex] -> [Edge] -> ST s (DependencyGraph s)
forall s. [Vertex] -> [Edge] -> ST s (DependencyGraph s)
graphConstructTRC (NontDependencyGraph -> [Vertex]
ndgVertices NontDependencyGraph
ndg) (NontDependencyGraph -> [Edge]
ndgEdges NontDependencyGraph
ndg)
                                NontDependencyGraphM s -> ST s (NontDependencyGraphM s)
forall (m :: * -> *) a. Monad m => a -> m a
return (NontDependencyGraphM s -> ST s (NontDependencyGraphM s))
-> NontDependencyGraphM s -> ST s (NontDependencyGraphM s)
forall a b. (a -> b) -> a -> b
$ NontDependencyGraphM :: forall s.
DependencyGraph s -> NontDependencyGraph -> NontDependencyGraphM s
NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s
ndgmDepGraph = DependencyGraph s
g
                                                              , ndgmOrig :: NontDependencyGraph
ndgmOrig     = NontDependencyGraph
ndg }


-- | Convert a ProdDependencyGraph to the corresponding monadic version

mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
mkProdDependencyGraphM Bool
trc ProdDependencyGraph
pdg = do DependencyGraph s
g <- if Bool
trc
                                         then [Vertex] -> [Edge] -> ST s (DependencyGraph s)
forall s. [Vertex] -> [Edge] -> ST s (DependencyGraph s)
graphConstructTRC (ProdDependencyGraph -> [Vertex]
pdgVertices ProdDependencyGraph
pdg) (ProdDependencyGraph -> [Edge]
pdgEdges ProdDependencyGraph
pdg)
                                         else do DependencyGraph s
g <- [Vertex] -> ST s (DependencyGraph s)
forall s. [Vertex] -> ST s (DependencyGraph s)
graphConstruct (ProdDependencyGraph -> [Vertex]
pdgVertices ProdDependencyGraph
pdg)
                                                 (Edge -> ST s ()) -> [Edge] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DependencyGraph s -> Edge -> ST s ()
forall s. DependencyGraph s -> Edge -> ST s ()
graphInsert DependencyGraph s
g) (ProdDependencyGraph -> [Edge]
pdgEdges ProdDependencyGraph
pdg)
                                                 DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return DependencyGraph s
g
                                    ProdDependencyGraphM s -> ST s (ProdDependencyGraphM s)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProdDependencyGraphM s -> ST s (ProdDependencyGraphM s))
-> ProdDependencyGraphM s -> ST s (ProdDependencyGraphM s)
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM :: forall s.
DependencyGraph s -> ProdDependencyGraph -> ProdDependencyGraphM s
ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s
pdgmDepGraph   = DependencyGraph s
g
                                                                  , pdgmOrig :: ProdDependencyGraph
pdgmOrig       = ProdDependencyGraph
pdg }

-- | Convert a NontDependencyInformation to the corresponding monadic version

mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s)
mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s)
mkNontDependencyInformationM NontDependencyInformation
ndi = do NontDependencyGraphM s
dg <- NontDependencyGraph -> ST s (NontDependencyGraphM s)
forall s. NontDependencyGraph -> ST s (NontDependencyGraphM s)
mkNontDependencyGraphM (NontDependencyInformation -> NontDependencyGraph
ndiDepGraph NontDependencyInformation
ndi)
                                      [ProdDependencyGraphM s]
prods <- (ProdDependencyGraph -> ST s (ProdDependencyGraphM s))
-> [ProdDependencyGraph] -> ST s [ProdDependencyGraphM s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
forall s.
Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
mkProdDependencyGraphM Bool
True) (NontDependencyInformation -> [ProdDependencyGraph]
ndiProds NontDependencyInformation
ndi)
                                      NontDependencyInformationM s -> ST s (NontDependencyInformationM s)
forall (m :: * -> *) a. Monad m => a -> m a
return (NontDependencyInformationM s
 -> ST s (NontDependencyInformationM s))
-> NontDependencyInformationM s
-> ST s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM :: forall s.
NontDependencyInformation
-> NontDependencyGraphM s
-> [ProdDependencyGraphM s]
-> NontDependencyInformationM s
NontDependencyInformationM { ndimOrig :: NontDependencyInformation
ndimOrig     = NontDependencyInformation
ndi
                                                                          , ndimDepGraph :: NontDependencyGraphM s
ndimDepGraph = NontDependencyGraphM s
dg
                                                                          , ndimProds :: [ProdDependencyGraphM s]
ndimProds    = [ProdDependencyGraphM s]
prods }

-- | Construct the production graphs from the transitivelly closed graphs

undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s]
undoTransitiveClosure :: [NontDependencyInformationM s]
-> ST s [NontDependencyInformationM s]
undoTransitiveClosure [NontDependencyInformationM s]
ndis = do [[Edge]]
edgesl <- (NontDependencyInformationM s -> ST s [Edge])
-> [NontDependencyInformationM s] -> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\NontDependencyInformationM s
ndi -> DependencyGraph s -> ST s [Edge]
forall s. DependencyGraph s -> ST s [Edge]
graphEdges (NontDependencyGraphM s -> DependencyGraph s
forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph (NontDependencyGraphM s -> DependencyGraph s)
-> NontDependencyGraphM s -> DependencyGraph s
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph NontDependencyInformationM s
ndi)) [NontDependencyInformationM s]
ndis
                                let edges :: [Edge]
edges = [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge]]
edgesl
                                [NontDependencyInformationM s]
-> (NontDependencyInformationM s
    -> ST s (NontDependencyInformationM s))
-> ST s [NontDependencyInformationM s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NontDependencyInformationM s]
ndis ((NontDependencyInformationM s
  -> ST s (NontDependencyInformationM s))
 -> ST s [NontDependencyInformationM s])
-> (NontDependencyInformationM s
    -> ST s (NontDependencyInformationM s))
-> ST s [NontDependencyInformationM s]
forall a b. (a -> b) -> a -> b
$ \NontDependencyInformationM s
ndi -> do
                                  [ProdDependencyGraphM s]
prods <- (ProdDependencyGraph -> ST s (ProdDependencyGraphM s))
-> [ProdDependencyGraph] -> ST s [ProdDependencyGraphM s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
forall s.
Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s)
mkProdDependencyGraphM Bool
False) (NontDependencyInformation -> [ProdDependencyGraph]
ndiProds (NontDependencyInformation -> [ProdDependencyGraph])
-> NontDependencyInformation -> [ProdDependencyGraph]
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                                  [(ProdDependencyGraphM s, ProdDependencyGraphM s)]
-> ((ProdDependencyGraphM s, ProdDependencyGraphM s) -> ST s ())
-> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([ProdDependencyGraphM s]
-> [ProdDependencyGraphM s]
-> [(ProdDependencyGraphM s, ProdDependencyGraphM s)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ProdDependencyGraphM s]
prods (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)) (((ProdDependencyGraphM s, ProdDependencyGraphM s) -> ST s ())
 -> ST s ())
-> ((ProdDependencyGraphM s, ProdDependencyGraphM s) -> ST s ())
-> ST s ()
forall a b. (a -> b) -> a -> b
$ \(ProdDependencyGraphM s
nprod,ProdDependencyGraphM s
oprod) -> do
                                    -- All possible edges

                                    let possa :: [Edge]
possa = do (Vertex
v1,Vertex
v2) <- [Edge]
edges
                                                   -- Take a child of this nonterminal type

                                                   Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v1
                                                   Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v2
                                                   let tp :: Identifier
tp = Vertex -> Identifier
getAttrChildName Vertex
v1
                                                   (Identifier
ch,Identifier
chtp) <- ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap (ProdDependencyGraph -> [(Identifier, Identifier)])
-> ProdDependencyGraph -> [(Identifier, Identifier)]
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
nprod
                                                   Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Identifier
tp Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
chtp
                                                   -- Construct edge as it should be in the production graph

                                                   let nv1 :: Vertex
nv1 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v1 Identifier
ch
                                                   let nv2 :: Vertex
nv2 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v2 Identifier
ch
                                                   Edge -> [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
nv1, Vertex
nv2)
                                    [Edge]
toadd <- (Edge -> ST s Bool) -> [Edge] -> ST s [Edge]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge (ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
oprod)) [Edge]
possa
                                    DependencyGraph s -> [Edge] -> ST s ()
forall s. DependencyGraph s -> [Edge] -> ST s ()
graphInsertEdges (ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
nprod) [Edge]
toadd
                                  NontDependencyInformationM s -> ST s (NontDependencyInformationM s)
forall (m :: * -> *) a. Monad m => a -> m a
return (NontDependencyInformationM s
 -> ST s (NontDependencyInformationM s))
-> NontDependencyInformationM s
-> ST s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM :: forall s.
NontDependencyInformation
-> NontDependencyGraphM s
-> [ProdDependencyGraphM s]
-> NontDependencyInformationM s
NontDependencyInformationM { ndimOrig :: NontDependencyInformation
ndimOrig     = NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
                                                                      , ndimDepGraph :: NontDependencyGraphM s
ndimDepGraph = NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph NontDependencyInformationM s
ndi
                                                                      , ndimProds :: [ProdDependencyGraphM s]
ndimProds    = [ProdDependencyGraphM s]
prods }


-------------------------------------------------------------------------------

--         Knuth-1 algorithm

-------------------------------------------------------------------------------


-- | Combine the dependency and nonterminal graphs using Knuth-1

--   this function assumes that the nonterminal graphs initially contains no edges

knuth1 :: [NontDependencyInformationM s] -> ST s ()
knuth1 :: [NontDependencyInformationM s] -> ST s ()
knuth1 [NontDependencyInformationM s]
ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges)

--               pndis :: [([[Edge]], NontDependencyInformation)]

                 [([[Edge]], NontDependencyInformationM s)]
pndis <- [NontDependencyInformationM s]
-> (NontDependencyInformationM s
    -> ST s ([[Edge]], NontDependencyInformationM s))
-> ST s [([[Edge]], NontDependencyInformationM s)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NontDependencyInformationM s]
ndis ((NontDependencyInformationM s
  -> ST s ([[Edge]], NontDependencyInformationM s))
 -> ST s [([[Edge]], NontDependencyInformationM s)])
-> (NontDependencyInformationM s
    -> ST s ([[Edge]], NontDependencyInformationM s))
-> ST s [([[Edge]], NontDependencyInformationM s)]
forall a b. (a -> b) -> a -> b
$ \NontDependencyInformationM s
ndi -> do
                   [[Edge]]
ipend <- (ProdDependencyGraphM s -> ST s [Edge])
-> [ProdDependencyGraphM s] -> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DependencyGraph s -> ST s [Edge]
forall s. DependencyGraph s -> ST s [Edge]
graphEdges (DependencyGraph s -> ST s [Edge])
-> (ProdDependencyGraphM s -> DependencyGraph s)
-> ProdDependencyGraphM s
-> ST s [Edge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) ([ProdDependencyGraphM s] -> ST s [[Edge]])
-> (NontDependencyInformationM s -> [ProdDependencyGraphM s])
-> NontDependencyInformationM s
-> ST s [[Edge]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds (NontDependencyInformationM s -> ST s [[Edge]])
-> NontDependencyInformationM s -> ST s [[Edge]]
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
                   ([[Edge]], NontDependencyInformationM s)
-> ST s ([[Edge]], NontDependencyInformationM s)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Edge]]
ipend, NontDependencyInformationM s
ndi)
                 [([[Edge]], NontDependencyInformationM s)] -> ST s ()
forall s. [([[Edge]], NontDependencyInformationM s)] -> ST s ()
knuth1' [([[Edge]], NontDependencyInformationM s)]
pndis

-- | Helper function for |knuth1| which repeats the process until we are done

knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s ()
knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s ()
knuth1' [([[Edge]], NontDependencyInformationM s)]
ndis = do -- Add edges from the production graphs to the nonterminal graph

--                ndis' :: [[Edge]]

                  [[Edge]]
ndis' <- (([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
-> [([[Edge]], NontDependencyInformationM s)] -> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([[Edge]], NontDependencyInformationM s) -> ST s [Edge]
forall s. ([[Edge]], NontDependencyInformationM s) -> ST s [Edge]
addProdNont [([[Edge]], NontDependencyInformationM s)]
ndis
                  -- List of all newly added edges

--                ntedge :: [Edge]

                  let pntedge :: [Edge]
pntedge = [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge]]
ndis'
                  -- Add backedges

                  --bedges <- addBackEdges ndis

                  -- All added nonterminal edges

                  let ntedge :: [Edge]
ntedge = [Edge]
pntedge -- ++ bedges

                  if [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Edge]
ntedge
                    -- When no new edges have been added we are done

                    then () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    else do -- Otherwise, the next step is to add edges from nonterminal to production graphs

--                          ndis'' :: [[[Edge]]]

                            [[[Edge]]]
ndis'' <- (([[Edge]], NontDependencyInformationM s) -> ST s [[Edge]])
-> [([[Edge]], NontDependencyInformationM s)] -> ST s [[[Edge]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\([[Edge]]
_,NontDependencyInformationM s
x) -> Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]
forall s.
Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]
addNontProd Bool
True ([Edge]
ntedge, NontDependencyInformationM s
x)) [([[Edge]], NontDependencyInformationM s)]
ndis
                            -- List of new states (production edges + dependency graphs)

--                          nndis' :: [([[Edge]], NontDependencyInformation)]

                            [([[Edge]], NontDependencyInformationM s)]
nndis' <- (([[Edge]], NontDependencyInformationM s)
 -> [[Edge]] -> ST s ([[Edge]], NontDependencyInformationM s))
-> [([[Edge]], NontDependencyInformationM s)]
-> [[[Edge]]]
-> ST s [([[Edge]], NontDependencyInformationM s)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\([[Edge]]
_,NontDependencyInformationM s
ndi) [[Edge]]
me -> ([[Edge]], NontDependencyInformationM s)
-> ST s ([[Edge]], NontDependencyInformationM s)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Edge]]
me, NontDependencyInformationM s
ndi)) [([[Edge]], NontDependencyInformationM s)]
ndis [[[Edge]]]
ndis''
                            if ([[Edge]] -> Bool) -> [[[Edge]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([[Edge]] -> Bool) -> [[Edge]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Edge]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[[Edge]]]
ndis''
                               -- We have added some edges, so continue the process

                              then [([[Edge]], NontDependencyInformationM s)] -> ST s ()
forall s. [([[Edge]], NontDependencyInformationM s)] -> ST s ()
knuth1' [([[Edge]], NontDependencyInformationM s)]
nndis'
                              -- No new edges added, we are done

                              else () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add pending edges from the production graphs to the nonterminal graph

--   and return the list of newly added nonterminal edges

addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge]
addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge]
addProdNont ([[Edge]]
pending, NontDependencyInformationM s
ndi) = do -- Unwrapping of the records

                                let nontDepGraph :: NontDependencyGraphM s
nontDepGraph = NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph NontDependencyInformationM s
ndi
                                let nontGraph :: DependencyGraph s
nontGraph = NontDependencyGraphM s -> DependencyGraph s
forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph NontDependencyGraphM s
nontDepGraph
                                -- nub the list because multiple productions can result in the same new edges

                                let possa :: [Edge]
possa = [Edge] -> [Edge]
forall a. Eq a => [a] -> [a]
nub ([Edge] -> [Edge]) -> [Edge] -> [Edge]
forall a b. (a -> b) -> a -> b
$ do (Vertex
v1,Vertex
v2) <- [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge]]
pending
                                                     -- Take only edges from syn.lhs to inh.lhs

                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v1
                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Identifier
getAttrChildName Vertex
v1 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
_LHS
                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> AttrType
getAttrType      Vertex
v1 AttrType -> AttrType -> Bool
forall a. Eq a => a -> a -> Bool
==  AttrType
Syn
                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v2
                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Identifier
getAttrChildName Vertex
v2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
_LHS
                                                     Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> AttrType
getAttrType      Vertex
v2 AttrType -> AttrType -> Bool
forall a. Eq a => a -> a -> Bool
==  AttrType
Inh
                                                     -- Construct edge as it should be in nonterminal graph

                                                     let nv1 :: Vertex
nv1 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v1 (NontDependencyInformation -> Identifier
ndiNonterminal (NontDependencyInformation -> Identifier)
-> NontDependencyInformation -> Identifier
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                                                     let nv2 :: Vertex
nv2 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v2 (NontDependencyInformation -> Identifier
ndiNonterminal (NontDependencyInformation -> Identifier)
-> NontDependencyInformation -> Identifier
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                                                     Edge -> [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
nv1, Vertex
nv2)
                                -- Edges that are not in the nonterminal graph yet

                                [Edge]
toadd <- (Edge -> ST s Bool) -> [Edge] -> ST s [Edge]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\Edge
e -> (Bool -> Bool) -> ST s (Bool -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool -> Bool
not ST s (Bool -> Bool) -> ST s Bool -> ST s Bool
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
nontGraph Edge
e) [Edge]
possa
                                -- Check whether new edges are to be added and return the added edges

                                Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Edge]
toadd) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                                   DependencyGraph s -> [Edge] -> ST s [Edge]
forall s. DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC DependencyGraph s
nontGraph [Edge]
toadd
                                   () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return [Edge]
toadd

-- | Add edges from the nonterminal graphs to the production graphs

--   and return the list of newly added production edges and the updated graph

addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]
addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]
addNontProd Bool
trc ([Edge]
pending, NontDependencyInformationM s
ndi) = do -- Just call the helper function for each nonterminal

                                    (ProdDependencyGraphM s -> ST s [Edge])
-> [ProdDependencyGraphM s] -> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge]
forall s. Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge]
addNontProd' Bool
trc [Edge]
pending) (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)

-- | Helper function for |addNontProd| for a single production

addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge]
addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge]
addNontProd' Bool
trc [Edge]
pend ProdDependencyGraphM s
pdg = do -- Unwrapping of the records

                               DependencyGraph s
prodGraph <- DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyGraph s -> ST s (DependencyGraph s))
-> DependencyGraph s -> ST s (DependencyGraph s)
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
pdg
                               -- Construct all possible new edges

                               let possa :: [Edge]
possa = do (Vertex
v1,Vertex
v2) <- [Edge]
pend
                                              -- Take a child of this nonterminal type

                                              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v1
                                              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v2
                                              let tp :: Identifier
tp = Vertex -> Identifier
getAttrChildName Vertex
v1
                                              (Identifier
ch,Identifier
chtp) <- ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap (ProdDependencyGraph -> [(Identifier, Identifier)])
-> ProdDependencyGraph -> [(Identifier, Identifier)]
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg
                                              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Identifier
tp Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
chtp
                                              -- Construct edge as it should be in the production graph

                                              let nv1 :: Vertex
nv1 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v1 Identifier
ch
                                              let nv2 :: Vertex
nv2 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v2 Identifier
ch
                                              Edge -> [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
nv1, Vertex
nv2)
                               -- Edges that are not in the production graph yet

                               [Edge]
toadd <- (Edge -> ST s Bool) -> [Edge] -> ST s [Edge]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\Edge
e -> (Bool -> Bool) -> ST s (Bool -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool -> Bool
not ST s (Bool -> Bool) -> ST s Bool -> ST s Bool
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
prodGraph Edge
e) [Edge]
possa
                               -- Check whether new edges are to be added and return the result

                               if [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Edge]
toadd
                                 then [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                 else do -- Insert all edges and return transitive edges that are added in this process

                                         [Edge]
ret <- if Bool
trc
                                                then DependencyGraph s -> [Edge] -> ST s [Edge]
forall s. DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC DependencyGraph s
prodGraph [Edge]
toadd
                                                else do (Edge -> ST s ()) -> [Edge] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DependencyGraph s -> Edge -> ST s ()
forall s. DependencyGraph s -> Edge -> ST s ()
graphInsert DependencyGraph s
prodGraph) [Edge]
toadd
                                                        [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                         -- Debug output

                                         --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd

                                         [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return [Edge]
ret

-- | Add the "back edges" to the nonterminal graphs for creating a global ordering

addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge]
addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge]
addBackEdges [([[Edge]], NontDependencyInformationM s)]
ndis = do -- gather all backedges

                       [[Edge]]
lBackEdges <- [([[Edge]], NontDependencyInformationM s)]
-> (([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
-> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([[Edge]], NontDependencyInformationM s)]
ndis ((([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
 -> ST s [[Edge]])
-> (([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
-> ST s [[Edge]]
forall a b. (a -> b) -> a -> b
$ \([[Edge]]
aedg,NontDependencyInformationM s
ndi) -> do
                         -- For every production

                         [[Edge]]
bs <- [([Edge], ProdDependencyGraphM s)]
-> (([Edge], ProdDependencyGraphM s) -> ST s [Edge])
-> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([[Edge]]
-> [ProdDependencyGraphM s] -> [([Edge], ProdDependencyGraphM s)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Edge]]
aedg (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)) ((([Edge], ProdDependencyGraphM s) -> ST s [Edge])
 -> ST s [[Edge]])
-> (([Edge], ProdDependencyGraphM s) -> ST s [Edge])
-> ST s [[Edge]]
forall a b. (a -> b) -> a -> b
$ \([Edge]
edg,ProdDependencyGraphM s
prod) -> do
                           -- Filter out the backedges

                           [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ do (Vertex
v1,Vertex
v2) <- [Edge]
edg
                                       -- Backedges are from inh.ch to syn.ch

                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v1
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Identifier
getAttrChildName Vertex
v1 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
/= Identifier
_LHS
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> AttrType
getAttrType      Vertex
v1 AttrType -> AttrType -> Bool
forall a. Eq a => a -> a -> Bool
==  AttrType
Inh
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v2
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Identifier
getAttrChildName Vertex
v2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
/= Identifier
_LHS
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> AttrType
getAttrType      Vertex
v2 AttrType -> AttrType -> Bool
forall a. Eq a => a -> a -> Bool
==  AttrType
Syn
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Identifier
getAttrChildName Vertex
v1 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex -> Identifier
getAttrChildName Vertex
v2
                                       -- Find the correct child name

                                       (Identifier
ch,Identifier
chtp) <- ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap (ProdDependencyGraph -> [(Identifier, Identifier)])
-> ProdDependencyGraph -> [(Identifier, Identifier)]
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod
                                       let tp :: Identifier
tp = Vertex -> Identifier
getAttrChildName Vertex
v1
                                       Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Identifier
tp Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
ch
                                       -- Construct the edge as it should be in the nonterminal graph

                                       let nv1 :: Vertex
nv1 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v1 Identifier
chtp
                                       let nv2 :: Vertex
nv2 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v2 Identifier
chtp
                                       Edge -> [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
nv1, Vertex
nv2)
                         [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ ([Edge] -> [Edge] -> [Edge]) -> [Edge] -> [[Edge]] -> [Edge]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Edge] -> [Edge] -> [Edge]
forall a. Eq a => [a] -> [a] -> [a]
union [] [[Edge]]
bs
                       -- Concatenate all lists of backedges

                       let backedges :: [Edge]
backedges = ([Edge] -> [Edge] -> [Edge]) -> [Edge] -> [[Edge]] -> [Edge]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Edge] -> [Edge] -> [Edge]
forall a. Eq a => [a] -> [a] -> [a]
union [] [[Edge]]
lBackEdges
                       -- Add backedges to every nonterminal graph

                       [[Edge]]
ret <- [([[Edge]], NontDependencyInformationM s)]
-> (([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
-> ST s [[Edge]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([[Edge]], NontDependencyInformationM s)]
ndis ((([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
 -> ST s [[Edge]])
-> (([[Edge]], NontDependencyInformationM s) -> ST s [Edge])
-> ST s [[Edge]]
forall a b. (a -> b) -> a -> b
$ \([[Edge]]
_,NontDependencyInformationM s
ndi) -> do
                         -- Find the backedges for this nonterminal

                         let nont :: Identifier
nont = NontDependencyInformation -> Identifier
ndiNonterminal (NontDependencyInformation -> Identifier)
-> (NontDependencyInformationM s -> NontDependencyInformation)
-> NontDependencyInformationM s
-> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig (NontDependencyInformationM s -> Identifier)
-> NontDependencyInformationM s -> Identifier
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
                         let thisbe :: [Edge]
thisbe = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter (Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
(==) Identifier
nont (Identifier -> Bool) -> (Edge -> Identifier) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> Identifier
getAttrChildName (Vertex -> Identifier) -> (Edge -> Vertex) -> Edge -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Vertex
forall a b. (a, b) -> a
fst) [Edge]
backedges
                         -- Add them to the graph

                         DependencyGraph s -> [Edge] -> ST s [Edge]
forall s. DependencyGraph s -> [Edge] -> ST s [Edge]
graphInsertEdgesTRC (NontDependencyGraphM s -> DependencyGraph s
forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph (NontDependencyGraphM s -> DependencyGraph s)
-> (NontDependencyInformationM s -> NontDependencyGraphM s)
-> NontDependencyInformationM s
-> DependencyGraph s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph (NontDependencyInformationM s -> DependencyGraph s)
-> NontDependencyInformationM s -> DependencyGraph s
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi) [Edge]
thisbe
                       [Edge] -> ST s [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> ST s [Edge]) -> [Edge] -> ST s [Edge]
forall a b. (a -> b) -> a -> b
$ [Edge]
backedges [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ [[Edge]] -> [Edge]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge]]
ret


-- | Add all resulting edges from a topsort on the nonterminal graph to the production graph

--   this will ignore edges that will make the graph cyclic

addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s ()
addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s ()
addTopSortEdges [Edge]
pend ProdDependencyGraphM s
pdg = do -- Unwrapping of the records

                              DependencyGraph s
prodGraph <- DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyGraph s -> ST s (DependencyGraph s))
-> DependencyGraph s -> ST s (DependencyGraph s)
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
pdg
                              -- Construct all possible new edges

                              let possa :: [Edge]
possa = do (Vertex
v1,Vertex
v2) <- [Edge]
pend
                                             -- Take a child of this nonterminal type

                                             Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v1
                                             Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isVertexAttr Vertex
v2
                                             let tp :: Identifier
tp = Vertex -> Identifier
getAttrChildName Vertex
v1
                                             (Identifier
ch,Identifier
chtp) <- ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap (ProdDependencyGraph -> [(Identifier, Identifier)])
-> ProdDependencyGraph -> [(Identifier, Identifier)]
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg
                                             Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Identifier
tp Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
chtp
                                             -- Construct edge as it should be in the production graph

                                             let nv1 :: Vertex
nv1 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v1 Identifier
ch
                                             let nv2 :: Vertex
nv2 = Vertex -> Identifier -> Vertex
setAttrChildName Vertex
v2 Identifier
ch
                                             Edge -> [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
nv1, Vertex
nv2)
                              -- Edges that are not in the production graph yet

                              [Edge] -> (Edge -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Edge]
possa ((Edge -> ST s ()) -> ST s ()) -> (Edge -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Vertex
v1,Vertex
v2) -> do Bool
e1 <- DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
prodGraph (Vertex
v1,Vertex
v2)
                                                           Bool
e2 <- DependencyGraph s -> Edge -> ST s Bool
forall s. DependencyGraph s -> Edge -> ST s Bool
graphContainsEdge DependencyGraph s
prodGraph (Vertex
v2,Vertex
v1)
                                                           Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
e1 Bool -> Bool -> Bool
|| Bool
e2) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                                                             DependencyGraph s -> Edge -> ST s [(Int, Set Int)]
forall s. DependencyGraph s -> Edge -> ST s [(Int, Set Int)]
graphInsertTRC DependencyGraph s
prodGraph (Vertex
v1,Vertex
v2)
                                                             () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()