module KennedyWarren where

import Prelude hiding (init, succ)
import CommonTypes
import Pretty
import Knuth1
import ExecutionPlan
import Debug.Trace
import Control.Monad.ST
import Control.Monad.State
import Control.Monad.Error
import Data.STRef
import Data.Maybe
import Data.List (intersperse, groupBy, partition, sortBy)
import Data.Ord
import qualified ErrorMessages as Err
import PrintErrorMessages ()

import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet

-- lazy version (does not return errors)
-- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes
kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan
kennedyWarrenLazy :: Options
-> Set Identifier
-> [NontDependencyInformation]
-> TypeSyns
-> Derivings
-> ExecutionPlan
kennedyWarrenLazy Options
_ Set Identifier
wr [NontDependencyInformation]
ndis TypeSyns
typesyns Derivings
derivings = ExecutionPlan
plan where
  plan :: ExecutionPlan
plan  = ENonterminals
-> TypeSyns -> Set Identifier -> Derivings -> ExecutionPlan
ExecutionPlan ENonterminals
nonts TypeSyns
typesyns Set Identifier
wr Derivings
derivings
  nonts :: ENonterminals
nonts = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NontDependencyInformation -> Int -> ENonterminal
mkNont [NontDependencyInformation]
ndis [Int]
nontIds
  nontIds :: [Int]
nontIds = forall a. Enum a => a -> a -> [a]
enumFromThen Int
1 Int
4
  initvMap :: Map Identifier Int
initvMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\NontDependencyInformation
ndi Int
initv -> (NontDependencyInformation -> Identifier
ndiNonterminal NontDependencyInformation
ndi, Int
initv)) [NontDependencyInformation]
ndis [Int]
nontIds

  mkNont :: NontDependencyInformation -> Int -> ENonterminal
mkNont NontDependencyInformation
ndi Int
initv = ENonterminal
nont where
    nont :: ENonterminal
nont = Identifier
-> [Identifier]
-> ClassContext
-> Int
-> [Int]
-> Map Int StateCtx
-> Map Int StateCtx
-> EProductions
-> Bool
-> HigherOrderInfo
-> ENonterminal
ENonterminal
                 (NontDependencyInformation -> Identifier
ndiNonterminal NontDependencyInformation
ndi)
                 (NontDependencyInformation -> [Identifier]
ndiParams NontDependencyInformation
ndi)
                 (NontDependencyInformation -> ClassContext
ndiClassCtxs NontDependencyInformation
ndi)
                 Int
initst
                 [Int
initv]
                 Map Int StateCtx
nextMap
                 Map Int StateCtx
prevMap
                 EProductions
prods
                 (NontDependencyInformation -> Bool
ndiRecursive NontDependencyInformation
ndi)
                 (NontDependencyInformation -> HigherOrderInfo
ndiHoInfo NontDependencyInformation
ndi)
    initst :: Int
initst  = Int
initv forall a. Num a => a -> a -> a
+ Int
1
    finals :: Int
finals  = Int
initv forall a. Num a => a -> a -> a
+ Int
2
    nextMap :: Map Int StateCtx
nextMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
initst, Int -> StateCtx
OneVis Int
initv), (Int
finals, StateCtx
NoneVis)]
    prevMap :: Map Int StateCtx
prevMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
initst, StateCtx
NoneVis), (Int
finals, Int -> StateCtx
OneVis Int
initv)]
    prods :: EProductions
prods   = forall a b. (a -> b) -> [a] -> [b]
map ProdDependencyGraph -> EProduction
mkProd (NontDependencyInformation -> [ProdDependencyGraph]
ndiProds NontDependencyInformation
ndi)

    mkProd :: ProdDependencyGraph -> EProduction
mkProd ProdDependencyGraph
pdi = EProduction
prod where
      prod :: EProduction
prod = Identifier
-> [Identifier]
-> [Type]
-> ERules
-> EChildren
-> Visits
-> EProduction
EProduction
               (ProdDependencyGraph -> Identifier
pdgProduction ProdDependencyGraph
pdi)
               (ProdDependencyGraph -> [Identifier]
pdgParams ProdDependencyGraph
pdi)
               (ProdDependencyGraph -> [Type]
pdgConstraints ProdDependencyGraph
pdi)
               (ProdDependencyGraph -> ERules
pdgRules ProdDependencyGraph
pdi)
               (ProdDependencyGraph -> EChildren
pdgChilds ProdDependencyGraph
pdi)
               Visits
visits
      visits :: Visits
visits = [Visit
vis]
      vis :: Visit
vis    = Int
-> Int
-> Int
-> Set Identifier
-> Set Identifier
-> VisitSteps
-> VisitKind
-> Visit
Visit Int
initv Int
initst Int
finals Set Identifier
inh Set Identifier
syn VisitSteps
steps VisitKind
kind
      inh :: Set Identifier
inh    = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [Identifier]
ndiInh NontDependencyInformation
ndi
      syn :: Set Identifier
syn    = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [Identifier]
ndiSyn NontDependencyInformation
ndi
      kind :: VisitKind
kind   = Bool -> VisitKind
VisitPure Bool
False
      steps :: VisitSteps
steps  = VisitSteps
childSteps forall a. [a] -> [a] -> [a]
++ VisitSteps
invokeSteps forall a. [a] -> [a] -> [a]
++ VisitSteps
ruleSteps

      childSteps :: VisitSteps
childSteps  = [ Identifier -> VisitStep
ChildIntro Identifier
nm | EChild Identifier
nm Type
_ ChildKind
_ Bool
_ Maybe [Identifier]
_ Bool
_ <- ProdDependencyGraph -> EChildren
pdgChilds ProdDependencyGraph
pdi ]
      invokeSteps :: VisitSteps
invokeSteps = [ Identifier -> Identifier -> Int -> VisitStep
ChildVisit Identifier
nm Identifier
nt Int
v
                    | EChild Identifier
nm Type
tp ChildKind
_ Bool
_ Maybe [Identifier]
_ Bool
_ <- ProdDependencyGraph -> EChildren
pdgChilds ProdDependencyGraph
pdi
                    , let nt :: Identifier
nt = Type -> Identifier
extractNonterminal Type
tp
                          v :: Int
v  = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"child not in initv-map") Identifier
nt Map Identifier Int
initvMap
                    ]
      ruleSteps :: VisitSteps
ruleSteps   = [ Identifier -> VisitStep
Sem Identifier
nm | (ERule Identifier
nm Pattern
_ Expression
_ Bool
_ [Char]
_ Bool
_ Bool
_ Maybe Error
_) <- ProdDependencyGraph -> ERules
pdgRules ProdDependencyGraph
pdi ]


-- ordered version (may return errors)
kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc)
kennedyWarrenOrder :: Options
-> Set Identifier
-> [NontDependencyInformation]
-> TypeSyns
-> Derivings
-> Either Error (ExecutionPlan, PP_Doc, PP_Doc)
kennedyWarrenOrder Options
opts Set Identifier
wr [NontDependencyInformation]
ndis TypeSyns
typesyns Derivings
derivings = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT forall a b. (a -> b) -> a -> b
$ do
  [NontDependencyInformationM s]
indi <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s.
NontDependencyInformation -> ST s (NontDependencyInformationM s)
mkNontDependencyInformationM [NontDependencyInformation]
ndis
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. [NontDependencyInformationM s] -> ST s ()
knuth1 [NontDependencyInformationM s]
indi
  -- Check all graphs for cyclicity, transitive closure and consistency
  -- traceST $ "Checking graphs..."
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NontDependencyInformationM s]
indi forall a b. (a -> b) -> a -> b
$ \NontDependencyInformationM s
ndi -> do
    let nont :: Identifier
nont = NontDependencyInformation -> Identifier
ndiNonterminal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
    let g :: DependencyGraph s
g = forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
    -- Topological sort
    --tsedg <- graphTopSort g
    -- Cyclicity check
    [Vertex]
ntCycVerts <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt DependencyGraph s
g
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
ntCycVerts) forall a b. (a -> b) -> a -> b
$ do
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe Identifier -> [[Char]] -> Error
Err.Cyclic Identifier
nont forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Vertex]
ntCycVerts)
--      let msg = "Nonterminal graph " ++ show nont ++ " is cylic!"
--      fail msg
    -- Transtive closure check
    Bool
trc <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s Bool
graphIsTRC DependencyGraph s
g
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
trc) forall a b. (a -> b) -> a -> b
$ do
      let msg :: [Char]
msg = [Char]
"Nonterminal graph " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
nont forall a. [a] -> [a] -> [a]
++ [Char]
" is not transitively closed!"
      forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg
    -- Consistency check
    Bool
cons <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s Bool
graphCheckConsistency DependencyGraph s
g
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
cons) forall a b. (a -> b) -> a -> b
$ do
      let msg :: [Char]
msg = [Char]
"Nonterminal graph " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
nont forall a. [a] -> [a] -> [a]
++ [Char]
" is not consistent!"
      forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg

    -- Loop trough all productions
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) forall a b. (a -> b) -> a -> b
$ \ProdDependencyGraphM s
prod -> do
      let pr :: Identifier
pr = ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod
      let g' :: DependencyGraph s
g' = forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s
prod
      -- Topsort
      --addTopSortEdges tsedg prod
      -- Check for cyclicity
      [Vertex]
pdCycVerts <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt DependencyGraph s
g'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
pdCycVerts) forall a b. (a -> b) -> a -> b
$ do
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe Identifier -> [[Char]] -> Error
Err.Cyclic Identifier
nont (forall a. a -> Maybe a
Just Identifier
pr) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Vertex]
pdCycVerts)
        -- let msg = "Production graph " ++ show pr ++ " of nonterminal "
        --                               ++ show nont ++ " is cylic!"
        -- fail msg
      -- Transtive closure check
      Bool
trc' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s Bool
graphIsTRC DependencyGraph s
g'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
trc') forall a b. (a -> b) -> a -> b
$ do
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. [Char] -> ST s ()
traceST forall a b. (a -> b) -> a -> b
$ [Char]
"Production graph " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
pr forall a. [a] -> [a] -> [a]
++ [Char]
" of nonterminal "
                                             forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
nont forall a. [a] -> [a] -> [a]
++ [Char]
" is not transitively closed!"
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Production graph is not transitively closed."
      -- Check consistency
      Bool
consistent <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. DependencyGraph s -> ST s Bool
graphCheckConsistency DependencyGraph s
g'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
consistent) forall a b. (a -> b) -> a -> b
$ do
        let msg :: [Char]
msg =  [Char]
"Production graph " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
pr forall a. [a] -> [a] -> [a]
++ [Char]
" of nonterminal "
                                       forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
nont forall a. [a] -> [a] -> [a]
++ [Char]
" is not consistent!"
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg
  -- reachable when everything is ok
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
        -- Create non-transitive closed graph for efficiency
        [NontDependencyInformationM s]
indi' <- forall s.
[NontDependencyInformationM s]
-> ST s [NontDependencyInformationM s]
undoTransitiveClosure [NontDependencyInformationM s]
indi
        -- Graphviz output of dependency graphs
        [PP_Doc]
gvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. NontDependencyInformationM s -> ST s PP_Doc
toGVNontDependencyInfo [NontDependencyInformationM s]
indi'
        -- Doing kennedywarren
        (ExecutionPlan
ret, PP_Doc
visitg) <- forall s a. VG s a -> ST s a
runVG forall a b. (a -> b) -> a -> b
$ do
         -- traceVG $ "Running kennedy-warren..."
         [[Int]]
initvs <- forall s.
Set Identifier -> [NontDependencyInformationM s] -> VG s [[Int]]
kennedyWarrenVisitM Set Identifier
wr [NontDependencyInformationM s]
indi'
         -- Print some debug info
         Int
nodes <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Int
vgNodeNum
         Int
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Int
vgEdgeNum
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Options -> Bool
beQuiet Options
opts) forall a b. (a -> b) -> a -> b
$ do
           forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Number of nodes = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
nodes
           forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Number of edges = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
edges
         -- Generate execution plan
         ExecutionPlan
ex <- forall s.
Options
-> [NontDependencyInformationM s]
-> [[Int]]
-> Set Identifier
-> TypeSyns
-> Derivings
-> VG s ExecutionPlan
kennedyWarrenExecutionPlan Options
opts [NontDependencyInformationM s]
indi' [[Int]]
initvs Set Identifier
wr TypeSyns
typesyns Derivings
derivings
         -- Get visit graph
         PP_Doc
visitg <- forall s. VG s PP_Doc
toGVVisitGraph
         forall (m :: * -> *) a. Monad m => a -> m a
return (ExecutionPlan
ex,PP_Doc
visitg)
        -- Return the result
        forall (m :: * -> *) a. Monad m => a -> m a
return (ExecutionPlan
ret, forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
gvs, PP_Doc
visitg)

-------------------------------------------------------------------------------
--         Debugging functionality
-------------------------------------------------------------------------------

-- | Pretty print a vertex in GraphViz format
toGVVertex :: Bool -> Vertex -> ST s PP_Doc
toGVVertex :: forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
l (VAttr AttrType
t Identifier
a Identifier
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"attr_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show AttrType
t forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
a forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
b) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=box,label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show AttrType
t forall a. [a] -> [a] -> [a]
++ [Char]
" @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
a forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
b forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty
toGVVertex Bool
l (VChild Identifier
c)    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"child_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
c) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=ellipse,label=\"Child " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
c forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty
toGVVertex Bool
l (VRule Identifier
r)   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"rule_"  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
r) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=diamond,label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Identifier
r forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty

-- | Pretty print an edge in GraphViz format
toGVEdge :: Edge -> ST s PP_Doc
toGVEdge :: forall s. Edge -> ST s PP_Doc
toGVEdge (Vertex
v1, Vertex
v2) = do PP_Doc
r1 <- forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
False Vertex
v1
                       PP_Doc
r2 <- forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
False Vertex
v2
                       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PP_Doc
r1 forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char] -> PP_Doc
text [Char]
"->" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< PP_Doc
r2

-- | Pretty print a NontDependencyInformation in GraphViz format
toGVNontDependencyInfo :: NontDependencyInformationM s -> ST s PP_Doc
toGVNontDependencyInfo :: forall s. NontDependencyInformationM s -> ST s PP_Doc
toGVNontDependencyInfo NontDependencyInformationM s
ndi = do DependencyGraph s
dg <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
                                [Vertex]
verts <- forall s. DependencyGraph s -> ST s [Vertex]
graphVertices DependencyGraph s
dg
                                [Edge]
edges <- forall s. DependencyGraph s -> ST s [Edge]
graphEdges DependencyGraph s
dg
                                [PP_Doc]
vtexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
True) [Vertex]
verts
                                [PP_Doc]
etexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. Edge -> ST s PP_Doc
toGVEdge [Edge]
edges
                                [PP_Doc]
ptexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. ProdDependencyGraphM s -> ST s PP_Doc
toGVProdDependencyGraph (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char]
"digraph ndg_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) forall a. [a] -> [a] -> [a]
++ [Char]
" {")
                                          forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
vtexts
                                          forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
etexts
                                          forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [Char] -> PP_Doc
text [Char]
"}"
                                          forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [Char] -> PP_Doc
text [Char]
"" -- empty line
                                          forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
ptexts)

-- | Pretty print a ProdDependencyGraph in GraphViz format
toGVProdDependencyGraph :: ProdDependencyGraphM s -> ST s PP_Doc
toGVProdDependencyGraph :: forall s. ProdDependencyGraphM s -> ST s PP_Doc
toGVProdDependencyGraph ProdDependencyGraphM s
pdg = do DependencyGraph s
dg <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
pdg
                                 [Vertex]
verts <- forall s. DependencyGraph s -> ST s [Vertex]
graphVertices DependencyGraph s
dg
                                 [Edge]
edges <- forall s. DependencyGraph s -> ST s [Edge]
graphEdges DependencyGraph s
dg
                                 [PP_Doc]
vtexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
True) [Vertex]
verts
                                 [PP_Doc]
etexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s. Edge -> ST s PP_Doc
toGVEdge [Edge]
edges
                                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char]
"digraph pdg_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg) forall a. [a] -> [a] -> [a]
++ [Char]
" {")
                                           forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           (forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
vtexts)
                                           forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           (forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
etexts)
                                           forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text ([Char]
"info [shape=box,label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg) forall a. [a] -> [a] -> [a]
++ [Char]
"\"];")
                                           forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text [Char]
"}"
                                           forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text [Char]
"")

toGVVisitGraph :: VG s PP_Doc
toGVVisitGraph :: forall s. VG s PP_Doc
toGVVisitGraph = do
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  [PP_Doc]
noded <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap (STRef s (NontDependencyInformationM s))
ndis) forall a b. (a -> b) -> a -> b
$ \(Int
n,STRef s (NontDependencyInformationM s)
rndi) -> do
    NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"node_" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< Int
n forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"[label=\"" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< NontDependencyInformation -> Identifier
ndiNonterminal (forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"_" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< Int
n forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\"];"
  IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  [PP_Doc]
edged <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap (VGNode, VGNode)
edges) forall a b. (a -> b) -> a -> b
$ \(Int
edg,(VGNode Int
from,VGNode Int
to)) -> do
    Set Identifier
inh <- forall s. VGEdge -> VG s (Set Identifier)
getInherited (Int -> VGEdge
VGEdge Int
edg)
    Set Identifier
syn <- forall s. VGEdge -> VG s (Set Identifier)
getSynthesized (Int -> VGEdge
VGEdge Int
edg)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"node_" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< Int
from forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"-> node_" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< Int
to forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"[label=\"visit v" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< Int
edg
      forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\\ninh:" forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse [Char]
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Identifier
inh) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\\nsyn: " forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse [Char]
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set Identifier
syn) forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\"];"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"digraph visitgraph { " forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-< forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
noded forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-< forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
edged forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-< [Char]
"}"

-------------------------------------------------------------------------------
--         Kennedy-Warren in monadic style
-------------------------------------------------------------------------------
{-
runVG                    :: VG s a -> ST s a
insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode
createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
selectPending            :: VG s VGEdge
getInherited             :: VGEdge -> VG s (Set Identifier)
getSynthesized           :: VGEdge -> VG s (Set Identifier)
markFinal                :: VGEdge -> VG s ()
getProductions           :: VGEdge -> VG s [VGProd]
onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool
setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
getChildState            :: VGProd -> Identifier -> VG s VGNode
addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
addVisitStep             :: VGProd -> VisitStep -> VG s ()
repeatM                  :: VG s () -> VG s ()
-}

newtype VGNode = VGNode Int deriving (Int -> VGNode -> ShowS
[VGNode] -> ShowS
VGNode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VGNode] -> ShowS
$cshowList :: [VGNode] -> ShowS
show :: VGNode -> [Char]
$cshow :: VGNode -> [Char]
showsPrec :: Int -> VGNode -> ShowS
$cshowsPrec :: Int -> VGNode -> ShowS
Show,VGNode -> VGNode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VGNode -> VGNode -> Bool
$c/= :: VGNode -> VGNode -> Bool
== :: VGNode -> VGNode -> Bool
$c== :: VGNode -> VGNode -> Bool
Eq,Eq VGNode
VGNode -> VGNode -> Bool
VGNode -> VGNode -> Ordering
VGNode -> VGNode -> VGNode
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 :: VGNode -> VGNode -> VGNode
$cmin :: VGNode -> VGNode -> VGNode
max :: VGNode -> VGNode -> VGNode
$cmax :: VGNode -> VGNode -> VGNode
>= :: VGNode -> VGNode -> Bool
$c>= :: VGNode -> VGNode -> Bool
> :: VGNode -> VGNode -> Bool
$c> :: VGNode -> VGNode -> Bool
<= :: VGNode -> VGNode -> Bool
$c<= :: VGNode -> VGNode -> Bool
< :: VGNode -> VGNode -> Bool
$c< :: VGNode -> VGNode -> Bool
compare :: VGNode -> VGNode -> Ordering
$ccompare :: VGNode -> VGNode -> Ordering
Ord)
newtype VGEdge = VGEdge Int deriving (Int -> VGEdge -> ShowS
[VGEdge] -> ShowS
VGEdge -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VGEdge] -> ShowS
$cshowList :: [VGEdge] -> ShowS
show :: VGEdge -> [Char]
$cshow :: VGEdge -> [Char]
showsPrec :: Int -> VGEdge -> ShowS
$cshowsPrec :: Int -> VGEdge -> ShowS
Show,VGEdge -> VGEdge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VGEdge -> VGEdge -> Bool
$c/= :: VGEdge -> VGEdge -> Bool
== :: VGEdge -> VGEdge -> Bool
$c== :: VGEdge -> VGEdge -> Bool
Eq,Eq VGEdge
VGEdge -> VGEdge -> Bool
VGEdge -> VGEdge -> Ordering
VGEdge -> VGEdge -> VGEdge
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 :: VGEdge -> VGEdge -> VGEdge
$cmin :: VGEdge -> VGEdge -> VGEdge
max :: VGEdge -> VGEdge -> VGEdge
$cmax :: VGEdge -> VGEdge -> VGEdge
>= :: VGEdge -> VGEdge -> Bool
$c>= :: VGEdge -> VGEdge -> Bool
> :: VGEdge -> VGEdge -> Bool
$c> :: VGEdge -> VGEdge -> Bool
<= :: VGEdge -> VGEdge -> Bool
$c<= :: VGEdge -> VGEdge -> Bool
< :: VGEdge -> VGEdge -> Bool
$c< :: VGEdge -> VGEdge -> Bool
compare :: VGEdge -> VGEdge -> Ordering
$ccompare :: VGEdge -> VGEdge -> Ordering
Ord)
newtype VGProd = VGProd (VGEdge,Int) deriving (Int -> VGProd -> ShowS
[VGProd] -> ShowS
VGProd -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VGProd] -> ShowS
$cshowList :: [VGProd] -> ShowS
show :: VGProd -> [Char]
$cshow :: VGProd -> [Char]
showsPrec :: Int -> VGProd -> ShowS
$cshowsPrec :: Int -> VGProd -> ShowS
Show,VGProd -> VGProd -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VGProd -> VGProd -> Bool
$c/= :: VGProd -> VGProd -> Bool
== :: VGProd -> VGProd -> Bool
$c== :: VGProd -> VGProd -> Bool
Eq,Eq VGProd
VGProd -> VGProd -> Bool
VGProd -> VGProd -> Ordering
VGProd -> VGProd -> VGProd
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 :: VGProd -> VGProd -> VGProd
$cmin :: VGProd -> VGProd -> VGProd
max :: VGProd -> VGProd -> VGProd
$cmax :: VGProd -> VGProd -> VGProd
>= :: VGProd -> VGProd -> Bool
$c>= :: VGProd -> VGProd -> Bool
> :: VGProd -> VGProd -> Bool
$c> :: VGProd -> VGProd -> Bool
<= :: VGProd -> VGProd -> Bool
$c<= :: VGProd -> VGProd -> Bool
< :: VGProd -> VGProd -> Bool
$c< :: VGProd -> VGProd -> Bool
compare :: VGProd -> VGProd -> Ordering
$ccompare :: VGProd -> VGProd -> Ordering
Ord)

data VGState s = VGState { forall s. VGState s -> Int
vgNodeNum       :: Int
                         , forall s. VGState s -> Int
vgEdgeNum       :: Int
                           -- Node maps
                         , forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing      :: IntMap (STRef s (Set VGEdge))
                         , forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming      :: IntMap (Maybe VGEdge)
                         , forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI           :: IntMap (STRef s (NontDependencyInformationM s))
                         , forall s.
VGState s
-> Map (Identifier, Set Identifier, Set Identifier) VGNode
vgInhSynNode    :: Map (Identifier, Set Identifier, Set Identifier) VGNode
                         , forall s. VGState s -> IntMap (Set Identifier, Set Identifier)
vgNodeInhSyn    :: IntMap (Set Identifier, Set Identifier)
                         , forall s. VGState s -> Map Identifier VGNode
vgInitial       :: Map Identifier VGNode
                           -- Edge maps
                         , forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges         :: IntMap (VGNode, VGNode)
                         , forall s. VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR        :: Map (VGNode,VGNode) VGEdge
                         , forall s. VGState s -> IntMap (Set Identifier)
vgInherited     :: IntMap (Set Identifier)
                         , forall s. VGState s -> IntMap (Set Identifier)
vgSynthesized   :: IntMap (Set Identifier)
                         , forall s. VGState s -> IntSet
vgPending       :: IntSet
                         , forall s.
VGState s -> IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits   :: IntMap (STRef s (Map (Identifier,Int) [VGNode]))
                           -- Final vertices in production graphs
                         , forall s. VGState s -> IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int)))
                           -- Construction of execution plan (Nonterminal,Production,Visit)
                         , forall s.
VGState s
-> Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits    :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep])
                         }

type VG s a = ErrorT String (StateT (VGState s) (ST s)) a

------------------------------------------------------------
---              Public functions                        ---
------------------------------------------------------------
-- | Run the VG monad in the ST monad
runVG :: VG s a -> ST s a
runVG :: forall s a. VG s a -> ST s a
runVG VG s a
vg = do (Either [Char] a, VGState s)
result <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT VG s a
vg) forall s. VGState s
vgEmptyState
              let (Right a
a,VGState s
_) = (Either [Char] a, VGState s)
result
              forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Insert an initial node for this nonterminal into the visit graph
insertInitialNode :: NontDependencyInformationM s -> VG s VGNode
insertInitialNode :: forall s. NontDependencyInformationM s -> VG s VGNode
insertInitialNode NontDependencyInformationM s
ndi = do
  STRef s (NontDependencyInformationM s)
rndi          <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef NontDependencyInformationM s
ndi
  (VGNode Int
node) <- forall s.
STRef s (NontDependencyInformationM s)
-> Set Identifier -> Set Identifier -> VG s VGNode
vgCreateNode STRef s (NontDependencyInformationM s)
rndi forall a. Set a
Set.empty forall a. Set a
Set.empty
  Map Identifier VGNode
initial       <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Map Identifier VGNode
vgInitial
  IntMap (Maybe VGEdge)
incoming      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgInitial :: Map Identifier VGNode
vgInitial  = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) (Int -> VGNode
VGNode Int
node) Map Identifier VGNode
initial
                     , vgIncoming :: IntMap (Maybe VGEdge)
vgIncoming = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
node forall a. Maybe a
Nothing IntMap (Maybe VGEdge)
incoming }
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> VGNode
VGNode Int
node)

-- | Create a pending edge from this node with a set of inherited and synthesized attributes
createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
createPending :: forall s. VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
createPending vgn :: VGNode
vgn@(VGNode Int
n) Set Identifier
inh Set Identifier
syn = do
  -- Check if target node already exists
  IntMap (Set Identifier, Set Identifier)
ninhsyn <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier, Set Identifier)
vgNodeInhSyn
  let (Set Identifier
pinh,Set Identifier
psyn) = forall a. Int -> IntMap a -> a
imLookup Int
n IntMap (Set Identifier, Set Identifier)
ninhsyn
  let ninh :: Set Identifier
ninh        = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Identifier
pinh Set Identifier
inh
  let nsyn :: Set Identifier
nsyn        = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Identifier
psyn Set Identifier
syn
  IntMap (STRef s (NontDependencyInformationM s))
mndi    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
n IntMap (STRef s (NontDependencyInformationM s))
mndi
  NontDependencyInformationM s
ndi     <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  Map (Identifier, Set Identifier, Set Identifier) VGNode
inhsynn <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s
-> Map (Identifier, Set Identifier, Set Identifier) VGNode
vgInhSynNode
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi, Set Identifier
ninh, Set Identifier
nsyn) Map (Identifier, Set Identifier, Set Identifier) VGNode
inhsynn of
    Just VGNode
tn -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VGNode
tn forall a. Eq a => a -> a -> Bool
== VGNode
vgn) forall a b. (a -> b) -> a -> b
$ do forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Source and target nodes are the same!"
                            forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Maybe there is a wrapper with no inherited or synthesized attributes."
                            forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Inh: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Set Identifier
inh
                            forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"Syn: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Set Identifier
syn
                            forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"PInh: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Set Identifier
pinh
                            forall s. [Char] -> VG s ()
traceVG forall a b. (a -> b) -> a -> b
$ [Char]
"PSyn: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Set Identifier
psyn
      -- tn is target node, now check if edge exists and create if not
      Map (VGNode, VGNode) VGEdge
edgesr <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (VGNode
vgn,VGNode
tn) Map (VGNode, VGNode) VGEdge
edgesr of
        Just VGEdge
e  -> forall (m :: * -> *) a. Monad m => a -> m a
return VGEdge
e
        Maybe VGEdge
Nothing -> forall s.
VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
vgCreatePendingEdge VGNode
vgn VGNode
tn Set Identifier
inh Set Identifier
syn
    Maybe VGNode
Nothing -> do
      -- target node does not exist, create it and then create the new edge
      VGNode
tn <- forall s.
STRef s (NontDependencyInformationM s)
-> Set Identifier -> Set Identifier -> VG s VGNode
vgCreateNode STRef s (NontDependencyInformationM s)
rndi Set Identifier
ninh Set Identifier
nsyn
      forall s.
VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
vgCreatePendingEdge VGNode
vgn VGNode
tn Set Identifier
inh Set Identifier
syn

-- | Return an arbitrary pending edge of which the from node is ready
selectPending :: VG s VGEdge
selectPending :: forall s. VG s VGEdge
selectPending = do
  IntSet
pending  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntSet
vgPending
  IntMap (Maybe VGEdge)
incoming <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
  IntMap (VGNode, VGNode)
edges    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let readyPend :: [Int]
readyPend = forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
p -> let (VGNode Int
fr,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
p IntMap (VGNode, VGNode)
edges
                                in  forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fr IntMap (Maybe VGEdge)
incoming) forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
pending
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
readyPend
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> VGEdge
VGEdge forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ [Int]
readyPend

-- | Get the inherited attributes of an edge
getInherited :: VGEdge -> VG s (Set Identifier)
getInherited :: forall s. VGEdge -> VG s (Set Identifier)
getInherited (VGEdge Int
edg) = do
  IntMap (Set Identifier)
inhs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier)
vgInherited
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (Set Identifier)
inhs

-- | Get the synthesized attributes of an edge
getSynthesized :: VGEdge -> VG s (Set Identifier)
getSynthesized :: forall s. VGEdge -> VG s (Set Identifier)
getSynthesized (VGEdge Int
edg) = do
  IntMap (Set Identifier)
syns <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier)
vgSynthesized
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (Set Identifier)
syns

-- | Mark an edge as final
markFinal :: VGEdge -> VG s ()
markFinal :: forall s. VGEdge -> VG s ()
markFinal vgedg :: VGEdge
vgedg@(VGEdge Int
edg) = do
  IntMap (Maybe VGEdge)
incoming <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
  IntMap (VGNode, VGNode)
edges    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  IntSet
pending  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntSet
vgPending
  let (VGNode
_,VGNode Int
to) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgIncoming :: IntMap (Maybe VGEdge)
vgIncoming = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
to (forall a. a -> Maybe a
Just VGEdge
vgedg) IntMap (Maybe VGEdge)
incoming
                     , vgPending :: IntSet
vgPending  = Int -> IntSet -> IntSet
IntSet.delete Int
edg IntSet
pending }

-- | Get all productions for an edge
getProductions :: VGEdge -> VG s [VGProd]
getProductions :: forall s. VGEdge -> VG s [VGProd]
getProductions vedg :: VGEdge
vedg@(VGEdge Int
edg) = do
  IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode Int
fr,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
fr IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (VGEdge, Int) -> VGProd
VGProd (VGEdge
vedg,Int
x)) [Int
0..(forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)forall a. Num a => a -> a -> a
-Int
1]

-- | Execute a function on the dependency graph for this production
onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph :: forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph ProdDependencyGraphM s -> ST s a
f (VGProd (VGEdge Int
edg, Int
n)) = do
  IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode Int
fr,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
fr IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ST s a
f forall a b. (a -> b) -> a -> b
$ (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) forall a. [a] -> Int -> a
!! Int
n -- not efficient, but lists are usually short

-- | Check whether this vertex has been marked as final
isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal :: forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal (VGProd (VGEdge Int
edg, Int
p)) Vertex
v = do
  IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode
from,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  forall s. VGNode -> Int -> Vertex -> VG s Bool
vgDepGraphVertexFinal VGNode
from Int
p Vertex
v

-- | Mark these vertices final in this production
setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal :: forall s. VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal (VGProd (VGEdge Int
edg, Int
p)) [Vertex]
vs = do
  IntMap (VGNode, VGNode)
edges   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode
_,VGNode Int
to) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  IntMap (STRef s (Set (Vertex, Int)))
finalv <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices
  let rfinalv :: STRef s (Set (Vertex, Int))
rfinalv       = forall a. Int -> IntMap a -> a
imLookup Int
to IntMap (STRef s (Set (Vertex, Int)))
finalv
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set (Vertex, Int))
rfinalv forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
v -> (Vertex
v,Int
p)) [Vertex]
vs)

-- | Add a child visit to this production and return the step for the execution plan
addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
addChildVisit :: forall s. VGProd -> Identifier -> VGEdge -> VG s VisitStep
addChildVisit (VGProd (VGEdge Int
edg, Int
p)) Identifier
ide (VGEdge Int
vs) = do
  IntMap (VGNode, VGNode)
edges   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode Int
from,VGNode
vgto) = forall a. Int -> IntMap a -> a
imLookup Int
vs IntMap (VGNode, VGNode)
edges -- from must be equal to the current state
  IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childvs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits
  let rchildv :: STRef s (Map (Identifier, Int) [VGNode])
rchildv = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childvs
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Map (Identifier, Int) [VGNode])
rchildv forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapStrict.insertWith forall a. [a] -> [a] -> [a]
(++) (Identifier
ide,Int
p) [VGNode
vgto]
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
from IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  let nt :: Identifier
nt = NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Identifier -> Identifier -> Int -> VisitStep
ChildVisit Identifier
ide Identifier
nt Int
vs

-- | Add a step to the execution plan of this visit
addVisitStep :: VGProd -> VisitStep -> VG s ()
addVisitStep :: forall s. VGProd -> VisitStep -> VG s ()
addVisitStep (VGProd (VGEdge Int
edg, Int
p)) VisitStep
st = do
  IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode Int
fr,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
fr IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodvs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s
-> Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits
  let nont :: Identifier
nont = NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
  let prod :: Identifier
prod = ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi forall a. [a] -> Int -> a
!! Int
p
  let Just STRef s VisitSteps
rprodv = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Identifier
nont, Identifier
prod, Int -> VGEdge
VGEdge Int
edg) Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodvs
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s VisitSteps
rprodv (forall a. [a] -> [a] -> [a]
++ [VisitStep
st])

-- | Get the state of a child in a certain production
getChildState :: VGProd -> Identifier -> VG s VGNode
getChildState :: forall s. VGProd -> Identifier -> VG s VGNode
getChildState (VGProd (VGEdge Int
edg,Int
p)) Identifier
ide = do
  IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childvs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits
  let rchildv :: STRef s (Map (Identifier, Int) [VGNode])
rchildv = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childvs
  Map (Identifier, Int) [VGNode]
childv  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (Map (Identifier, Int) [VGNode])
rchildv
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Identifier
ide,Int
p) Map (Identifier, Int) [VGNode]
childv of
    Just (VGNode
n:[VGNode]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return VGNode
n
    Maybe [VGNode]
_          -> do
      -- Look for previous edge
      IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
      let (VGNode Int
from,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
      IntMap (Maybe VGEdge)
incoming <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
      case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
from IntMap (Maybe VGEdge)
incoming of
        Just (Just VGEdge
iedg) -> forall s. VGProd -> Identifier -> VG s VGNode
getChildState ((VGEdge, Int) -> VGProd
VGProd (VGEdge
iedg,Int
p)) Identifier
ide
        Just Maybe VGEdge
Nothing     -> do
          -- Lookup initial state
          IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
          let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
from IntMap (STRef s (NontDependencyInformationM s))
ndis
          NontDependencyInformationM s
ndi  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
          let Just Identifier
nt = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Identifier
ide forall a b. (a -> b) -> a -> b
$ ProdDependencyGraph -> [(Identifier, Identifier)]
pdgChildMap forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig forall a b. (a -> b) -> a -> b
$ (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) forall a. [a] -> Int -> a
!! Int
p
          forall s. Identifier -> VG s VGNode
vgFindInitial Identifier
nt
        Maybe (Maybe VGEdge)
Nothing          -> forall a. HasCallStack => [Char] -> a
error [Char]
"getChildState"

-- | Repeat action untill mzero is encountered
repeatM :: VG s () -> VG s ()
repeatM :: forall s. VG s () -> VG s ()
repeatM VG s ()
m = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (VG s ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. VG s () -> VG s ()
repeatM VG s ()
m) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())

------------------------------------------------------------
---              Internal functions                      ---
------------------------------------------------------------
-- | Execute a ST action inside the VG monad
vgInST :: ST s a -> VG s a
vgInST :: forall s a. ST s a -> VG s a
vgInST = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

vgEmptyState :: VGState s
vgEmptyState :: forall s. VGState s
vgEmptyState = VGState { vgNodeNum :: Int
vgNodeNum       = Int
0
                       , vgEdgeNum :: Int
vgEdgeNum       = Int
0
                       , vgOutgoing :: IntMap (STRef s (Set VGEdge))
vgOutgoing      = forall a. IntMap a
IntMap.empty
                       , vgIncoming :: IntMap (Maybe VGEdge)
vgIncoming      = forall a. IntMap a
IntMap.empty
                       , vgNDI :: IntMap (STRef s (NontDependencyInformationM s))
vgNDI           = forall a. IntMap a
IntMap.empty
                       , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode
vgInhSynNode    = forall k a. Map k a
Map.empty
                       , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier)
vgNodeInhSyn    = forall a. IntMap a
IntMap.empty
                       , vgInitial :: Map Identifier VGNode
vgInitial       = forall k a. Map k a
Map.empty
                       , vgEdges :: IntMap (VGNode, VGNode)
vgEdges         = forall a. IntMap a
IntMap.empty
                       , vgEdgesR :: Map (VGNode, VGNode) VGEdge
vgEdgesR        = forall k a. Map k a
Map.empty
                       , vgInherited :: IntMap (Set Identifier)
vgInherited     = forall a. IntMap a
IntMap.empty
                       , vgSynthesized :: IntMap (Set Identifier)
vgSynthesized   = forall a. IntMap a
IntMap.empty
                       , vgPending :: IntSet
vgPending       = IntSet
IntSet.empty
                       , vgChildVisits :: IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits   = forall a. IntMap a
IntMap.empty
                       , vgFinalVertices :: IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices = forall a. IntMap a
IntMap.empty
                       , vgProdVisits :: Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits    = forall k a. Map k a
Map.empty
                       }
-- | Create a new node
vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode
vgCreateNode :: forall s.
STRef s (NontDependencyInformationM s)
-> Set Identifier -> Set Identifier -> VG s VGNode
vgCreateNode STRef s (NontDependencyInformationM s)
rndi Set Identifier
inh Set Identifier
syn = do
  Int
num      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Int
vgNodeNum
  IntMap (STRef s (Set VGEdge))
outgoing <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing
  Map (Identifier, Set Identifier, Set Identifier) VGNode
inhsyn   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s
-> Map (Identifier, Set Identifier, Set Identifier) VGNode
vgInhSynNode
  IntMap (Set Identifier, Set Identifier)
ninhsyn  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier, Set Identifier)
vgNodeInhSyn
  IntMap (STRef s (NontDependencyInformationM s))
ndi      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  IntMap (STRef s (Set (Vertex, Int)))
finalv   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices
  STRef s (Set VGEdge)
rout     <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef forall a. Set a
Set.empty
  STRef s (Set (Vertex, Int))
rfinalv  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef forall a. Set a
Set.empty
  NontDependencyInformationM s
nndi     <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgNodeNum :: Int
vgNodeNum       = Int
num forall a. Num a => a -> a -> a
+ Int
1
                     , vgOutgoing :: IntMap (STRef s (Set VGEdge))
vgOutgoing      = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num STRef s (Set VGEdge)
rout IntMap (STRef s (Set VGEdge))
outgoing
                     , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode
vgInhSynNode    = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
nndi,Set Identifier
inh,Set Identifier
syn) (Int -> VGNode
VGNode Int
num) Map (Identifier, Set Identifier, Set Identifier) VGNode
inhsyn
                     , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier)
vgNodeInhSyn    = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num (Set Identifier
inh,Set Identifier
syn) IntMap (Set Identifier, Set Identifier)
ninhsyn
                     , vgNDI :: IntMap (STRef s (NontDependencyInformationM s))
vgNDI           = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num STRef s (NontDependencyInformationM s)
rndi IntMap (STRef s (NontDependencyInformationM s))
ndi
                     , vgFinalVertices :: IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num STRef s (Set (Vertex, Int))
rfinalv IntMap (STRef s (Set (Vertex, Int)))
finalv }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> VGNode
VGNode Int
num

-- | Create a new pending edge
vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
vgCreatePendingEdge :: forall s.
VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
vgCreatePendingEdge vgn1 :: VGNode
vgn1@(VGNode Int
n1) VGNode
vgn2 Set Identifier
inh Set Identifier
syn = do
  Int
num      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Int
vgEdgeNum
  IntMap (VGNode, VGNode)
edges    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  Map (VGNode, VGNode) VGEdge
edgesr   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR
  IntMap (Set Identifier)
inhs     <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier)
vgInherited
  IntMap (Set Identifier)
syns     <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Set Identifier)
vgSynthesized
  IntMap (STRef s (Set VGEdge))
outgoing <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing
  IntSet
pend     <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntSet
vgPending
  IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childv   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits
  STRef s (Map (Identifier, Int) [VGNode])
rchildv  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef forall k a. Map k a
Map.empty
  let outr :: STRef s (Set VGEdge)
outr    = forall a. Int -> IntMap a -> a
imLookup Int
n1 IntMap (STRef s (Set VGEdge))
outgoing
  let ret :: VGEdge
ret     = Int -> VGEdge
VGEdge Int
num
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set VGEdge)
outr (forall a. Ord a => a -> Set a -> Set a
Set.insert VGEdge
ret)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgEdgeNum :: Int
vgEdgeNum     = Int
num forall a. Num a => a -> a -> a
+ Int
1
                     , vgEdges :: IntMap (VGNode, VGNode)
vgEdges       = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num (VGNode
vgn1,VGNode
vgn2) IntMap (VGNode, VGNode)
edges
                     , vgEdgesR :: Map (VGNode, VGNode) VGEdge
vgEdgesR      = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (VGNode
vgn1,VGNode
vgn2) VGEdge
ret Map (VGNode, VGNode) VGEdge
edgesr
                     , vgPending :: IntSet
vgPending     = Int -> IntSet -> IntSet
IntSet.insert Int
num IntSet
pend
                     , vgInherited :: IntMap (Set Identifier)
vgInherited   = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num Set Identifier
inh IntMap (Set Identifier)
inhs
                     , vgSynthesized :: IntMap (Set Identifier)
vgSynthesized = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num Set Identifier
syn IntMap (Set Identifier)
syns
                     , vgChildVisits :: IntMap (STRef s (Map (Identifier, Int) [VGNode]))
vgChildVisits = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
num STRef s (Map (Identifier, Int) [VGNode])
rchildv IntMap (STRef s (Map (Identifier, Int) [VGNode]))
childv }
  -- Add prod visits (for constructing an execution plan)
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = forall a. Int -> IntMap a -> a
imLookup Int
n1 IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodv  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s
-> Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits
  [((Identifier, Identifier, VGEdge), STRef s VisitSteps)]
refs   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) forall a b. (a -> b) -> a -> b
$ \ProdDependencyGraphM s
prod -> do
    STRef s VisitSteps
rprod <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef []
    forall (m :: * -> *) a. Monad m => a -> m a
return ((NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi, ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod, VGEdge
ret),STRef s VisitSteps
rprod)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgProdVisits :: Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((Identifier, Identifier, VGEdge), STRef s VisitSteps)]
refs) Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodv }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ VGEdge
ret

-- | Check whether a vertex is marked final on this node in this production
vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool
vgDepGraphVertexFinal :: forall s. VGNode -> Int -> Vertex -> VG s Bool
vgDepGraphVertexFinal (VGNode Int
n) Int
p Vertex
v = do
  IntMap (STRef s (Set (Vertex, Int)))
finalv <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set (Vertex, Int)))
vgFinalVertices
  let rfinalv :: STRef s (Set (Vertex, Int))
rfinalv = forall a. Int -> IntMap a -> a
imLookup Int
n IntMap (STRef s (Set (Vertex, Int)))
finalv
  Set (Vertex, Int)
curset <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (Set (Vertex, Int))
rfinalv
  if forall a. Ord a => a -> Set a -> Bool
Set.member (Vertex
v,Int
p) Set (Vertex, Int)
curset
    then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      IntMap (Maybe VGEdge)
incoming <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
      case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n IntMap (Maybe VGEdge)
incoming of
        Just (Just (VGEdge Int
edg)) -> do
          IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
          let (VGNode
fr,VGNode
_) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
          forall s. VGNode -> Int -> Vertex -> VG s Bool
vgDepGraphVertexFinal VGNode
fr Int
p Vertex
v
        Just Maybe VGEdge
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe (Maybe VGEdge)
Nothing      -> forall a. HasCallStack => [Char] -> a
error [Char]
"This can never happen"

-- | Find the initial node for a nonterminal
vgFindInitial :: Identifier -> VG s VGNode
vgFindInitial :: forall s. Identifier -> VG s VGNode
vgFindInitial Identifier
nt = do
  Map Identifier VGNode
initial <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> Map Identifier VGNode
vgInitial
  let Just VGNode
r = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
nt Map Identifier VGNode
initial
  forall (m :: * -> *) a. Monad m => a -> m a
return VGNode
r

-- | Always succeeding IntMap lookup
imLookup :: Int -> IntMap a -> a
imLookup :: forall a. Int -> IntMap a -> a
imLookup Int
k IntMap a
m = let Just a
r = forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap a
m in a
r

-- | Trace inside the vg monad
traceVG :: String -> VG s ()
traceVG :: forall s. [Char] -> VG s ()
traceVG [Char]
s = forall a. [Char] -> a -> a
trace [Char]
s (forall (m :: * -> *) a. Monad m => a -> m a
return ())

------------------------------------------------------------
---         The kennedy warren algorithm                 ---
------------------------------------------------------------
{-
runVG                    :: VG s a -> ST s a
insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode
createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
selectPending            :: VG s VGEdge
getInherited             :: VGEdge -> VG s (Set Identifier)
getSynthesized           :: VGEdge -> VG s (Set Identifier)
markFinal                :: VGEdge -> VG s ()
getProductions           :: VGEdge -> VG s [VGProd]
onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool
setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
getChildState            :: VGProd -> Identifier -> VG s VGNode
addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
addVisitStep             :: VGProd -> VisitStep -> VG s ()
repeatM                  :: VG s () -> VG s ()
-}

kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [[VisitIdentifier]]
kennedyWarrenVisitM :: forall s.
Set Identifier -> [NontDependencyInformationM s] -> VG s [[Int]]
kennedyWarrenVisitM Set Identifier
wr [NontDependencyInformationM s]
ndis = do
  -- Create initial nodes and edges (edges only for wrapper nodes)
  [[Int]]
initvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NontDependencyInformationM s]
ndis forall a b. (a -> b) -> a -> b
$ \NontDependencyInformationM s
ndi -> do
    VGNode
nd <- forall s. NontDependencyInformationM s -> VG s VGNode
insertInitialNode NontDependencyInformationM s
ndi
    let inh :: Set Identifier
inh = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [Identifier]
ndiInh forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
    let syn :: Set Identifier
syn = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [Identifier]
ndiSyn forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
    if (forall a. Ord a => a -> Set a -> Bool
Set.member (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi) Set Identifier
wr) Bool -> Bool -> Bool
&& (Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set Identifier
inh) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set Identifier
syn))
      then do
        VGEdge Int
initv <- forall s. VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
createPending VGNode
nd Set Identifier
inh Set Identifier
syn
        forall (m :: * -> *) a. Monad m => a -> m a
return [Int
initv]
      else forall (m :: * -> *) a. Monad m => a -> m a
return []
  -- Handle all pending edges while there are any
  forall s. VG s () -> VG s ()
repeatM forall a b. (a -> b) -> a -> b
$ do
    VGEdge
pend  <- forall s. VG s VGEdge
selectPending
    [VGProd]
prods <- forall s. VGEdge -> VG s [VGProd]
getProductions VGEdge
pend
    Set Identifier
inhs  <- forall s. VGEdge -> VG s (Set Identifier)
getInherited VGEdge
pend
    Set Identifier
syns  <- forall s. VGEdge -> VG s (Set Identifier)
getSynthesized VGEdge
pend
    -- Handle each production for this edge
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VGProd]
prods forall a b. (a -> b) -> a -> b
$ \VGProd
prod -> do
      -- Mark all inherited attributes as final
      forall s. VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal VGProd
prod (forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Vertex
createLhsInh forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set Identifier
inhs)
      -- Find depth of all synthesized child visits
      (ChildVisits
vis,Int
_) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall s.
VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)
foldChildVisits VGProd
prod) ([],Int
0) (forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Vertex
createLhsSyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set Identifier
syns)
      -- Mark them as final
      forall s. VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal VGProd
prod (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst ChildVisits
vis)
      -- Change the inherited child visits
      ChildVisits
vis2 <- forall s. VGProd -> ChildVisits -> VG s ChildVisits
correctInhChilds VGProd
prod ChildVisits
vis
      -- Add all synthesized attributes that are also ready but are not needed
      ChildVisits
extravis <- forall s. VGProd -> ChildVisits -> VG s ChildVisits
extraChildSyn VGProd
prod ChildVisits
vis2
      forall s. VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal VGProd
prod (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst ChildVisits
extravis)
      -- Group by visit number and do visit for every num
      let gvis :: [ChildVisits]
gvis = forall a. (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ ChildVisits
vis2 forall a. [a] -> [a] -> [a]
++ ChildVisits
extravis
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ChildVisits]
gvis forall a b. (a -> b) -> a -> b
$ \ChildVisits
vis3 -> do
        -- Split child visits from rules
        let ([Vertex]
chattrs, [Vertex]
rules) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Vertex -> Bool
isChildAttr forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst ChildVisits
vis3
        -- Evaluate all rules
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Vertex]
rules) forall a b. (a -> b) -> a -> b
$ \Vertex
rule ->
          case Vertex
rule of
            VRule Identifier
r  -> forall s. VGProd -> VisitStep -> VG s ()
addVisitStep VGProd
prod forall a b. (a -> b) -> a -> b
$ Identifier -> VisitStep
Sem Identifier
r
            VChild Identifier
c -> forall s. VGProd -> VisitStep -> VG s ()
addVisitStep VGProd
prod forall a b. (a -> b) -> a -> b
$ Identifier -> VisitStep
ChildIntro Identifier
c
            Vertex
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- Now group by child, and do a visit for each child
        let chs :: [[Vertex]]
chs = forall a. (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Vertex -> Identifier
getAttrChildName) forall a b. (a -> b) -> a -> b
$ [Vertex]
chattrs
        VisitSteps
chvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Vertex]]
chs forall a b. (a -> b) -> a -> b
$ \[Vertex]
childvs -> do -- childs :: [Vertex]
          let cinhs :: [Identifier]
cinhs = forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Identifier
getAttrName forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Vertex -> Bool
isChildInh [Vertex]
childvs
          let csyns :: [Identifier]
csyns = forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Identifier
getAttrName forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Vertex -> Bool
isChildSyn [Vertex]
childvs
          let cname :: Identifier
cname = Vertex -> Identifier
getAttrChildName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Vertex]
childvs
          -- Insert a new pending edge for this visit
          VGNode
curstate <- forall s. VGProd -> Identifier -> VG s VGNode
getChildState VGProd
prod Identifier
cname
          VGEdge
target   <- forall s. VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
createPending VGNode
curstate (forall a. Ord a => [a] -> Set a
Set.fromList [Identifier]
cinhs) (forall a. Ord a => [a] -> Set a
Set.fromList [Identifier]
csyns)
          forall s. VGProd -> Identifier -> VGEdge -> VG s VisitStep
addChildVisit VGProd
prod Identifier
cname VGEdge
target
        -- Add child visits as simultanuous step
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null VisitSteps
chvs) forall a b. (a -> b) -> a -> b
$
          if (forall (t :: * -> *) a. Foldable t => t a -> Int
length VisitSteps
chvs forall a. Eq a => a -> a -> Bool
== Int
1)
          then forall s. VGProd -> VisitStep -> VG s ()
addVisitStep VGProd
prod forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head VisitSteps
chvs
          else forall s. VGProd -> VisitStep -> VG s ()
addVisitStep VGProd
prod forall a b. (a -> b) -> a -> b
$ VisitSteps -> VisitStep
Sim VisitSteps
chvs

    -- Mark this edge as final
    forall s. VGEdge -> VG s ()
markFinal VGEdge
pend
  -- We are done
  -- traceVG "Done."
  forall (m :: * -> *) a. Monad m => a -> m a
return [[Int]]
initvs

-- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements
groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy a -> a -> Ordering
f = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\a
x a
y -> a -> a -> Ordering
f a
x a
y forall a. Eq a => a -> a -> Bool
== Ordering
EQ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
f

type ChildVisits = [(Vertex,Int)]

-- | Helper function for folding over child visits
foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)
foldChildVisits :: forall s.
VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)
foldChildVisits VGProd
prod (ChildVisits
vis,Int
i) Vertex
v = do
  (ChildVisits
nvis,Int
ni) <- forall s.
VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int)
findChildVisits VGProd
prod Vertex
v ChildVisits
vis
  forall (m :: * -> *) a. Monad m => a -> m a
return (ChildVisits
nvis, Int
ni forall a. Ord a => a -> a -> a
`max` Int
i)

-- | Recursively find all visits to childs
findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int)
findChildVisits :: forall s.
VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int)
findChildVisits VGProd
prod Vertex
v ChildVisits
vis = do
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Vertex
v ChildVisits
vis of
    Just Int
i  -> forall (m :: * -> *) a. Monad m => a -> m a
return (ChildVisits
vis,Int
i)
    Maybe Int
Nothing -> do
      Bool
final <- forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal VGProd
prod Vertex
v
      if Bool
final
        then forall (m :: * -> *) a. Monad m => a -> m a
return (ChildVisits
vis,Int
0)
        else do
          [Vertex]
succs <- forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors Vertex
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
          (ChildVisits
nvis,Int
ni)  <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall s.
VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)
foldChildVisits VGProd
prod) (ChildVisits
vis,Int
0) [Vertex]
succs
          if Vertex -> Bool
isChildSyn Vertex
v
            then forall (m :: * -> *) a. Monad m => a -> m a
return ((Vertex
v,Int
ni forall a. Num a => a -> a -> a
+ Int
1) forall a. a -> [a] -> [a]
: ChildVisits
nvis, Int
ni forall a. Num a => a -> a -> a
+ Int
1)
            else forall (m :: * -> *) a. Monad m => a -> m a
return ((Vertex
v,Int
ni) forall a. a -> [a] -> [a]
: ChildVisits
nvis, Int
ni)

-- | Correct inherited child visits after foldChildVisits
correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits
correctInhChilds :: forall s. VGProd -> ChildVisits -> VG s ChildVisits
correctInhChilds VGProd
prod ChildVisits
vis =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ChildVisits
vis forall a b. (a -> b) -> a -> b
$ \(Vertex
v,Int
i) -> do
    if Vertex -> Bool
isChildInh Vertex
v
     then do
      [Vertex]
preds <- forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphPredecessors Vertex
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
      let ni :: Int
ni = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Ord a => a -> a -> a
min Int
99999999 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ChildVisits
vis) [Vertex]
preds
      forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
v,Int
ni)
     else if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Vertex -> Bool
isChildSyn Vertex
v
           then do
            [Vertex]
succs <- forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors Vertex
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
            let ni :: Int
ni = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Ord a => a -> a -> a
max (-Int
1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ChildVisits
vis) [Vertex]
succs
            forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
v,Int
niforall a. Num a => a -> a -> a
+Int
1)
           else forall (m :: * -> *) a. Monad m => a -> m a
return (Vertex
v,Int
i)

-- | Synthesized attributes that can also be evaluated
extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits
extraChildSyn :: forall s. VGProd -> ChildVisits -> VG s ChildVisits
extraChildSyn VGProd
prod ChildVisits
vis = do
  [Set Vertex]
allpreds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ChildVisits
vis forall a b. (a -> b) -> a -> b
$ \(Vertex
v,Int
_) -> do
    if Vertex -> Bool
isChildInh Vertex
v
     then do
      [Vertex]
preds <- forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphPredecessors Vertex
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Vertex -> Bool
isChildSyn [Vertex]
preds
     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
  [Maybe (Vertex, Int)]
lextravis <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Vertex]
allpreds) forall a b. (a -> b) -> a -> b
$ \Vertex
v -> do
    Maybe Int
ready <- forall s. VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)
isReadyVertex VGProd
prod ChildVisits
vis Vertex
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (\Int
i -> forall a. a -> Maybe a
Just (Vertex
v,Int
i)) Maybe Int
ready
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Vertex, Int)]
lextravis

-- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num
isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)
isReadyVertex :: forall s. VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)
isReadyVertex VGProd
prod ChildVisits
vis Vertex
v = do
  Bool
final <- forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal VGProd
prod Vertex
v
  if Vertex
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst ChildVisits
vis) Bool -> Bool -> Bool
|| Bool
final
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    else do
      Set Vertex
succ <- forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors Vertex
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
      [Maybe Int]
rd <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Vertex
x -> do case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Vertex
x ChildVisits
vis of
                             Just Int
i  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
i
                             Maybe Int
Nothing -> do Bool
fin <- forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal VGProd
prod Vertex
x
                                           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
fin then forall a. a -> Maybe a
Just Int
1 else forall a. Maybe a
Nothing) (forall a. Set a -> [a]
Set.toList Set Vertex
succ)
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe Int]
rd
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Ord a => a -> a -> a
max forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
rd
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing

-- | Check if this vertex is a synthesized attribute of a child
isChildSyn :: Vertex -> Bool
isChildSyn :: Vertex -> Bool
isChildSyn Vertex
v = Vertex -> Bool
isChildAttr Vertex
v Bool -> Bool -> Bool
&& Vertex -> AttrType
getAttrType Vertex
v forall a. Eq a => a -> a -> Bool
== AttrType
Syn

-- | Check if this vertex is an inherited attribute of a child
isChildInh :: Vertex -> Bool
isChildInh :: Vertex -> Bool
isChildInh Vertex
v = Vertex -> Bool
isChildAttr Vertex
v Bool -> Bool -> Bool
&& Vertex -> AttrType
getAttrType Vertex
v forall a. Eq a => a -> a -> Bool
== AttrType
Inh

-- | Check if this vertex is an attribute of a child
isChildAttr :: Vertex -> Bool
isChildAttr :: Vertex -> Bool
isChildAttr Vertex
v = Vertex -> Bool
isVertexAttr Vertex
v Bool -> Bool -> Bool
&& Vertex -> Identifier
getAttrChildName Vertex
v forall a. Eq a => a -> a -> Bool
/= Identifier
_LHS Bool -> Bool -> Bool
&& Vertex -> AttrType
getAttrType Vertex
v forall a. Eq a => a -> a -> Bool
/= AttrType
Loc

-- | Create lhs.inh vertex
createLhsInh :: Identifier -> Vertex
createLhsInh :: Identifier -> Vertex
createLhsInh = AttrType -> Identifier -> Identifier -> Vertex
VAttr AttrType
Inh Identifier
_LHS

-- | Create lhs.inh vertex
createLhsSyn :: Identifier -> Vertex
createLhsSyn :: Identifier -> Vertex
createLhsSyn = AttrType -> Identifier -> Identifier -> Vertex
VAttr AttrType
Syn Identifier
_LHS

------------------------------------------------------------
---         Construction of the execution plan           ---
------------------------------------------------------------
kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [[VisitIdentifier]] ->
                              Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan
kennedyWarrenExecutionPlan :: forall s.
Options
-> [NontDependencyInformationM s]
-> [[Int]]
-> Set Identifier
-> TypeSyns
-> Derivings
-> VG s ExecutionPlan
kennedyWarrenExecutionPlan Options
opts [NontDependencyInformationM s]
ndis [[Int]]
initvs Set Identifier
wr TypeSyns
typesyns Derivings
derivings = do
  -- Loop over all nonterminals
  ENonterminals
nonts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [NontDependencyInformationM s]
ndis [[Int]]
initvs) forall a b. (a -> b) -> a -> b
$ \(NontDependencyInformationM s
ndi, [Int]
initv) -> do
    -- Loop over all productions of this nonterminal
    EProductions
prods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) forall a b. (a -> b) -> a -> b
$ \ProdDependencyGraphM s
prod -> do
      -- Construct the visits for this production
      let inont :: Identifier
inont = NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
      let iprod :: Identifier
iprod = ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod
      Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodvs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
VGState s
-> Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
vgProdVisits
      let thisvisits :: [((Identifier, Identifier, VGEdge), STRef s VisitSteps)]
thisvisits = forall a. (a -> Bool) -> [a] -> [a]
filter (\((Identifier
int,Identifier
ipr,VGEdge
_),STRef s VisitSteps
_) -> Identifier
int forall a. Eq a => a -> a -> Bool
== Identifier
inont Bool -> Bool -> Bool
&& Identifier
ipr forall a. Eq a => a -> a -> Bool
== Identifier
iprod) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map (Identifier, Identifier, VGEdge) (STRef s VisitSteps)
prodvs
      Visits
visits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((Identifier, Identifier, VGEdge), STRef s VisitSteps)]
thisvisits forall a b. (a -> b) -> a -> b
$ \((Identifier
_,Identifier
_,vgedg :: VGEdge
vgedg@(VGEdge Int
edg)),STRef s VisitSteps
rprodvs) -> do
        IntMap (VGNode, VGNode)
edges <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
        let (VGNode Int
fr, VGNode Int
to) = forall a. Int -> IntMap a -> a
imLookup Int
edg IntMap (VGNode, VGNode)
edges
        VisitSteps
steps <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s VisitSteps
rprodvs
        Set Identifier
inh   <- forall s. VGEdge -> VG s (Set Identifier)
getInherited VGEdge
vgedg
        Set Identifier
syn   <- forall s. VGEdge -> VG s (Set Identifier)
getSynthesized VGEdge
vgedg
        let kind :: VisitKind
kind | Options -> Bool
monadic Options
opts = VisitKind
VisitMonadic
                 | Bool
otherwise    = Bool -> VisitKind
VisitPure Bool
True
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Int
-> Set Identifier
-> Set Identifier
-> VisitSteps
-> VisitKind
-> Visit
Visit Int
edg Int
fr Int
to Set Identifier
inh Set Identifier
syn VisitSteps
steps VisitKind
kind
      -- Return execution plan for this production
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Identifier
-> [Identifier]
-> [Type]
-> ERules
-> EChildren
-> Visits
-> EProduction
EProduction (ProdDependencyGraph -> Identifier
pdgProduction forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod)
                           (ProdDependencyGraph -> [Identifier]
pdgParams     forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod)
               (ProdDependencyGraph -> [Type]
pdgConstraints forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod)
                           (ProdDependencyGraph -> ERules
pdgRules      forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod)
                           (ProdDependencyGraph -> EChildren
pdgChilds     forall a b. (a -> b) -> a -> b
$ forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod)
               Visits
visits
    -- Find initial state for this nonterminal
    VGNode Int
init <- forall s. Identifier -> VG s VGNode
vgFindInitial forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
    -- Construct an environment that specifies the next visit of the states that have exactly one
    Map Int StateCtx
nextMap <- forall s. Int -> VG s (Map Int StateCtx)
mkNextMap Int
init
    Map Int StateCtx
prevMap <- forall s. Int -> VG s (Map Int StateCtx)
mkPrevMap Int
init
    -- Return execution plan for this nonterminal
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$  Identifier
-> [Identifier]
-> ClassContext
-> Int
-> [Int]
-> Map Int StateCtx
-> Map Int StateCtx
-> EProductions
-> Bool
-> HigherOrderInfo
-> ENonterminal
ENonterminal (NontDependencyInformation -> Identifier
ndiNonterminal forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                           (NontDependencyInformation -> [Identifier]
ndiParams      forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                           (NontDependencyInformation -> ClassContext
ndiClassCtxs forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                           Int
init
                           [Int]
initv
                           Map Int StateCtx
nextMap
                           Map Int StateCtx
prevMap
                           EProductions
prods
                           (NontDependencyInformation -> Bool
ndiRecursive forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)
                           (NontDependencyInformation -> HigherOrderInfo
ndiHoInfo    forall a b. (a -> b) -> a -> b
$ forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi)

  -- Return complete execution plan
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ENonterminals
-> TypeSyns -> Set Identifier -> Derivings -> ExecutionPlan
ExecutionPlan ENonterminals
nonts TypeSyns
typesyns Set Identifier
wr Derivings
derivings

------------------------------------------------------------
---         Construction of the single-exit states map   ---
------------------------------------------------------------

-- depth-first traversal over the graph that starts at 'init' and maintains a state 'a'
-- the function 'f' can inspect the prev/next edges per state
exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a
exploreGraph :: forall a s.
(VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a)
-> VGNode -> a -> VG s a
exploreGraph VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a
f (VGNode Int
init) a
a0 = do
  STRef s IntSet
exploredRef <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef IntSet
IntSet.empty
  STRef s [Int]
pendingRef  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef [Int
init]
  STRef s a
resRef      <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall a s. a -> ST s (STRef s a)
newSTRef a
a0
  IntMap (STRef s (Set VGEdge))
outgoingMap <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing
  IntMap (VGNode, VGNode)
edgesInfo   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let explore :: ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore = do
        [Int]
pending <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s [Int]
pendingRef
        case [Int]
pending of
          []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Int
p:[Int]
ps) -> do
            forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [Int]
pendingRef [Int]
ps
            IntSet
explored <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s IntSet
exploredRef
            if Int -> IntSet -> Bool
IntSet.member Int
p IntSet
explored
              then forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else do
                forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s IntSet
exploredRef (Int -> IntSet -> IntSet
IntSet.insert Int
p IntSet
explored)
                case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
p IntMap (STRef s (Set VGEdge))
outgoingMap of
                  Maybe (STRef s (Set VGEdge))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just STRef s (Set VGEdge)
outRef -> case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
p IntMap (STRef s (Set VGEdge))
outgoingMap of
                    Maybe (STRef s (Set VGEdge))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just STRef s (Set VGEdge)
inRef -> do
                            Set VGEdge
outSet  <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (Set VGEdge)
outRef
                            Set VGEdge
inSet   <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s (Set VGEdge)
inRef
                            a
sol0    <- forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s a
resRef
                            a
sol1    <- VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a
f (Int -> VGNode
VGNode Int
p) Set VGEdge
inSet Set VGEdge
outSet a
sol0
                            forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
resRef a
sol1
                            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
Set.elems Set VGEdge
outSet) forall a b. (a -> b) -> a -> b
$ \(VGEdge Int
edge) ->
                              case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
edge IntMap (VGNode, VGNode)
edgesInfo of
                                Maybe (VGNode, VGNode)
Nothing            -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just (VGNode
_,VGNode Int
to) -> forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s [Int]
pendingRef (Int
to forall a. a -> [a] -> [a]
:)
            ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore
  ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore
  forall s a. ST s a -> VG s a
vgInST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s a
resRef

mkNextMap :: Int -> VG s (Map Int StateCtx)
mkNextMap :: forall s. Int -> VG s (Map Int StateCtx)
mkNextMap Int
start = forall a s.
(VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a)
-> VGNode -> a -> VG s a
exploreGraph forall {p} {s}.
VGNode
-> p -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
f (Int -> VGNode
VGNode Int
start) forall k a. Map k a
Map.empty where
  f :: VGNode
-> p -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
f (VGNode Int
nd) p
_ Set VGEdge
edges = forall s.
Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
updateCountMap Int
nd Set VGEdge
edges

mkPrevMap :: Int -> VG s (Map Int StateCtx)
mkPrevMap :: forall s. Int -> VG s (Map Int StateCtx)
mkPrevMap Int
start = forall a s.
(VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a)
-> VGNode -> a -> VG s a
exploreGraph forall {p} {s}.
VGNode
-> Set VGEdge -> p -> Map Int StateCtx -> VG s (Map Int StateCtx)
f (Int -> VGNode
VGNode Int
start) forall k a. Map k a
Map.empty where
  f :: VGNode
-> Set VGEdge -> p -> Map Int StateCtx -> VG s (Map Int StateCtx)
f (VGNode Int
nd) Set VGEdge
edges p
_ = forall s.
Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
updateCountMap Int
nd Set VGEdge
edges

updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
updateCountMap :: forall s.
Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
updateCountMap Int
nd Set VGEdge
edges Map Int StateCtx
mp = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
nd StateCtx
v Map Int StateCtx
mp where
    s :: Int
s = forall a. Set a -> Int
Set.size Set VGEdge
edges
    v :: StateCtx
v | Int
s forall a. Eq a => a -> a -> Bool
== Int
0    = StateCtx
NoneVis
      | Int
s forall a. Eq a => a -> a -> Bool
== Int
1    = let [VGEdge Int
v'] = forall a. Set a -> [a]
Set.elems Set VGEdge
edges
                    in Int -> StateCtx
OneVis Int
v'
      | Bool
otherwise = StateCtx
ManyVis