bug fix in the module dependencies checker

9 files changed, 73 insertions, 58 deletions

diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs
index c00b1bd67..e5ae611b5 100644
--- a/src/GF/Compile.hs
+++ b/src/GF/Compile.hs
@@ -173,7 +173,7 @@ compileOne opts env@(_,srcgr,_) file = do
           -- sm is optimized before generation, but not in the env
        extendCompileEnvInt env k' (Just gfo) sm1
   where
-   isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete && isNothing (mwith m)
+   isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
 
 compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
 compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index 4cf2101de..bb9310041 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -27,6 +27,7 @@ import GF.Grammar.Macros
 import GF.Data.Operations
 
 import Control.Monad
+import Data.List(nub)
 
 extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
 extendModule ms (name,m)
@@ -38,21 +39,25 @@ extendModule ms (name,m)
                                                  return (name,m')
  where
    extOne mo (n,cond) = do
-        (m0,isCompl) <- do
-          m <- lookupModule (MGrammar ms) n
+     m0 <- lookupModule (MGrammar ms) n
 
-          -- test that the module types match, and find out if the old is complete
-          testErr (sameMType (mtype m) (mtype mo)) 
-                    ("illegal extension type to module" +++ prt name)
-          return (m, isCompleteModule m)
+     -- test that the module types match, and find out if the old is complete
+     testErr (sameMType (mtype m) (mtype mo)) 
+             ("illegal extension type to module" +++ prt name)
 
-        -- build extension in a way depending on whether the old module is complete
-        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
+     let isCompl = isCompleteModule m0
 
-        -- if incomplete, throw away extension information
-        let es  = extend mo
-        let es' = if isCompl then es else (filter ((/=n) . fst) es) 
-        return $ mo {extend = es', jments = js1}
+     -- build extension in a way depending on whether the old module is complete
+     js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
+
+     -- if incomplete, throw away extension information
+     return $ 
+          if isCompl
+            then mo {jments = js1}
+            else mo {extend = filter ((/=n) . fst) (extend mo)
+                    ,mexdeps= nub (n : mexdeps mo)
+                    ,jments = js1
+                    }
 
 -- | When extending a complete module: new information is inserted,
 -- and the process is interrupted if unification fails.
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index 81029117d..e57191de2 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -223,8 +223,8 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
 
 reorder :: Ident -> SourceGrammar -> SourceGrammar
 reorder abs cg = M.MGrammar $ 
-    (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] adefs poss):
-      [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] (sorted2tree js) poss)
+    (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss):
+      [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss)
             | (c,(fs,js)) <- cncs] 
      where
        poss = emptyBinTree -- positions no longer needed
diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs
index de61d5e42..f8b6f9e51 100644
--- a/src/GF/Compile/ReadFiles.hs
+++ b/src/GF/Compile/ReadFiles.hs
@@ -179,6 +179,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
       depModType (mtype mi)  .
       depExtends (extend mi) .
       depWith    (mwith mi)  .
+      depExDeps  (mexdeps mi).
       depOpens   (opens mi)
 
     depModType (MTAbstract)       xs = xs
@@ -190,16 +191,22 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
 
     depExtends es xs = foldr depInclude xs es
 
-    depWith (Just (m,_,os)) xs = modName m : depOpens os xs
+    depWith (Just (m,_,is)) xs = modName m : depInsts is xs
     depWith Nothing         xs = xs
 
+    depExDeps eds xs = map modName eds ++ xs
+
     depOpens os xs = foldr depOpen xs os
 
+    depInsts is xs = foldr depInst xs is
+
     depInclude (m,_) xs = modName m:xs
 
     depOpen (OSimple n  ) xs = modName n:xs
     depOpen (OQualif _ n) xs = modName n:xs
 
+    depInst (m,n) xs = modName m:modName n:xs
+
     modName = prIdent
 
 -- | options can be passed to the compiler by comments in @--#@, in the main file
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 53f1ec0f1..8adf81824 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -32,62 +32,59 @@ import Data.Maybe (isNothing)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming. 
 -- AR 24/10/2003
 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
-rebuildModule ms mo@(i,mi) = do
+rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
   let gr = MGrammar ms
 ----  deps <- moduleDeps ms
 ----  is   <- openInterfaces deps i
   let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
-  mi'  <- case mi of
+  mi'  <- case mw of
 
     -- add the information given in interface into an instance module
-    m | isNothing (mwith m) -> do
-      testErr (null is || mstatus m == MSIncomplete) 
+    Nothing -> do
+      testErr (null is || mstatus mi == MSIncomplete) 
               ("module" +++ prt i +++ 
                "has open interfaces and must therefore be declared incomplete") 
-      case mtype m of
+      case mt of
         MTInstance i0 -> do
           m1 <- lookupModule gr i0
           testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
-          m' <- do
-            js' <- extendMod False (i0,const True) i (jments m1) (jments m)
-            --- to avoid double inclusions, in instance I of I0 = J0 ** ...
-            case extends m of
-              [] -> return $ replaceJudgements m js'
-              j0s -> do 
+          js' <- extendMod False (i0,const True) i (jments m1) (jments mi)
+          --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+          case extends mi of
+            []  -> return $ replaceJudgements mi js'
+            j0s -> do
                 m0s <- mapM (lookupModule gr) j0s
                 let notInM0 c _  = all (not . isInBinTree c . jments) m0s
                 let js2 = filterBinTree notInM0 js'
-                return $ (replaceJudgements m js2) 
+                return $ (replaceJudgements mi js2) 
                   {positions = 
                     buildTree (tree2list (positions m1) ++ 
-                               tree2list (positions m))}
---          checkCompleteInstance m1 m'
-          return m'
+                               tree2list (positions mi))}
         _ -> return mi
 
     -- add the instance opens to an incomplete module "with" instances
-    ModInfo mt stat fs_ me (Just (ext,incl,ops)) ops_ js_ ps_ -> do
-      let insts = [(inf,inst) | OQualif inf inst <- ops]
-      let infs  = map fst insts
+    Just (ext,incl,ops) -> do
+      let (infs,insts) = unzip ops
       let stat' = ifNull MSComplete (const MSIncomplete)
                     [i | i <- is, notElem i infs]
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ prt i +++ "remains incomplete")
-      ModInfo mt0 _ fs me' _ ops0 js ps0 <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
-                   ops ++ [o | o <- ops0, notElem (openedModule o) infs]
-                       ++ [OQualif i i | i <- map snd insts] ----
-                       ++ [OSimple i   | i <- map snd insts] ----
+                   [OQualif i j | (i,j) <- ops] ++
+                   [o | o <- ops0, notElem (openedModule o) infs] ++
+                   [OQualif i i | i <- insts] ++
+                   [OSimple i   | i <- insts]
 
       --- check if me is incomplete
       let fs1 = fs `addOptions` fs_                           -- new flags have priority
       let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
       let js1 = buildTree (tree2list js_ ++ js0)
       let ps1 = buildTree (tree2list ps_ ++ tree2list ps0)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 js1 ps1
+      let med1= nub (ext : infs ++ insts ++ med_)
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1
 
-    _ -> return mi
   return (i,mi')
 
 checkCompleteInstance :: SourceModInfo -> SourceModInfo -> Err ()
diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs
index cb2690425..65fbfcd89 100644
--- a/src/GF/Grammar/Binary.hs
+++ b/src/GF/Grammar/Binary.hs
@@ -31,9 +31,9 @@ instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where
   get               = fmap MGrammar get

 

 instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where

-  put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,jments mi,positions mi)

-  get    = do (mtype,mstatus,flags,extend,mwith,opens,jments,positions) <- get

-              return (ModInfo mtype mstatus flags extend mwith opens jments positions)

+  put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi)

+  get    = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get

+              return (ModInfo mtype mstatus flags extend mwith opens med jments positions)

 

 instance (Binary i) => Binary (ModuleType i) where

   put MTAbstract       = putWord8 0

@@ -264,5 +264,5 @@ instance Binary MetaSymb where
 

 decodeModHeader :: FilePath -> IO SourceModule

 decodeModHeader fpath = do

-  (m,mtype,mstatus,flags,extend,mwith,opens) <- decodeFile fpath

-  return (m,ModInfo mtype mstatus flags extend mwith opens Map.empty Map.empty)

+  (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath

+  return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty)

diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
index 7145ff33b..ef4508717 100644
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -25,7 +25,7 @@ import Data.Maybe (maybe)
 import Data.List  (intersperse)

 

 ppModule :: SourceModule -> Doc

-ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) =

+ppModule (mn, ModInfo mtype mstat opts exts with opens _ jments _) =

     (let defs = tree2list jments

      in if null defs

           then hdr

@@ -58,7 +58,7 @@ ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) =
       ppExtends (id,MIOnly   incs) = ppIdent id              <+> brackets (commaPunct ppIdent incs)

       ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)

       

-      ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppOpenSpec opens

+      ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens

 

 ppOptions opts = 

   text "flags" $$

@@ -210,6 +210,8 @@ ppLabel = ppIdent . label2ident
 ppOpenSpec (OSimple id)   = ppIdent id

 ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)

 

+ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)

+

 ppLocDef (id, (mbt, e)) =

   ppIdent id <+>

   (case mbt of {Just t -> colon  <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi

diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index 56cfb8063..573c59ca5 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -61,14 +61,13 @@ data ModInfo i a = ModInfo {
     mstatus :: ModuleStatus ,
     flags   :: Options,
     extend  :: [(i,MInclude i)],
-    mwith   :: Maybe (i,MInclude i,[OpenSpec i]),
+    mwith   :: Maybe (i,MInclude i,[(i,i)]),
     opens   :: [OpenSpec i] ,
+    mexdeps :: [i] ,
     jments  :: BinTree i a ,
     positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
   }
----  deriving Show
-instance Show (ModInfo i a) where
-  show _ = "cannot show ModInfo with FiniteMap"
+  deriving Show
 
 -- | encoding the type of the module
 data ModuleType i = 
@@ -107,13 +106,13 @@ updateMGrammar old new = MGrammar $
    ns = modules new
 
 updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t
-updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps
+updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps
 
 replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
-replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps
+replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps
 
 addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
-addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps
+addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps
 
 addFlag :: Options -> ModInfo i t -> ModInfo i t
 addFlag f mo = mo {flags = flags mo `addOptions` f} 
@@ -225,7 +224,7 @@ emptyMGrammar :: MGrammar i a
 emptyMGrammar = MGrammar []
 
 emptyModInfo :: ModInfo i a
-emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree
+emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree
 
 -- | we store the module type with the identifier
 data IdentM i = IdentM {
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index 11cec4898..a52c6c2be 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -110,7 +110,7 @@ transModDef x = case x of
         defs'    <- U.buildAnyTree [(i,d) | Left  ds <- defs0, (i,_,d) <- ds]
         flags'   <- return $ concatOptions [o | Right o <- defs0]
         let poss1 = buildPosTree id' poss0
-        return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1)
+        return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1)
 
        MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
        MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -118,14 +118,14 @@ transModDef x = case x of
        MWithEBody extends m insts opens defs -> do
         extends' <- mapM transIncludedExt extends
         m'       <- transIncludedExt m
-        insts'   <- mapM transOpen insts 
+        insts'   <- mapM transInst insts 
         opens'   <- transOpens opens
         defs0    <- mapM trDef $ getTopDefs defs
         poss0    <- return [(i,p) | Left  ds <- defs0, (i,p,_) <- ds]
         defs'    <- U.buildAnyTree [(i,d) | Left  ds <- defs0, (i,_,d) <- ds]
         flags'   <- return $ concatOptions [o | Right o <- defs0]
         let poss1 = buildPosTree id' poss0
-        return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1)
+        return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1)
 
       mkModRes id mtyp body = do
          id' <- transIdent id
@@ -178,6 +178,11 @@ transOpen x = case x of
   OQualQO q id -> liftM  GM.OSimple (transIdent id)
   OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
 
+transInst :: Open -> Err (Ident,Ident)
+transInst x = case x of
+  OQual q id m -> liftM2 (,) (transIdent id) (transIdent m)
+  _            -> Bad "qualified open expected"
+
 transIncluded :: Included -> Err (Ident,[Ident])
 transIncluded x = case x of
   IAll i        -> liftM (flip (curry id) []) $ transIdent i