restricted inheritance almost implemented

10 files changed, 77 insertions, 60 deletions

diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs
index b26aeca26..be901d5ee 100644
--- a/src/GF/Canon/CanonToGrammar.hs
+++ b/src/GF/Canon/CanonToGrammar.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:21 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.13 $
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
 --
 -- a decompiler. AR 12/6/2003 -- 19/4/2004
 -----------------------------------------------------------------------------
@@ -53,7 +53,7 @@ canon2sourceModule (i,mi) = do
   return (i',info')
  where
    redExtOpen m = do
-     e' <- mapM redIdent $ M.extends m
+     e'  <- return $ M.extend m
      os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ 
                  M.opens m
      return (e',os')
diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs
index d727edd08..81706e9b7 100644
--- a/src/GF/Canon/MkGFC.hs
+++ b/src/GF/Canon/MkGFC.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:43 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
+-- > CVS $Revision: 1.15 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -52,7 +52,7 @@ mod2info m = case m of
             MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y))
       in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
  where
-  ee (Ext m) = m
+  ee (Ext m) = map M.inheritAll m
   ee _ = []
   oo (Opens ms) = map M.oSimple ms
   oo _ = []
@@ -72,7 +72,7 @@ info2mod m = case m of
       in
         Mod mt' (gfcE me) (gfcO os) flags defs'
  where
-  gfcE = ifNull NoExt Ext
+  gfcE = ifNull NoExt Ext . map fst
   gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os]
 
 
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index e2b835273..9ea0fdf91 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/27 11:37:57 $
+-- > CVS $Date: 2005/05/30 21:08:14 $
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.39 $
+-- > CVS $Revision: 1.40 $
 --
 -- The top-level compilation chain from source file to gfc\/gfr.
 -----------------------------------------------------------------------------
@@ -221,7 +221,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
 
   ModMod m -> case mtype m of
     MTReuse c -> do
-      sm <- ioeErr $ makeReuse gr i (extends m) c
+      sm <- ioeErr $ makeReuse gr i (extend m) c
       let mo2 = (i, ModMod sm)
           mos = modules gr
       --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index b519bf2fd..ae87b3e71 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:43 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.17 $
+-- > CVS $Revision: 1.18 $
 --
 -- AR 14\/5\/2003 -- 11\/11
 --
@@ -37,10 +37,10 @@ extendModule ms (name,mod) = case mod of
   ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
 
   ModMod m -> do
-    mod' <- foldM extOne m (extends m) 
+    mod' <- foldM extOne m (extend m) 
     return (name,ModMod mod') 
  where
-   extOne mod@(Module mt st fs es ops js) n = do
+   extOne mod@(Module mt st fs es ops js) (n,cond) = do
         (m0,isCompl) <- do
           m <- lookupModMod  (MGrammar ms) n
 
@@ -51,18 +51,20 @@ extendModule ms (name,mod) = case mod of
 ----       return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
 
         -- build extension in a way depending on whether the old module is complete
-        js1 <- extendMod isCompl n name (jments m0) js
+        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) js
 
         -- if incomplete, throw away extension information
-        let me' = if isCompl then es else (filter (/=n) es) 
+        let me' = if isCompl then es else (filter ((/=n) . fst) 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.
 -- If the extended module is incomplete, its judgements are just copied.
-extendMod :: Bool -> Ident -> Ident -> BinTree Ident Info -> BinTree Ident Info -> 
+extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
              Err (BinTree Ident Info)
-extendMod isCompl name base old new = foldM try new $ tree2list old where
+extendMod isCompl (name,cond) base old new = foldM try new $ tree2list old where
+  try t i@(c,_) | not (cond c) = return t
   try t i@(c,_) = errIn ("constant" +++ prt c) $
                   tryInsert (extendAnyInfo isCompl name base) indirIf t i
   indirIf = if isCompl then indirInfo name else id
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index affdffb7e..e69113a21 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:43 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
+-- > CVS $Revision: 1.20 $
 --
 -- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
@@ -78,7 +78,7 @@ redModInfo (c,info) = do
  where
    redExtOpen m = do
      e' <- case extends m of
-       es -> mapM redIdent es
+       es -> mapM (liftM inheritAll . 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 3ba67d49e..10831b5c6 100644
--- a/src/GF/Compile/MkResource.hs
+++ b/src/GF/Compile/MkResource.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
 -----------------------------------------------------------------------------
@@ -27,7 +27,7 @@ import Control.Monad
 
 -- | extracting resource r from abstract + concrete syntax.
 -- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
-makeReuse :: SourceGrammar -> Ident -> [Ident] -> 
+makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> 
              MReuseType Ident -> Err SourceRes
 makeReuse gr r me mrc = do
   flags <- return [] --- no flags are passed: they would not make sense
@@ -47,7 +47,7 @@ makeReuse gr r me mrc = do
         ModMod m -> case mtype m of
           MTAbstract -> liftM ((,) (opens m)) $ 
                           mkResDefs True False gr r c me 
-                            (extends m) (jments m) emptyBinTree
+                            (extend m) (jments m) emptyBinTree
           _ -> prtBad "expected abstract to be the type of" c
         _ -> prtBad "expected abstract to be the type of" c
 
@@ -65,7 +65,7 @@ makeReuse gr r me mrc = do
                ModMod m' -> return $ jments m'
                _ -> prtBad "expected abstract to be the type of" a
             liftM ((,) (opens m)) $ 
-               mkResDefs hasT True gr r a me (extends m) jmsA (jments m)
+               mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
           _ -> prtBad "expected concrete to be the type of" c
         _ -> prtBad "expected concrete to be the type of" c
 
@@ -73,7 +73,8 @@ makeReuse gr r me mrc = do
 -- | the first  Boolean indicates if the type needs be given
 -- the second Boolean indicates if the definition needs be given
 mkResDefs :: Bool -> Bool -> 
-             SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] -> 
+             SourceGrammar -> Ident -> Ident -> 
+             [(Ident,MInclude Ident)] -> [(Ident,MInclude 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
@@ -98,7 +99,7 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
       AnyInd b n -> do
         mo    <- lookupModMod gr n
         info' <- lookupInfo mo f
-        mkOne n (extends mo) (f,info')
+        mkOne n (extend mo) (f,info')
 
   look cnc f = do
      info <- lookupTree prt f cnc
@@ -109,13 +110,13 @@ mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs wher
        AnyInd _ n -> do 
          mo    <- lookupModMod gr n
          t <- look (jments mo) f
-         redirTyp False n (extends mo) t
+         redirTyp False n (extend mo) t
        _ -> prtBad "not enough information to reuse" f
 
   -- 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 || [n] == mae -> return $ Q r c ---- FIX for non-singleton exts
+    Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
     _ -> composOp (redirTyp always a mae) ty
 
 -- | no reuse for functions of HO\/dep types
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 2e7bdd65d..fd7d4cd88 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- Rebuild a source module from incomplete and its with-instance.
 -----------------------------------------------------------------------------
@@ -45,7 +45,7 @@ rebuildModule ms mo@(i,mi) = do
           m1 <- lookupModMod gr i0
           testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
           m' <- do
-            js' <- extendMod False i0 i (jments m1) (jments m)
+            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'
@@ -72,8 +72,8 @@ rebuildModule ms mo@(i,mi) = do
                      ++ [oQualif i i | i <- map snd insts] ----
                      ++ [oSimple i   | i <- map snd insts] ----
                ----      ++ [oSimple ext] ---- to encode dependence
-      --- check if me is incomplete
-      return $ ModMod $ Module mt0 stat' fs me ops1 js 
+      --- check if me is incomplete; --- why inherit all forced by syntax
+      return $ ModMod $ Module mt0 stat' fs (map inheritAll me) ops1 js 
                           ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
 
     _ -> return mi
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index 63f14d2f4..561e4ff0a 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.23 $
+-- > CVS $Revision: 1.24 $
 --
 -- Datastructures and functions for modules, common to GF and GFC.
 --
@@ -18,8 +18,11 @@
 -- Invariant: modules are stored in dependency order
 -----------------------------------------------------------------------------
 
-module GF.Infra.Modules (MGrammar(..), ModInfo(..), Module(..), ModuleType(..), MReuseType(..),
-		extendm, updateMGrammar, updateModule, replaceJudgements,
+module GF.Infra.Modules (
+		MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
+		MReuseType(..), MInclude (..),
+		extends, isInherited,inheritAll, 
+                updateMGrammar, updateModule, replaceJudgements,
 		addOpenQualif, flagsModule, allFlags, mapModules,
 		MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
 		oSimple, oQualif,
@@ -61,7 +64,7 @@ data Module i f a = Module {
     mtype   :: ModuleType i ,
     mstatus :: ModuleStatus ,
     flags   :: [f] ,
-    extends :: [i], ---- [(i,MInclude i)],
+    extend  :: [(i,MInclude i)],
     opens   :: [OpenSpec i] ,
     jments  :: BinTree i a
   }
@@ -88,11 +91,17 @@ data MReuseType i = MRInterface i | MRInstance i i | MRResource i
 data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
   deriving (Show,Eq)
 
--- | previously: single inheritance
-extendm :: Module i f a -> Maybe i
-extendm m = case extends m of
-  [i] -> Just i
-  _   -> Nothing
+extends :: Module i f a -> [i]
+extends = map fst . extend
+
+isInherited :: Eq i => MInclude i -> i -> Bool
+isInherited c i = case c of
+  MIAll -> True
+  MIOnly is -> elem i is
+  MIExcept is -> notElem i is
+
+inheritAll :: i -> (i,MInclude i)
+inheritAll i = (i,MIAll)
 
 -- destructive update
 
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index 8b10b7dee..ad89d5540 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/26 14:18:17 $ 
+-- > CVS $Date: 2005/05/30 21:08:15 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.21 $
+-- > CVS $Revision: 1.22 $
 --
 -- From internal source syntax to BNFC-generated (used for printing).
 -----------------------------------------------------------------------------
@@ -45,12 +45,17 @@ trModule (i,mo) = case mo of
       MTInstance a -> P.MTInstance i' (tri a)
       MTInterface -> P.MTInterface i'
     body = P.MBody 
-             (trExtend (extends m)) 
+             (trExtends (extend m)) 
              (mkOpens (map trOpen (opens m)))
              (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m)))
 
-trExtend :: [Ident] -> P.Extend
-trExtend i = ifNull P.NoExt (P.Ext . map (P.IAll . tri)) i ---- IAll
+trExtends :: [(Ident,MInclude Ident)] -> P.Extend
+trExtends [] = P.NoExt 
+trExtends es = (P.Ext $ map tre es) where
+  tre (i,c) = case c of 
+    MIAll       -> P.IAll   (tri i)
+    MIOnly is   -> P.ISome  (tri i) (map tri is)
+    MIExcept is -> P.IMinus (tri i) (map tri is)
 
 ---- this has to be completed with other mtys
 forName (MTConcrete a) = tri a
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index 2247bd8d7..4af60f1bf 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 21:08:15 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.25 $
+-- > CVS $Revision: 1.26 $
 --
 -- based on the skeleton Haskell module generated by the BNF converter
 -----------------------------------------------------------------------------
@@ -112,7 +112,7 @@ transModDef x = case x of
         opens'   <- mapM transOpen opens 
         return (id', GM.ModWith mtyp' mstat' m' [] opens')
       MWithE extends m opens -> do
-        extends' <- mapM transIncludedExt extends
+        extends' <- liftM (map fst) $ mapM transIncludedExt extends
         m'       <- transIdent m
         opens'   <- mapM transOpen opens 
         return (id', GM.ModWith mtyp' mstat' m' extends' opens')
@@ -168,7 +168,7 @@ transTransfer x = case x of
   TransferIn open  -> liftM Left  $ transOpen open
   TransferOut open -> liftM Right $ transOpen open
 
-transExtend :: Extend -> Err [Ident]
+transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)]
 transExtend x = case x of
   Ext ids  -> mapM transIncludedExt ids
   NoExt -> return []
@@ -192,15 +192,15 @@ transQualOpen x = case x of
 
 transIncluded :: Included -> Err (Ident,[Ident])
 transIncluded x = case x of
-  IAll i  -> liftM (flip (curry id) []) $ transIdent i
+  IAll i        -> liftM (flip (curry id) []) $ transIdent i
   ISome  i ids  -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
   IMinus i ids  -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ----
 
-transIncludedExt :: Included -> Err Ident ---- (Ident,[Ident])
+transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident)
 transIncludedExt x = case x of
-  IAll i       -> transIdent i
-  ISome  i ids -> transIdent i
-  IMinus i ids -> transIdent i
+  IAll i       -> liftM2 (,) (transIdent i) (return GM.MIAll)
+  ISome  i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly   $ mapM transIdent ids) 
+  IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
 
 transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
 transAbsDef x = case x of