Working with interfaces and incomplete modules.

src/GF/Compile/CheckGrammar.hs

@@ -37,24 +37,28 @@ showCheckModule mos m = do
 checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
 checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
 
-  ModMod mo@(Module mt fs me ops js) -> case mt of
-    MTAbstract -> do
-      js' <- mapMTree (checkAbsInfo gr name) js
-      return $ (name, ModMod (Module mt fs me ops js')) : ms
+  ModMod mo@(Module mt st fs me ops js) -> do
+    js' <- case mt of
+      MTAbstract -> mapMTree (checkAbsInfo gr name) js
 
-    MTTransfer a b -> do
-      js' <- mapMTree (checkAbsInfo gr name) js
-      return $ (name, ModMod (Module mt fs me ops js')) : ms
+      MTTransfer a b -> mapMTree (checkAbsInfo gr name) js
 
-    MTResource -> do
-      js' <- mapMTree (checkResInfo gr) js
-      return $ (name, ModMod (Module mt fs me ops js')) : ms
+      MTResource -> mapMTree (checkResInfo gr) js
+
+      MTConcrete a -> do
+        ModMod abs <- checkErr $ lookupModule gr a
+        checkCompleteGrammar abs mo
+        mapMTree (checkCncInfo gr name (a,abs)) js
+
+      MTInterface -> mapMTree (checkResInfo gr) js
+
+      MTInstance a -> do
+        ModMod abs <- checkErr $ lookupModule gr a
+        checkCompleteInstance abs mo
+        mapMTree (checkResInfo gr) js
+
+    return $ (name, ModMod (Module mt st fs me ops js')) : ms
 
-    MTConcrete a -> do
-      ModMod abs <- checkErr $ lookupModule gr a
-      checkCompleteGrammar abs mo
-      js' <- mapMTree (checkCncInfo gr name (a,abs)) js
-      return $ (name, ModMod (Module mt fs me ops js')) : ms
   _ -> return $ (name,mod) : ms
  where
    gr  = MGrammar $ (name,mod):ms
@@ -87,6 +91,18 @@ checkCompleteGrammar abs cnc = mapM_ checkWarn $
                       then id
                       else (("Warning: no linearization of" +++ prt f):)
 
+checkCompleteInstance :: SourceRes -> SourceRes -> Check ()
+checkCompleteInstance abs cnc = mapM_ checkWarn $
+  checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
+   where
+     abs' = tree2list $ jments abs
+     cnc' = mapTree fst $ jments cnc
+     checkComplete sought given = foldr ckOne [] sought
+       where
+         ckOne f = if isInBinTree f given 
+                      then id
+                      else (("Warning: no definition given to" +++ prt f):)
+
 -- General Principle: only Yes-values are checked. 
 -- A May-value has always been checked in its origin module.
 

src/GF/Compile/Compile.hs

@@ -144,8 +144,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
  where
    putp = putPointE opts
 
-compileSourceModule :: Options -> CompileEnv -> SourceModule -> 
-                       IOE (Int,SourceModule)
+compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
 compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
   let putp = putPointE opts
@@ -158,7 +157,7 @@ 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:_ <- putp "  optimizing " $ ioeErr $ evalModule mos mo3r
 
   return (k',mo4)
 
@@ -172,16 +171,16 @@ generateModuleCode opts path minfo@(name,info) = do
 
   -- for resource, also emit gfr
   case info of
-    ModMod m | mtype m == MTResource && emit && nomulti -> do
+    ModMod m | isResourceModule info && isCompilableModule info && emit && nomulti -> do
       let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
       ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
     _ -> return ()
   (file,out) <- do
       code <- return $ MkGFC.prCanonModInfo minfo'
       return (gfcFile pname, code)
-  if emit && nomulti 
+  if isCompilableModule info && emit && nomulti 
      then ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
-     else return ()
+     else ioeIO $ putStrFlush "no need to save for this module "
   return minfo'
  where 
    nomulti = not $ oElem makeMulti opts

src/GF/Compile/Extend.hs

@@ -17,10 +17,10 @@ import Monad
 
 extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo
 extendModInfo name old new = case (old,new) of
-  (ModMod m0, ModMod (Module mt fs _ ops js)) -> do
+  (ModMod m0, ModMod (Module mt st fs _ ops js)) -> do
     testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name)
     js' <- extendMod name (jments m0) js
-    return $ ModMod (Module mt fs Nothing ops js)
+    return $ ModMod (Module mt st fs Nothing ops js)
 
 -- this is what happens when extending a module: new information is inserted,
 -- and the process is interrupted if unification fails

src/GF/Compile/GrammarToCanon.hs

@@ -28,7 +28,10 @@ showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
 -- abstract syntax without dependent types
 
 redGrammar :: SourceGrammar -> Err C.CanonGrammar
-redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr
+redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
+  active (_,m) = case typeOfModule m of
+    MTInterface -> False
+    _ -> True
 
 redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
 redModInfo (c,info) = do
@@ -43,19 +46,25 @@ redModInfo (c,info) = do
            return (a', MTConcrete a') 
          MTAbstract -> return (c',MTAbstract) --- c' not needed
          MTResource -> return (c',MTResource) --- c' not needed
+         MTInterface -> return (c',MTResource) ---- not needed
+         MTInstance _ -> return (c',MTResource) --- c' not needed
          MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
-      defss <- mapM (redInfo a) $ tree2list $ jments m
+
+      ---- this generates empty GFC. Better: none 
+      let js = if mstatus m == MSIncomplete then NT else jments m
+
+      defss <- mapM (redInfo a) $ tree2list $ js
       defs  <- return $ sorted2tree $ concat defss  -- sorted, but reduced
-      return $ ModMod $ Module mt flags e os defs
+      return $ ModMod $ Module mt MSComplete flags e os defs
   return (c',info')
  where
    redExtOpen m = do
      e' <- case extends m of
        Just e -> liftM Just $ redIdent e
        _ -> return Nothing
-     os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
+     os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m
      return (e',os')
-   om = OSimple . openedModule --- normalizing away qualif
+   om = oSimple . openedModule --- normalizing away qualif
 
 redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
 redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do

src/GF/Compile/MkResource.hs

@@ -30,7 +30,7 @@ makeReuse gr r me c = do
       _ -> prtBad "expected concrete to be the type of" c
     _ -> prtBad "expected concrete to be the type of" c
 
-  return $ Module MTResource flags me ops jms
+  return $ Module MTResource MSComplete flags me ops jms
 
 mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
              BinTree (Ident,Info) -> BinTree (Ident,Info) -> 

src/GF/Compile/ModDeps.hs

@@ -39,7 +39,7 @@ checkUniqueErr ms = do
 
 checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
 checkUniqueImportNames ns mo = case mo of
-  ModMod m -> test [n | OQualif n v <- opens m, n /= v]
+  ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
 
  where
 
@@ -80,7 +80,7 @@ moduleDeps ms = mapM deps ms where
   -- check for superficial compatibility, not submodule relation etc
   compatMType mt0 mt = case (mt0,mt) of
     (MTConcrete _, MTConcrete _) -> True
-    (MTResourceImpl _, MTResourceImpl _) -> True
+    (MTInstance _, MTInstance _) -> True
     (MTReuse _, MTReuse _) -> True
     ---- some more
     _ -> mt0 == mt

src/GF/Compile/Optimize.hs

@@ -29,7 +29,7 @@ evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
                Err [(Ident,SourceModInfo)]
 evalModule ms mo@(name,mod) = case mod of
 
-  ModMod (Module mt fs me ops js) -> case mt of
+  ModMod (Module mt st fs me ops js) | st == MSComplete -> case mt of
     MTResource -> do
       let deps = allOperDependencies name js
       ids <- topoSortOpers deps
@@ -37,9 +37,10 @@ evalModule ms mo@(name,mod) = case mod of
       return $ mod' : ms
     MTConcrete a -> do
       js' <- mapMTree (evalCncInfo gr0 name a) js
-      return $ (name, ModMod (Module mt fs me ops js')) : ms
+      return $ (name, ModMod (Module mt st fs me ops js')) : ms
 
     _ -> return $ (name,mod):ms
+  _ -> return $ (name,mod):ms
  where
    gr0 = MGrammar $ ms
    gr  = MGrammar $ (name,mod) : ms

src/GF/Compile/RemoveLiT.hs

@@ -21,9 +21,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 fs me ops js) -> do
+  ModMod (Module mt st fs me ops js) -> do
     js1 <- mapMTree (remlResInfo gr) js
-    let mod2 = ModMod $ Module mt fs me ops js1
+    let mod2 = ModMod $ Module mt st fs me ops js1
     return $ (name,mod2)
   _ -> return mi
 

src/GF/Compile/Rename.hs

@@ -32,17 +32,17 @@ renameSourceTerm g m t = do
 
 renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
 renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
-  ModMod (Module mt fs me ops js) -> do
+  ModMod (Module mt st fs me ops js) -> do
     (_,mod1@(ModMod m)) <- extendModule ms (name,mod)
     let js1 = jments m
     status <- buildStatus (MGrammar ms) name mod1
     js2    <- mapMTree (renameInfo status) js1
-    let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2
+    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
     return $ (name,mod2) : ms
 
 extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
 extendModule ms (name,mod) = case mod of
-  ModMod (Module mt fs me ops js0) -> do
+  ModMod (Module mt st fs me ops js0) -> do
     js  <- case mt of
 {- --- building the {s : Str} lincat
       MTConcrete a -> do
@@ -62,7 +62,7 @@ extendModule ms (name,mod) = case mod of
           _ -> Bad $ "cannot find extended module" +++ prt n
         extendMod n (jments m0) js
       _ -> return js
-    return $ (name,ModMod (Module mt fs me ops js1))
+    return $ (name,ModMod (Module mt st fs me ops js1))
 
 
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
@@ -91,9 +91,9 @@ renameIdentTerm env@(act,imps) t =
     return $ f c
   _ -> return t
  where
-   opens   = act : [st  | (OSimple _,st) <- imps]
-   qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
-             [(m, st) | (OSimple m, st) <- imps] -- qualifying is always possible
+   opens   = act : [st  | (OSimple _ _,st) <- imps]
+   qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ 
+             [(m, st) | (OSimple _ m, st) <- imps] -- qualifying is always possible
 
 --- would it make sense to optimize this by inlining?
 renameIdentPatt :: Status -> Patt -> Err Patt
@@ -114,14 +114,14 @@ info2status mq (c,i) = (c, case i of
 
 tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
 tree2status o = case o of
-  OSimple i   -> mapTree (info2status (Just i))
-  OQualif i j -> mapTree (info2status (Just j))
+  OSimple _ i   -> mapTree (info2status (Just i))
+  OQualif _ i j -> mapTree (info2status (Just j))
 
 buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
 buildStatus gr c mo = let mo' = self2status c mo in case mo of
   ModMod m -> do
     let gr1 = MGrammar $ (c,mo) : modules gr 
-        ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens m
+        ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m
     mods <- mapM (lookupModule gr1 . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc m
@@ -144,8 +144,8 @@ self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
     _ -> True
 
 forceQualif o = case o of
-  OSimple i   -> OQualif i i
-  OQualif _ i -> OQualif i i
+  OSimple q i   -> OQualif q i i
+  OQualif q _ i -> OQualif q i i
   
 renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
 renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $