From 49c17be41a7d572d27df74eb7351b672e85953a1 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 5 Nov 2003 14:42:29 +0000 Subject: [PATCH] working with interfaces --- src/GF/Compile/Compile.hs | 5 ++-- src/GF/Compile/Extend.hs | 1 + src/GF/Compile/ModDeps.hs | 4 ++- src/GF/Compile/Rebuild.hs | 21 +++++++++------ src/GF/Compile/Rename.hs | 6 ++--- src/GF/Grammar/Compute.hs | 6 +++-- src/GF/Grammar/Lookup.hs | 55 +++++++++++++++++++++++---------------- src/GF/Infra/Modules.hs | 20 ++++++++++++-- src/Makefile | 2 +- src/Today.hs | 2 +- 10 files changed, 79 insertions(+), 43 deletions(-) diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index a1b1758fb..edd75ef6b 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -186,18 +186,19 @@ generateModuleCode opts path minfo@(name,info) = do -- for resource, also emit gfr case info of - ModMod m | isResourceModule info && isCompilableModule info && emit && nomulti -> do + ModMod m | isResourceModule info && isCompilable info && emit && nomulti -> do let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) _ -> return () (file,out) <- do code <- return $ MkGFC.prCanonModInfo minfo' return (gfcFile pname, code) - if isCompilableModule info && emit && nomulti + if isCompilable info && emit && nomulti then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) else ioeIO $ putStrFlush "no need to save for this module " return minfo' where + isCompilable _ = True ---- isCompilableModule ---- emit code for interfaces nomulti = not $ oElem makeMulti opts emit = oElem emitCode opts optim = oElem optimizeCanon opts diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 5c70a1141..c0c46f956 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -15,6 +15,7 @@ import Monad -- The top-level function $extendModInfo$ -- extends a module symbol table by indirections to the module it extends +--- this is not in use 5/11/2003 extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo extendModInfo name old new = case (old,new) of (ModMod m0, ModMod (Module mt st fs _ ops js)) -> do diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index 93c2e6781..2f5f916d6 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -82,7 +82,9 @@ moduleDeps ms = mapM deps ms where (MTConcrete _, MTConcrete _) -> True (MTInstance _, MTInstance _) -> True (MTReuse _, MTReuse _) -> True - ---- some more + (MTInstance _, MTResource) -> True + (MTResource, MTInstance _) -> True + ---- some more? _ -> mt0 == mt -- in the same way; this defines what can be opened compatOType mt0 mt = case mt0 of diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 6bb25ed7f..5a551ea6c 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -11,7 +11,8 @@ import Ident import Modules import Operations --- rebuilding instance + interface, and "with" modules, prior to renaming. AR 24/10/2003 +-- rebuilding instance + interface, and "with" modules, prior to renaming. +-- AR 24/10/2003 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule rebuildModule ms mo@(i,mi) = do @@ -28,7 +29,7 @@ rebuildModule ms mo@(i,mi) = do MTInstance i0 -> do m0 <- lookupModule gr i0 m' <- case m0 of - ModMod m1 | mtype m1 == MTInterface -> do + ModMod m1 | isResourceModule m0 -> do ---- mtype m1 == MTInterface -> do ---- checkCompleteInstance m1 m -- do this later, in CheckGrammar js' <- extendMod i (jments m1) (jments m) return $ replaceJudgements m js' @@ -41,7 +42,8 @@ rebuildModule ms mo@(i,mi) = do 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] + 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 @@ -52,7 +54,8 @@ rebuildModule ms mo@(i,mi) = do 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 $ ModMod $ Module mt0 stat' fs me ops1 + (mapTree (qualifInstanceInfo insts) js) _ -> return mi return (i,mi') @@ -75,8 +78,8 @@ 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)) + CncFun mp pt pp -> CncFun (qualLin 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 @@ -88,7 +91,9 @@ qualifInstanceInfo insts (c,i) = (c,qualInfo i) where Q m c -> Q (qualId m) c QC m c -> QC (qualId m) c _ -> composSafeOp qual t + qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co]) + qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t))) + qualLin Nothing = Nothing + -- NB constructor patterns never appear in interfaces so we need not rename them - - diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 393f48a9c..120286d4d 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -121,12 +121,12 @@ buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status buildStatus gr c mo = let mo' = self2status c mo in case mo of ModMod m -> do let gr1 = MGrammar $ (c,mo) : modules gr - ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m + ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m mods <- mapM (lookupModule gr1 . openedModule) ops let sts = map modInfo2status $ zip ops mods return $ if isModCnc m - then (NT, sts) -- the module itself does not define any names - else (mo',sts) -- so the empty ident is not needed + then (NT, reverse sts) -- the module itself does not define any names + else (mo',reverse sts) -- so the empty ident is not needed modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) modInfo2status (o,i) = (o,case i of diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs index 1f1eba28c..3dd90012d 100644 --- a/src/GF/Grammar/Compute.hs +++ b/src/GF/Grammar/Compute.hs @@ -129,10 +129,12 @@ computeTerm gr = comp where (K a, Alts (d,vs)) -> do let glx = Glue x comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, K a) -> do - x' <- strsFromTerm x + (Alts _, K a) -> checks [do + x' <- strsFromTerm x -- this may fail when compiling opers return $ variants [ foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + ,return $ Glue x y + ] _ -> do mapM_ checkNoArgVars [x,y] r <- composOp (comp g) t diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index 83d6787ef..684b08cff 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -10,19 +10,23 @@ import Monad -- lookup in resource and concrete in compiling; for abstract, use Look lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term -lookupResDef gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupInfo mo c - case info of - ResOper _ (Yes t) -> return $ qualifAnnot m t - ResOper _ Nope -> return $ Q m c - AnyInd _ n -> lookupResDef gr n c - ResParam _ -> return $ QC m c - ResValue _ -> return $ QC m c - _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" +lookupResDef gr = look True where + look isTop m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResOper _ (Yes t) -> return $ qualifAnnot m t + ResOper _ Nope -> return (Q m c) ---- if isTop then lookExt m c + ---- else prtBad "cannot find in exts" c + AnyInd _ n -> look False n c + ResParam _ -> return $ QC m c + ResValue _ -> return $ QC m c + _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + lookExt m c = + checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c)]) lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type lookupResType gr m c = do @@ -40,16 +44,21 @@ lookupResType gr m c = do _ -> Bad $ prt m +++ "is not a resource" lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param] -lookupParams gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupInfo mo c - case info of - ResParam (Yes ps) -> return ps - AnyInd _ n -> lookupParams gr n c - _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" +lookupParams gr = look True where + look isTop m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResParam (Yes ps) -> return ps + ---- ResParam Nope -> if isTop then lookExt m c + ---- else prtBad "cannot find params in exts" c + AnyInd _ n -> look False n c + _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + lookExt m c = + checks [look False n c | n <- allExtensions gr m] lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] lookupParamValues gr m c = do diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 5d2e0fd15..569806e60 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -133,6 +133,16 @@ allExtendsPlus gr i = case lookupModule gr i of where exts m = [j | Just j <- [extends m]] ++ [j | MTInstance j <- [mtype m]] +-- conversely: all modules that extend a given module, incl. instances of interface +allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i] +allExtensions gr i = case lookupModule gr i of + Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es + _ -> [] + where + exts i = [j | (j,m) <- mods, elem (Just i) [extends m] + || elem (MTInstance i) [mtype m]] + mods = [(j,m) | (j,ModMod m) <- modules gr] + -- initial search path: the nonqualified dependencies searchPathModule :: Ord i => Module i f a -> [i] searchPathModule m = [i | OSimple _ i <- depPathModule m] @@ -160,7 +170,7 @@ typeOfModule mi = case mi of isResourceModule mi = case typeOfModule mi of MTResource -> True MTReuse _ -> True ---- MTInterface -> True + MTInterface -> True --- MTInstance _ -> True _ -> False @@ -207,6 +217,7 @@ isModAbs m = case mtype m of isModRes m = case mtype m of MTResource -> True + MTInstance _ -> True _ -> False isModCnc m = case mtype m of @@ -219,6 +230,12 @@ isModTrans m = case mtype m of sameMType m n = case (m,n) of (MTConcrete _, MTConcrete _) -> True + (MTInstance _, MTInstance _) -> True + (MTInstance _, MTResource) -> True + (MTInstance _, MTInterface) -> True + (MTResource, MTInstance _) -> True + (MTResource, MTInterface) -> True + (MTInterface,MTResource) -> True _ -> m == n -- don't generate code for interfaces and for incomplete modules @@ -227,4 +244,3 @@ isCompilableModule m = case m of MTInterface -> False _ -> mstatus m == MSComplete _ -> False --- - diff --git a/src/Makefile b/src/Makefile index 164eaba4e..c5816b2ab 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,5 +1,5 @@ GHMAKE=ghc -GHCFLAGS=-package lang -package util +GHCFLAGS=-package lang -package util -fglasgow-exts GHCFUDFLAG=-package Fudgets GHCINCLUDE=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc -iparsing GHCINCLUDENOFUD=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc-nofud -iparsing diff --git a/src/Today.hs b/src/Today.hs index 3e96c4560..b1a3f414b 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Tue Nov 4 13:55:38 CET 2003" +module Today where today = "Wed Nov 5 13:15:35 CET 2003"