restricted inheritance almost implemented

This commit is contained in:
aarne
2005-05-30 20:08:14 +00:00
parent 46e796f7cf
commit 0c310d3cae
10 changed files with 77 additions and 60 deletions

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/04/21 16:21:21 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: bringert $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $ -- > CVS $Revision: 1.14 $
-- --
-- a decompiler. AR 12/6/2003 -- 19/4/2004 -- a decompiler. AR 12/6/2003 -- 19/4/2004
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -53,7 +53,7 @@ canon2sourceModule (i,mi) = do
return (i',info') return (i',info')
where where
redExtOpen m = do 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)) $ os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $
M.opens m M.opens m
return (e',os') return (e',os')

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:43 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $ -- > CVS $Revision: 1.15 $
-- --
-- (Description of the module) -- (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)) 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')) in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
where where
ee (Ext m) = m ee (Ext m) = map M.inheritAll m
ee _ = [] ee _ = []
oo (Opens ms) = map M.oSimple ms oo (Opens ms) = map M.oSimple ms
oo _ = [] oo _ = []
@@ -72,7 +72,7 @@ info2mod m = case m of
in in
Mod mt' (gfcE me) (gfcO os) flags defs' Mod mt' (gfcE me) (gfcO os) flags defs'
where 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] gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os]

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/27 11:37:57 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.39 $ -- > CVS $Revision: 1.40 $
-- --
-- The top-level compilation chain from source file to gfc\/gfr. -- 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 ModMod m -> case mtype m of
MTReuse c -> do MTReuse c -> do
sm <- ioeErr $ makeReuse gr i (extends m) c sm <- ioeErr $ makeReuse gr i (extend m) c
let mo2 = (i, ModMod sm) let mo2 = (i, ModMod sm)
mos = modules gr mos = modules gr
--- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:43 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.17 $ -- > CVS $Revision: 1.18 $
-- --
-- AR 14\/5\/2003 -- 11\/11 -- 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 | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
ModMod m -> do ModMod m -> do
mod' <- foldM extOne m (extends m) mod' <- foldM extOne m (extend m)
return (name,ModMod mod') return (name,ModMod mod')
where 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 (m0,isCompl) <- do
m <- lookupModMod (MGrammar ms) n 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)) ---- return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
-- build extension in a way depending on whether the old module is complete -- 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 -- 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 return $ Module mt st fs me' ops js1
-- | When extending a complete module: new information is inserted, -- | When extending a complete module: new information is inserted,
-- and the process is interrupted if unification fails. -- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied. -- 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) 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) $ try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name base) indirIf t i tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id indirIf = if isCompl then indirInfo name else id

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:43 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $ -- > CVS $Revision: 1.20 $
-- --
-- Code generator from optimized GF source code to GFC. -- Code generator from optimized GF source code to GFC.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -78,7 +78,7 @@ redModInfo (c,info) = do
where where
redExtOpen m = do redExtOpen m = do
e' <- case extends m of e' <- case extends m of
es -> mapM redIdent es es -> mapM (liftM inheritAll . redIdent) es
os' <- mapM (\o -> case o of os' <- mapM (\o -> case o of
OQualif q _ i -> liftM (OSimple q) (redIdent i) OQualif q _ i -> liftM (OSimple q) (redIdent i)
_ -> prtBad "cannot translate unqualified open in" c) $ opens m _ -> prtBad "cannot translate unqualified open in" c) $ opens m

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $ -- > CVS $Revision: 1.14 $
-- --
-- Compile a gfc module into a "reuse" gfr resource, interface, or instance. -- 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. -- | extracting resource r from abstract + concrete syntax.
-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules -- 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 MReuseType Ident -> Err SourceRes
makeReuse gr r me mrc = do makeReuse gr r me mrc = do
flags <- return [] --- no flags are passed: they would not make sense 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 ModMod m -> case mtype m of
MTAbstract -> liftM ((,) (opens m)) $ MTAbstract -> liftM ((,) (opens m)) $
mkResDefs True False gr r c me 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
_ -> 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' ModMod m' -> return $ jments m'
_ -> prtBad "expected abstract to be the type of" a _ -> prtBad "expected abstract to be the type of" a
liftM ((,) (opens m)) $ 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
_ -> 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 first Boolean indicates if the type needs be given
-- the second Boolean indicates if the definition needs be given -- the second Boolean indicates if the definition needs be given
mkResDefs :: Bool -> Bool -> mkResDefs :: Bool -> Bool ->
SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] -> SourceGrammar -> Ident -> Ident ->
[(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] ->
BinTree Ident Info -> BinTree Ident Info -> BinTree Ident Info -> BinTree Ident Info ->
Err (BinTree Ident Info) Err (BinTree Ident Info)
mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where 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 AnyInd b n -> do
mo <- lookupModMod gr n mo <- lookupModMod gr n
info' <- lookupInfo mo f info' <- lookupInfo mo f
mkOne n (extends mo) (f,info') mkOne n (extend mo) (f,info')
look cnc f = do look cnc f = do
info <- lookupTree prt f cnc 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 AnyInd _ n -> do
mo <- lookupModMod gr n mo <- lookupModMod gr n
t <- look (jments mo) f t <- look (jments mo) f
redirTyp False n (extends mo) t redirTyp False n (extend mo) t
_ -> prtBad "not enough information to reuse" f _ -> prtBad "not enough information to reuse" f
-- type constant qualifications changed from abstract to resource -- type constant qualifications changed from abstract to resource
redirTyp always a mae ty = case ty of redirTyp always a mae ty = case ty of
Q _ c | always -> return $ Q r c 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 _ -> composOp (redirTyp always a mae) ty
-- | no reuse for functions of HO\/dep types -- | no reuse for functions of HO\/dep types

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $ -- > CVS $Revision: 1.14 $
-- --
-- Rebuild a source module from incomplete and its with-instance. -- Rebuild a source module from incomplete and its with-instance.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -45,7 +45,7 @@ rebuildModule ms mo@(i,mi) = do
m1 <- lookupModMod gr i0 m1 <- lookupModMod gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prt i0) testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
m' <- do 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 ** ... --- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends m of case extends m of
[] -> return $ replaceJudgements m js' [] -> return $ replaceJudgements m js'
@@ -72,8 +72,8 @@ rebuildModule ms mo@(i,mi) = do
++ [oQualif i i | i <- map snd insts] ---- ++ [oQualif i i | i <- map snd insts] ----
++ [oSimple i | i <- map snd insts] ---- ++ [oSimple i | i <- map snd insts] ----
---- ++ [oSimple ext] ---- to encode dependence ---- ++ [oSimple ext] ---- to encode dependence
--- check if me is incomplete --- check if me is incomplete; --- why inherit all forced by syntax
return $ ModMod $ Module mt0 stat' fs me ops1 js return $ ModMod $ Module mt0 stat' fs (map inheritAll me) ops1 js
---- (mapTree (qualifInstanceInfo insts) js) -- not needed ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
_ -> return mi _ -> return mi

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.23 $ -- > CVS $Revision: 1.24 $
-- --
-- Datastructures and functions for modules, common to GF and GFC. -- Datastructures and functions for modules, common to GF and GFC.
-- --
@@ -18,8 +18,11 @@
-- Invariant: modules are stored in dependency order -- Invariant: modules are stored in dependency order
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.Modules (MGrammar(..), ModInfo(..), Module(..), ModuleType(..), MReuseType(..), module GF.Infra.Modules (
extendm, updateMGrammar, updateModule, replaceJudgements, MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
MReuseType(..), MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements,
addOpenQualif, flagsModule, allFlags, mapModules, addOpenQualif, flagsModule, allFlags, mapModules,
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..), MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
oSimple, oQualif, oSimple, oQualif,
@@ -61,7 +64,7 @@ data Module i f a = Module {
mtype :: ModuleType i , mtype :: ModuleType i ,
mstatus :: ModuleStatus , mstatus :: ModuleStatus ,
flags :: [f] , flags :: [f] ,
extends :: [i], ---- [(i,MInclude i)], extend :: [(i,MInclude i)],
opens :: [OpenSpec i] , opens :: [OpenSpec i] ,
jments :: BinTree i a 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] data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Show,Eq) deriving (Show,Eq)
-- | previously: single inheritance extends :: Module i f a -> [i]
extendm :: Module i f a -> Maybe i extends = map fst . extend
extendm m = case extends m of
[i] -> Just i isInherited :: Eq i => MInclude i -> i -> Bool
_ -> Nothing 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 -- destructive update

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/26 14:18:17 $ -- > CVS $Date: 2005/05/30 21:08:15 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.21 $ -- > CVS $Revision: 1.22 $
-- --
-- From internal source syntax to BNFC-generated (used for printing). -- 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) MTInstance a -> P.MTInstance i' (tri a)
MTInterface -> P.MTInterface i' MTInterface -> P.MTInterface i'
body = P.MBody body = P.MBody
(trExtend (extends m)) (trExtends (extend m))
(mkOpens (map trOpen (opens m))) (mkOpens (map trOpen (opens m)))
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m))) (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m)))
trExtend :: [Ident] -> P.Extend trExtends :: [(Ident,MInclude Ident)] -> P.Extend
trExtend i = ifNull P.NoExt (P.Ext . map (P.IAll . tri)) i ---- IAll 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 ---- this has to be completed with other mtys
forName (MTConcrete a) = tri a forName (MTConcrete a) = tri a

View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Date: 2005/05/30 21:08:15 $
-- > CVS $Author: aarne $ -- > CVS $Author: aarne $
-- > CVS $Revision: 1.25 $ -- > CVS $Revision: 1.26 $
-- --
-- based on the skeleton Haskell module generated by the BNF converter -- based on the skeleton Haskell module generated by the BNF converter
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -112,7 +112,7 @@ transModDef x = case x of
opens' <- mapM transOpen opens opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' [] opens') return (id', GM.ModWith mtyp' mstat' m' [] opens')
MWithE extends m opens -> do MWithE extends m opens -> do
extends' <- mapM transIncludedExt extends extends' <- liftM (map fst) $ mapM transIncludedExt extends
m' <- transIdent m m' <- transIdent m
opens' <- mapM transOpen opens opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' extends' 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 TransferIn open -> liftM Left $ transOpen open
TransferOut open -> liftM Right $ transOpen open TransferOut open -> liftM Right $ transOpen open
transExtend :: Extend -> Err [Ident] transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)]
transExtend x = case x of transExtend x = case x of
Ext ids -> mapM transIncludedExt ids Ext ids -> mapM transIncludedExt ids
NoExt -> return [] NoExt -> return []
@@ -192,15 +192,15 @@ transQualOpen x = case x of
transIncluded :: Included -> Err (Ident,[Ident]) transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of 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) ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
IMinus 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 transIncludedExt x = case x of
IAll i -> transIdent i IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll)
ISome i ids -> transIdent i ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> transIdent i IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
transAbsDef x = case x of transAbsDef x = case x of