mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 03:32:51 -06:00
restricted inheritance almost implemented
This commit is contained in:
@@ -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')
|
||||||
|
|||||||
@@ -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]
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
Reference in New Issue
Block a user