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

Interfaces and instances by reuse.

Browse Source
This commit is contained in:
aarne
2004-01-09 16:40:56 +00:00
parent 412a4f0fdb
commit 52bc53dfd7
4 changed files with 79 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -13,43 +13,74 @@ import Monad
-- extracting resource r from abstract + concrete syntax
-- AR 21/8/2002 -- 22/6/2003 for GF with modules
makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes
makeReuse gr r me c = do
mc <- lookupModule gr c
makeReuse :: SourceGrammar -> Ident -> Maybe Ident ->
MReuseType Ident -> Err SourceRes
makeReuse gr r me mrc = do
flags <- return [] --- no flags are passed: they would not make sense
case mrc of
MRResource c -> do
(ops,jms) <- mkFull True c
return $ Module MTResource MSComplete flags me ops jms
(ops,jms) <- case mc of
ModMod m -> case mtype m of
MTConcrete a -> do
ma <- lookupModule gr a
jmsA <- case ma of
ModMod m' -> return $ jments m'
_ -> prtBad "expected abstract to be the type of" a
liftM ((,) (opens m)) $ mkResDefs gr r a me (extends m) jmsA (jments m)
_ -> prtBad "expected concrete to be the type of" c
_ -> prtBad "expected concrete to be the type of" c
MRInstance c a -> do
(ops,jms) <- mkFull False c
return $ Module (MTInstance a) MSComplete flags me ops jms
return $ Module MTResource MSComplete flags me ops jms
MRInterface c -> do
mc <- lookupModule gr c
mkResDefs :: SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident ->
(ops,jms) <- case mc of
ModMod m -> case mtype m of
MTAbstract -> liftM ((,) (opens m)) $
mkResDefs True False gr r c me (extends m) (jments m) NT
_ -> prtBad "expected abstract to be the type of" c
_ -> prtBad "expected abstract to be the type of" c
return $ Module MTInterface MSIncomplete flags me ops jms
where
mkFull hasT c = do
mc <- lookupModule gr c
case mc of
ModMod m -> case mtype m of
MTConcrete a -> do
ma <- lookupModule gr a
jmsA <- case ma of
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)
_ -> prtBad "expected concrete to be the type of" c
_ -> prtBad "expected concrete to be the type of" c
-- 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 -> Maybe Ident -> Maybe Ident ->
BinTree (Ident,Info) -> BinTree (Ident,Info) ->
Err (BinTree (Ident,Info))
mkResDefs 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
ifTyped = yes --- if hasT then yes else const nope --- needed for TC
ifCompl = if isC then yes else const nope
doIf b t = if b then t else return typeType -- latter value not used
mkOne a mae (f,info) = case info of
AbsCat _ _ -> do
typ <- err (const (return defLinType)) return $ look cnc f
typ' <- lockRecType f typ
return (f, ResOper (Yes typeType) (Yes typ'))
typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f
typ' <- doIf isC $ lockRecType f typ
return (f, ResOper (ifTyped typeType) (ifCompl typ'))
AbsFun (Yes typ0) _ -> do
trm <- look cnc f
trm <- doIf isC $ look cnc f
testErr (not (isHardType typ0))
("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
typ <- redirTyp True a mae typ0
cat <- valCat typ
trm' <- unlockRecord (snd cat) trm
return (f, ResOper (Yes typ) (Yes trm'))
trm' <- doIf isC $ unlockRecord (snd cat) trm
return (f, ResOper (ifTyped typ) (ifCompl trm'))
AnyInd b n -> do
mo <- lookupModMod gr n
info' <- lookupInfo mo f

6
src/GF/Infra/Modules.hs
View File

@@ -43,9 +43,13 @@ data ModuleType i =
| MTInterface
| MTInstance i
| MTReuse i
| MTReuse (MReuseType i)
deriving (Eq,Show)
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
deriving (Show,Eq)
-- destructive update
--- dep order preserved since old cannot depend on new

34
src/GF/Source/SourceToGrammar.hs
View File

@@ -51,14 +51,7 @@ transModDef x = case x of
MTAbstract id -> do
id' <- transIdent id
return (transAbsDef, GM.MTAbstract, id')
MTResource id -> case body of
MReuse c -> do
id' <- transIdent id
c' <- transIdent c
return (transResDef, GM.MTReuse c', id')
_ -> do
id' <- transIdent id
return (transResDef, GM.MTResource, id')
MTResource id -> mkModRes id GM.MTResource body
MTConcrete id open -> do
id' <- transIdent id
open' <- transIdent open
@@ -68,14 +61,11 @@ transModDef x = case x of
a' <- transOpen a
b' <- transOpen a
return (transAbsDef, GM.MTTransfer a' b', id')
MTInterface id -> do
id' <- transIdent id
return (transResDef, GM.MTInterface, id')
MTInterface id -> mkModRes id GM.MTInterface body
MTInstance id open -> do
id' <- transIdent id
open' <- transIdent open
return (transResDef, GM.MTInstance open', id')
mkModRes id (GM.MTInstance open') body
case body of
MBody extends opens defs -> do
extends' <- transExtend extends
@@ -83,13 +73,27 @@ transModDef x = case x of
defs0 <- mapM trDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags' <- return [f | Right fs <- defs0, f <- fs]
return $ (id', GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' [] Nothing [] NT))
MWith m opens -> do
m' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' opens')
where
mkModRes id mtyp body = do
id' <- transIdent id
case body of
MReuse c -> do
c' <- transIdent c
mtyp' <- trMReuseType mtyp c'
return (transResDef, GM.MTReuse mtyp', id')
_ -> return (transResDef, mtyp, id')
trMReuseType mtyp c = case mtyp of
GM.MTInterface -> return $ GM.MRInterface c
GM.MTInstance op -> return $ GM.MRInstance c op
GM.MTResource -> return $ GM.MRResource c
transComplMod :: ComplMod -> GM.ModuleStatus
transComplMod x = case x of

2
src/Today.hs
View File

@@ -1 +1 @@
module Today where today = "Thu Jan 8 16:37:47 CET 2004"
module Today where today = "Fri Jan 9 18:17:26 CET 2004"