msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

restricted inheritance almost implemented

Browse Source
This commit is contained in:
aarne
2005-05-30 20:08:14 +00:00
parent 5bf9a7fe70
commit 3a3342a0f9
10 changed files with 77 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/Compile/Compile.hs
View File

@@ -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

18
src/GF/Compile/Extend.hs
View File

@@ -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

6
src/GF/Compile/GrammarToCanon.hs
View File

@@ -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

19
src/GF/Compile/MkResource.hs
View File

@@ -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

10
src/GF/Compile/Rebuild.hs
View File

@@ -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