introducing multiple inheritance

8 files changed, 34 insertions, 40 deletions

diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index 5ca8d71b4..8057904a8 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -10,7 +10,7 @@ import Modules
 import ReadFiles
 import ShellState
 import MkResource
-import MkUnion
+---- import MkUnion
 
 -- the main compiler passes
 import GetGrammar
@@ -202,9 +202,12 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
           mos = modules gr
       --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
       return $ (k,mo2)
+{- ---- obsolete
     MTUnion ty imps -> do
       mo' <- ioeErr $ makeUnion gr i ty imps
       compileSourceModule opts env mo'
+-}
+
     _ -> compileSourceModule opts env mo
   _ -> compileSourceModule opts env mo
  where
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index 84eb91945..6f76ad093 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -17,21 +17,11 @@ import Monad
 
 extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
 extendModule ms (name,mod) = case mod of
-  ModMod (Module mt st fs me ops js) -> do
-
-{- --- building the {s : Str} lincat from js0
-    js  <- case mt of
-      MTConcrete a -> do
-        ModMod ma <- lookupModule (MGrammar ms) a
-        let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
-            jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
-        return $ updatesTreeNondestr jscs js0
-      _ -> return js0
--}
-
-    case me of
-      -- if the module is an extension of another one...
-      Just n -> do
+  ModMod m -> do
+    mod' <- foldM extOne m (extends m) 
+    return (name,ModMod mod') 
+ where
+   extOne mod@(Module mt st fs es ops js) n = do
         (m0,isCompl) <- do
           m <- lookupModMod  (MGrammar ms) n
 
@@ -44,11 +34,8 @@ extendModule ms (name,mod) = case mod of
         js1 <- extendMod isCompl n (jments m0) js
 
         -- if incomplete, throw away extension information
-        let me' = if isCompl then me else Nothing 
-        return $ (name,ModMod (Module mt st fs me' ops js1))
-
-      -- if the module is not an extension, just return it
-      _ -> return (name,mod)
+        let me' = if isCompl then es else (filter (/=n) es) 
+        return $ Module mt st fs me' ops js1
 
 -- When extending a complete module: new information is inserted,
 -- and the process is interrupted if unification fails.
@@ -94,6 +81,12 @@ extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j
 
 ----  (AnyInd _ _, ResOper _ _) -> return j ----
 
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) "inconsistent indirection status"
+    testErr (m1 == m2) $ 
+      "different sources of indirection: " +++ show m1 +++ show m2
+    return i
+
   _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
 
 --- where
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index 7b7620f3b..ed145385c 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -39,7 +39,7 @@ redModInfo (c,info) = do
   info' <- case info of
     ModMod m -> do
       let isIncompl = not $ isCompleteModule m
-      (e,os) <- if isIncompl then return (Nothing,[]) else redExtOpen m ----
+      (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ----
       flags <- mapM redFlag $ flags m 
       (a,mt) <- case mtype m of
          MTConcrete a -> do
@@ -61,8 +61,7 @@ redModInfo (c,info) = do
  where
    redExtOpen m = do
      e' <- case extends m of
-       Just e -> liftM Just $ redIdent e
-       _ -> return Nothing
+       es -> mapM redIdent es
      os' <- mapM (\o -> case o of 
               OQualif q _ i -> liftM (OSimple q) (redIdent i)
               _ -> prtBad "cannot translate unqualified open in" c) $ opens m
diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
index ed24389a5..d28384e5d 100644
--- a/src/GF/Compile/MkResource.hs
+++ b/src/GF/Compile/MkResource.hs
@@ -13,7 +13,7 @@ import Monad
 -- extracting resource r from abstract + concrete syntax
 -- AR 21/8/2002 -- 22/6/2003 for GF with modules
 
-makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> 
+makeReuse :: SourceGrammar -> Ident -> [Ident] -> 
              MReuseType Ident -> Err SourceRes
 makeReuse gr r me mrc = do
   flags <- return [] --- no flags are passed: they would not make sense
@@ -59,7 +59,7 @@ makeReuse gr r me mrc = do
 -- the second Boolean indicates if the definition needs be given
 
 mkResDefs :: Bool -> Bool -> 
-             SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
+             SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] -> 
              BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
 mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
@@ -101,7 +101,7 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
   -- type constant qualifications changed from abstract to resource
   redirTyp always a mae ty = case ty of
     Q _ c | always -> return $ Q r c
-    Q n c | n == a || Just n == mae -> return $ Q r c
+    Q n c | n == a || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
     _ -> composOp (redirTyp always a mae) ty
 
 lockRecType :: Ident -> Type -> Err Type
diff --git a/src/GF/Compile/MkUnion.hs b/src/GF/Compile/MkUnion.hs
index e6260e6dc..6c46068a4 100644
--- a/src/GF/Compile/MkUnion.hs
+++ b/src/GF/Compile/MkUnion.hs
@@ -13,7 +13,7 @@ import List
 import Monad
 
 -- building union of modules
--- AR 1/3/2004
+-- AR 1/3/2004 --- OBSOLETE 15/9/2004 with multiple inheritance
 
 makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
              Err SourceModule
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
index c4784e243..60f360746 100644
--- a/src/GF/Compile/ModDeps.hs
+++ b/src/GF/Compile/ModDeps.hs
@@ -65,9 +65,7 @@ moduleDeps ms = mapM deps ms where
       t -> chDep (IdentM c t) (extends m) t (opens m) t
 
   chDep it es ety os oty = do
-    ests <- case es of
-      Just e -> liftM singleton $ lookupModuleType gr e
-      _ -> return []
+    ests <- mapM (lookupModuleType gr) es
     testErr (all (compatMType ety) ests) "inappropriate extension module type" 
     osts <- mapM (lookupModuleType gr . openedModule) os
     testErr (all (compatOType oty) osts) "inappropriate open module type"
@@ -75,7 +73,7 @@ moduleDeps ms = mapM deps ms where
                IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
                _ -> [] ---- 
     return (it, ab ++
-                [IdentM e ety | Just e <- [es]] ++ 
+                [IdentM e ety | e <- es] ++ 
                 [IdentM (openedModule o) oty | o <- os])
 
   -- check for superficial compatibility, not submodule relation etc: what can be extended
@@ -114,7 +112,7 @@ requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
 requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
   more i = errVal [] $ do
     m <- lookupModMod gr i
-    return $ maybe [] return (extends m) ++ map openedModule (opens m)
+    return $ extends m ++ map openedModule (opens m)
 
 
 
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 048af3c7c..491c9c9f2 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -34,12 +34,14 @@ rebuildModule ms mo@(i,mi) = do
             js' <- extendMod False i0 (jments m1) (jments m)
             --- to avoid double inclusions, in instance I of I0 = J0 ** ...
             case extends m of
-              Nothing -> return $ replaceJudgements m js'
-              Just j0 -> do 
+              [] -> return $ replaceJudgements m js'
+              j0:jj -> do 
                 m0 <- lookupModMod gr j0
                 let notInM0 c = not $ isInBinTree (fst c) $ mapTree fst $ jments m0
                 let js2 = sorted2tree $ filter notInM0 $ tree2list js'
-                return $ replaceJudgements m js2
+                if null jj 
+                  then return $ replaceJudgements m js2
+                  else Bad "FIXME: handle multiple inheritance in instance"
           return $ ModMod m'
         _ -> return mi
 
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 8676a60b6..1c90d1369 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -181,11 +181,10 @@ filterAbstracts abstr cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <-
     Just a -> elem i $ needs a
     _ -> True
   needs a = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || dep i a]
-  dep i a = elem i (ext a mse)
+  dep i a = elem i (ext mse a)
   mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
-  ext a es = case lookup a es of
-    Just (Just e) -> a : ext e es
-    Just _ -> a : []
+  ext es a = case lookup a es of
+    Just e -> a : concatMap (ext es) e  ---- FIX multiple exts
     _ -> []