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 NontermIdent
-> [NontDependencyInformation]
-> TypeSyns
-> Derivings
-> ExecutionPlan
kennedyWarrenLazy Options
_ Set NontermIdent
wr [NontDependencyInformation]
ndis TypeSyns
typesyns Derivings
derivings = ExecutionPlan
plan where
  plan :: ExecutionPlan
plan  = ENonterminals
-> TypeSyns -> Set NontermIdent -> Derivings -> ExecutionPlan
ExecutionPlan ENonterminals
nonts TypeSyns
typesyns Set NontermIdent
wr Derivings
derivings
  nonts :: ENonterminals
nonts = (NontDependencyInformation -> StateIdentifier -> ENonterminal)
-> [NontDependencyInformation]
-> [StateIdentifier]
-> ENonterminals
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith NontDependencyInformation -> StateIdentifier -> ENonterminal
mkNont [NontDependencyInformation]
ndis [StateIdentifier]
nontIds
  nontIds :: [StateIdentifier]
nontIds = StateIdentifier -> StateIdentifier -> [StateIdentifier]
forall a. Enum a => a -> a -> [a]
enumFromThen StateIdentifier
1 StateIdentifier
4
  initvMap :: Map NontermIdent StateIdentifier
initvMap = [(NontermIdent, StateIdentifier)]
-> Map NontermIdent StateIdentifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NontermIdent, StateIdentifier)]
 -> Map NontermIdent StateIdentifier)
-> [(NontermIdent, StateIdentifier)]
-> Map NontermIdent StateIdentifier
forall a b. (a -> b) -> a -> b
$ (NontDependencyInformation
 -> StateIdentifier -> (NontermIdent, StateIdentifier))
-> [NontDependencyInformation]
-> [StateIdentifier]
-> [(NontermIdent, StateIdentifier)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\NontDependencyInformation
ndi StateIdentifier
initv -> (NontDependencyInformation -> NontermIdent
ndiNonterminal NontDependencyInformation
ndi, StateIdentifier
initv)) [NontDependencyInformation]
ndis [StateIdentifier]
nontIds

  mkNont :: NontDependencyInformation -> StateIdentifier -> ENonterminal
mkNont NontDependencyInformation
ndi StateIdentifier
initv = ENonterminal
nont where
    nont :: ENonterminal
nont = NontermIdent
-> [NontermIdent]
-> ClassContext
-> StateIdentifier
-> [StateIdentifier]
-> Map StateIdentifier StateCtx
-> Map StateIdentifier StateCtx
-> EProductions
-> Bool
-> HigherOrderInfo
-> ENonterminal
ENonterminal
                 (NontDependencyInformation -> NontermIdent
ndiNonterminal NontDependencyInformation
ndi)
                 (NontDependencyInformation -> [NontermIdent]
ndiParams NontDependencyInformation
ndi)
                 (NontDependencyInformation -> ClassContext
ndiClassCtxs NontDependencyInformation
ndi)
                 StateIdentifier
initst
                 [StateIdentifier
initv]
                 Map StateIdentifier StateCtx
nextMap
                 Map StateIdentifier StateCtx
prevMap
                 EProductions
prods
                 (NontDependencyInformation -> Bool
ndiRecursive NontDependencyInformation
ndi)
                 (NontDependencyInformation -> HigherOrderInfo
ndiHoInfo NontDependencyInformation
ndi)
    initst :: StateIdentifier
initst  = StateIdentifier
initv StateIdentifier -> StateIdentifier -> StateIdentifier
forall a. Num a => a -> a -> a
+ StateIdentifier
1
    finals :: StateIdentifier
finals  = StateIdentifier
initv StateIdentifier -> StateIdentifier -> StateIdentifier
forall a. Num a => a -> a -> a
+ StateIdentifier
2
    nextMap :: Map StateIdentifier StateCtx
nextMap = [(StateIdentifier, StateCtx)] -> Map StateIdentifier StateCtx
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(StateIdentifier
initst, StateIdentifier -> StateCtx
OneVis StateIdentifier
initv), (StateIdentifier
finals, StateCtx
NoneVis)]
    prevMap :: Map StateIdentifier StateCtx
prevMap = [(StateIdentifier, StateCtx)] -> Map StateIdentifier StateCtx
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(StateIdentifier
initst, StateCtx
NoneVis), (StateIdentifier
finals, StateIdentifier -> StateCtx
OneVis StateIdentifier
initv)]
    prods :: EProductions
prods   = (ProdDependencyGraph -> EProduction)
-> [ProdDependencyGraph] -> EProductions
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 = NontermIdent
-> [NontermIdent]
-> [Type]
-> ERules
-> EChildren
-> Visits
-> EProduction
EProduction
               (ProdDependencyGraph -> NontermIdent
pdgProduction ProdDependencyGraph
pdi)
               (ProdDependencyGraph -> [NontermIdent]
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    = StateIdentifier
-> StateIdentifier
-> StateIdentifier
-> Set NontermIdent
-> Set NontermIdent
-> VisitSteps
-> VisitKind
-> Visit
Visit StateIdentifier
initv StateIdentifier
initst StateIdentifier
finals Set NontermIdent
inh Set NontermIdent
syn VisitSteps
steps VisitKind
kind
      inh :: Set NontermIdent
inh    = [NontermIdent] -> Set NontermIdent
forall a. Ord a => [a] -> Set a
Set.fromList ([NontermIdent] -> Set NontermIdent)
-> [NontermIdent] -> Set NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [NontermIdent]
ndiInh NontDependencyInformation
ndi
      syn :: Set NontermIdent
syn    = [NontermIdent] -> Set NontermIdent
forall a. Ord a => [a] -> Set a
Set.fromList ([NontermIdent] -> Set NontermIdent)
-> [NontermIdent] -> Set NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformation -> [NontermIdent]
ndiSyn NontDependencyInformation
ndi
      kind :: VisitKind
kind   = Bool -> VisitKind
VisitPure Bool
False
      steps :: VisitSteps
steps  = VisitSteps
childSteps VisitSteps -> VisitSteps -> VisitSteps
forall a. [a] -> [a] -> [a]
++ VisitSteps
invokeSteps VisitSteps -> VisitSteps -> VisitSteps
forall a. [a] -> [a] -> [a]
++ VisitSteps
ruleSteps

      childSteps :: VisitSteps
childSteps  = [ NontermIdent -> VisitStep
ChildIntro NontermIdent
nm | EChild NontermIdent
nm Type
_ ChildKind
_ Bool
_ Maybe [NontermIdent]
_ Bool
_ <- ProdDependencyGraph -> EChildren
pdgChilds ProdDependencyGraph
pdi ]
      invokeSteps :: VisitSteps
invokeSteps = [ NontermIdent -> NontermIdent -> StateIdentifier -> VisitStep
ChildVisit NontermIdent
nm NontermIdent
nt StateIdentifier
v
                    | EChild NontermIdent
nm Type
tp ChildKind
_ Bool
_ Maybe [NontermIdent]
_ Bool
_ <- ProdDependencyGraph -> EChildren
pdgChilds ProdDependencyGraph
pdi
                    , let nt :: NontermIdent
nt = Type -> NontermIdent
extractNonterminal Type
tp
                          v :: StateIdentifier
v  = StateIdentifier
-> NontermIdent
-> Map NontermIdent StateIdentifier
-> StateIdentifier
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Char] -> StateIdentifier
forall a. HasCallStack => [Char] -> a
error [Char]
"child not in initv-map") NontermIdent
nt Map NontermIdent StateIdentifier
initvMap
                    ]
      ruleSteps :: VisitSteps
ruleSteps   = [ NontermIdent -> VisitStep
Sem NontermIdent
nm | (ERule NontermIdent
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 NontermIdent
-> [NontDependencyInformation]
-> TypeSyns
-> Derivings
-> Either Error (ExecutionPlan, PP_Doc, PP_Doc)
kennedyWarrenOrder Options
opts Set NontermIdent
wr [NontDependencyInformation]
ndis TypeSyns
typesyns Derivings
derivings = (forall s. ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc)))
-> Either Error (ExecutionPlan, PP_Doc, PP_Doc)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc)))
 -> Either Error (ExecutionPlan, PP_Doc, PP_Doc))
-> (forall s. ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc)))
-> Either Error (ExecutionPlan, PP_Doc, PP_Doc)
forall a b. (a -> b) -> a -> b
$ ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc)
-> ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc))
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc)
 -> ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc)))
-> ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc)
-> ST s (Either Error (ExecutionPlan, PP_Doc, PP_Doc))
forall a b. (a -> b) -> a -> b
$ do
  [NontDependencyInformationM s]
indi <- ST s [NontDependencyInformationM s]
-> ErrorT Error (ST s) [NontDependencyInformationM s]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s [NontDependencyInformationM s]
 -> ErrorT Error (ST s) [NontDependencyInformationM s])
-> ST s [NontDependencyInformationM s]
-> ErrorT Error (ST s) [NontDependencyInformationM s]
forall a b. (a -> b) -> a -> b
$ (NontDependencyInformation -> ST s (NontDependencyInformationM s))
-> [NontDependencyInformation]
-> ST s [NontDependencyInformationM s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NontDependencyInformation -> ST s (NontDependencyInformationM s)
forall s.
NontDependencyInformation -> ST s (NontDependencyInformationM s)
mkNontDependencyInformationM [NontDependencyInformation]
ndis
  ST s () -> ErrorT Error (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ErrorT Error (ST s) ())
-> ST s () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ [NontDependencyInformationM s] -> ST s ()
forall s. [NontDependencyInformationM s] -> ST s ()
knuth1 [NontDependencyInformationM s]
indi
  -- Check all graphs for cyclicity, transitive closure and consistency
  -- traceST $ "Checking graphs..."
  [NontDependencyInformationM s]
-> (NontDependencyInformationM s -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NontDependencyInformationM s]
indi ((NontDependencyInformationM s -> ErrorT Error (ST s) ())
 -> ErrorT Error (ST s) ())
-> (NontDependencyInformationM s -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ \NontDependencyInformationM s
ndi -> do
    let nont :: NontermIdent
nont = NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> (NontDependencyInformationM s -> NontDependencyInformation)
-> NontDependencyInformationM s
-> NontermIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig (NontDependencyInformationM s -> NontermIdent)
-> NontDependencyInformationM s -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
    let g :: DependencyGraph s
g = NontDependencyGraphM s -> DependencyGraph s
forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph (NontDependencyGraphM s -> DependencyGraph s)
-> (NontDependencyInformationM s -> NontDependencyGraphM s)
-> NontDependencyInformationM s
-> DependencyGraph s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph (NontDependencyInformationM s -> DependencyGraph s)
-> NontDependencyInformationM s -> DependencyGraph s
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
    -- Topological sort
    --tsedg <- graphTopSort g
    -- Cyclicity check
    [Vertex]
ntCycVerts <- ST s [Vertex] -> ErrorT Error (ST s) [Vertex]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s [Vertex] -> ErrorT Error (ST s) [Vertex])
-> ST s [Vertex] -> ErrorT Error (ST s) [Vertex]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s [Vertex]
forall s. DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt DependencyGraph s
g
    Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
ntCycVerts) (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
      Error -> ErrorT Error (ST s) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ErrorT Error (ST s) ())
-> Error -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ NontermIdent -> Maybe NontermIdent -> [[Char]] -> Error
Err.Cyclic NontermIdent
nont Maybe NontermIdent
forall a. Maybe a
Nothing ((Vertex -> [Char]) -> [Vertex] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> [Char]
forall a. Show a => a -> [Char]
show [Vertex]
ntCycVerts)
--      let msg = "Nonterminal graph " ++ show nont ++ " is cylic!"
--      fail msg
    -- Transtive closure check
    Bool
trc <- ST s Bool -> ErrorT Error (ST s) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Bool -> ErrorT Error (ST s) Bool)
-> ST s Bool -> ErrorT Error (ST s) Bool
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s Bool
forall s. DependencyGraph s -> ST s Bool
graphIsTRC DependencyGraph s
g
    Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
trc) (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
      let msg :: [Char]
msg = [Char]
"Nonterminal graph " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
nont [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not transitively closed!"
      [Char] -> ErrorT Error (ST s) ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg
    -- Consistency check
    Bool
cons <- ST s Bool -> ErrorT Error (ST s) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Bool -> ErrorT Error (ST s) Bool)
-> ST s Bool -> ErrorT Error (ST s) Bool
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s Bool
forall s. DependencyGraph s -> ST s Bool
graphCheckConsistency DependencyGraph s
g
    Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
cons) (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
      let msg :: [Char]
msg = [Char]
"Nonterminal graph " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
nont [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not consistent!"
      [Char] -> ErrorT Error (ST s) ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg

    -- Loop trough all productions
    [ProdDependencyGraphM s]
-> (ProdDependencyGraphM s -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) ((ProdDependencyGraphM s -> ErrorT Error (ST s) ())
 -> ErrorT Error (ST s) ())
-> (ProdDependencyGraphM s -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ \ProdDependencyGraphM s
prod -> do
      let pr :: NontermIdent
pr = ProdDependencyGraph -> NontermIdent
pdgProduction (ProdDependencyGraph -> NontermIdent)
-> ProdDependencyGraph -> NontermIdent
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod
      let g' :: DependencyGraph s
g' = ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph (ProdDependencyGraphM s -> DependencyGraph s)
-> ProdDependencyGraphM s -> DependencyGraph s
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s
prod
      -- Topsort
      --addTopSortEdges tsedg prod
      -- Check for cyclicity
      [Vertex]
pdCycVerts <- ST s [Vertex] -> ErrorT Error (ST s) [Vertex]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s [Vertex] -> ErrorT Error (ST s) [Vertex])
-> ST s [Vertex] -> ErrorT Error (ST s) [Vertex]
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s [Vertex]
forall s. DependencyGraph s -> ST s [Vertex]
graphCyclicVerticesExt DependencyGraph s
g'
      Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
pdCycVerts) (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
        Error -> ErrorT Error (ST s) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> ErrorT Error (ST s) ())
-> Error -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ NontermIdent -> Maybe NontermIdent -> [[Char]] -> Error
Err.Cyclic NontermIdent
nont (NontermIdent -> Maybe NontermIdent
forall a. a -> Maybe a
Just NontermIdent
pr) ((Vertex -> [Char]) -> [Vertex] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> [Char]
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' <- ST s Bool -> ErrorT Error (ST s) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Bool -> ErrorT Error (ST s) Bool)
-> ST s Bool -> ErrorT Error (ST s) Bool
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s Bool
forall s. DependencyGraph s -> ST s Bool
graphIsTRC DependencyGraph s
g'
      Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
trc') (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
        ST s () -> ErrorT Error (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> ErrorT Error (ST s) ())
-> ST s () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ST s ()
forall s. [Char] -> ST s ()
traceST ([Char] -> ST s ()) -> [Char] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Production graph " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
pr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of nonterminal "
                                             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
nont [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not transitively closed!"
        [Char] -> ErrorT Error (ST s) ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Production graph is not transitively closed."
      -- Check consistency
      Bool
consistent <- ST s Bool -> ErrorT Error (ST s) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Bool -> ErrorT Error (ST s) Bool)
-> ST s Bool -> ErrorT Error (ST s) Bool
forall a b. (a -> b) -> a -> b
$ DependencyGraph s -> ST s Bool
forall s. DependencyGraph s -> ST s Bool
graphCheckConsistency DependencyGraph s
g'
      Bool -> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
consistent) (ErrorT Error (ST s) () -> ErrorT Error (ST s) ())
-> ErrorT Error (ST s) () -> ErrorT Error (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
        let msg :: [Char]
msg =  [Char]
"Production graph " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
pr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of nonterminal "
                                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
nont [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not consistent!"
        [Char] -> ErrorT Error (ST s) ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
msg
  -- reachable when everything is ok
  ST s (ExecutionPlan, PP_Doc, PP_Doc)
-> ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (ExecutionPlan, PP_Doc, PP_Doc)
 -> ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc))
-> ST s (ExecutionPlan, PP_Doc, PP_Doc)
-> ErrorT Error (ST s) (ExecutionPlan, PP_Doc, PP_Doc)
forall a b. (a -> b) -> a -> b
$ do
        -- Create non-transitive closed graph for efficiency
        [NontDependencyInformationM s]
indi' <- [NontDependencyInformationM s]
-> ST s [NontDependencyInformationM s]
forall s.
[NontDependencyInformationM s]
-> ST s [NontDependencyInformationM s]
undoTransitiveClosure [NontDependencyInformationM s]
indi
        -- Graphviz output of dependency graphs
        [PP_Doc]
gvs <- (NontDependencyInformationM s -> ST s PP_Doc)
-> [NontDependencyInformationM s] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NontDependencyInformationM s -> ST s PP_Doc
forall s. NontDependencyInformationM s -> ST s PP_Doc
toGVNontDependencyInfo [NontDependencyInformationM s]
indi'
        -- Doing kennedywarren
        (ExecutionPlan
ret, PP_Doc
visitg) <- VG s (ExecutionPlan, PP_Doc) -> ST s (ExecutionPlan, PP_Doc)
forall s a. VG s a -> ST s a
runVG (VG s (ExecutionPlan, PP_Doc) -> ST s (ExecutionPlan, PP_Doc))
-> VG s (ExecutionPlan, PP_Doc) -> ST s (ExecutionPlan, PP_Doc)
forall a b. (a -> b) -> a -> b
$ do
         -- traceVG $ "Running kennedy-warren..."
         [[StateIdentifier]]
initvs <- Set NontermIdent
-> [NontDependencyInformationM s] -> VG s [[StateIdentifier]]
forall s.
Set NontermIdent
-> [NontDependencyInformationM s] -> VG s [[StateIdentifier]]
kennedyWarrenVisitM Set NontermIdent
wr [NontDependencyInformationM s]
indi'
         -- Print some debug info
         StateIdentifier
nodes <- (VGState s -> StateIdentifier)
-> ErrorT [Char] (StateT (VGState s) (ST s)) StateIdentifier
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> StateIdentifier
forall s. VGState s -> StateIdentifier
vgNodeNum
         StateIdentifier
edges <- (VGState s -> StateIdentifier)
-> ErrorT [Char] (StateT (VGState s) (ST s)) StateIdentifier
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> StateIdentifier
forall s. VGState s -> StateIdentifier
vgEdgeNum
         Bool
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Options -> Bool
beQuiet Options
opts) (ErrorT [Char] (StateT (VGState s) (ST s)) ()
 -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ do
           [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Number of nodes = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StateIdentifier -> [Char]
forall a. Show a => a -> [Char]
show StateIdentifier
nodes
           [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Number of edges = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StateIdentifier -> [Char]
forall a. Show a => a -> [Char]
show StateIdentifier
edges
         -- Generate execution plan
         ExecutionPlan
ex <- Options
-> [NontDependencyInformationM s]
-> [[StateIdentifier]]
-> Set NontermIdent
-> TypeSyns
-> Derivings
-> VG s ExecutionPlan
forall s.
Options
-> [NontDependencyInformationM s]
-> [[StateIdentifier]]
-> Set NontermIdent
-> TypeSyns
-> Derivings
-> VG s ExecutionPlan
kennedyWarrenExecutionPlan Options
opts [NontDependencyInformationM s]
indi' [[StateIdentifier]]
initvs Set NontermIdent
wr TypeSyns
typesyns Derivings
derivings
         -- Get visit graph
         PP_Doc
visitg <- VG s PP_Doc
forall s. VG s PP_Doc
toGVVisitGraph
         (ExecutionPlan, PP_Doc) -> VG s (ExecutionPlan, PP_Doc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExecutionPlan
ex,PP_Doc
visitg)
        -- Return the result
        (ExecutionPlan, PP_Doc, PP_Doc)
-> ST s (ExecutionPlan, PP_Doc, PP_Doc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExecutionPlan
ret, [PP_Doc] -> PP_Doc
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 :: Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
l (VAttr AttrType
t NontermIdent
a NontermIdent
b) = PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char] -> PP_Doc) -> [Char] -> PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"attr_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AttrType -> [Char]
forall a. Show a => a -> [Char]
show AttrType
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
b) PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=box,label=\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AttrType -> [Char]
forall a. Show a => a -> [Char]
show AttrType
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" @" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty
toGVVertex Bool
l (VChild NontermIdent
c)    = PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char] -> PP_Doc) -> [Char] -> PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"child_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
c) PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=ellipse,label=\"Child " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty
toGVVertex Bool
l (VRule NontermIdent
r)   = PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char] -> PP_Doc) -> [Char] -> PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"rule_"  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
r) PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< if Bool
l
                        then [Char] -> PP_Doc
text ([Char]
"[shape=diamond,label=\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show NontermIdent
r [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"]") else PP_Doc
empty

-- | Pretty print an edge in GraphViz format
toGVEdge :: Edge -> ST s PP_Doc
toGVEdge :: Edge -> ST s PP_Doc
toGVEdge (Vertex
v1, Vertex
v2) = do PP_Doc
r1 <- Bool -> Vertex -> ST s PP_Doc
forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
False Vertex
v1
                       PP_Doc
r2 <- Bool -> Vertex -> ST s PP_Doc
forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
False Vertex
v2
                       PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ PP_Doc
r1 PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char] -> PP_Doc
text [Char]
"->" PP_Doc -> PP_Doc -> PP_Doc
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 :: NontDependencyInformationM s -> ST s PP_Doc
toGVNontDependencyInfo NontDependencyInformationM s
ndi = do DependencyGraph s
dg <- DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyGraph s -> ST s (DependencyGraph s))
-> DependencyGraph s -> ST s (DependencyGraph s)
forall a b. (a -> b) -> a -> b
$ NontDependencyGraphM s -> DependencyGraph s
forall s. NontDependencyGraphM s -> DependencyGraph s
ndgmDepGraph (NontDependencyGraphM s -> DependencyGraph s)
-> (NontDependencyInformationM s -> NontDependencyGraphM s)
-> NontDependencyInformationM s
-> DependencyGraph s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NontDependencyInformationM s -> NontDependencyGraphM s
forall s. NontDependencyInformationM s -> NontDependencyGraphM s
ndimDepGraph (NontDependencyInformationM s -> DependencyGraph s)
-> NontDependencyInformationM s -> DependencyGraph s
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
ndi
                                [Vertex]
verts <- DependencyGraph s -> ST s [Vertex]
forall s. DependencyGraph s -> ST s [Vertex]
graphVertices DependencyGraph s
dg
                                [Edge]
edges <- DependencyGraph s -> ST s [Edge]
forall s. DependencyGraph s -> ST s [Edge]
graphEdges DependencyGraph s
dg
                                [PP_Doc]
vtexts <- (Vertex -> ST s PP_Doc) -> [Vertex] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Vertex -> ST s PP_Doc
forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
True) [Vertex]
verts
                                [PP_Doc]
etexts <- (Edge -> ST s PP_Doc) -> [Edge] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Edge -> ST s PP_Doc
forall s. Edge -> ST s PP_Doc
toGVEdge [Edge]
edges
                                [PP_Doc]
ptexts <- (ProdDependencyGraphM s -> ST s PP_Doc)
-> [ProdDependencyGraphM s] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ProdDependencyGraphM s -> ST s PP_Doc
forall s. ProdDependencyGraphM s -> ST s PP_Doc
toGVProdDependencyGraph (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi)
                                PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char]
"digraph ndg_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show (NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> NontDependencyInformation -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" {")
                                          PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
vtexts
                                          PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
etexts
                                          PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [Char] -> PP_Doc
text [Char]
"}"
                                          PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [Char] -> PP_Doc
text [Char]
"" -- empty line
                                          PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                          [PP_Doc] -> 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 :: ProdDependencyGraphM s -> ST s PP_Doc
toGVProdDependencyGraph ProdDependencyGraphM s
pdg = do DependencyGraph s
dg <- DependencyGraph s -> ST s (DependencyGraph s)
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyGraph s -> ST s (DependencyGraph s))
-> DependencyGraph s -> ST s (DependencyGraph s)
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph ProdDependencyGraphM s
pdg
                                 [Vertex]
verts <- DependencyGraph s -> ST s [Vertex]
forall s. DependencyGraph s -> ST s [Vertex]
graphVertices DependencyGraph s
dg
                                 [Edge]
edges <- DependencyGraph s -> ST s [Edge]
forall s. DependencyGraph s -> ST s [Edge]
graphEdges DependencyGraph s
dg
                                 [PP_Doc]
vtexts <- (Vertex -> ST s PP_Doc) -> [Vertex] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Vertex -> ST s PP_Doc
forall s. Bool -> Vertex -> ST s PP_Doc
toGVVertex Bool
True) [Vertex]
verts
                                 [PP_Doc]
etexts <- (Edge -> ST s PP_Doc) -> [Edge] -> ST s [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Edge -> ST s PP_Doc
forall s. Edge -> ST s PP_Doc
toGVEdge [Edge]
edges
                                 PP_Doc -> ST s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> ST s PP_Doc) -> PP_Doc -> ST s PP_Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> PP_Doc
text ([Char]
"digraph pdg_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show (ProdDependencyGraph -> NontermIdent
pdgProduction (ProdDependencyGraph -> NontermIdent)
-> ProdDependencyGraph -> NontermIdent
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" {")
                                           PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           ([PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
vtexts)
                                           PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           ([PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
etexts)
                                           PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text ([Char]
"info [shape=box,label=\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [(NontermIdent, NontermIdent)] -> [Char]
forall a. Show a => a -> [Char]
show (ProdDependencyGraph -> [(NontermIdent, NontermIdent)]
pdgChildMap (ProdDependencyGraph -> [(NontermIdent, NontermIdent)])
-> ProdDependencyGraph -> [(NontermIdent, NontermIdent)]
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
pdg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"];")
                                           PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text [Char]
"}"
                                           PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-<
                                           [Char] -> PP_Doc
text [Char]
"")

toGVVisitGraph :: VG s PP_Doc
toGVVisitGraph :: VG s PP_Doc
toGVVisitGraph = do
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- (VGState s -> IntMap (STRef s (NontDependencyInformationM s)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (NontDependencyInformationM s)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (NontDependencyInformationM s))
forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  [PP_Doc]
noded <- [(StateIdentifier, STRef s (NontDependencyInformationM s))]
-> ((StateIdentifier, STRef s (NontDependencyInformationM s))
    -> VG s PP_Doc)
-> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (IntMap (STRef s (NontDependencyInformationM s))
-> [(StateIdentifier, STRef s (NontDependencyInformationM s))]
forall a. IntMap a -> [(StateIdentifier, a)]
IntMap.toList IntMap (STRef s (NontDependencyInformationM s))
ndis) (((StateIdentifier, STRef s (NontDependencyInformationM s))
  -> VG s PP_Doc)
 -> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc])
-> ((StateIdentifier, STRef s (NontDependencyInformationM s))
    -> VG s PP_Doc)
-> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc]
forall a b. (a -> b) -> a -> b
$ \(StateIdentifier
n,STRef s (NontDependencyInformationM s)
rndi) -> do
    NontDependencyInformationM s
ndi <- ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall s a. ST s a -> VG s a
vgInST (ST s (NontDependencyInformationM s)
 -> VG s (NontDependencyInformationM s))
-> ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ STRef s (NontDependencyInformationM s)
-> ST s (NontDependencyInformationM s)
forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
    PP_Doc -> VG s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> VG s PP_Doc) -> PP_Doc -> VG s PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"node_" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< StateIdentifier
n StateIdentifier -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"[label=\"" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) NontermIdent -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"_" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< StateIdentifier
n StateIdentifier -> [Char] -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\"];"
  IntMap (VGNode, VGNode)
edges <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  [PP_Doc]
edged <- [(StateIdentifier, (VGNode, VGNode))]
-> ((StateIdentifier, (VGNode, VGNode)) -> VG s PP_Doc)
-> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (IntMap (VGNode, VGNode) -> [(StateIdentifier, (VGNode, VGNode))]
forall a. IntMap a -> [(StateIdentifier, a)]
IntMap.toList IntMap (VGNode, VGNode)
edges) (((StateIdentifier, (VGNode, VGNode)) -> VG s PP_Doc)
 -> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc])
-> ((StateIdentifier, (VGNode, VGNode)) -> VG s PP_Doc)
-> ErrorT [Char] (StateT (VGState s) (ST s)) [PP_Doc]
forall a b. (a -> b) -> a -> b
$ \(StateIdentifier
edg,(VGNode StateIdentifier
from,VGNode StateIdentifier
to)) -> do
    Set NontermIdent
inh <- VGEdge -> VG s (Set NontermIdent)
forall s. VGEdge -> VG s (Set NontermIdent)
getInherited (StateIdentifier -> VGEdge
VGEdge StateIdentifier
edg)
    Set NontermIdent
syn <- VGEdge -> VG s (Set NontermIdent)
forall s. VGEdge -> VG s (Set NontermIdent)
getSynthesized (StateIdentifier -> VGEdge
VGEdge StateIdentifier
edg)
    PP_Doc -> VG s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> VG s PP_Doc) -> PP_Doc -> VG s PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"node_" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< StateIdentifier
from StateIdentifier -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"-> node_" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< StateIdentifier
to StateIdentifier -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< [Char]
"[label=\"visit v" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< StateIdentifier
edg
      StateIdentifier -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\\ninh:" [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>#< ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (NontermIdent -> [Char]) -> [NontermIdent] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show ([NontermIdent] -> [[Char]]) -> [NontermIdent] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set NontermIdent -> [NontermIdent]
forall a. Set a -> [a]
Set.toList Set NontermIdent
inh) [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\\nsyn: " [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
", " ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (NontermIdent -> [Char]) -> [NontermIdent] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show ([NontermIdent] -> [[Char]]) -> [NontermIdent] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Set NontermIdent -> [NontermIdent]
forall a. Set a -> [a]
Set.toList Set NontermIdent
syn) [Char] -> [Char] -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>|< [Char]
"\"];"
  PP_Doc -> VG s PP_Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (PP_Doc -> VG s PP_Doc) -> PP_Doc -> VG s PP_Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"digraph visitgraph { " [Char] -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-< [PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
noded PP_Doc -> PP_Doc -> PP_Doc
forall a b. (PP a, PP b) => a -> b -> PP_Doc
>-< [PP_Doc] -> PP_Doc
forall a. PP a => [a] -> PP_Doc
vlist [PP_Doc]
edged PP_Doc -> [Char] -> PP_Doc
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 (StateIdentifier -> VGNode -> [Char] -> [Char]
[VGNode] -> [Char] -> [Char]
VGNode -> [Char]
(StateIdentifier -> VGNode -> [Char] -> [Char])
-> (VGNode -> [Char])
-> ([VGNode] -> [Char] -> [Char])
-> Show VGNode
forall a.
(StateIdentifier -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [VGNode] -> [Char] -> [Char]
$cshowList :: [VGNode] -> [Char] -> [Char]
show :: VGNode -> [Char]
$cshow :: VGNode -> [Char]
showsPrec :: StateIdentifier -> VGNode -> [Char] -> [Char]
$cshowsPrec :: StateIdentifier -> VGNode -> [Char] -> [Char]
Show,VGNode -> VGNode -> Bool
(VGNode -> VGNode -> Bool)
-> (VGNode -> VGNode -> Bool) -> Eq VGNode
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
Eq VGNode
-> (VGNode -> VGNode -> Ordering)
-> (VGNode -> VGNode -> Bool)
-> (VGNode -> VGNode -> Bool)
-> (VGNode -> VGNode -> Bool)
-> (VGNode -> VGNode -> Bool)
-> (VGNode -> VGNode -> VGNode)
-> (VGNode -> VGNode -> VGNode)
-> Ord 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
$cp1Ord :: Eq VGNode
Ord)
newtype VGEdge = VGEdge Int deriving (StateIdentifier -> VGEdge -> [Char] -> [Char]
[VGEdge] -> [Char] -> [Char]
VGEdge -> [Char]
(StateIdentifier -> VGEdge -> [Char] -> [Char])
-> (VGEdge -> [Char])
-> ([VGEdge] -> [Char] -> [Char])
-> Show VGEdge
forall a.
(StateIdentifier -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [VGEdge] -> [Char] -> [Char]
$cshowList :: [VGEdge] -> [Char] -> [Char]
show :: VGEdge -> [Char]
$cshow :: VGEdge -> [Char]
showsPrec :: StateIdentifier -> VGEdge -> [Char] -> [Char]
$cshowsPrec :: StateIdentifier -> VGEdge -> [Char] -> [Char]
Show,VGEdge -> VGEdge -> Bool
(VGEdge -> VGEdge -> Bool)
-> (VGEdge -> VGEdge -> Bool) -> Eq VGEdge
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
Eq VGEdge
-> (VGEdge -> VGEdge -> Ordering)
-> (VGEdge -> VGEdge -> Bool)
-> (VGEdge -> VGEdge -> Bool)
-> (VGEdge -> VGEdge -> Bool)
-> (VGEdge -> VGEdge -> Bool)
-> (VGEdge -> VGEdge -> VGEdge)
-> (VGEdge -> VGEdge -> VGEdge)
-> Ord 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
$cp1Ord :: Eq VGEdge
Ord)
newtype VGProd = VGProd (VGEdge,Int) deriving (StateIdentifier -> VGProd -> [Char] -> [Char]
[VGProd] -> [Char] -> [Char]
VGProd -> [Char]
(StateIdentifier -> VGProd -> [Char] -> [Char])
-> (VGProd -> [Char])
-> ([VGProd] -> [Char] -> [Char])
-> Show VGProd
forall a.
(StateIdentifier -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [VGProd] -> [Char] -> [Char]
$cshowList :: [VGProd] -> [Char] -> [Char]
show :: VGProd -> [Char]
$cshow :: VGProd -> [Char]
showsPrec :: StateIdentifier -> VGProd -> [Char] -> [Char]
$cshowsPrec :: StateIdentifier -> VGProd -> [Char] -> [Char]
Show,VGProd -> VGProd -> Bool
(VGProd -> VGProd -> Bool)
-> (VGProd -> VGProd -> Bool) -> Eq VGProd
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
Eq VGProd
-> (VGProd -> VGProd -> Ordering)
-> (VGProd -> VGProd -> Bool)
-> (VGProd -> VGProd -> Bool)
-> (VGProd -> VGProd -> Bool)
-> (VGProd -> VGProd -> Bool)
-> (VGProd -> VGProd -> VGProd)
-> (VGProd -> VGProd -> VGProd)
-> Ord 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
$cp1Ord :: Eq VGProd
Ord)

data VGState s = VGState { VGState s -> StateIdentifier
vgNodeNum       :: Int
                         , VGState s -> StateIdentifier
vgEdgeNum       :: Int
                           -- Node maps
                         , VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing      :: IntMap (STRef s (Set VGEdge))
                         , VGState s -> IntMap (Maybe VGEdge)
vgIncoming      :: IntMap (Maybe VGEdge)
                         , VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI           :: IntMap (STRef s (NontDependencyInformationM s))
                         , VGState s
-> Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
vgInhSynNode    :: Map (Identifier, Set Identifier, Set Identifier) VGNode
                         , VGState s -> IntMap (Set NontermIdent, Set NontermIdent)
vgNodeInhSyn    :: IntMap (Set Identifier, Set Identifier)
                         , VGState s -> Map NontermIdent VGNode
vgInitial       :: Map Identifier VGNode
                           -- Edge maps
                         , VGState s -> IntMap (VGNode, VGNode)
vgEdges         :: IntMap (VGNode, VGNode)
                         , VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR        :: Map (VGNode,VGNode) VGEdge
                         , VGState s -> IntMap (Set NontermIdent)
vgInherited     :: IntMap (Set Identifier)
                         , VGState s -> IntMap (Set NontermIdent)
vgSynthesized   :: IntMap (Set Identifier)
                         , VGState s -> IntSet
vgPending       :: IntSet
                         , VGState s
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
vgChildVisits   :: IntMap (STRef s (Map (Identifier,Int) [VGNode]))
                           -- Final vertices in production graphs
                         , VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier)))
vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int)))
                           -- Construction of execution plan (Nonterminal,Production,Visit)
                         , VGState s
-> Map (NontermIdent, NontermIdent, 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 :: VG s a -> ST s a
runVG VG s a
vg = do (Right a
a,VGState s
_) <- StateT (VGState s) (ST s) (Either [Char] a)
-> VGState s -> ST s (Either [Char] a, VGState s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (VG s a -> StateT (VGState s) (ST s) (Either [Char] a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT VG s a
vg) VGState s
forall s. VGState s
vgEmptyState
              a -> ST s a
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 :: NontDependencyInformationM s -> VG s VGNode
insertInitialNode NontDependencyInformationM s
ndi = do
  STRef s (NontDependencyInformationM s)
rndi          <- ST s (STRef s (NontDependencyInformationM s))
-> VG s (STRef s (NontDependencyInformationM s))
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s (NontDependencyInformationM s))
 -> VG s (STRef s (NontDependencyInformationM s)))
-> ST s (STRef s (NontDependencyInformationM s))
-> VG s (STRef s (NontDependencyInformationM s))
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s
-> ST s (STRef s (NontDependencyInformationM s))
forall a s. a -> ST s (STRef s a)
newSTRef NontDependencyInformationM s
ndi
  (VGNode StateIdentifier
node) <- STRef s (NontDependencyInformationM s)
-> Set NontermIdent -> Set NontermIdent -> VG s VGNode
forall s.
STRef s (NontDependencyInformationM s)
-> Set NontermIdent -> Set NontermIdent -> VG s VGNode
vgCreateNode STRef s (NontDependencyInformationM s)
rndi Set NontermIdent
forall a. Set a
Set.empty Set NontermIdent
forall a. Set a
Set.empty
  Map NontermIdent VGNode
initial       <- (VGState s -> Map NontermIdent VGNode)
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (Map NontermIdent VGNode)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> Map NontermIdent VGNode
forall s. VGState s -> Map NontermIdent VGNode
vgInitial
  IntMap (Maybe VGEdge)
incoming      <- (VGState s -> IntMap (Maybe VGEdge))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (Maybe VGEdge))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (Maybe VGEdge)
forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
  (VGState s -> VGState s)
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((VGState s -> VGState s)
 -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> (VGState s -> VGState s)
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgInitial :: Map NontermIdent VGNode
vgInitial  = NontermIdent
-> VGNode -> Map NontermIdent VGNode -> Map NontermIdent VGNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> NontDependencyInformation -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi) (StateIdentifier -> VGNode
VGNode StateIdentifier
node) Map NontermIdent VGNode
initial
                     , vgIncoming :: IntMap (Maybe VGEdge)
vgIncoming = StateIdentifier
-> Maybe VGEdge -> IntMap (Maybe VGEdge) -> IntMap (Maybe VGEdge)
forall a. StateIdentifier -> a -> IntMap a -> IntMap a
IntMap.insert StateIdentifier
node Maybe VGEdge
forall a. Maybe a
Nothing IntMap (Maybe VGEdge)
incoming }
  VGNode -> VG s VGNode
forall (m :: * -> *) a. Monad m => a -> m a
return (StateIdentifier -> VGNode
VGNode StateIdentifier
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 :: VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
createPending vgn :: VGNode
vgn@(VGNode StateIdentifier
n) Set NontermIdent
inh Set NontermIdent
syn = do
  -- Check if target node already exists
  IntMap (Set NontermIdent, Set NontermIdent)
ninhsyn <- (VGState s -> IntMap (Set NontermIdent, Set NontermIdent))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (Set NontermIdent, Set NontermIdent))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (Set NontermIdent, Set NontermIdent)
forall s. VGState s -> IntMap (Set NontermIdent, Set NontermIdent)
vgNodeInhSyn
  let (Set NontermIdent
pinh,Set NontermIdent
psyn) = StateIdentifier
-> IntMap (Set NontermIdent, Set NontermIdent)
-> (Set NontermIdent, Set NontermIdent)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
n IntMap (Set NontermIdent, Set NontermIdent)
ninhsyn
  let ninh :: Set NontermIdent
ninh        = Set NontermIdent -> Set NontermIdent -> Set NontermIdent
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set NontermIdent
pinh Set NontermIdent
inh
  let nsyn :: Set NontermIdent
nsyn        = Set NontermIdent -> Set NontermIdent -> Set NontermIdent
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set NontermIdent
psyn Set NontermIdent
syn
  IntMap (STRef s (NontDependencyInformationM s))
mndi    <- (VGState s -> IntMap (STRef s (NontDependencyInformationM s)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (NontDependencyInformationM s)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (NontDependencyInformationM s))
forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = StateIdentifier
-> IntMap (STRef s (NontDependencyInformationM s))
-> STRef s (NontDependencyInformationM s)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
n IntMap (STRef s (NontDependencyInformationM s))
mndi
  NontDependencyInformationM s
ndi     <- ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall s a. ST s a -> VG s a
vgInST (ST s (NontDependencyInformationM s)
 -> VG s (NontDependencyInformationM s))
-> ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ STRef s (NontDependencyInformationM s)
-> ST s (NontDependencyInformationM s)
forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
inhsynn <- (VGState s
 -> Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode)
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s
-> Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
forall s.
VGState s
-> Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
vgInhSynNode
  case (NontermIdent, Set NontermIdent, Set NontermIdent)
-> Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
-> Maybe VGNode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> NontDependencyInformation -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi, Set NontermIdent
ninh, Set NontermIdent
nsyn) Map (NontermIdent, Set NontermIdent, Set NontermIdent) VGNode
inhsynn of
    Just VGNode
tn -> do
      Bool
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VGNode
tn VGNode -> VGNode -> Bool
forall a. Eq a => a -> a -> Bool
== VGNode
vgn) (ErrorT [Char] (StateT (VGState s) (ST s)) ()
 -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ do [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Source and target nodes are the same!"
                            [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Maybe there is a wrapper with no inherited or synthesized attributes."
                            [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Inh: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Set NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show Set NontermIdent
inh
                            [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Syn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Set NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show Set NontermIdent
syn
                            [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"PInh: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Set NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show Set NontermIdent
pinh
                            [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s. [Char] -> VG s ()
traceVG ([Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> [Char] -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"PSyn: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Set NontermIdent -> [Char]
forall a. Show a => a -> [Char]
show Set NontermIdent
psyn
      -- tn is target node, now check if edge exists and create if not
      Map (VGNode, VGNode) VGEdge
edgesr <- (VGState s -> Map (VGNode, VGNode) VGEdge)
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (Map (VGNode, VGNode) VGEdge)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> Map (VGNode, VGNode) VGEdge
forall s. VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR
      case (VGNode, VGNode) -> Map (VGNode, VGNode) VGEdge -> Maybe VGEdge
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  -> VGEdge -> VG s VGEdge
forall (m :: * -> *) a. Monad m => a -> m a
return VGEdge
e
        Maybe VGEdge
Nothing -> VGNode
-> VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
forall s.
VGNode
-> VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
vgCreatePendingEdge VGNode
vgn VGNode
tn Set NontermIdent
inh Set NontermIdent
syn
    Maybe VGNode
Nothing -> do
      -- target node does not exist, create it and then create the new edge
      VGNode
tn <- STRef s (NontDependencyInformationM s)
-> Set NontermIdent -> Set NontermIdent -> VG s VGNode
forall s.
STRef s (NontDependencyInformationM s)
-> Set NontermIdent -> Set NontermIdent -> VG s VGNode
vgCreateNode STRef s (NontDependencyInformationM s)
rndi Set NontermIdent
ninh Set NontermIdent
nsyn
      VGNode
-> VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
forall s.
VGNode
-> VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
vgCreatePendingEdge VGNode
vgn VGNode
tn Set NontermIdent
inh Set NontermIdent
syn

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

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

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

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

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

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

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

-- | Mark these vertices final in this production
setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
setDepGraphVerticesFinal (VGProd (VGEdge StateIdentifier
edg, StateIdentifier
p)) [Vertex]
vs = do
  IntMap (VGNode, VGNode)
edges   <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode
_,VGNode StateIdentifier
to) = StateIdentifier -> IntMap (VGNode, VGNode) -> (VGNode, VGNode)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
edg IntMap (VGNode, VGNode)
edges
  IntMap (STRef s (Set (Vertex, StateIdentifier)))
finalv <- (VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier))))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (Set (Vertex, StateIdentifier))))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier)))
forall s.
VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier)))
vgFinalVertices
  let rfinalv :: STRef s (Set (Vertex, StateIdentifier))
rfinalv       = StateIdentifier
-> IntMap (STRef s (Set (Vertex, StateIdentifier)))
-> STRef s (Set (Vertex, StateIdentifier))
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
to IntMap (STRef s (Set (Vertex, StateIdentifier)))
finalv
  ST s () -> VG s ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> VG s ()) -> ST s () -> VG s ()
forall a b. (a -> b) -> a -> b
$ STRef s (Set (Vertex, StateIdentifier))
-> (Set (Vertex, StateIdentifier) -> Set (Vertex, StateIdentifier))
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set (Vertex, StateIdentifier))
rfinalv ((Set (Vertex, StateIdentifier) -> Set (Vertex, StateIdentifier))
 -> ST s ())
-> (Set (Vertex, StateIdentifier) -> Set (Vertex, StateIdentifier))
-> ST s ()
forall a b. (a -> b) -> a -> b
$ Set (Vertex, StateIdentifier)
-> Set (Vertex, StateIdentifier) -> Set (Vertex, StateIdentifier)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(Vertex, StateIdentifier)] -> Set (Vertex, StateIdentifier)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Vertex, StateIdentifier)] -> Set (Vertex, StateIdentifier))
-> [(Vertex, StateIdentifier)] -> Set (Vertex, StateIdentifier)
forall a b. (a -> b) -> a -> b
$ (Vertex -> (Vertex, StateIdentifier))
-> [Vertex] -> [(Vertex, StateIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
v -> (Vertex
v,StateIdentifier
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 :: VGProd -> NontermIdent -> VGEdge -> VG s VisitStep
addChildVisit (VGProd (VGEdge StateIdentifier
edg, StateIdentifier
p)) NontermIdent
ide (VGEdge StateIdentifier
vs) = do
  IntMap (VGNode, VGNode)
edges   <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let (VGNode StateIdentifier
from,VGNode
vgto) = StateIdentifier -> IntMap (VGNode, VGNode) -> (VGNode, VGNode)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
vs IntMap (VGNode, VGNode)
edges -- from must be equal to the current state
  IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
childvs <- (VGState s
 -> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode])))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode])))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall s.
VGState s
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
vgChildVisits
  let rchildv :: STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
rchildv = StateIdentifier
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
-> STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
edg IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
childvs
  ST s () -> VG s ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> VG s ()) -> ST s () -> VG s ()
forall a b. (a -> b) -> a -> b
$ STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
-> (Map (NontermIdent, StateIdentifier) [VGNode]
    -> Map (NontermIdent, StateIdentifier) [VGNode])
-> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
rchildv ((Map (NontermIdent, StateIdentifier) [VGNode]
  -> Map (NontermIdent, StateIdentifier) [VGNode])
 -> ST s ())
-> (Map (NontermIdent, StateIdentifier) [VGNode]
    -> Map (NontermIdent, StateIdentifier) [VGNode])
-> ST s ()
forall a b. (a -> b) -> a -> b
$ ([VGNode] -> [VGNode] -> [VGNode])
-> (NontermIdent, StateIdentifier)
-> [VGNode]
-> Map (NontermIdent, StateIdentifier) [VGNode]
-> Map (NontermIdent, StateIdentifier) [VGNode]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapStrict.insertWith [VGNode] -> [VGNode] -> [VGNode]
forall a. [a] -> [a] -> [a]
(++) (NontermIdent
ide,StateIdentifier
p) [VGNode
vgto]
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- (VGState s -> IntMap (STRef s (NontDependencyInformationM s)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (NontDependencyInformationM s)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (NontDependencyInformationM s))
forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = StateIdentifier
-> IntMap (STRef s (NontDependencyInformationM s))
-> STRef s (NontDependencyInformationM s)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
from IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall s a. ST s a -> VG s a
vgInST (ST s (NontDependencyInformationM s)
 -> VG s (NontDependencyInformationM s))
-> ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ STRef s (NontDependencyInformationM s)
-> ST s (NontDependencyInformationM s)
forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  let nt :: NontermIdent
nt = NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> NontDependencyInformation -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi
  VisitStep -> VG s VisitStep
forall (m :: * -> *) a. Monad m => a -> m a
return (VisitStep -> VG s VisitStep) -> VisitStep -> VG s VisitStep
forall a b. (a -> b) -> a -> b
$ NontermIdent -> NontermIdent -> StateIdentifier -> VisitStep
ChildVisit NontermIdent
ide NontermIdent
nt StateIdentifier
vs

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

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

-- | Repeat action untill mzero is encountered
repeatM :: VG s () -> VG s ()
repeatM :: VG s () -> VG s ()
repeatM VG s ()
m = VG s () -> ([Char] -> VG s ()) -> VG s ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (VG s ()
m VG s () -> VG s () -> VG s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VG s () -> VG s ()
forall s. VG s () -> VG s ()
repeatM VG s ()
m) (VG s () -> [Char] -> VG s ()
forall a b. a -> b -> a
const (VG s () -> [Char] -> VG s ()) -> VG s () -> [Char] -> VG s ()
forall a b. (a -> b) -> a -> b
$ () -> VG s ()
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 :: ST s a -> VG s a
vgInST = StateT (VGState s) (ST s) a -> VG s a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (VGState s) (ST s) a -> VG s a)
-> (ST s a -> StateT (VGState s) (ST s) a) -> ST s a -> VG s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s a -> StateT (VGState s) (ST s) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

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

-- | Create a new pending edge
vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
vgCreatePendingEdge :: VGNode
-> VGNode -> Set NontermIdent -> Set NontermIdent -> VG s VGEdge
vgCreatePendingEdge vgn1 :: VGNode
vgn1@(VGNode StateIdentifier
n1) VGNode
vgn2 Set NontermIdent
inh Set NontermIdent
syn = do
  StateIdentifier
num      <- (VGState s -> StateIdentifier)
-> ErrorT [Char] (StateT (VGState s) (ST s)) StateIdentifier
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> StateIdentifier
forall s. VGState s -> StateIdentifier
vgEdgeNum
  IntMap (VGNode, VGNode)
edges    <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  Map (VGNode, VGNode) VGEdge
edgesr   <- (VGState s -> Map (VGNode, VGNode) VGEdge)
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (Map (VGNode, VGNode) VGEdge)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> Map (VGNode, VGNode) VGEdge
forall s. VGState s -> Map (VGNode, VGNode) VGEdge
vgEdgesR
  IntMap (Set NontermIdent)
inhs     <- (VGState s -> IntMap (Set NontermIdent))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (Set NontermIdent))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (Set NontermIdent)
forall s. VGState s -> IntMap (Set NontermIdent)
vgInherited
  IntMap (Set NontermIdent)
syns     <- (VGState s -> IntMap (Set NontermIdent))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (Set NontermIdent))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (Set NontermIdent)
forall s. VGState s -> IntMap (Set NontermIdent)
vgSynthesized
  IntMap (STRef s (Set VGEdge))
outgoing <- (VGState s -> IntMap (STRef s (Set VGEdge)))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (STRef s (Set VGEdge)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (Set VGEdge))
forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing
  IntSet
pend     <- (VGState s -> IntSet)
-> ErrorT [Char] (StateT (VGState s) (ST s)) IntSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntSet
forall s. VGState s -> IntSet
vgPending
  IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
childv   <- (VGState s
 -> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode])))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode])))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall s.
VGState s
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
vgChildVisits
  STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
rchildv  <- ST s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
-> VG s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
 -> VG s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode])))
-> ST s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
-> VG s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall a b. (a -> b) -> a -> b
$ Map (NontermIdent, StateIdentifier) [VGNode]
-> ST s (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall a s. a -> ST s (STRef s a)
newSTRef Map (NontermIdent, StateIdentifier) [VGNode]
forall k a. Map k a
Map.empty
  let outr :: STRef s (Set VGEdge)
outr    = StateIdentifier
-> IntMap (STRef s (Set VGEdge)) -> STRef s (Set VGEdge)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
n1 IntMap (STRef s (Set VGEdge))
outgoing
  let ret :: VGEdge
ret     = StateIdentifier -> VGEdge
VGEdge StateIdentifier
num
  ST s () -> VG s ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> VG s ()) -> ST s () -> VG s ()
forall a b. (a -> b) -> a -> b
$ STRef s (Set VGEdge) -> (Set VGEdge -> Set VGEdge) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s (Set VGEdge)
outr (VGEdge -> Set VGEdge -> Set VGEdge
forall a. Ord a => a -> Set a -> Set a
Set.insert VGEdge
ret)
  (VGState s -> VGState s) -> VG s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((VGState s -> VGState s) -> VG s ())
-> (VGState s -> VGState s) -> VG s ()
forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgEdgeNum :: StateIdentifier
vgEdgeNum     = StateIdentifier
num StateIdentifier -> StateIdentifier -> StateIdentifier
forall a. Num a => a -> a -> a
+ StateIdentifier
1
                     , vgEdges :: IntMap (VGNode, VGNode)
vgEdges       = StateIdentifier
-> (VGNode, VGNode)
-> IntMap (VGNode, VGNode)
-> IntMap (VGNode, VGNode)
forall a. StateIdentifier -> a -> IntMap a -> IntMap a
IntMap.insert StateIdentifier
num (VGNode
vgn1,VGNode
vgn2) IntMap (VGNode, VGNode)
edges
                     , vgEdgesR :: Map (VGNode, VGNode) VGEdge
vgEdgesR      = (VGNode, VGNode)
-> VGEdge
-> Map (VGNode, VGNode) VGEdge
-> Map (VGNode, VGNode) VGEdge
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     = StateIdentifier -> IntSet -> IntSet
IntSet.insert StateIdentifier
num IntSet
pend
                     , vgInherited :: IntMap (Set NontermIdent)
vgInherited   = StateIdentifier
-> Set NontermIdent
-> IntMap (Set NontermIdent)
-> IntMap (Set NontermIdent)
forall a. StateIdentifier -> a -> IntMap a -> IntMap a
IntMap.insert StateIdentifier
num Set NontermIdent
inh IntMap (Set NontermIdent)
inhs
                     , vgSynthesized :: IntMap (Set NontermIdent)
vgSynthesized = StateIdentifier
-> Set NontermIdent
-> IntMap (Set NontermIdent)
-> IntMap (Set NontermIdent)
forall a. StateIdentifier -> a -> IntMap a -> IntMap a
IntMap.insert StateIdentifier
num Set NontermIdent
syn IntMap (Set NontermIdent)
syns
                     , vgChildVisits :: IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
vgChildVisits = StateIdentifier
-> STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
-> IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
forall a. StateIdentifier -> a -> IntMap a -> IntMap a
IntMap.insert StateIdentifier
num STRef s (Map (NontermIdent, StateIdentifier) [VGNode])
rchildv IntMap (STRef s (Map (NontermIdent, StateIdentifier) [VGNode]))
childv }
  -- Add prod visits (for constructing an execution plan)
  IntMap (STRef s (NontDependencyInformationM s))
ndis <- (VGState s -> IntMap (STRef s (NontDependencyInformationM s)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (NontDependencyInformationM s)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (NontDependencyInformationM s))
forall s.
VGState s -> IntMap (STRef s (NontDependencyInformationM s))
vgNDI
  let rndi :: STRef s (NontDependencyInformationM s)
rndi = StateIdentifier
-> IntMap (STRef s (NontDependencyInformationM s))
-> STRef s (NontDependencyInformationM s)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
n1 IntMap (STRef s (NontDependencyInformationM s))
ndis
  NontDependencyInformationM s
ndi <- ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall s a. ST s a -> VG s a
vgInST (ST s (NontDependencyInformationM s)
 -> VG s (NontDependencyInformationM s))
-> ST s (NontDependencyInformationM s)
-> VG s (NontDependencyInformationM s)
forall a b. (a -> b) -> a -> b
$ STRef s (NontDependencyInformationM s)
-> ST s (NontDependencyInformationM s)
forall s a. STRef s a -> ST s a
readSTRef STRef s (NontDependencyInformationM s)
rndi
  Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
prodv  <- (VGState s
 -> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s
-> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
forall s.
VGState s
-> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
vgProdVisits
  [((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)]
refs   <- [ProdDependencyGraphM s]
-> (ProdDependencyGraphM s
    -> ErrorT
         [Char]
         (StateT (VGState s) (ST s))
         ((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     [((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (NontDependencyInformationM s -> [ProdDependencyGraphM s]
forall s. NontDependencyInformationM s -> [ProdDependencyGraphM s]
ndimProds NontDependencyInformationM s
ndi) ((ProdDependencyGraphM s
  -> ErrorT
       [Char]
       (StateT (VGState s) (ST s))
       ((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps))
 -> ErrorT
      [Char]
      (StateT (VGState s) (ST s))
      [((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)])
-> (ProdDependencyGraphM s
    -> ErrorT
         [Char]
         (StateT (VGState s) (ST s))
         ((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     [((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)]
forall a b. (a -> b) -> a -> b
$ \ProdDependencyGraphM s
prod -> do
    STRef s VisitSteps
rprod <- ST s (STRef s VisitSteps) -> VG s (STRef s VisitSteps)
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s VisitSteps) -> VG s (STRef s VisitSteps))
-> ST s (STRef s VisitSteps) -> VG s (STRef s VisitSteps)
forall a b. (a -> b) -> a -> b
$ VisitSteps -> ST s (STRef s VisitSteps)
forall a s. a -> ST s (STRef s a)
newSTRef []
    ((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     ((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NontDependencyInformation -> NontermIdent
ndiNonterminal (NontDependencyInformation -> NontermIdent)
-> NontDependencyInformation -> NontermIdent
forall a b. (a -> b) -> a -> b
$ NontDependencyInformationM s -> NontDependencyInformation
forall s. NontDependencyInformationM s -> NontDependencyInformation
ndimOrig NontDependencyInformationM s
ndi, ProdDependencyGraph -> NontermIdent
pdgProduction (ProdDependencyGraph -> NontermIdent)
-> ProdDependencyGraph -> NontermIdent
forall a b. (a -> b) -> a -> b
$ ProdDependencyGraphM s -> ProdDependencyGraph
forall s. ProdDependencyGraphM s -> ProdDependencyGraph
pdgmOrig ProdDependencyGraphM s
prod, VGEdge
ret),STRef s VisitSteps
rprod)
  (VGState s -> VGState s) -> VG s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((VGState s -> VGState s) -> VG s ())
-> (VGState s -> VGState s) -> VG s ()
forall a b. (a -> b) -> a -> b
$ \VGState s
st -> VGState s
st { vgProdVisits :: Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
vgProdVisits = Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
-> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
-> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)]
-> Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((NontermIdent, NontermIdent, VGEdge), STRef s VisitSteps)]
refs) Map (NontermIdent, NontermIdent, VGEdge) (STRef s VisitSteps)
prodv }
  VGEdge -> VG s VGEdge
forall (m :: * -> *) a. Monad m => a -> m a
return (VGEdge -> VG s VGEdge) -> VGEdge -> VG s VGEdge
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 :: VGNode -> StateIdentifier -> Vertex -> VG s Bool
vgDepGraphVertexFinal (VGNode StateIdentifier
n) StateIdentifier
p Vertex
v = do
  IntMap (STRef s (Set (Vertex, StateIdentifier)))
finalv <- (VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier))))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (IntMap (STRef s (Set (Vertex, StateIdentifier))))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier)))
forall s.
VGState s -> IntMap (STRef s (Set (Vertex, StateIdentifier)))
vgFinalVertices
  let rfinalv :: STRef s (Set (Vertex, StateIdentifier))
rfinalv = StateIdentifier
-> IntMap (STRef s (Set (Vertex, StateIdentifier)))
-> STRef s (Set (Vertex, StateIdentifier))
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
n IntMap (STRef s (Set (Vertex, StateIdentifier)))
finalv
  Set (Vertex, StateIdentifier)
curset <- ST s (Set (Vertex, StateIdentifier))
-> VG s (Set (Vertex, StateIdentifier))
forall s a. ST s a -> VG s a
vgInST (ST s (Set (Vertex, StateIdentifier))
 -> VG s (Set (Vertex, StateIdentifier)))
-> ST s (Set (Vertex, StateIdentifier))
-> VG s (Set (Vertex, StateIdentifier))
forall a b. (a -> b) -> a -> b
$ STRef s (Set (Vertex, StateIdentifier))
-> ST s (Set (Vertex, StateIdentifier))
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set (Vertex, StateIdentifier))
rfinalv
  if (Vertex, StateIdentifier) -> Set (Vertex, StateIdentifier) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Vertex
v,StateIdentifier
p) Set (Vertex, StateIdentifier)
curset
    then Bool -> VG s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      IntMap (Maybe VGEdge)
incoming <- (VGState s -> IntMap (Maybe VGEdge))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (Maybe VGEdge))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (Maybe VGEdge)
forall s. VGState s -> IntMap (Maybe VGEdge)
vgIncoming
      case StateIdentifier -> IntMap (Maybe VGEdge) -> Maybe (Maybe VGEdge)
forall a. StateIdentifier -> IntMap a -> Maybe a
IntMap.lookup StateIdentifier
n IntMap (Maybe VGEdge)
incoming of
        Just (Just (VGEdge StateIdentifier
edg)) -> do
          IntMap (VGNode, VGNode)
edges <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
          let (VGNode
fr,VGNode
_) = StateIdentifier -> IntMap (VGNode, VGNode) -> (VGNode, VGNode)
forall a. StateIdentifier -> IntMap a -> a
imLookup StateIdentifier
edg IntMap (VGNode, VGNode)
edges
          VGNode -> StateIdentifier -> Vertex -> VG s Bool
forall s. VGNode -> StateIdentifier -> Vertex -> VG s Bool
vgDepGraphVertexFinal VGNode
fr StateIdentifier
p Vertex
v
        Just Maybe VGEdge
Nothing -> Bool -> VG s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe (Maybe VGEdge)
Nothing      -> [Char] -> VG s Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"This can never happen"

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

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

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

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

-- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements
groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]]
groupSortBy a -> a -> Ordering
f = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\a
x a
y -> a -> a -> Ordering
f a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ) ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
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 :: VGProd
-> ([(Vertex, StateIdentifier)], StateIdentifier)
-> Vertex
-> VG s ([(Vertex, StateIdentifier)], StateIdentifier)
foldChildVisits VGProd
prod ([(Vertex, StateIdentifier)]
vis,StateIdentifier
i) Vertex
v = do
  ([(Vertex, StateIdentifier)]
nvis,StateIdentifier
ni) <- VGProd
-> Vertex
-> [(Vertex, StateIdentifier)]
-> VG s ([(Vertex, StateIdentifier)], StateIdentifier)
forall s.
VGProd
-> Vertex
-> [(Vertex, StateIdentifier)]
-> VG s ([(Vertex, StateIdentifier)], StateIdentifier)
findChildVisits VGProd
prod Vertex
v [(Vertex, StateIdentifier)]
vis
  ([(Vertex, StateIdentifier)], StateIdentifier)
-> VG s ([(Vertex, StateIdentifier)], StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Vertex, StateIdentifier)]
nvis, StateIdentifier
ni StateIdentifier -> StateIdentifier -> StateIdentifier
forall a. Ord a => a -> a -> a
`max` StateIdentifier
i)

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

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

-- | Synthesized attributes that can also be evaluated
extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits
extraChildSyn :: VGProd
-> [(Vertex, StateIdentifier)] -> VG s [(Vertex, StateIdentifier)]
extraChildSyn VGProd
prod [(Vertex, StateIdentifier)]
vis = do
  [Set Vertex]
allpreds <- [(Vertex, StateIdentifier)]
-> ((Vertex, StateIdentifier)
    -> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex))
-> ErrorT [Char] (StateT (VGState s) (ST s)) [Set Vertex]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Vertex, StateIdentifier)]
vis (((Vertex, StateIdentifier)
  -> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex))
 -> ErrorT [Char] (StateT (VGState s) (ST s)) [Set Vertex])
-> ((Vertex, StateIdentifier)
    -> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex))
-> ErrorT [Char] (StateT (VGState s) (ST s)) [Set Vertex]
forall a b. (a -> b) -> a -> b
$ \(Vertex
v,StateIdentifier
_) -> do
    if Vertex -> Bool
isChildInh Vertex
v
     then do
      [Vertex]
preds <- (ProdDependencyGraphM s -> ST s [Vertex])
-> VGProd -> VG s [Vertex]
forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph ((Set Vertex -> [Vertex]) -> ST s (Set Vertex) -> ST s [Vertex]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (ST s (Set Vertex) -> ST s [Vertex])
-> (ProdDependencyGraphM s -> ST s (Set Vertex))
-> ProdDependencyGraphM s
-> ST s [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DependencyGraph s -> Vertex -> ST s (Set Vertex))
-> Vertex -> DependencyGraph s -> ST s (Set Vertex)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DependencyGraph s -> Vertex -> ST s (Set Vertex)
forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphPredecessors Vertex
v (DependencyGraph s -> ST s (Set Vertex))
-> (ProdDependencyGraphM s -> DependencyGraph s)
-> ProdDependencyGraphM s
-> ST s (Set Vertex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
      Set Vertex
-> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Vertex
 -> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex))
-> Set Vertex
-> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex)
forall a b. (a -> b) -> a -> b
$ [Vertex] -> Set Vertex
forall a. Ord a => [a] -> Set a
Set.fromList ([Vertex] -> Set Vertex) -> [Vertex] -> Set Vertex
forall a b. (a -> b) -> a -> b
$ (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter Vertex -> Bool
isChildSyn [Vertex]
preds
     else Set Vertex
-> ErrorT [Char] (StateT (VGState s) (ST s)) (Set Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Vertex
forall a. Set a
Set.empty
  [Maybe (Vertex, StateIdentifier)]
lextravis <- [Vertex]
-> (Vertex
    -> ErrorT
         [Char]
         (StateT (VGState s) (ST s))
         (Maybe (Vertex, StateIdentifier)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     [Maybe (Vertex, StateIdentifier)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (Set Vertex -> [Vertex]) -> Set Vertex -> [Vertex]
forall a b. (a -> b) -> a -> b
$ [Set Vertex] -> Set Vertex
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Vertex]
allpreds) ((Vertex
  -> ErrorT
       [Char]
       (StateT (VGState s) (ST s))
       (Maybe (Vertex, StateIdentifier)))
 -> ErrorT
      [Char]
      (StateT (VGState s) (ST s))
      [Maybe (Vertex, StateIdentifier)])
-> (Vertex
    -> ErrorT
         [Char]
         (StateT (VGState s) (ST s))
         (Maybe (Vertex, StateIdentifier)))
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     [Maybe (Vertex, StateIdentifier)]
forall a b. (a -> b) -> a -> b
$ \Vertex
v -> do
    Maybe StateIdentifier
ready <- VGProd
-> [(Vertex, StateIdentifier)]
-> Vertex
-> VG s (Maybe StateIdentifier)
forall s.
VGProd
-> [(Vertex, StateIdentifier)]
-> Vertex
-> VG s (Maybe StateIdentifier)
isReadyVertex VGProd
prod [(Vertex, StateIdentifier)]
vis Vertex
v
    Maybe (Vertex, StateIdentifier)
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (Maybe (Vertex, StateIdentifier))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Vertex, StateIdentifier)
 -> ErrorT
      [Char]
      (StateT (VGState s) (ST s))
      (Maybe (Vertex, StateIdentifier)))
-> Maybe (Vertex, StateIdentifier)
-> ErrorT
     [Char]
     (StateT (VGState s) (ST s))
     (Maybe (Vertex, StateIdentifier))
forall a b. (a -> b) -> a -> b
$ Maybe (Vertex, StateIdentifier)
-> (StateIdentifier -> Maybe (Vertex, StateIdentifier))
-> Maybe StateIdentifier
-> Maybe (Vertex, StateIdentifier)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Vertex, StateIdentifier)
forall a. Maybe a
Nothing (\StateIdentifier
i -> (Vertex, StateIdentifier) -> Maybe (Vertex, StateIdentifier)
forall a. a -> Maybe a
Just (Vertex
v,StateIdentifier
i)) Maybe StateIdentifier
ready
  [(Vertex, StateIdentifier)] -> VG s [(Vertex, StateIdentifier)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Vertex, StateIdentifier)] -> VG s [(Vertex, StateIdentifier)])
-> [(Vertex, StateIdentifier)] -> VG s [(Vertex, StateIdentifier)]
forall a b. (a -> b) -> a -> b
$ [Maybe (Vertex, StateIdentifier)] -> [(Vertex, StateIdentifier)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Vertex, StateIdentifier)]
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 :: VGProd
-> [(Vertex, StateIdentifier)]
-> Vertex
-> VG s (Maybe StateIdentifier)
isReadyVertex VGProd
prod [(Vertex, StateIdentifier)]
vis Vertex
v = do
  Bool
final <- VGProd -> Vertex -> VG s Bool
forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal VGProd
prod Vertex
v
  if Vertex
v Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Vertex, StateIdentifier) -> Vertex)
-> [(Vertex, StateIdentifier)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, StateIdentifier) -> Vertex
forall a b. (a, b) -> a
fst [(Vertex, StateIdentifier)]
vis) Bool -> Bool -> Bool
|| Bool
final
    then Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateIdentifier
forall a. Maybe a
Nothing
    else do
      Set Vertex
succ <- (ProdDependencyGraphM s -> ST s (Set Vertex))
-> VGProd -> VG s (Set Vertex)
forall s a. (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
onMarkedDepGraph ((DependencyGraph s -> Vertex -> ST s (Set Vertex))
-> Vertex -> DependencyGraph s -> ST s (Set Vertex)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DependencyGraph s -> Vertex -> ST s (Set Vertex)
forall s. DependencyGraph s -> Vertex -> ST s (Set Vertex)
graphSuccessors Vertex
v (DependencyGraph s -> ST s (Set Vertex))
-> (ProdDependencyGraphM s -> DependencyGraph s)
-> ProdDependencyGraphM s
-> ST s (Set Vertex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProdDependencyGraphM s -> DependencyGraph s
forall s. ProdDependencyGraphM s -> DependencyGraph s
pdgmDepGraph) VGProd
prod
      [Maybe StateIdentifier]
rd <- (Vertex -> VG s (Maybe StateIdentifier))
-> [Vertex]
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) [Maybe StateIdentifier]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Vertex
x -> do case Vertex -> [(Vertex, StateIdentifier)] -> Maybe StateIdentifier
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Vertex
x [(Vertex, StateIdentifier)]
vis of
                             Just StateIdentifier
i  -> Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateIdentifier -> VG s (Maybe StateIdentifier))
-> Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall a b. (a -> b) -> a -> b
$ StateIdentifier -> Maybe StateIdentifier
forall a. a -> Maybe a
Just StateIdentifier
i
                             Maybe StateIdentifier
Nothing -> do Bool
fin <- VGProd -> Vertex -> VG s Bool
forall s. VGProd -> Vertex -> VG s Bool
isDepGraphVertexFinal VGProd
prod Vertex
x
                                           Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateIdentifier -> VG s (Maybe StateIdentifier))
-> Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall a b. (a -> b) -> a -> b
$ if Bool
fin then StateIdentifier -> Maybe StateIdentifier
forall a. a -> Maybe a
Just StateIdentifier
1 else Maybe StateIdentifier
forall a. Maybe a
Nothing) (Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
succ)
      if (Maybe StateIdentifier -> Bool) -> [Maybe StateIdentifier] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe StateIdentifier -> Bool
forall a. Maybe a -> Bool
isJust [Maybe StateIdentifier]
rd
        then Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateIdentifier -> VG s (Maybe StateIdentifier))
-> Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall a b. (a -> b) -> a -> b
$ StateIdentifier -> Maybe StateIdentifier
forall a. a -> Maybe a
Just (StateIdentifier -> Maybe StateIdentifier)
-> StateIdentifier -> Maybe StateIdentifier
forall a b. (a -> b) -> a -> b
$ (StateIdentifier -> StateIdentifier -> StateIdentifier)
-> [StateIdentifier] -> StateIdentifier
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 StateIdentifier -> StateIdentifier -> StateIdentifier
forall a. Ord a => a -> a -> a
max ([StateIdentifier] -> StateIdentifier)
-> [StateIdentifier] -> StateIdentifier
forall a b. (a -> b) -> a -> b
$ [Maybe StateIdentifier] -> [StateIdentifier]
forall a. [Maybe a] -> [a]
catMaybes [Maybe StateIdentifier]
rd
        else Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StateIdentifier -> VG s (Maybe StateIdentifier))
-> Maybe StateIdentifier -> VG s (Maybe StateIdentifier)
forall a b. (a -> b) -> a -> b
$ Maybe StateIdentifier
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 AttrType -> AttrType -> Bool
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 AttrType -> AttrType -> Bool
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 -> NontermIdent
getAttrChildName Vertex
v NontermIdent -> NontermIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= NontermIdent
_LHS Bool -> Bool -> Bool
&& Vertex -> AttrType
getAttrType Vertex
v AttrType -> AttrType -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrType
Loc

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

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

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

  -- Return complete execution plan
  ExecutionPlan -> VG s ExecutionPlan
forall (m :: * -> *) a. Monad m => a -> m a
return (ExecutionPlan -> VG s ExecutionPlan)
-> ExecutionPlan -> VG s ExecutionPlan
forall a b. (a -> b) -> a -> b
$ ENonterminals
-> TypeSyns -> Set NontermIdent -> Derivings -> ExecutionPlan
ExecutionPlan ENonterminals
nonts TypeSyns
typesyns Set NontermIdent
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 :: (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 StateIdentifier
init) a
a0 = do
  STRef s IntSet
exploredRef <- ST s (STRef s IntSet) -> VG s (STRef s IntSet)
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s IntSet) -> VG s (STRef s IntSet))
-> ST s (STRef s IntSet) -> VG s (STRef s IntSet)
forall a b. (a -> b) -> a -> b
$ IntSet -> ST s (STRef s IntSet)
forall a s. a -> ST s (STRef s a)
newSTRef IntSet
IntSet.empty
  STRef s [StateIdentifier]
pendingRef  <- ST s (STRef s [StateIdentifier])
-> VG s (STRef s [StateIdentifier])
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s [StateIdentifier])
 -> VG s (STRef s [StateIdentifier]))
-> ST s (STRef s [StateIdentifier])
-> VG s (STRef s [StateIdentifier])
forall a b. (a -> b) -> a -> b
$ [StateIdentifier] -> ST s (STRef s [StateIdentifier])
forall a s. a -> ST s (STRef s a)
newSTRef [StateIdentifier
init]
  STRef s a
resRef      <- ST s (STRef s a) -> VG s (STRef s a)
forall s a. ST s a -> VG s a
vgInST (ST s (STRef s a) -> VG s (STRef s a))
-> ST s (STRef s a) -> VG s (STRef s a)
forall a b. (a -> b) -> a -> b
$ a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef a
a0
  IntMap (STRef s (Set VGEdge))
outgoingMap <- (VGState s -> IntMap (STRef s (Set VGEdge)))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (STRef s (Set VGEdge)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (STRef s (Set VGEdge))
forall s. VGState s -> IntMap (STRef s (Set VGEdge))
vgOutgoing
  IntMap (VGNode, VGNode)
edgesInfo   <- (VGState s -> IntMap (VGNode, VGNode))
-> ErrorT
     [Char] (StateT (VGState s) (ST s)) (IntMap (VGNode, VGNode))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets VGState s -> IntMap (VGNode, VGNode)
forall s. VGState s -> IntMap (VGNode, VGNode)
vgEdges
  let explore :: ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore = do
        [StateIdentifier]
pending <- ST s [StateIdentifier] -> VG s [StateIdentifier]
forall s a. ST s a -> VG s a
vgInST (ST s [StateIdentifier] -> VG s [StateIdentifier])
-> ST s [StateIdentifier] -> VG s [StateIdentifier]
forall a b. (a -> b) -> a -> b
$ STRef s [StateIdentifier] -> ST s [StateIdentifier]
forall s a. STRef s a -> ST s a
readSTRef STRef s [StateIdentifier]
pendingRef
        case [StateIdentifier]
pending of
          []     -> () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (StateIdentifier
p:[StateIdentifier]
ps) -> do
            ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ STRef s [StateIdentifier] -> [StateIdentifier] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [StateIdentifier]
pendingRef [StateIdentifier]
ps
            IntSet
explored <- ST s IntSet -> VG s IntSet
forall s a. ST s a -> VG s a
vgInST (ST s IntSet -> VG s IntSet) -> ST s IntSet -> VG s IntSet
forall a b. (a -> b) -> a -> b
$ STRef s IntSet -> ST s IntSet
forall s a. STRef s a -> ST s a
readSTRef STRef s IntSet
exploredRef
            if StateIdentifier -> IntSet -> Bool
IntSet.member StateIdentifier
p IntSet
explored
              then () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else do
                ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ STRef s IntSet -> IntSet -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s IntSet
exploredRef (StateIdentifier -> IntSet -> IntSet
IntSet.insert StateIdentifier
p IntSet
explored)
                case StateIdentifier
-> IntMap (STRef s (Set VGEdge)) -> Maybe (STRef s (Set VGEdge))
forall a. StateIdentifier -> IntMap a -> Maybe a
IntMap.lookup StateIdentifier
p IntMap (STRef s (Set VGEdge))
outgoingMap of
                  Maybe (STRef s (Set VGEdge))
Nothing -> () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just STRef s (Set VGEdge)
outRef -> case StateIdentifier
-> IntMap (STRef s (Set VGEdge)) -> Maybe (STRef s (Set VGEdge))
forall a. StateIdentifier -> IntMap a -> Maybe a
IntMap.lookup StateIdentifier
p IntMap (STRef s (Set VGEdge))
outgoingMap of
                    Maybe (STRef s (Set VGEdge))
Nothing -> () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just STRef s (Set VGEdge)
inRef -> do
                            Set VGEdge
outSet  <- ST s (Set VGEdge) -> VG s (Set VGEdge)
forall s a. ST s a -> VG s a
vgInST (ST s (Set VGEdge) -> VG s (Set VGEdge))
-> ST s (Set VGEdge) -> VG s (Set VGEdge)
forall a b. (a -> b) -> a -> b
$ STRef s (Set VGEdge) -> ST s (Set VGEdge)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set VGEdge)
outRef
                            Set VGEdge
inSet   <- ST s (Set VGEdge) -> VG s (Set VGEdge)
forall s a. ST s a -> VG s a
vgInST (ST s (Set VGEdge) -> VG s (Set VGEdge))
-> ST s (Set VGEdge) -> VG s (Set VGEdge)
forall a b. (a -> b) -> a -> b
$ STRef s (Set VGEdge) -> ST s (Set VGEdge)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set VGEdge)
inRef
                            a
sol0    <- ST s a -> VG s a
forall s a. ST s a -> VG s a
vgInST (ST s a -> VG s a) -> ST s a -> VG s a
forall a b. (a -> b) -> a -> b
$ STRef s a -> ST s a
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 (StateIdentifier -> VGNode
VGNode StateIdentifier
p) Set VGEdge
inSet Set VGEdge
outSet a
sol0
                            ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ STRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
resRef a
sol1
                            [VGEdge]
-> (VGEdge -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set VGEdge -> [VGEdge]
forall a. Set a -> [a]
Set.elems Set VGEdge
outSet) ((VGEdge -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
 -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> (VGEdge -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ \(VGEdge StateIdentifier
edge) ->
                              case StateIdentifier
-> IntMap (VGNode, VGNode) -> Maybe (VGNode, VGNode)
forall a. StateIdentifier -> IntMap a -> Maybe a
IntMap.lookup StateIdentifier
edge IntMap (VGNode, VGNode)
edgesInfo of
                                Maybe (VGNode, VGNode)
Nothing            -> () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just (VGNode
_,VGNode StateIdentifier
to) -> ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall s a. ST s a -> VG s a
vgInST (ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ())
-> ST s () -> ErrorT [Char] (StateT (VGState s) (ST s)) ()
forall a b. (a -> b) -> a -> b
$ STRef s [StateIdentifier]
-> ([StateIdentifier] -> [StateIdentifier]) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s [StateIdentifier]
pendingRef (StateIdentifier
to StateIdentifier -> [StateIdentifier] -> [StateIdentifier]
forall a. a -> [a] -> [a]
:)
            ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore
  ErrorT [Char] (StateT (VGState s) (ST s)) ()
explore
  ST s a -> VG s a
forall s a. ST s a -> VG s a
vgInST (ST s a -> VG s a) -> ST s a -> VG s a
forall a b. (a -> b) -> a -> b
$ STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef STRef s a
resRef

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

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

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