bug fix in the module dependencies checker

4 files changed, 48 insertions, 39 deletions

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 ()