From f3152a0c226974c448455f3b56c743d5b8e05253 Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 5 Mar 2009 09:08:52 +0000 Subject: [PATCH] in GF.Grammar.Update - remove the indirection before to print the error message --- src/GF/Compile.hs | 10 +++++----- src/GF/Compile/Update.hs | 43 +++++++++++++++++++++++----------------- src/GF/Grammar/Lookup.hs | 8 +++++--- 3 files changed, 35 insertions(+), 26 deletions(-) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index 529a7b700..59357f783 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -141,7 +141,6 @@ compileOne opts env@(_,srcgr,_) file = do let gf = takeExtensions file let path = dropFileName file let name = dropExtension file - let mos = modules srcgr case gf of @@ -154,7 +153,7 @@ compileOne opts env@(_,srcgr,_) file = do intermOut opts DumpSource (ppModule Qualified sm0) let sm1 = unsubexpModule sm0 - sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1 + sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 extendCompileEnv env file sm @@ -186,18 +185,19 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do let putp = putPointE Normal opts putpp = putPointE Verbose opts - mos = modules gr - mo1 <- ioeErr $ rebuildModule mos mo + mo1 <- ioeErr $ rebuildModule gr mo intermOut opts DumpRebuild (ppModule Qualified mo1) - mo1b <- ioeErr $ extendModule mos mo1 + mo1b <- ioeErr $ extendModule gr mo1 intermOut opts DumpExtend (ppModule Qualified mo1b) case mo1b of (_,n) | not (isCompleteModule n) -> do return (k,mo1b) -- refresh would fail, since not renamed _ -> do + let mos = modules gr + mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b intermOut opts DumpRename (ppModule Qualified mo2) diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs index ba0f383a8..1200e51c0 100644 --- a/src/GF/Compile/Update.hs +++ b/src/GF/Compile/Update.hs @@ -17,6 +17,7 @@ module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Printer +import GF.Grammar.Lookup import GF.Infra.Modules import GF.Infra.Option @@ -43,8 +44,8 @@ buildAnyTree m = go Map.empty text "in module" <+> ppIdent m) Nothing -> go (Map.insert c j map) is -extendModule :: [SourceModule] -> SourceModule -> Err SourceModule -extendModule ms (name,m) +extendModule :: SourceGrammar -> SourceModule -> Err SourceModule +extendModule gr (name,m) ---- Just to allow inheritance in incomplete concrete (which are not ---- compiled anyway), extensions are not built for them. ---- Should be replaced by real control. AR 4/2/2005 @@ -53,7 +54,7 @@ extendModule ms (name,m) return (name,m') where extOne mo (n,cond) = do - m0 <- lookupModule (MGrammar ms) n + m0 <- lookupModule gr n -- test that the module types match, and find out if the old is complete testErr (sameMType (mtype m) (mtype mo)) @@ -62,7 +63,7 @@ extendModule ms (name,m) let isCompl = isCompleteModule m0 -- build extension in a way depending on whether the old module is complete - js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo) + js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo) -- if incomplete, throw away extension information return $ @@ -75,9 +76,8 @@ extendModule ms (name,m) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 -rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule -rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do - let gr = MGrammar ms +rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule +rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do ---- deps <- moduleDeps ms ---- is <- openInterfaces deps i let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 @@ -92,7 +92,7 @@ rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do MTInstance i0 -> do m1 <- lookupModule gr i0 testErr (isModRes m1) ("interface expected instead of" +++ prIdent i0) - js' <- extendMod False (i0,const True) i (jments m1) (jments mi) + js' <- extendMod gr 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' @@ -132,24 +132,31 @@ rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do -- | 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,Ident -> Bool) -> Ident -> +extendMod :: SourceGrammar -> + Bool -> (Ident,Ident -> Bool) -> Ident -> BinTree Ident Info -> BinTree Ident Info -> Err (BinTree Ident Info) -extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old +extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old where try new (c,i) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo c i j of Ok k -> return $ updateTree (c,k) new - Bad _ -> fail $ render (text "cannot unify the information" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - text "in module" <+> ppIdent name <+> text "with" $$ - nest 4 (ppJudgement Qualified (c,j)) $$ - text "in module" <+> ppIdent base) - Nothing -> if isCompl - then return $ updateTree (c,indirInfo name i) new - else return $ updateTree (c,i) new + Bad _ -> do (base,j) <- case j of + AnyInd _ m -> lookupOrigInfo gr m c + _ -> return (base,j) + (name,i) <- case i of + AnyInd _ m -> lookupOrigInfo gr m c + _ -> return (name,i) + fail $ render (text "cannot unify the information" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + text "in module" <+> ppIdent name <+> text "with" $$ + nest 4 (ppJudgement Qualified (c,j)) $$ + text "in module" <+> ppIdent base) + Nothing-> if isCompl + then return $ updateTree (c,indirInfo name i) new + else return $ updateTree (c,i) new indirInfo :: Ident -> Info -> Info indirInfo n info = AnyInd b n' where diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index f11f7d428..312cfd38e 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -19,6 +19,7 @@ module GF.Grammar.Lookup ( lookupIdent, lookupIdentInfo, lookupIdentInfoIn, + lookupOrigInfo, lookupResDef, lookupResDefKind, lookupResType, @@ -139,13 +140,14 @@ lookupOverload gr m c = do AnyInd _ n -> lookupOverload gr n c _ -> Bad $ prt c +++ "is not an overloaded operation" -lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info +-- | returns the original 'Info' and the module where it was found +lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info) lookupOrigInfo gr m c = do mo <- lookupModule gr m info <- lookupIdentInfo mo c case info of AnyInd _ n -> lookupOrigInfo gr n c - i -> return i + i -> return (m,i) lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues) lookupParams gr = look True where @@ -194,7 +196,7 @@ lookupIndexValue gr ty i = do allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] allOrigInfos gr m = errVal [] $ do mo <- lookupModule gr m - return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]] + return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]] where look = lookupOrigInfo gr m