Show relative file paths in error messages

This is to avoid one trivial reason for failures in the test suite.

4 files changed, 40 insertions, 42 deletions

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 5b707157c..aa39dea50 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -45,26 +45,25 @@ import Control.Monad
 import Text.PrettyPrint
 
 -- | checking is performed in the dependency order of modules
-checkModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule
-checkModule opts sgr mo@(m,mi) = do
-  checkRestrictedInheritance sgr mo
+checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+checkModule opts cwd sgr mo@(m,mi) = do
+  checkRestrictedInheritance cwd sgr mo
   mo <- case mtype mi of
           MTConcrete a -> do let gr = prependModule sgr mo
                              abs <- lookupModule gr a
-                             checkCompleteGrammar opts gr (a,abs) mo
+                             checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
-  infoss <- checkIn (ppLocation (msrc mi) NoLoc <> colon) $
-            topoSortJments2 mo
+  infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
   foldM updateCheckInfos mo infoss
   where
     updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
-      where check (i,info) = fmap ((,) i) (checkInfo opts sgr mo i info)
+      where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
     update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)})
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
-checkRestrictedInheritance :: SourceGrammar -> SourceModule -> Check ()
-checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do
+checkRestrictedInheritance :: FilePath -> SourceGrammar -> SourceModule -> Check ()
+checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty $ do
   let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll]  -- names with restr. inh.
   let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
                              -- the restr. modules themself, with restr. infos
@@ -83,8 +82,8 @@ checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <
                          nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
    allDeps = concatMap (allDependencies (const True) . jments . snd) mos
 
-checkCompleteGrammar :: Options -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
-checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do
+checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
+checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do
   let jsa = jments abs
   let jsc = jments cnc
 
@@ -157,9 +156,9 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
 
 -- | General Principle: only Just-values are checked. 
 -- A May-value has always been checked in its origin module.
-checkInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
-checkInfo opts sgr (m,mo) c info = do
-  checkIn (ppLocation (msrc mo) NoLoc <> colon) $
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
+checkInfo opts cwd sgr (m,mo) c info = do
+  checkInModule cwd mo NoLoc empty $
     checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) -> 
@@ -264,8 +263,8 @@ checkInfo opts sgr (m,mo) c info = do
     _ ->  return info
  where
    gr = prependModule sgr (m,mo)
-   chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ 
-                           nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
+   chIn loc cat = checkInModule cwd mo loc
+                             (text "Happened in" <+> text cat <+> ppIdent c)
 
    mkPar (f,co) = do
        vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -280,9 +279,7 @@ checkInfo opts sgr (m,mo) c info = do
 
    mkCheck loc cat ss = case ss of
      [] -> return info
-     _  -> checkError (ppLocation (msrc mo) loc <> colon $$ 
-                       nest 2 (text "Happened in" <+> text cat <+> ppIdent c $$ 
-                               nest 2 (vcat ss)))
+     _ -> chIn loc cat $ checkError (vcat ss)
 
    compAbsTyp g t = case t of
      Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index 10a857bf9..6393d51d2 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -33,18 +33,20 @@ import Data.Char(isAscii)
 import Control.Monad (foldM,when,unless)
 import System.Cmd (system)
 --import System.IO(mkTextEncoding) --,utf8
-import System.Directory(removeFile)
+import System.Directory(removeFile,getCurrentDirectory)
+import System.FilePath(makeRelative)
 
 getSourceModule :: Options -> FilePath -> IOE SourceModule
 getSourceModule opts file0 = 
-  errIn file0 $
+--errIn file0 $
   do tmp <- lift $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
      raw <- lift $ keepTemp tmp
    --ePutStrLn $ "1 "++file0
      (optCoding,parsed) <- parseSource opts pModDef raw
      case parsed of
        Left (Pn l c,msg) -> do file <- lift $ writeTemp tmp
-                               let location = file++":"++show l++":"++show c
+                               cwd <- lift $ getCurrentDirectory
+                               let location = makeRelative cwd file++":"++show l++":"++show c
                                raise (location++":\n   "++msg)
        Right (i,mi0) ->
          do lift $ removeTemp tmp
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 8821d99ca..732693b49 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -46,13 +46,13 @@ import Text.PrettyPrint
 renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
 renameSourceTerm g m t = do
   mi     <- lookupModule g m
-  status <- buildStatus g (m,mi)
+  status <- buildStatus "" g (m,mi)
   renameTerm status [] t
 
-renameModule :: SourceGrammar -> SourceModule -> Check SourceModule
-renameModule gr mo@(m,mi) = do
-  status <- buildStatus gr mo
-  js     <- checkMapRecover (renameInfo status mo) (jments mi)
+renameModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+renameModule cwd gr mo@(m,mi) = do
+  status <- buildStatus cwd gr mo
+  js     <- checkMapRecover (renameInfo cwd status mo) (jments mi)
   return (m, mi{jments = js})
 
 type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -123,8 +123,8 @@ tree2status o = case o of
   OSimple i   -> mapTree (info2status (Just i))
   OQualif i j -> mapTree (info2status (Just j))
 
-buildStatus :: SourceGrammar -> SourceModule -> Check Status
-buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
+buildStatus :: FilePath -> SourceGrammar -> SourceModule -> Check Status
+buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
   let gr1  = prependModule gr mo
       exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
   ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
@@ -140,8 +140,8 @@ self2status :: Ident -> SourceModInfo -> StatusTree
 self2status c m = mapTree (info2status (Just c)) (jments m)
 
   
-renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
-renameInfo status (m,mi) i info = 
+renameInfo :: FilePath -> Status -> SourceModule -> Ident -> Info -> Check Info
+renameInfo cwd status (m,mi) i info =
   case info of
     AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
     AbsFun  pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
@@ -165,7 +165,7 @@ renameInfo status (m,mi) i info =
     renMaybe ren Nothing  = return Nothing
 
     renLoc ren (L loc x) =
-      checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
+      checkInModule cwd mi loc (text "Happened in the renaming of" <+> ppIdent i) $ do
         x <- ren x
         return (L loc x)
 
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 6821a2981..88f44a631 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -29,7 +29,7 @@ import Control.Monad
 import Text.PrettyPrint
 
 -- | combine a list of definitions into a balanced binary search tree
-buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info)
+buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info)
 buildAnyTree m = go Map.empty
   where
     go map []         = return map
@@ -37,20 +37,19 @@ buildAnyTree m = go Map.empty
       case Map.lookup c map of
         Just i  -> case unifyAnyInfo m i j of
 		     Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render (text "cannot unify the informations" $$ 
+		     Bad _ -> fail $ render (text "conflicting information in module"<+>ppIdent m $$
 		                             nest 4 (ppJudgement Qualified (c,i)) $$
 		                             text "and" $+$
-		                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                             text "in module" <+> ppIdent m)
+		                             nest 4 (ppJudgement Qualified (c,j)))
         Nothing -> go (Map.insert c j map) is
 
-extendModule :: SourceGrammar -> SourceModule -> Check SourceModule
-extendModule gr (name,m)
+extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+extendModule cwd 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
   | mstatus m == MSIncomplete && isModCnc m = return (name,m)
-  | otherwise                               = checkIn (ppLocation (msrc m) NoLoc <> colon) $ do
+  | otherwise                               = checkInModule cwd m NoLoc empty $ do
                                                  m' <- foldM extOne m (mextend m) 
                                                  return (name,m')
  where
@@ -77,9 +76,9 @@ extendModule gr (name,m)
 
 -- | rebuilding instance + interface, and "with" modules, prior to renaming. 
 -- AR 24/10/2003
-rebuildModule :: SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) = 
-  checkIn (ppLocation msrc_ NoLoc <> colon) $ do
+rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
+  checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
 ----  is   <- openInterfaces deps i