From 8cce874f8b5f93c3bff65b625c03b3c55f1b5f31 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 24 Oct 2003 18:19:47 +0000 Subject: [PATCH] More woek on interfaces --- src/GF/Compile/CheckGrammar.hs | 30 +++------- src/GF/Compile/Compile.hs | 7 ++- src/GF/Compile/Extend.hs | 2 +- src/GF/Compile/ModDeps.hs | 33 ++++++++++- src/GF/Compile/Rebuild.hs | 94 ++++++++++++++++++++++++++++++++ src/GF/Infra/Modules.hs | 11 ++++ src/GF/Source/SourceToGrammar.hs | 16 +++--- src/Today.hs | 2 +- 8 files changed, 161 insertions(+), 34 deletions(-) create mode 100644 src/GF/Compile/Rebuild.hs diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 7bfd2924e..8e07778bc 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -54,7 +54,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod MTInstance a -> do ModMod abs <- checkErr $ lookupModule gr a - checkCompleteInstance abs mo + -- checkCompleteInstance abs mo -- this is done in Rebuild mapMTree (checkResInfo gr) js return $ (name, ModMod (Module mt st fs me ops js')) : ms @@ -91,18 +91,6 @@ checkCompleteGrammar abs cnc = mapM_ checkWarn $ then id else (("Warning: no linearization of" +++ prt f):) -checkCompleteInstance :: SourceRes -> SourceRes -> Check () -checkCompleteInstance abs cnc = mapM_ checkWarn $ - checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc' - where - abs' = tree2list $ jments abs - cnc' = mapTree fst $ jments cnc - checkComplete sought given = foldr ckOne [] sought - where - ckOne f = if isInBinTree f given - then id - else (("Warning: no definition given to" +++ prt f):) - -- General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. @@ -623,14 +611,14 @@ checkEqLType env t u trm = do (Prod x a b, Prod y c d) -> alpha g a c && alpha ((x,y):g) b d ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtends env n) - || elem n (allExtends env m) - (QC m a, QC n b) | a == b -> elem m (allExtends env n) - || elem n (allExtends env m) - (QC m a, Q n b) | a == b -> elem m (allExtends env n) - || elem n (allExtends env m) - (Q m a, QC n b) | a == b -> elem m (allExtends env n) - || elem n (allExtends env m) + (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req | ((l,a),(k,b)) <- zip rs ts] diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 2a119878d..4822cf2b4 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -7,13 +7,13 @@ import PrGrammar import Update import Lookup import Modules -import ModDeps import ReadFiles import ShellState import MkResource -- the main compiler passes import GetGrammar +import Rebuild import Rename import Refresh import CheckGrammar @@ -141,6 +141,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 return $ (k,mo2) _ -> compileSourceModule opts env mo + _ -> compileSourceModule opts env mo where putp = putPointE opts @@ -150,7 +151,9 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do let putp = putPointE opts mos = modules gr - mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo + mo1 <- ioeErr $ rebuildModule mos mo + + mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1 (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 putStrE warnings diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 5bb38a891..5c70a1141 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -80,7 +80,7 @@ extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j --- opers declared in one module and defined in an extension are a special case +-- opers declared in an interface and defined in an instance are a special case extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of (Nope,_) -> return $ ResOper (strip mt1) m2 diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index c940fdd7c..93c2e6781 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -69,7 +69,7 @@ moduleDeps ms = mapM deps ms where _ -> return [] testErr (all (compatMType ety) ests) "inappropriate extension module type" osts <- mapM (lookupModuleType gr . openedModule) os - testErr (all (==oty) osts) "inappropriate open module type" + testErr (all (compatOType oty) osts) "inappropriate open module type" let ab = case it of IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] _ -> [] ---- @@ -77,12 +77,41 @@ moduleDeps ms = mapM deps ms where [IdentM e ety | Just e <- [es]] ++ [IdentM (openedModule o) oty | o <- os]) - -- check for superficial compatibility, not submodule relation etc + -- check for superficial compatibility, not submodule relation etc: what can be extended compatMType mt0 mt = case (mt0,mt) of (MTConcrete _, MTConcrete _) -> True (MTInstance _, MTInstance _) -> True (MTReuse _, MTReuse _) -> True ---- some more _ -> mt0 == mt + -- in the same way; this defines what can be opened + compatOType mt0 mt = case mt0 of + MTAbstract -> mt == MTAbstract + MTTransfer _ _ -> mt == MTAbstract + _ -> case mt of + MTResource -> True + MTReuse _ -> True + MTInterface -> True + MTInstance _ -> True + _ -> False gr = MGrammar ms --- hack + +openInterfaces :: Dependencies -> Ident -> Err [Ident] +openInterfaces ds m = do + let deps = [(i,ds) | (IdentM i _,ds) <- ds] + let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] + let mods = iterFix (concatMap more) (more (m,undefined)) + return $ [i | (i,MTInterface) <- mods] + +{- +-- to test +exampleDeps = [ + (ir "Nat",[ii "Gen", ir "Adj"]), + (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), + (ir "Nou",[ii "Cas"]) + ] + +ii s = IdentM (IC s) MTInterface +ir s = IdentM (IC s) MTResource +-} diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs new file mode 100644 index 000000000..6bb25ed7f --- /dev/null +++ b/src/GF/Compile/Rebuild.hs @@ -0,0 +1,94 @@ +module Rebuild where + +import Grammar +import ModDeps +import PrGrammar +import Lookup +import Extend +import Macros + +import Ident +import Modules +import Operations + +-- rebuilding instance + interface, and "with" modules, prior to renaming. AR 24/10/2003 + +rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule +rebuildModule ms mo@(i,mi) = do + let gr = MGrammar ms + deps <- moduleDeps ms + is <- openInterfaces deps i + mi' <- case mi of + + -- add the interface type signatures into an instance module + ModMod m -> do + testErr (null is || mstatus m == MSIncomplete) + ("module" +++ prt i +++ "must be declared incomplete") + mi' <- case mtype m of + MTInstance i0 -> do + m0 <- lookupModule gr i0 + m' <- case m0 of + ModMod m1 | mtype m1 == MTInterface -> do +---- checkCompleteInstance m1 m -- do this later, in CheckGrammar + js' <- extendMod i (jments m1) (jments m) + return $ replaceJudgements m js' + _ -> prtBad "interface expected instead of" i0 + return mi ----- + _ -> return mi + return mi' + + -- add the instance opens to an incomplete module "with" instances + ModWith mt stat ext ops -> do + let insts = [(inf,inst) |OQualif _ inf inst <- ops] + let infs = map fst insts + let stat' = ifNull MSComplete (const MSIncomplete) [i | i <- is, notElem i infs] + testErr (stat' == MSComplete || stat == MSIncomplete) + ("module" +++ prt i +++ "remains incomplete") + Module mt0 stat0 fs me ops0 js <- do + mi <- lookupModule gr ext + case mi of + ModMod m -> return m --- check compatibility of module type + _ -> prtBad "expected regular module in 'with' clause, not" ext + let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs] + ++ [oQualif i i | i <- map snd insts] ---- + --- check if me is incomplete + return $ ModMod $ Module mt0 stat' fs me ops1 (mapTree (qualifInstanceInfo insts) js) + + _ -> return mi + return (i,mi') + +checkCompleteInstance :: SourceRes -> SourceRes -> Err () +checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $ + checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc' + where + abs' = tree2list $ jments abs + cnc' = mapTree fst $ jments cnc + checkComplete sought given = foldr ckOne [] sought + where + ckOne f = if isInBinTree f given + then id + else (("Error: no definition given to" +++ prt f):) + +qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info) +qualifInstanceInfo insts (c,i) = (c,qualInfo i) where + + qualInfo i = case i of + ResOper pty pt -> ResOper (qualP pty) (qualP pt) + CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp) + CncFun mp pt pp -> CncFun mp (qualP pt) (qualP pp) ---- mp + ----- ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) + ResValue pty -> ResValue (qualP pty) + _ -> i + qualP pt = case pt of + Yes t -> yes $ qual t + May m -> may $ qualId m + _ -> pt + qualId x = maybe x id $ lookup x insts + qual t = case t of + Q m c -> Q (qualId m) c + QC m c -> QC (qualId m) c + _ -> composSafeOp qual t + + -- NB constructor patterns never appear in interfaces so we need not rename them + + diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index d0c5dc516..ed3e2db83 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -60,6 +60,9 @@ updateModule :: Ord i => Module i f t -> i -> t -> Module i f t updateModule (Module mt ms fs me ops js) i t = Module mt ms fs me ops (updateTree (i,t) js) +replaceJudgements :: Module i f t -> BinTree (i,t) -> Module i f t +replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js + data MainGrammar i = MainGrammar { mainAbstract :: i , mainConcretes :: [MainConcreteSpec i] @@ -119,6 +122,14 @@ allExtends gr i = case lookupModule gr i of _ -> [i] _ -> [] +-- this plus that an instance extends its interface +allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i] +allExtendsPlus gr i = case lookupModule gr i of + Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m) + _ -> [] + where + exts m = [j | Just j <- [extends m]] ++ [j | MTInstance j <- [mtype m]] + -- initial search path: the nonqualified dependencies searchPathModule :: Ord i => Module i f a -> [i] searchPathModule m = [i | OSimple _ i <- depPathModule m] diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index d01f50fa3..4c4bc93a6 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -74,19 +74,21 @@ transModDef x = case x of id' <- transIdent id open' <- transIdent open return (transResDef, GM.MTInstance open', id') - - (extends', opens', defs',flags') <- case body of + + case body of MBody extends opens defs -> do extends' <- transExtend extends opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] flags' <- return [f | Right fs <- defs0, f <- fs] - return $ (extends', opens', defs',flags') - MReuse _ -> - return (Nothing,[],NT,[]) - - 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') transComplMod :: ComplMod -> GM.ModuleStatus transComplMod x = case x of diff --git a/src/Today.hs b/src/Today.hs index b74abc457..09acfaae2 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Thu Oct 23 17:57:21 CEST 2003" +module Today where today = "Fri Oct 24 16:27:10 CEST 2003"