added positions to Module record; avoided Module constructor where possible; moved Refresh to Compile/

src-3.0/GF/Compile/BackOpt.hs

@@ -34,8 +34,8 @@ type OptSpec = Set Optimization
 
 shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
 shareModule opt (i,m) = case m of
-  M.ModMod (M.Module mt st fs me ops js) -> 
-    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  M.ModMod mo -> 
+    (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
   _ -> (i,m)
 
 shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)

src-3.0/GF/Compile/CheckGrammar.hs

@@ -29,7 +29,7 @@ import GF.Infra.Modules
 
 import GF.Compile.TypeCheck
 
-import GF.Grammar.Refresh
+import GF.Compile.Refresh
 import GF.Grammar.Grammar
 import GF.Grammar.PrGrammar
 import GF.Grammar.Lookup
@@ -65,9 +65,10 @@ mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fs
 checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
 checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
 
-  ModMod mo@(Module mt st fs me ops js) -> do
+  ModMod mo -> do
+    let js = jments mo
     checkRestrictedInheritance ms (name, mo)
-    js' <- case mt of
+    js' <- case mtype mo of
       MTAbstract -> mapsCheckTree (checkAbsInfo gr name) js
 
       MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name) js
@@ -87,7 +88,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
         -- checkCompleteInstance abs mo -- this is done in Rebuild
         mapsCheckTree (checkResInfo gr name) js
 
-    return $ (name, ModMod (Module mt st fs me ops js')) : ms
+    return $ (name, ModMod (replaceJudgements mo js')) : ms
 
   _ -> return $ (name,mod) : ms
  where

src-3.0/GF/Compile/Compute.hs

@@ -24,7 +24,7 @@ import GF.Infra.Modules
 import GF.Grammar.Predef
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
-import GF.Grammar.Refresh
+import GF.Compile.Refresh
 import GF.Grammar.PatternMatch
 import GF.Grammar.Lockfield (isLockLabel) ----
 

src-3.0/GF/Compile/Extend.hs

@@ -40,22 +40,22 @@ extendModule ms (name,mod) = case mod of
     mod' <- foldM extOne m (extend m) 
     return (name,ModMod mod') 
  where
-   extOne mod@(Module mt st fs es ops js) (n,cond) = do
+   extOne mo (n,cond) = do
         (m0,isCompl) <- do
           m <- lookupModMod  (MGrammar ms) n
 
           -- test that the module types match, and find out if the old is complete
-          testErr (sameMType (mtype m) mt) 
+          testErr (sameMType (mtype m) (mtype mo)) 
                     ("illegal extension type to module" +++ prt name)
           return (m, isCompleteModule m)
-----       return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
 
         -- build extension in a way depending on whether the old module is complete
-        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) js
+        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
 
         -- if incomplete, throw away extension information
-        let me' = if isCompl then es else (filter ((/=n) . fst) es) 
-        return $ Module mt st fs me' ops js1
+        let es  = extend mo
+        let es' = if isCompl then es else (filter ((/=n) . fst) es) 
+        return $ mo {extend = es', jments = js1}
 
 -- | When extending a complete module: new information is inserted,
 -- and the process is interrupted if unification fails.

src-3.0/GF/Compile/GrammarToGFCC.hs

@@ -218,11 +218,12 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
 reorder :: Ident -> SourceGrammar -> SourceGrammar
 reorder abs cg = M.MGrammar $ 
     (abs, M.ModMod $ 
-          M.Module M.MTAbstract M.MSComplete aflags [] [] adefs):
+          M.Module M.MTAbstract M.MSComplete aflags [] [] adefs poss):
       [(c, M.ModMod $ 
-          M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js)) 
+          M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js) poss) 
             | (c,(fs,js)) <- cncs] 
      where
+       poss = emptyBinTree -- positions no longer needed
        mos = M.allModMod cg
        adefs = sorted2tree $ sortIds $
                  predefADefs ++ Look.allOrigInfos cg abs
@@ -268,8 +269,8 @@ canon2canon abs =
   js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
 
   c2c f2 (c,m) = case m of
-      M.ModMod mo@(M.Module _ _ _ _ _ js) ->
-        (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js)
+      M.ModMod mo ->
+        (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo))
       _ -> (c,m)    
   j2j cg (f,j) = case j of
       CncFun x (Yes tr) z -> (f,CncFun x (Yes (trace ("+ " ++ prt f) (t2t tr))) z)

src-3.0/GF/Compile/Optimize.hs

@@ -22,7 +22,7 @@ import GF.Grammar.PrGrammar
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
-import GF.Grammar.Refresh
+import GF.Compile.Refresh
 import GF.Compile.Compute
 import GF.Compile.BackOpt
 import GF.Compile.CheckGrammar
@@ -52,8 +52,7 @@ type EEnv = () --- not used
 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 -> do
+  ModMod m0 | mstatus m0 == MSComplete && isModRes m0 -> do
       (mo1,_) <- evalModule oopts mse mo
       let mo2 = shareModule optim mo1
       return (mo2,eenv)
@@ -66,16 +65,16 @@ 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
+  ModMod m0 | mstatus m0 == MSComplete -> case mtype m0 of
     _ | isModRes m0 -> do
-      let deps = allOperDependencies name js
+      let deps = allOperDependencies name (jments m0)
       ids <- topoSortOpers deps
       MGrammar (mod' : _) <- foldM evalOp gr ids
       return $ (mod',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')),eenv)
+      js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
+      return $ ((name, ModMod (replaceJudgements m0 js')),eenv)
 
     _ -> return $ ((name,mod),eenv)
   _ -> return $ ((name,mod),eenv)

src-3.0/GF/Compile/OptimizeGF.hs

@@ -47,8 +47,8 @@ unshareModule gr = processModule (const (unoptim gr))
 processModule :: 
   (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
 processModule opt (i,m) = case m of
-  M.ModMod (M.Module mt st fs me ops js) -> 
-    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  M.ModMod mo -> 
+    (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
   _ -> (i,m)
 
 shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m)
@@ -168,19 +168,20 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs.
 -}
 
 subexpModule :: SourceModule -> SourceModule
-subexpModule (mo,m) = errVal (mo,m) $ case m of
-  M.ModMod (M.Module mt st fs me ops js) -> do
-    (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0)
-    js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js
-    return (mo,M.ModMod (M.Module mt st fs me ops js2))
-  _ -> return (mo,m)
+subexpModule (n,m) = errVal (n,m) $ case m of
+  M.ModMod mo -> do
+    let ljs = tree2list (M.jments mo)
+    (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
+    js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
+    return (n,M.ModMod (M.replaceJudgements mo js2))
+  _ -> return (n,m)
 
 unsubexpModule :: SourceModule -> SourceModule
-unsubexpModule mo@(i,m) = case m of
-    M.ModMod (M.Module mt st fs me ops js) | hasSub ljs ->
-      (i, M.ModMod (M.Module mt st fs me ops 
+unsubexpModule sm@(i,m) = case m of
+    M.ModMod mo | hasSub ljs ->
+      (i, M.ModMod (M.replaceJudgements mo
                      (rebuild (map unparInfo ljs)))) 
-                        where ljs = tree2list js
+                        where ljs = tree2list (M.jments mo)
     _ -> (i,m)
   where
     -- perform this iff the module has opers
@@ -194,7 +195,7 @@ unsubexpModule mo@(i,m) = case m of
       Q m c | isOperIdent c -> --- name convention of subexp opers
         errVal t $ liftM unparTerm $ lookupResDef gr m c 
       _ -> C.composSafeOp unparTerm t
-    gr = M.MGrammar [mo] 
+    gr = M.MGrammar [sm] 
     rebuild = buildTree . concat
 
 -- implementation

src-3.0/GF/Compile/Rebuild.hs

@@ -62,14 +62,14 @@ rebuildModule ms mo@(i,mi) = do
 
     -- add the instance opens to an incomplete module "with" instances
     --      ModWith mt stat ext me ops -> do
-    ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
+    ModWith (Module mt stat fs_ me ops_ js_ ps_) (ext,incl) ops -> do
       let insts = [(inf,inst) | OQualif _ inf inst <- ops]
       let infs  = map fst insts
       let stat' = ifNull MSComplete (const MSIncomplete)
                     [i | i <- is, notElem i infs]
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ prt i +++ "remains incomplete")
-      Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
+      Module mt0 _ fs me' ops0 js ps0 <- lookupModMod gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    ops ++ [o | o <- ops0, notElem (openedModule o) infs]
@@ -80,7 +80,8 @@ rebuildModule ms mo@(i,mi) = do
       let fs1 = addModuleOptions fs fs_                           -- new flags have priority
       let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
       let js1 = buildTree (tree2list js_ ++ js0)
-      return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 
+      let ps1 = buildTree (tree2list ps_ ++ tree2list ps0)
+      return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 ps1 
                           ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
 
     _ -> return mi

src-3.0/GF/Compile/Refresh.hs

@@ -0,0 +1,133 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Refresh
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:27 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.Refresh (refreshTerm, refreshTermN,
+		refreshModule
+	       ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import Control.Monad
+
+refreshTerm :: Term -> Err Term
+refreshTerm = refreshTermN 0
+
+refreshTermN :: Int -> Term -> Err Term
+refreshTermN i e = liftM snd $ refreshTermKN i e
+
+refreshTermKN :: Int -> Term -> Err (Int,Term)
+refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (refresh e) (initIdStateN i)
+
+refresh :: Term -> STM IdState Term
+refresh e = case e of
+
+  Vr x    -> liftM  Vr  (lookVar x)
+  Abs x b -> liftM2 Abs (refVarPlus x)  (refresh b)
+
+  Prod x a b -> do
+    a'  <- refresh a
+    x'  <- refVar  x
+    b'  <- refresh b
+    return $ Prod x' a' b'
+
+  Let (x,(mt,a)) b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    x'  <- refVar x
+    b'  <- refresh b
+    return (Let (x',(mt',a')) b')
+
+  R r  -> liftM R $ refreshRecord r
+
+  ExtR r s -> liftM2 ExtR (refresh r)  (refresh s)
+  
+  T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
+
+  _ -> composOp refresh e
+
+refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
+refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
+
+refreshPatt p = case p of
+  PV x    -> liftM PV     (refVar x)
+  PC c ps -> liftM (PC c) (mapM refreshPatt ps)
+  PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
+  PR r    -> liftM PR     (mapPairsM refreshPatt r)
+  PT t p' -> liftM2 PT    (refresh t) (refreshPatt p')
+
+  PAs x p'   -> liftM2 PAs     (refVar x) (refreshPatt p')
+
+  PSeq p' q' -> liftM2 PSeq    (refreshPatt p') (refreshPatt q')
+  PAlt p' q' -> liftM2 PAlt    (refreshPatt p') (refreshPatt q')
+  PRep p'    -> liftM  PRep    (refreshPatt p')
+  PNeg p'    -> liftM  PNeg    (refreshPatt p')
+
+  _ -> return p
+
+refreshRecord r = case r of
+  [] -> return r
+  (x,(mt,a)):b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    b'  <- refreshRecord b
+    return $ (x,(mt',a')) : b'
+
+refreshTInfo i = case i of
+  TTyped t -> liftM TTyped $ refresh t
+  TComp t -> liftM TComp $ refresh t
+  TWild t -> liftM TWild $ refresh t
+  _ -> return i
+
+-- for abstract syntax
+
+refreshEquation :: Equation -> Err ([Patt],Term)
+refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
+  refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
+
+-- for concrete and resource in grammar, before optimizing
+
+refreshGrammar :: SourceGrammar -> Err SourceGrammar
+refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
+
+refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
+refreshModule (k,ms) mi@(i,m) = case m of
+    ModMod mo | (isModCnc mo || isModRes mo) -> do
+      (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
+      return (k', (i, ModMod(replaceJudgements mo (buildTree js'))) : ms)
+    _ -> return (k, mi:ms)
+ where
+  refreshRes (k,cs) ci@(c,info) = case info of
+    ResOper ptyp (Yes trm) -> do   ---- refresh ptyp
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, ResOper ptyp (Yes trm')):cs)
+    ResOverload tyts -> do
+      (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (mapPairsM refresh tyts) (initIdStateN k)
+      return $ (k', (c, ResOverload tyts'):cs)
+    CncCat mt (Yes trm) pn -> do   ---- refresh mt, pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncCat mt (Yes trm') pn):cs)
+    CncFun mt (Yes trm) pn -> do   ---- refresh pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncFun mt (Yes trm') pn):cs)
+    _ -> return (k, ci:cs)
+

src-3.0/GF/Compile/RemoveLiT.hs

@@ -34,9 +34,9 @@ removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
 
 remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
 remlModule gr mi@(name,mod) = case mod of
-  ModMod (Module mt st fs me ops js) -> do
-    js1 <- mapMTree (remlResInfo gr) js
-    let mod2 = ModMod $ Module mt st fs me ops js1
+  ModMod mo -> do
+    js1 <- mapMTree (remlResInfo gr) (jments mo)
+    let mod2 = ModMod $ mo {jments = js1}
     return $ (name,mod2)
   _ -> return mi
 

src-3.0/GF/Compile/Rename.hs

@@ -55,11 +55,11 @@ renameSourceTerm g m t = do
 
 renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
 renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
-  ModMod m@(Module mt st fs me ops js) -> do
-    let js1 = jments m
+  ModMod mo -> do
+    let js1 = jments mo
     status <- buildStatus (MGrammar ms) name mod
     js2    <- mapsErrTree (renameInfo status) js1
-    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
+    let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2}
     return $ (name,mod2) : ms
 
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])

src-3.0/GF/Compile/TypeCheck.hs

@@ -23,7 +23,7 @@ import GF.Data.Operations
 import GF.Data.Zipper
 
 import GF.Grammar.Abstract
-import GF.Grammar.Refresh
+import GF.Compile.Refresh
 import GF.Grammar.LookAbs
 import qualified GF.Grammar.Lookup as Lookup ---
 import GF.Grammar.Unify ---