Fixed reuse of extended modules.

src/GF/Compile/Compile.hs

@@ -166,7 +166,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
       sm <- ioeErr $ makeReuse gr i (extends m) c
       let mo2 = (i, ModMod sm)
           mos = modules gr
-      putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
+      --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
       return $ (k,mo2)
     _ -> compileSourceModule opts env mo
   _ -> compileSourceModule opts env mo
@@ -212,7 +212,7 @@ generateModuleCode opts path minfo@(name,info) = do
 
   -- for resource, also emit gfr
   case info of
-    ModMod m | isModRes m && isCompilable info && emit && nomulti -> do
+    ModMod m | emitsGFR m && emit && nomulti -> do
       let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
       ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
     _ -> return ()
@@ -224,6 +224,8 @@ generateModuleCode opts path minfo@(name,info) = do
      else ioeIO $ putStrFlush $ "no need to save module" +++ prt name
   return minfo'
  where 
+   emitsGFR m = isModRes m && isCompilable info
+     ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
    isCompilable mi = case mi of
      ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete 
      _ -> True

src/GF/Compile/MkResource.hs

@@ -26,49 +26,52 @@ makeReuse gr r me c = do
         jmsA <- case ma of 
            ModMod m' -> return $ jments m'
            _ -> prtBad "expected abstract to be the type of" a
-        liftM ((,) (opens m)) $ mkResDefs r a me (extends m) jmsA (jments m)
+        liftM ((,) (opens m)) $ mkResDefs gr r a me (extends m) jmsA (jments m)
       _ -> prtBad "expected concrete to be the type of" c
     _ -> prtBad "expected concrete to be the type of" c
 
   return $ Module MTResource MSComplete flags me ops jms
 
-mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
+mkResDefs :: SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
              BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
-mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where
+mkResDefs gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
 
-  mkOne (f,info) = case info of
+  mkOne a mae (f,info) = case info of
       AbsCat _ _ -> do
-        typ  <- err (const (return defLinType)) return $ look f
+        typ  <- err (const (return defLinType)) return $ look cnc f
         typ' <- lockRecType f typ 
         return (f, ResOper (Yes typeType) (Yes typ'))
       AbsFun (Yes typ0) _ -> do
-        trm <- look f
+        trm <- look cnc f
         testErr (not (isHardType typ0)) 
                 ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
-        typ <- redirTyp typ0
+        typ <- redirTyp True a mae typ0
         cat <- valCat typ
         trm' <- unlockRecord (snd cat) trm 
         return (f, ResOper (Yes typ) (Yes trm'))
-      AnyInd b _ -> case mext of
+      AnyInd b n -> do
-        Just ext -> return (f,AnyInd b ext)
+        mo    <- lookupModMod gr n
-        _ -> prtBad "no indirection possible in" r
+        info' <- lookupInfo mo f
+        mkOne n (extends mo) (f,info')
 
-  look f = do
+  look cnc f = do
      info <- lookupTree prt f cnc
      case info of
        CncCat (Yes ty) _ _ -> return ty
        CncCat _ _ _        -> return defLinType
        CncFun _ (Yes tr) _ -> return tr
+       AnyInd _ n -> do 
+         mo    <- lookupModMod gr n
+         t <- look (jments mo) f
+         redirTyp False n (extends mo) t
        _ -> prtBad "not enough information to reuse" f
 
   -- type constant qualifications changed from abstract to resource
-  redirTyp ty = case ty of
+  redirTyp always a mae ty = case ty of
-    Q n c | n == a -> return $ Q r c
+    Q _ c | always -> return $ Q r c
-    Q n c | Just n == maext -> case mext of
+    Q n c | n == a || Just n == mae -> return $ Q r c
-      Just ext -> return $ Q ext c
+    _ -> composOp (redirTyp always a mae) ty
-      _ -> prtBad "no indirection of type possible in" r
-    _ -> composOp redirTyp ty
 
 lockRecType :: Ident -> Type -> Err Type
 lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Tue Nov 18 17:18:44 CET 2003"
+module Today where today = "Wed Nov 19 17:07:15 CET 2003"