GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki 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
| fileSuffix f == "gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f
| otherwise = do
((_,_,gr),_) <- compileModule os emptyShellState f
((_,_,gr,_),_) <- compileModule os emptyShellState f
ioeErr $ grammar2stateGrammar os gr
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.Compile.CheckGrammar
import GF.Compile.Optimize
import GF.Compile.Evaluate
import GF.Compile.GrammarToCanon
import GF.Canon.Share
import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
@@ -93,10 +94,10 @@ compileModule opts st0 file |
where
suff = fileSuffix file
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
ft <- getReadTimes file ---
extendCompileEnvInt env (k',sm,cm) ft
extendCompileEnvInt env (k',sm,cm) eenv' ft
compileModule opts1 st0 file = do
opts0 <- ioeIO $ getOptionsFromFile file
@@ -130,12 +131,13 @@ getReadTimes file = do
return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
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]
sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
notInc i = notElem (prt i) $ map fileBody fs
notIns i = notElem (prt i) $ map fileBody fs
fts = readFiles st
eenv = evalEnv st
pathListOpts :: Options -> FileName -> IO [InitPath]
pathListOpts opts file = return $ maybe [file] pFilePaths $ getOptVal opts pathList
@@ -150,23 +152,23 @@ keepResModules opts gr =
-- | the environment
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
emptyCompileEnv :: TimedCompileEnv
emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar),[])
emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
extendCompileEnvInt ((_,MGrammar ss, MGrammar cs),fts) (k,sm,cm) ft =
return ((k,MGrammar (sm:ss), MGrammar (cm:cs)),ft++fts) --- reverse later
extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft =
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 =
return ((k,s, MGrammar (modules cgr ++ modules c)),ft++fts)
extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft =
return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
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 putpp = putPointEsil opts
@@ -185,7 +187,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
"gfcm" -> do
cgr <- putp ("+ reading" +++ file) $ getCanonGrammar 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
"gfc" -> do
@@ -193,7 +195,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
let cancgr = updateMGrammar (MGrammar [cm]) cancgr0
sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
ft <- getReadTimes file
extendCompileEnv env (sm, cm) ft
extendCompileEnv env (sm, cm) eenv ft
-- for compiled resource, parse and organize, then update environment
"gfr" -> do
@@ -204,7 +206,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file
extendCompileEnv env (sm,cm) ft
extendCompileEnv env (sm,cm) eenv ft
-- for gf source, do full compilation
@@ -219,7 +221,7 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ 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
ft <- getReadTimes file
@@ -227,11 +229,12 @@ compileOne opts env@((_,srcgr,cancgr0),_) file = do
---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
_ -> return [sm]
extendCompileEnvInt env (k',sm',cm) ft
extendCompileEnvInt env (k',sm',cm) eenv' ft
-- | dispatch reused resource at early stage
makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
makeSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule,EEnv)
makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
ModMod m -> case mtype m of
MTReuse c -> do
@@ -239,7 +242,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
let mo2 = (i, ModMod sm)
mos = modules gr
--- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2
return $ (k,mo2)
return $ (k,mo2,eenv)
{- ---- obsolete
MTUnion ty imps -> do
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
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
SourceModule -> IOE (Int,SourceModule,EEnv)
compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
let putp = putPointE opts
putpp = putPointEsil opts
@@ -271,7 +274,7 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
case mo1b of
(_,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
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
mo4 <-
(mo4,eenv') <-
---- if oElem "check_only" opts
putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
return (k',mo4)
putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
return (k',mo4,eenv')
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
@@ -346,7 +349,7 @@ compileOld opts file = do
let putp = putPointE opts
grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
files <- mapM writeNewGF $ modules grammar1
((_,_,grammar),_) <- foldM (compileOne opts) emptyCompileEnv files
((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
return grammar
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.
-----------------------------------------------------------------------------
module GF.Compile.Evaluate (appEvalConcrete) where
module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
import GF.Data.Operations
import GF.Grammar.Grammar
@@ -98,7 +98,7 @@ apps t = case t of
App f a -> (f',xs ++ [a]) where (f',xs) = apps f
_ -> (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 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'
(RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
(_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
_ -> return $ ExtR r' s'
-- 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.
-- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
Err (Ident,SourceModInfo)
optimizeModule opts ms mo@(_,mi) = case mi of
optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) |
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
mo1 <- evalModule oopts ms mo
return $ case optim of
(mo1,_) <- evalModule oopts mse mo
let
mo2 = case optim of
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
"share" -> shareModule shareOpt mo1 -- sharing of branches
"all" -> shareModule allOpt mo1 -- first parametrize then values
"none" -> mo1 -- no optimization
_ -> mo1 -- none; default for src
_ -> evalModule oopts ms mo
return (mo2,eenv)
_ -> evalModule oopts mse mo
where
oopts = addOptions opts (iOpts (flagsModule mo))
optim = maybe "all" id $ getOptVal oopts useOptimizer
evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
Err (Ident,SourceModInfo)
evalModule oopts ms mo@(name,mod) = case mod of
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
_ | isModRes m0 && not (oElem oEval oopts) -> do
let deps = allOperDependencies name js
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ mod'
return $ (mod',eenv)
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
return $ (name, ModMod (Module mt st fs me ops js'))
return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
MTConcrete a -> do
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)
_ -> return $ ((name,mod),eenv)
_ -> return $ ((name,mod),eenv)
where
gr0 = MGrammar $ 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.Grammar.LookAbs
import GF.Compile.ModDeps
import GF.Compile.Evaluate
import qualified GF.Infra.Modules as M
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as P
@@ -76,8 +77,9 @@ data ShellState = ShSt {
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
-- functions to them,
-- functions on them)
statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)] -- ^ transfer modules
statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)], -- ^ transfer modules
evalEnv :: EEnv -- ^ evaluation environment
}
type Treebank = Map.Map String [String] -- string, trees
@@ -118,7 +120,8 @@ emptyShellState = ShSt {
readFiles = [],
absCats = [],
statistics = [],
transfers = []
transfers = [],
evalEnv = emptyEEnv
}
optInitShellState :: Options -> ShellState
@@ -198,14 +201,13 @@ cncModuleIdST = stateGrammarST
-- | form a shell state from a canonical grammar
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
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
updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState ->
((Int,G.SourceGrammar,CanonGrammar),[(String,(FilePath,ModTime))]) ->
---- (CanonGrammar,(G.SourceGrammar,[(String,(FilePath,ModTime))])) ->
Err ShellState
updateShellState opts ign mcnc sh ((_,sgr,gr),rts) = do
((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
Err ShellState
updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let cgr0 = M.updateMGrammar (canModules sh) gr
-- 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,
absCats = csi,
statistics = [StDepTypes deps,StBoundVars binds],
transfers = transfers sh
transfers = transfers sh,
evalEnv = eenv
}
prShellStateInfo :: ShellState -> String
@@ -335,7 +338,8 @@ purgeShellState sh = ShSt {
readFiles = [],
absCats = absCats sh,
statistics = statistics sh,
transfers = transfers sh
transfers = transfers sh,
evalEnv = emptyEEnv
}
where
abstr = abstract sh
@@ -347,17 +351,17 @@ purgeShellState sh = ShSt {
complete = not . isIncompleteCanon
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) =
return (ShSt Nothing Nothing [] 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 ee)
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
Just _ -> do
a <- M.abstractOfConcrete ms c
let cas = M.allConcretes ms a
let cs' = [((c,c),True) | c <- cas]
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
-- | form just one state grammar, if unique, from a canonical grammar