thread EEnv into ShellState

5 files changed, 70 insertions, 58 deletions

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