in GF.Grammar.Update - remove the indirection before to print the error message

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)
 

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 :: SourceGrammar -> SourceModule -> Err SourceModule
-extendModule ms (name,m)
+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 :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
+rebuildModule gr 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
@@ -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,22 +132,29 @@ 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" $$ 
+		                     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
+                         Nothing-> if isCompl
                                      then return $ updateTree (c,indirInfo name i) new
                                      else return $ updateTree (c,i) new
 

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