From 54c72f5ab023c0cdac83eb28dd1f81d4cd35aeae Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 11 Nov 2003 15:44:24 +0000 Subject: Working with interfaces. Working with interfaces. Created new place for grammar parsers. Created new script jgf2+. --- src/GF/Compile/Compile.hs | 29 +++++++---- src/GF/Compile/Extend.hs | 101 +++++++++++++++++++++++---------------- src/GF/Compile/GrammarToCanon.hs | 9 ++-- src/GF/Compile/Rebuild.hs | 40 +++++++--------- src/GF/Compile/Rename.hs | 30 +----------- 5 files changed, 107 insertions(+), 102 deletions(-) (limited to 'src/GF/Compile') diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index edd75ef6b..cc327be37 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -13,6 +13,7 @@ import MkResource -- the main compiler passes import GetGrammar +import Extend import Rebuild import Rename import Refresh @@ -93,7 +94,7 @@ reverseModules (MGrammar ms) = MGrammar $ reverse ms keepResModules :: Options -> SourceGrammar -> SourceGrammar keepResModules opts gr = if oElem retainOpers opts - then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi] + then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m] else emptyMGrammar @@ -157,7 +158,8 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of where putp = putPointE opts -compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) +compileSourceModule :: Options -> CompileEnv -> + SourceModule -> IOE (Int,SourceModule) compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do let putp = putPointE opts @@ -165,16 +167,25 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do mo1 <- ioeErr $ rebuildModule mos mo - mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1 + mo1b <- ioeErr $ extendModule mos mo1 + ---- prDebug mo1b - (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 - putStrE warnings + case mo1b of + (_,ModMod n) | not (isCompleteModule n) -> return (k,mo1b) + _ -> do + mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1b + + (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 + putStrE warnings - (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 + (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 - mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r + mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r + + return (k',mo4) + where + prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug - return (k',mo4) generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule generateModuleCode opts path minfo@(name,info) = do @@ -186,7 +197,7 @@ generateModuleCode opts path minfo@(name,info) = do -- for resource, also emit gfr case info of - ModMod m | isResourceModule info && isCompilable info && emit && nomulti -> do + ModMod m | isModRes m && isCompilable info && emit && nomulti -> do let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) _ -> return () diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index c0c46f956..689c59553 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -10,27 +10,56 @@ import Operations import Monad --- AR 14/5/2003 +-- AR 14/5/2003 -- 11/11 --- The top-level function $extendModInfo$ +-- The top-level function $extendModule$ -- 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 - testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name) - js' <- extendMod name (jments m0) js - return $ ModMod (Module mt st fs Nothing ops js) +extendModule :: [SourceModule] -> SourceModule -> Err SourceModule +extendModule ms (name,mod) = case mod of + ModMod (Module mt st fs me ops js) -> do + +{- --- building the {s : Str} lincat from js0 + js <- case mt of + MTConcrete a -> do + ModMod ma <- lookupModule (MGrammar ms) a + let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma] + jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats] + return $ updatesTreeNondestr jscs js0 + _ -> return js0 +-} + + case me of + -- if the module is an extension of another one... + Just n -> do + (m0,isCompl) <- do + m <- lookupModMod (MGrammar ms) n + + -- test that the module types match, and find out if the old is complete + testErr (sameMType (mtype m) mt) + ("illegal extension type to module" +++ prt name) + return (m,isCompleteModule m) + + -- build extension in a way depending on whether the old module is complete + js1 <- extendMod isCompl n (jments m0) js --- this is what happens when extending a module: new information is inserted, --- and the process is interrupted if unification fails + -- if incomplete, throw away extension information + let me' = if isCompl then me else Nothing + return $ (name,ModMod (Module mt st fs me' ops js1)) -extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> + -- if the module is not an extension, just return it + _ -> return (name,mod) + +-- When extending a complete module: new information is inserted, +-- and the process is interrupted if unification fails. +-- If the extended module is incomplete, its judgements are just copied. + +extendMod :: Bool -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> Err (BinTree (Ident,Info)) -extendMod name old new = foldM try new $ tree2list old where +extendMod isCompl name old new = foldM try new $ tree2list old where try t i@(c,_) = errIn ("constant" +++ prt c) $ - tryInsert (extendAnyInfo name) (indirInfo name) t i + tryInsert (extendAnyInfo isCompl name) indirIf t i + indirIf = if isCompl then indirInfo name else id indirInfo :: Ident -> Info -> Info indirInfo n info = AnyInd b n' where @@ -41,46 +70,37 @@ indirInfo n info = AnyInd b n' where AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs -{- ---- -case info of - AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr) - ---- find a suitable indirection for cat info! - - ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr) - ResParam pp -> ResParam (perhIndir n pp) - _ -> info - - CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr) - CncFun m ptr ppr -> CncFun m (perhIndir n ptr) (perhIndir n ppr) --} - perhIndir :: Ident -> Perh a -> Perh a perhIndir n p = case p of Yes _ -> May n _ -> p -extendAnyInfo :: Ident -> Info -> Info -> Err Info -extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of +extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info +extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs + liftM2 AbsCat (updn mc1 mc2) (updn mf1 mf2) --- add cstrs (AbsFun mt1 md1, AbsFun mt2 md2) -> - liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs - - (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2 - (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2 - (ResOper mt1 m1, ResOper mt2 m2) -> extendResOper n mt1 m1 mt2 m2 - + liftM2 AbsFun (updn mt1 mt2) (updn md1 md2) --- add defs + (ResParam mt1, ResParam mt2) -> + liftM ResParam $ updn mt1 mt2 + (ResValue mt1, ResValue mt2) -> + liftM ResValue $ updn mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> ---- extendResOper n mt1 m1 mt2 m2 + liftM2 ResOper (updn mt1 mt2) (updn m1 m2) (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (updatePerhaps n mc1 mc2) - (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2) + liftM3 CncCat (updn mc1 mc2) (updn mf1 mf2) (updn mp1 mp2) (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) + liftM2 (CncFun m) (updn mt1 mt2) (updn md1 md2) - (AnyInd _ _, ResOper _ _) -> return j ---- +---- (AnyInd _ _, ResOper _ _) -> return j ---- _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j + where + updn = if isc then (updatePerhaps n) else (updatePerhapsHard n) + +{- ---- no more needed: this is done in Rebuild -- opers declared in an interface and defined in an instance are a special case extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of @@ -93,3 +113,4 @@ extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of Q _ c -> Vr c QC _ c -> Vr c _ -> composSafeOp strp t +-} diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index ab493f761..786eb5fa5 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/src/GF/Compile/GrammarToCanon.hs @@ -38,7 +38,8 @@ redModInfo (c,info) = do c' <- redIdent c info' <- case info of ModMod m -> do - (e,os) <- redExtOpen m + let isIncompl = mstatus m == MSIncomplete + (e,os) <- if isIncompl then return (Nothing,[]) else redExtOpen m ---- flags <- mapM redFlag $ flags m (a,mt) <- case mtype m of MTConcrete a -> do @@ -51,7 +52,7 @@ redModInfo (c,info) = do MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed ---- this generates empty GFC. Better: none - let js = if mstatus m == MSIncomplete then NT else jments m + let js = if isIncompl then NT else jments m defss <- mapM (redInfo a) $ tree2list $ js defs <- return $ sorted2tree $ concat defss -- sorted, but reduced @@ -62,7 +63,9 @@ redModInfo (c,info) = do e' <- case extends m of Just e -> liftM Just $ redIdent e _ -> return Nothing - os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m + os' <- mapM (\o -> case o of + OQualif q _ i -> liftM (OSimple q) (redIdent i) + _ -> prtBad "cannot translate unqualified open in" c) $ opens m return (e',os') om = oSimple . openedModule --- normalizing away qualif diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 5a551ea6c..d0e750e09 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -19,43 +19,38 @@ rebuildModule ms mo@(i,mi) = do let gr = MGrammar ms deps <- moduleDeps ms is <- openInterfaces deps i - mi' <- case mi of + mi' <- case mi of - -- add the interface type signatures into an instance module + -- add the information given in interface 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 + ("module" +++ prt i +++ + "has open interfaces and must therefore be declared incomplete") + case mtype m of MTInstance i0 -> do - m0 <- lookupModule gr i0 - m' <- case m0 of - 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' - _ -> prtBad "interface expected instead of" i0 - return mi ----- + m1 <- lookupModMod gr i0 + testErr (isModRes m1) ("interface expected instead of" +++ prt i0) + m' <- do + js' <- extendMod False i0 (jments m1) (jments m) + return $ replaceJudgements m js' + return $ ModMod m' _ -> 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 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 + Module mt0 _ fs me ops0 js <- lookupModMod gr ext let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs] ++ [oQualif i i | i <- map snd insts] ---- + ++ [oSimple 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 js + ---- (mapTree (qualifInstanceInfo insts) js) -- not needed _ -> return mi return (i,mi') @@ -72,6 +67,7 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $ then id else (("Error: no definition given to" +++ prt f):) +{- ---- should not be needed qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info) qualifInstanceInfo insts (c,i) = (c,qualInfo i) where @@ -95,5 +91,5 @@ qualifInstanceInfo insts (c,i) = (c,qualInfo i) where 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 3a0bf5c52..20914ecc1 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -33,39 +33,13 @@ renameSourceTerm g m t = do renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod (Module mt st fs me ops js) -> do - (_,mod1@(ModMod m)) <- extendModule ms (name,mod) + ModMod m@(Module mt st fs me ops js) -> do let js1 = jments m - status <- buildStatus (MGrammar ms) name mod1 + status <- buildStatus (MGrammar ms) name mod js2 <- mapMTree (renameInfo status) js1 let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 return $ (name,mod2) : ms -extendModule :: [SourceModule] -> SourceModule -> Err SourceModule -extendModule ms (name,mod) = case mod of - ModMod (Module mt st fs me ops js0) -> do - js <- case mt of -{- --- building the {s : Str} lincat - MTConcrete a -> do - ModMod ma <- lookupModule (MGrammar ms) a - let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma] - jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats] - return $ updatesTreeNondestr jscs js0 --} - _ -> return js0 - js1 <- case me of - Just n -> do - m0 <- case lookup n ms of - Just (ModMod m) -> do - testErr (sameMType (mtype m) mt) - ("illegal extension type to module" +++ prt name) - return m - _ -> Bad $ "cannot find extended module" +++ prt n - extendMod n (jments m0) js - _ -> return js - return $ (name,ModMod (Module mt st fs me ops js1)) - - type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) type StatusTree = BinTree (Ident,StatusInfo) -- cgit v1.2.3