From 52bc53dfd76d1cdc4c0f81e17c9dc28e58fbcb69 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 9 Jan 2004 16:40:56 +0000 Subject: [PATCH] Interfaces and instances by reuse. --- src/GF/Compile/MkResource.hs | 77 ++++++++++++++++++++++---------- src/GF/Infra/Modules.hs | 6 ++- src/GF/Source/SourceToGrammar.hs | 34 +++++++------- src/Today.hs | 2 +- 4 files changed, 79 insertions(+), 40 deletions(-) diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs index 7a63f413d..ed24389a5 100644 --- a/src/GF/Compile/MkResource.hs +++ b/src/GF/Compile/MkResource.hs @@ -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 diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index d2bfae5c1..45933e126 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -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 diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 17e1819ca..c01d06c9b 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -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 diff --git a/src/Today.hs b/src/Today.hs index 20d7e02ee..339269333 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -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"