msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

thread EEnv into ShellState

Browse Source
This commit is contained in:
aarne
2006-11-12 13:24:13 +00:00
parent 69dba72a3e
commit 52bb034d8e
5 changed files with 70 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GF/API.hs
View File

@@ -154,7 +154,7 @@ optFile2grammar :: Options -> FilePath -> IOE GFGrammar
optFile2grammar os f optFile2grammar os f
| fileSuffix f == "gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f | fileSuffix f == "gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f
| otherwise = do | otherwise = do
((_,_,gr),_) <- compileModule os emptyShellState f ((_,_,gr,_),_) <- compileModule os emptyShellState f
ioeErr $ grammar2stateGrammar os gr ioeErr $ grammar2stateGrammar os gr
optFile2grammarE :: Options -> FilePath -> IOE GFGrammar optFile2grammarE :: Options -> FilePath -> IOE GFGrammar

55
src/GF/Compile/Compile.hs
View File

@@ -36,6 +36,7 @@ import GF.Compile.Rename
import GF.Grammar.Refresh import GF.Grammar.Refresh
import GF.Compile.CheckGrammar import GF.Compile.CheckGrammar
import GF.Compile.Optimize import GF.Compile.Optimize
import GF.Compile.Evaluate
import GF.Compile.GrammarToCanon import GF.Compile.GrammarToCanon
import GF.Canon.Share import GF.Canon.Share
import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
@@ -93,10 +94,10 @@ compileModule opts st0 file |
where where
suff = fileSuffix file suff = fileSuffix file
comp putpp path env sm0 = do comp putpp path env sm0 = do
(k',sm) <- makeSourceModule opts (fst env) sm0 (k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file --- ft <- getReadTimes file ---
extendCompileEnvInt env (k',sm,cm) ft extendCompileEnvInt env (k',sm,cm) eenv' ft
compileModule opts1 st0 file = do compileModule opts1 st0 file = do
opts0 <- ioeIO $ getOptionsFromFile file opts0 <- ioeIO $ getOptionsFromFile file
@@ -130,12 +131,13 @@ getReadTimes file = do
return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)] return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
compileEnvShSt st fs = ((0,sgr,cgr),fts) where compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where
cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
notInc i = notElem (prt i) $ map fileBody fs notInc i = notElem (prt i) $ map fileBody fs
notIns i = notElem (prt i) $ map fileBody fs notIns i = notElem (prt i) $ map fileBody fs
fts = readFiles st fts = readFiles st
eenv = evalEnv st
pathListOpts :: Options -> FileName -> IO [InitPath] pathListOpts :: Options -> FileName -> IO [InitPath]
pathListOpts opts file = return $ maybe [file] pFilePaths $ getOptVal opts pathList pathListOpts opts file = return $ maybe [file] pFilePaths $ getOptVal opts pathList
@@ -150,23 +152,23 @@ keepResModules opts gr =
-- | the environment -- | the environment
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar) type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
emptyCompileEnv :: TimedCompileEnv emptyCompileEnv :: TimedCompileEnv
emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar),[]) emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
extendCompileEnvInt ((_,MGrammar ss, MGrammar cs),fts) (k,sm,cm) ft = extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft =
return ((k,MGrammar (sm:ss), MGrammar (cm:cs)),ft++fts) --- reverse later return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later
extendCompileEnv e@((k,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm) extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
extendCompileEnvCanon ((k,s,c),fts) cgr ft = extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft =
return ((k,s, MGrammar (modules cgr ++ modules c)),ft++fts) return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))]) type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
compileOne opts env@((_,srcgr,cancgr0),_) file = do compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do
let putp = putPointE opts let putp = putPointE opts
let putpp = putPointEsil opts let putpp = putPointEsil opts
@@ -185,7 +187,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
"gfcm" -> do "gfcm" -> do
cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
ft <- getReadTimes file ft <- getReadTimes file
extendCompileEnvCanon env cgr ft extendCompileEnvCanon env cgr eenv ft
-- for canonical gf, read the file and update environment, also source env -- for canonical gf, read the file and update environment, also source env
"gfc" -> do "gfc" -> do
@@ -193,7 +195,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 let cancgr = updateMGrammar (MGrammar [cm]) cancgr0
sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
ft <- getReadTimes file ft <- getReadTimes file
extendCompileEnv env (sm, cm) ft extendCompileEnv env (sm, cm) eenv ft
-- for compiled resource, parse and organize, then update environment -- for compiled resource, parse and organize, then update environment
"gfr" -> do "gfr" -> do
@@ -204,7 +206,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
let gfc = gfcFile name let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file ft <- getReadTimes file
extendCompileEnv env (sm,cm) ft extendCompileEnv env (sm,cm) eenv ft
-- for gf source, do full compilation -- for gf source, do full compilation
@@ -219,7 +221,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file getSourceModule opts file
(k',sm) <- makeSourceModule opts (fst env) sm0 (k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file ft <- getReadTimes file
@@ -227,11 +229,12 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm ---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
_ -> return [sm] _ -> return [sm]
extendCompileEnvInt env (k',sm',cm) ft extendCompileEnvInt env (k',sm',cm) eenv' ft
-- | dispatch reused resource at early stage -- | dispatch reused resource at early stage
makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) makeSourceModule :: Options -> CompileEnv ->
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of SourceModule -> IOE (Int,SourceModule,EEnv)
makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
ModMod m -> case mtype m of ModMod m -> case mtype m of
MTReuse c -> do MTReuse c -> do
@@ -239,7 +242,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
let mo2 = (i, ModMod sm) let mo2 = (i, ModMod sm)
mos = modules gr mos = modules gr
--- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2
return $ (k,mo2) return $ (k,mo2,eenv)
{- ---- obsolete {- ---- obsolete
MTUnion ty imps -> do MTUnion ty imps -> do
mo' <- ioeErr $ makeUnion gr i ty imps mo' <- ioeErr $ makeUnion gr i ty imps
@@ -252,8 +255,8 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
putp = putPointE opts putp = putPointE opts
compileSourceModule :: Options -> CompileEnv -> compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule) SourceModule -> IOE (Int,SourceModule,EEnv)
compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
let putp = putPointE opts let putp = putPointE opts
putpp = putPointEsil opts putpp = putPointEsil opts
@@ -271,7 +274,7 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
case mo1b of case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do (_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed return (k,mo1b,eenv) -- refresh would fail, since not renamed
_ -> do _ -> do
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
@@ -280,10 +283,10 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
(k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
mo4 <- (mo4,eenv') <-
---- if oElem "check_only" opts ---- if oElem "check_only" opts
putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
return (k',mo4) return (k',mo4,eenv')
where where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
@@ -346,7 +349,7 @@ compileOld opts file = do
let putp = putPointE opts let putp = putPointE opts
grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
files <- mapM writeNewGF $ modules grammar1 files <- mapM writeNewGF $ modules grammar1
((_,_,grammar),_) <- foldM (compileOne opts) emptyCompileEnv files ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
return grammar return grammar
writeNewGF :: SourceModule -> IOE FilePath writeNewGF :: SourceModule -> IOE FilePath

7
src/GF/Compile/Evaluate.hs
View File

@@ -12,7 +12,7 @@
-- Computation of source terms. Used in compilation and in @cc@ command. -- Computation of source terms. Used in compilation and in @cc@ command.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Compile.Evaluate (appEvalConcrete) where module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar.Grammar import GF.Grammar.Grammar
@@ -98,7 +98,7 @@ apps t = case t of
App f a -> (f',xs ++ [a]) where (f',xs) = apps f App f a -> (f',xs ++ [a]) where (f',xs) = apps f
_ -> (t,[]) _ -> (t,[])
appEvalConcrete gr bt = liftM fst $ appSTM (evalConcrete gr bt) emptyEEnv appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env
evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info) evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
evalConcrete gr mo = mapMTree evaldef mo where evalConcrete gr mo = mapMTree evaldef mo where
@@ -350,6 +350,9 @@ evalConcrete gr mo = mapMTree evaldef mo where
(R rs, R ss) -> stmErr $ plusRecord r' s' (R rs, R ss) -> stmErr $ plusRecord r' s'
(RecType rs, RecType ss) -> stmErr $ plusRecType r' s' (RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
(_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
_ -> return $ ExtR r' s' _ -> return $ ExtR r' s'
-- case-expand tables -- case-expand tables

32
src/GF/Compile/Optimize.hs
View File

@@ -39,46 +39,48 @@ oEval = iOpt "eval"
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-- only do this for resource: concrete is optimized in gfc form -- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
Err (Ident,SourceModInfo) (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts ms mo@(_,mi) = case mi of optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) | ModMod m0@(Module mt st fs me ops js) |
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
mo1 <- evalModule oopts ms mo (mo1,_) <- evalModule oopts mse mo
return $ case optim of let
mo2 = case optim of
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
"values" -> shareModule valOpt mo1 -- tables as courses-of-values "values" -> shareModule valOpt mo1 -- tables as courses-of-values
"share" -> shareModule shareOpt mo1 -- sharing of branches "share" -> shareModule shareOpt mo1 -- sharing of branches
"all" -> shareModule allOpt mo1 -- first parametrize then values "all" -> shareModule allOpt mo1 -- first parametrize then values
"none" -> mo1 -- no optimization "none" -> mo1 -- no optimization
_ -> mo1 -- none; default for src _ -> mo1 -- none; default for src
_ -> evalModule oopts ms mo return (mo2,eenv)
_ -> evalModule oopts mse mo
where where
oopts = addOptions opts (iOpts (flagsModule mo)) oopts = addOptions opts (iOpts (flagsModule mo))
optim = maybe "all" id $ getOptVal oopts useOptimizer optim = maybe "all" id $ getOptVal oopts useOptimizer
evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err (Ident,SourceModInfo) Err ((Ident,SourceModInfo),EEnv)
evalModule oopts ms mo@(name,mod) = case mod of evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
_ | isModRes m0 && not (oElem oEval oopts) -> do _ | isModRes m0 && not (oElem oEval oopts) -> do
let deps = allOperDependencies name js let deps = allOperDependencies name js
ids <- topoSortOpers deps ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids MGrammar (mod' : _) <- foldM evalOp gr ids
return $ mod' return $ (mod',eenv)
MTConcrete a | oElem oEval oopts -> do MTConcrete a | oElem oEval oopts -> do
js0 <- appEvalConcrete gr js (js0,eenv') <- appEvalConcrete gr js eenv
js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005
return $ (name, ModMod (Module mt st fs me ops js')) return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
MTConcrete a -> do MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
return $ (name, ModMod (Module mt st fs me ops js')) return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
_ -> return $ (name,mod) _ -> return $ ((name,mod),eenv)
_ -> return $ (name,mod) _ -> return $ ((name,mod),eenv)
where where
gr0 = MGrammar $ ms gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms gr = MGrammar $ (name,mod) : ms

32
src/GF/Compile/ShellState.hs
View File

@@ -24,6 +24,7 @@ import GF.Canon.Look
import GF.Canon.Subexpressions import GF.Canon.Subexpressions
import GF.Grammar.LookAbs import GF.Grammar.LookAbs
import GF.Compile.ModDeps import GF.Compile.ModDeps
import GF.Compile.Evaluate
import qualified GF.Infra.Modules as M import qualified GF.Infra.Modules as M
import qualified GF.Grammar.Grammar as G import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as P import qualified GF.Grammar.PrGrammar as P
@@ -76,8 +77,9 @@ data ShellState = ShSt {
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts, [((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
-- functions to them, -- functions to them,
-- functions on them) -- functions on them)
statistics :: [Statistics], -- ^ statistics on grammars statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)] -- ^ transfer modules transfers :: [(Ident,T.Env)], -- ^ transfer modules
evalEnv :: EEnv -- ^ evaluation environment
} }
type Treebank = Map.Map String [String] -- string, trees type Treebank = Map.Map String [String] -- string, trees
@@ -118,7 +120,8 @@ emptyShellState = ShSt {
readFiles = [], readFiles = [],
absCats = [], absCats = [],
statistics = [], statistics = [],
transfers = [] transfers = [],
evalEnv = emptyEEnv
} }
optInitShellState :: Options -> ShellState optInitShellState :: Options -> ShellState
@@ -198,14 +201,13 @@ cncModuleIdST = stateGrammarST
-- | form a shell state from a canonical grammar -- | form a shell state from a canonical grammar
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
grammar2shellState opts (gr,sgr) = grammar2shellState opts (gr,sgr) =
updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr),[]) --- is 0 safe? updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe?
-- | update a shell state from a canonical grammar -- | update a shell state from a canonical grammar
updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState ->
((Int,G.SourceGrammar,CanonGrammar),[(String,(FilePath,ModTime))]) -> ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
---- (CanonGrammar,(G.SourceGrammar,[(String,(FilePath,ModTime))])) -> Err ShellState
Err ShellState updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
updateShellState opts ign mcnc sh ((_,sgr,gr),rts) = do
let cgr0 = M.updateMGrammar (canModules sh) gr let cgr0 = M.updateMGrammar (canModules sh) gr
-- a0 = abstract of old state -- a0 = abstract of old state
@@ -283,7 +285,8 @@ updateShellState opts ign mcnc sh ((_,sgr,gr),rts) = do
readFiles = [ft | ft@(_,(f,_)) <- readFiles sh, notInrts f] ++ rts, readFiles = [ft | ft@(_,(f,_)) <- readFiles sh, notInrts f] ++ rts,
absCats = csi, absCats = csi,
statistics = [StDepTypes deps,StBoundVars binds], statistics = [StDepTypes deps,StBoundVars binds],
transfers = transfers sh transfers = transfers sh,
evalEnv = eenv
} }
prShellStateInfo :: ShellState -> String prShellStateInfo :: ShellState -> String
@@ -335,7 +338,8 @@ purgeShellState sh = ShSt {
readFiles = [], readFiles = [],
absCats = absCats sh, absCats = absCats sh,
statistics = statistics sh, statistics = statistics sh,
transfers = transfers sh transfers = transfers sh,
evalEnv = emptyEEnv
} }
where where
abstr = abstract sh abstr = abstract sh
@@ -347,17 +351,17 @@ purgeShellState sh = ShSt {
complete = not . isIncompleteCanon complete = not . isIncompleteCanon
changeMain :: Maybe Ident -> ShellState -> Err ShellState changeMain :: Maybe Ident -> ShellState -> Err ShellState
changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs) = changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs) return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee)
changeMain changeMain
(Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs) = (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
case lookup c (M.modules ms) of case lookup c (M.modules ms) of
Just _ -> do Just _ -> do
a <- M.abstractOfConcrete ms c a <- M.abstractOfConcrete ms c
let cas = M.allConcretes ms a let cas = M.allConcretes ms a
let cs' = [((c,c),True) | c <- cas] let cs' = [((c,c),True) | c <- cas]
return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs
pinfos mos tbs pbs os rs acs s trs) pinfos mos tbs pbs os rs acs s trs ee)
_ -> P.prtBad "The state has no concrete syntax named" c _ -> P.prtBad "The state has no concrete syntax named" c
-- | form just one state grammar, if unique, from a canonical grammar -- | form just one state grammar, if unique, from a canonical grammar