From 99c430e5f50b6f37dfb357401c4f5497fc8ca302 Mon Sep 17 00:00:00 2001 From: krasimir Date: Sat, 31 Jan 2009 10:49:01 +0000 Subject: [PATCH] bug fix in the module dependencies checker --- src/GF/Compile.hs | 2 +- src/GF/Compile/Extend.hs | 29 +++++++++++--------- src/GF/Compile/GrammarToGFCC.hs | 4 +-- src/GF/Compile/ReadFiles.hs | 9 ++++++- src/GF/Compile/Rebuild.hs | 45 +++++++++++++++----------------- src/GF/Grammar/Binary.hs | 10 +++---- src/GF/Grammar/Printer.hs | 6 +++-- src/GF/Infra/Modules.hs | 15 +++++------ src/GF/Source/SourceToGrammar.hs | 11 +++++--- 9 files changed, 73 insertions(+), 58 deletions(-) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index c00b1bd67..e5ae611b5 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -173,7 +173,7 @@ compileOne opts env@(_,srcgr,_) file = do -- sm is optimized before generation, but not in the env extendCompileEnvInt env k' (Just gfo) sm1 where - isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete && isNothing (mwith m) + isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 4cf2101de..bb9310041 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -27,6 +27,7 @@ import GF.Grammar.Macros import GF.Data.Operations import Control.Monad +import Data.List(nub) extendModule :: [SourceModule] -> SourceModule -> Err SourceModule extendModule ms (name,m) @@ -38,21 +39,25 @@ extendModule ms (name,m) return (name,m') where extOne mo (n,cond) = do - (m0,isCompl) <- do - m <- lookupModule (MGrammar ms) n + m0 <- lookupModule (MGrammar ms) n - -- test that the module types match, and find out if the old is complete - testErr (sameMType (mtype m) (mtype mo)) - ("illegal extension type to module" +++ prt name) - return (m, isCompleteModule m) + -- test that the module types match, and find out if the old is complete + testErr (sameMType (mtype m) (mtype mo)) + ("illegal extension type to module" +++ prt name) - -- build extension in a way depending on whether the old module is complete - js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo) + let isCompl = isCompleteModule m0 - -- if incomplete, throw away extension information - let es = extend mo - let es' = if isCompl then es else (filter ((/=n) . fst) es) - return $ mo {extend = es', jments = js1} + -- build extension in a way depending on whether the old module is complete + js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo) + + -- if incomplete, throw away extension information + return $ + if isCompl + then mo {jments = js1} + else mo {extend = filter ((/=n) . fst) (extend mo) + ,mexdeps= nub (n : mexdeps mo) + ,jments = js1 + } -- | When extending a complete module: new information is inserted, -- and the process is interrupted if unification fails. diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 81029117d..e57191de2 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -223,8 +223,8 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do reorder :: Ident -> SourceGrammar -> SourceGrammar reorder abs cg = M.MGrammar $ - (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] adefs poss): - [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] (sorted2tree js) poss) + (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): + [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) | (c,(fs,js)) <- cncs] where poss = emptyBinTree -- positions no longer needed diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs index de61d5e42..f8b6f9e51 100644 --- a/src/GF/Compile/ReadFiles.hs +++ b/src/GF/Compile/ReadFiles.hs @@ -179,6 +179,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi []) depModType (mtype mi) . depExtends (extend mi) . depWith (mwith mi) . + depExDeps (mexdeps mi). depOpens (opens mi) depModType (MTAbstract) xs = xs @@ -190,16 +191,22 @@ importsOfModule (m,mi) = (modName m,depModInfo mi []) depExtends es xs = foldr depInclude xs es - depWith (Just (m,_,os)) xs = modName m : depOpens os xs + depWith (Just (m,_,is)) xs = modName m : depInsts is xs depWith Nothing xs = xs + depExDeps eds xs = map modName eds ++ xs + depOpens os xs = foldr depOpen xs os + depInsts is xs = foldr depInst xs is + depInclude (m,_) xs = modName m:xs depOpen (OSimple n ) xs = modName n:xs depOpen (OQualif _ n) xs = modName n:xs + depInst (m,n) xs = modName m:modName n:xs + modName = prIdent -- | options can be passed to the compiler by comments in @--#@, in the main file diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 53f1ec0f1..8adf81824 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -32,62 +32,59 @@ import Data.Maybe (isNothing) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule -rebuildModule ms mo@(i,mi) = do +rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do let gr = MGrammar ms ---- deps <- moduleDeps ms ---- is <- openInterfaces deps i let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 - mi' <- case mi of + mi' <- case mw of -- add the information given in interface into an instance module - m | isNothing (mwith m) -> do - testErr (null is || mstatus m == MSIncomplete) + Nothing -> do + testErr (null is || mstatus mi == MSIncomplete) ("module" +++ prt i +++ "has open interfaces and must therefore be declared incomplete") - case mtype m of + case mt of MTInstance i0 -> do m1 <- lookupModule gr i0 testErr (isModRes m1) ("interface expected instead of" +++ prt i0) - m' <- do - js' <- extendMod False (i0,const True) i (jments m1) (jments m) - --- to avoid double inclusions, in instance I of I0 = J0 ** ... - case extends m of - [] -> return $ replaceJudgements m js' - j0s -> do + js' <- extendMod False (i0,const True) i (jments m1) (jments mi) + --- to avoid double inclusions, in instance I of I0 = J0 ** ... + case extends mi of + [] -> return $ replaceJudgements mi js' + j0s -> do m0s <- mapM (lookupModule gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' - return $ (replaceJudgements m js2) + return $ (replaceJudgements mi js2) {positions = buildTree (tree2list (positions m1) ++ - tree2list (positions m))} --- checkCompleteInstance m1 m' - return m' + tree2list (positions mi))} _ -> return mi -- add the instance opens to an incomplete module "with" instances - ModInfo mt stat fs_ me (Just (ext,incl,ops)) ops_ js_ ps_ -> do - let insts = [(inf,inst) | OQualif inf inst <- ops] - let infs = map fst insts + Just (ext,incl,ops) -> do + let (infs,insts) = unzip ops let stat' = ifNull MSComplete (const MSIncomplete) [i | i <- is, notElem i infs] testErr (stat' == MSComplete || stat == MSIncomplete) ("module" +++ prt i +++ "remains incomplete") - ModInfo mt0 _ fs me' _ ops0 js ps0 <- lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already - ops ++ [o | o <- ops0, notElem (openedModule o) infs] - ++ [OQualif i i | i <- map snd insts] ---- - ++ [OSimple i | i <- map snd insts] ---- + [OQualif i j | (i,j) <- ops] ++ + [o | o <- ops0, notElem (openedModule o) infs] ++ + [OQualif i i | i <- insts] ++ + [OSimple i | i <- insts] --- check if me is incomplete let fs1 = fs `addOptions` fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) let ps1 = buildTree (tree2list ps_ ++ tree2list ps0) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 js1 ps1 + let med1= nub (ext : infs ++ insts ++ med_) + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 - _ -> return mi return (i,mi') checkCompleteInstance :: SourceModInfo -> SourceModInfo -> Err () diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs index cb2690425..65fbfcd89 100644 --- a/src/GF/Grammar/Binary.hs +++ b/src/GF/Grammar/Binary.hs @@ -31,9 +31,9 @@ instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where get = fmap MGrammar get instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where - put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,jments mi,positions mi) - get = do (mtype,mstatus,flags,extend,mwith,opens,jments,positions) <- get - return (ModInfo mtype mstatus flags extend mwith opens jments positions) + put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi) + get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get + return (ModInfo mtype mstatus flags extend mwith opens med jments positions) instance (Binary i) => Binary (ModuleType i) where put MTAbstract = putWord8 0 @@ -264,5 +264,5 @@ instance Binary MetaSymb where decodeModHeader :: FilePath -> IO SourceModule decodeModHeader fpath = do - (m,mtype,mstatus,flags,extend,mwith,opens) <- decodeFile fpath - return (m,ModInfo mtype mstatus flags extend mwith opens Map.empty Map.empty) + (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath + return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty) diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs index 7145ff33b..ef4508717 100644 --- a/src/GF/Grammar/Printer.hs +++ b/src/GF/Grammar/Printer.hs @@ -25,7 +25,7 @@ import Data.Maybe (maybe) import Data.List (intersperse) ppModule :: SourceModule -> Doc -ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) = +ppModule (mn, ModInfo mtype mstat opts exts with opens _ jments _) = (let defs = tree2list jments in if null defs then hdr @@ -58,7 +58,7 @@ ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) = ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs) ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs) - ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppOpenSpec opens + ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens ppOptions opts = text "flags" $$ @@ -210,6 +210,8 @@ ppLabel = ppIdent . label2ident ppOpenSpec (OSimple id) = ppIdent id ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) +ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) + ppLocDef (id, (mbt, e)) = ppIdent id <+> (case mbt of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 56cfb8063..573c59ca5 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -61,14 +61,13 @@ data ModInfo i a = ModInfo { mstatus :: ModuleStatus , flags :: Options, extend :: [(i,MInclude i)], - mwith :: Maybe (i,MInclude i,[OpenSpec i]), + mwith :: Maybe (i,MInclude i,[(i,i)]), opens :: [OpenSpec i] , + mexdeps :: [i] , jments :: BinTree i a , positions :: BinTree i (String,(Int,Int)) -- file, first line, last line } ---- deriving Show -instance Show (ModInfo i a) where - show _ = "cannot show ModInfo with FiniteMap" + deriving Show -- | encoding the type of the module data ModuleType i = @@ -107,13 +106,13 @@ updateMGrammar old new = MGrammar $ ns = modules new updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t -updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps +updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t -replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps +replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t -addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps +addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps addFlag :: Options -> ModInfo i t -> ModInfo i t addFlag f mo = mo {flags = flags mo `addOptions` f} @@ -225,7 +224,7 @@ emptyMGrammar :: MGrammar i a emptyMGrammar = MGrammar [] emptyModInfo :: ModInfo i a -emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree +emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree -- | we store the module type with the identifier data IdentM i = IdentM { diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 11cec4898..a52c6c2be 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -110,7 +110,7 @@ transModDef x = case x of defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 - return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1) + return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1) MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs @@ -118,14 +118,14 @@ transModDef x = case x of MWithEBody extends m insts opens defs -> do extends' <- mapM transIncludedExt extends m' <- transIncludedExt m - insts' <- mapM transOpen insts + insts' <- mapM transInst insts opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 - return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1) + return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1) mkModRes id mtyp body = do id' <- transIdent id @@ -178,6 +178,11 @@ transOpen x = case x of OQualQO q id -> liftM GM.OSimple (transIdent id) OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m) +transInst :: Open -> Err (Ident,Ident) +transInst x = case x of + OQual q id m -> liftM2 (,) (transIdent id) (transIdent m) + _ -> Bad "qualified open expected" + transIncluded :: Included -> Err (Ident,[Ident]) transIncluded x = case x of IAll i -> liftM (flip (curry id) []) $ transIdent i