From 3a3342a0f96ba33d0df745b87f700b9998c86f4f Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 30 May 2005 20:08:14 +0000 Subject: [PATCH] restricted inheritance almost implemented --- src/GF/Canon/CanonToGrammar.hs | 8 ++++---- src/GF/Canon/MkGFC.hs | 8 ++++---- src/GF/Compile/Compile.hs | 6 +++--- src/GF/Compile/Extend.hs | 18 ++++++++++-------- src/GF/Compile/GrammarToCanon.hs | 6 +++--- src/GF/Compile/MkResource.hs | 19 ++++++++++--------- src/GF/Compile/Rebuild.hs | 10 +++++----- src/GF/Infra/Modules.hs | 29 +++++++++++++++++++---------- src/GF/Source/GrammarToSource.hs | 15 ++++++++++----- src/GF/Source/SourceToGrammar.hs | 18 +++++++++--------- 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