resources and new instantiation syntax

src/GF/Compile/Compile.hs

@@ -165,12 +165,13 @@ extendCompileEnvCanon ((k,s,c),fts) cgr ft =
 type TimedCompileEnv = (CompileEnv,[(FilePath,ModTime)])
 
 compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
-compileOne opts env file = do
+compileOne opts env@((_,srcgr,_),_) file = do
 
   let putp = putPointE opts
   let gf   = fileSuffix file
   let path = justInitPath file
   let name = fileBody file
+  let mos  = modules srcgr
 
   case gf of
     -- for multilingual canonical gf, just read the file and update environment
@@ -188,12 +189,13 @@ compileOne opts env file = do
 
     -- for compiled resource, parse and organize, then update environment
     "gfr" -> do
-       sm0  <- putp ("| parsing" +++ file) $ getSourceModule file
-       let mos = case env of ((_,gr,_),_) -> modules gr
+       sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
        sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
+---- experiment with not optimizing gfr 
+----      sm:_  <- putp "  optimizing " $ ioeErr $ evalModule mos sm1
        let gfc = gfcFile name 
-       cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
-       ft <- getReadTimes file
+       cm  <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
+       ft  <- getReadTimes file
        extendCompileEnv env (sm,cm) ft
 
     -- for gf source, do full compilation
@@ -202,7 +204,12 @@ compileOne opts env file = do
        (k',sm)  <- makeSourceModule opts (fst env) sm0
        cm  <- putp "  generating code... " $ generateModuleCode opts path sm
        ft <- getReadTimes file
-       extendCompileEnvInt env (k',sm,cm) ft
+
+       sm':_ <- case snd sm of
+----         ModMod n | isModRes n -> putp "  optimizing " $ ioeErr $ evalModule mos sm
+         _ -> return [sm]
+
+       extendCompileEnvInt env (k',sm',cm) ft
 
 -- dispatch reused resource at early stage
 
@@ -255,8 +262,11 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
       (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
 
-      mo4:_ <- putp "  optimizing " $ ioeErr $ evalModule mos mo3r
-
+      mo4:_ <- 
+----        case snd mo1b of
+----          ModMod n | isModCnc n -> 
+        putp "  optimizing " $ ioeErr $ evalModule mos mo3r
+----        _ -> return [mo3r]
       return (k',mo4)
  where
    ----   prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug

src/GF/Compile/Extend.hs

@@ -31,6 +31,12 @@ import Monad
 
 extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
 extendModule ms (name,mod) = case mod of
+
+  ---- Just to allow inheritance in incomplete concrete (which are not
+  ---- compiled anyway), extensions are not built for them.
+  ---- Should be replaced by real control. AR 4/2/2005
+  ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
+
   ModMod m -> do
     mod' <- foldM extOne m (extends m) 
     return (name,ModMod mod') 
@@ -42,10 +48,11 @@ extendModule ms (name,mod) = case mod of
           -- test that the module types match, and find out if the old is complete
           testErr (sameMType (mtype m) mt) 
                     ("illegal extension type to module" +++ prt name)
-          return (m,isCompleteModule m)
+          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 (jments m0) js
+        js1 <- extendMod isCompl n name (jments m0) js
 
         -- if incomplete, throw away extension information
         let me' = if isCompl then es else (filter (/=n) es) 
@@ -55,11 +62,11 @@ extendModule ms (name,mod) = case mod of
 -- and the process is interrupted if unification fails.
 -- If the extended module is incomplete, its judgements are just copied.
 
-extendMod :: Bool -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
-extendMod isCompl name old new = foldM try new $ tree2list old where
+extendMod isCompl name base old new = foldM try new $ tree2list old where
   try t i@(c,_) = errIn ("constant" +++ prt c) $
-                  tryInsert (extendAnyInfo isCompl name) indirIf t i
+                  tryInsert (extendAnyInfo isCompl name base) indirIf t i
   indirIf = if isCompl then indirInfo name else id
 
 indirInfo :: Ident -> Info -> Info
@@ -76,8 +83,9 @@ perhIndir n p = case p of
   Yes _ -> May n
   _ -> p
 
-extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
-extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
+extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc n o i j = 
+ errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
   (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
     liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs
   (AbsFun mt1 md1, AbsFun mt2 md2) -> 
@@ -107,7 +115,8 @@ extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j
 
 --- where
    
-updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n)
+updn isc n = if isc  then (updatePerhaps n) else (updatePerhapsHard n)
+updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n)
 
 
 

src/GF/Compile/Rebuild.hs

@@ -9,7 +9,7 @@
 -- > CVS $Author $
 -- > CVS $Revision $
 --
--- (Description of the module)
+-- Rebuild a source module from incomplete and its with-instance.
 -----------------------------------------------------------------------------
 
 module Rebuild where
@@ -45,7 +45,7 @@ rebuildModule ms mo@(i,mi) = do
           m1 <- lookupModMod gr i0
           testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
           m' <- do
-            js' <- extendMod False i0 (jments m1) (jments m)
+            js' <- extendMod False i0 i (jments m1) (jments m)
             --- to avoid double inclusions, in instance I of I0 = J0 ** ...
             case extends m of
               [] -> return $ replaceJudgements m js'
@@ -60,14 +60,14 @@ rebuildModule ms mo@(i,mi) = do
         _ -> return mi
 
     -- add the instance opens to an incomplete module "with" instances
-    ModWith mt stat ext ops -> do
+    ModWith mt stat ext me 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 <- lookupModMod gr ext
       let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
                      ++ [oQualif i i | i <- map snd insts] ----
                      ++ [oSimple i   | i <- map snd insts] ----