diff --git a/lib/resource-1.0/mathematical/Symbol.gf b/lib/resource-1.0/mathematical/Symbol.gf index 5e0bc97d3..a198ad280 100644 --- a/lib/resource-1.0/mathematical/Symbol.gf +++ b/lib/resource-1.0/mathematical/Symbol.gf @@ -19,6 +19,11 @@ fun SymbS : Symb -> S ; -- A +--2 Symbols as numerals + + SymbNum : Symb -> Num ; -- n + SymbOrd : Symb -> Num ; -- n'th + --2 Symbol lists -- A symbol list has at least two elements. The last two are separated diff --git a/lib/resource-1.0/mathematical/SymbolEng.gf b/lib/resource-1.0/mathematical/SymbolEng.gf index aa0e09f4e..4b17a531a 100644 --- a/lib/resource-1.0/mathematical/SymbolEng.gf +++ b/lib/resource-1.0/mathematical/SymbolEng.gf @@ -15,6 +15,9 @@ lin SymbS sy = sy ; + SymbNum sy = sy ; + SymbOrd sy = {s = sy.s ++ "th"} ; + lincat Symb, [Symb] = SS ; diff --git a/src/GF/API.hs b/src/GF/API.hs index 950fed731..9eb60ef19 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -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 diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index ebdfe1054..13d2129b7 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -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 diff --git a/src/GF/Compile/Evaluate.hs b/src/GF/Compile/Evaluate.hs index bb5ece46b..1f8c328dc 100644 --- a/src/GF/Compile/Evaluate.hs +++ b/src/GF/Compile/Evaluate.hs @@ -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 diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index abaf4909c..0872cc5b2 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -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 diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index aabb11e34..3793b8651 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -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