Now the compiler maintains more precise information for the source locations of the different definitions. There is a --tags option which generates a list of all identifiers with their source locations.

7 files changed, 72 insertions, 51 deletions

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index b3129128b..44e2e552b 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -112,14 +112,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
                                                   return $ updateTree (c,CncFun ty (Just def) pn) js
                                     Ok (CncFun ty Nothing    pn) ->
                                       case mb_def of
-                                        Ok def -> return $ updateTree (c,CncFun ty (Just (L (0,0) def)) pn) js
+                                        Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js
                                         Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
                                                      return js
                                     _ -> do
                                       case mb_def of
                                         Ok def -> do (cont,val) <- linTypeOfType gr cm ty
                                                      let linty = (snd (valCat ty),cont,val)
-                                                     return $ updateTree (c,CncFun (Just linty) (Just (L (0,0) def)) Nothing) js
+                                                     return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
                                         Bad _  -> do checkWarn $ text "no linearization of" <+> ppIdent c
                                                      return js
        AbsCat (Just _) -> case lookupIdent c js of
@@ -128,11 +128,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
          Ok (CncCat _ mt mp) -> do
            checkWarn $ 
              text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
-           return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) mt mp) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
          _ -> do
            checkWarn $ 
              text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
-           return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) Nothing Nothing) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
        _ -> return js
      
    checkCnc js i@(c,info) =
@@ -158,15 +158,15 @@ checkInfo ms (m,mo) c info = do
   checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) -> 
-      mkCheck loc "category" $ 
+      mkCheck loc "the category" $ 
         checkContext gr cont
 
     AbsFun (Just (L loc typ0)) ma md moper -> do
       typ <- compAbsTyp [] typ0   -- to calculate let definitions
-      mkCheck loc "type of function" $
+      mkCheck loc "the type of function" $
         checkTyp gr typ
       case md of
-        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "definition of function" $
+        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
 	                                        checkDef gr (m,c) typ eq) eqs
         Nothing  -> return ()
       return (AbsFun (Just (L loc typ)) ma md moper)
@@ -204,7 +204,7 @@ checkInfo ms (m,mo) c info = do
              checkError (text "No definition given to the operation")
       return (ResOper pty' pde')
 
-    ResOverload os tysts -> chIn (0,0) "overloading" $ do
+    ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
       tysts0 <- checkErr $ lookupOverload gr (m,c)  -- check against inherited ones too
       tysts1 <- mapM (uncurry $ flip (checkLType gr [])) 
@@ -215,17 +215,17 @@ checkInfo ms (m,mo) c info = do
         sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
-    ResParam (Just pcs) _ -> do
-      ts <- liftM concat $ mapM mkPar pcs
-      return (ResParam (Just pcs) (Just ts))
+    ResParam (Just (L loc pcs)) _ -> do
+      ts <- chIn loc "parameter type" $ 
+              liftM concat $ mapM mkPar pcs
+      return (ResParam (Just (L loc pcs)) (Just ts))
 
     _ ->  return info
  where
    gr = mGrammar ((m,mo) : ms)
-   chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon)
+   chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c)
 
-   mkPar (L loc (f,co)) = 
-     chIn loc "parameter type" $ do
+   mkPar (f,co) = do
        vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
        return $ map (mkApp (QC (m,f))) vs
 
@@ -238,7 +238,7 @@ checkInfo ms (m,mo) c info = do
 
    mkCheck loc cat ss = case ss of
      [] -> return info
-     _  -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition m loc)
+     _  -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (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/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index d15d57001..8732a8e06 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -46,14 +46,14 @@ arrityPredefined f = do ty <- typPredefined f
                         return (length ctxt)
 
 predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] primitives
+predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
 
 primitives = Map.fromList
   [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
   , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
   , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
   , (cInts     , fun [typeInt] typePType)
-  , (cPBool    , ResParam (Just [noLoc (cPTrue,[]),noLoc (cPFalse,[])]) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
   , (cPTrue    , ResValue (noLoc typePBool))
   , (cPFalse   , ResValue (noLoc typePBool))
   , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
@@ -87,7 +87,7 @@ primitives = Map.fromList
     fun from to = oper (mkFunType from to)
     oper ty     = ResOper (Just (noLoc ty)) Nothing
 
-    noLoc = L (0,0)
+    noLoc = L NoLoc
 
     varL :: Ident
     varL = identC (BS.pack "L")
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index c7fea11b0..339f28578 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -41,9 +41,12 @@ getSourceModule opts file0 = ioe $
                                  let location = file++":"++show l++":"++show c
                                  return (Bad (location++": "++msg))
          Right mo          -> do removeTemp tmp
-                                 return (Ok (addOptionsToModule opts mo))
+                                 return (Ok (addOptionsToModule opts (setSrcPath file0 mo)))
   `catch` (return . Bad . show)
 
+setSrcPath :: FilePath -> SourceModule -> SourceModule
+setSrcPath fpath = mapSourceModule (\m -> m{msrc=fpath})
+
 addOptionsToModule :: Options -> SourceModule -> SourceModule
 addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
 
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index ed10697fd..81d2b3632 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -154,8 +154,8 @@ compilePatt eqs        = whilePP eqs Map.empty
 reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
 reorder abs cg =
 --  M.MGrammar $
-       ((abs, M.ModInfo M.MTAbstract       M.MSComplete aflags [] Nothing [] [] adefs),
-      [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
+       ((abs, M.ModInfo M.MTAbstract       M.MSComplete aflags [] Nothing [] [] "" adefs),
+      [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] "" cdefs)
             | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
   where
     aflags = 
@@ -165,7 +165,7 @@ reorder abs cg =
       Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
       where
         predefADefs = 
-           [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
+           [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
 
     concr la = (flags, Map.fromList (predefCDefs ++ jments))
       where 
@@ -173,4 +173,4 @@ reorder abs cg =
                                                 Just r <- [lookup i (M.allExtendSpecs cg la)]]
         jments = Look.allOrigInfos cg la
         predefCDefs = 
-           [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
+           [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 8cd84a1a0..4c959c194 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -47,24 +47,23 @@ import Text.PrettyPrint
 -- | this gives top-level access to renaming term input in the cc command
 renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
 renameSourceTerm g m t = do
-  mo     <- checkErr $ lookupModule g m
-  status <- buildStatus g m mo
+  mi     <- checkErr $ lookupModule g m
+  status <- buildStatus g m mi
   renameTerm status [] t
 
 -- | this gives top-level access to renaming term input in the cj command
 renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
 renameSourceJudgement g m (i,t) = do
-  mo     <- checkErr $ lookupModule g m
-  status <- buildStatus g m mo
-  t2 <- renameInfo status m i t
+  mi     <- checkErr $ lookupModule g m
+  status <- buildStatus g m mi
+  t2 <- renameInfo status (m,mi) i t
   return (i,t2)
 
 renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
-renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
-  let js1 = jments mo
-  status <- buildStatus (mGrammar ms) name mo
-  js2    <- checkMap (renameInfo status name) js1
-  return (name, mo {opens = map forceQualif (opens mo), jments = js2})
+renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
+  status <- buildStatus (mGrammar ms) m mi
+  js     <- checkMap (renameInfo status mo) (jments mi)
+  return (m, mi{opens = map forceQualif (opens mi), jments = js})
 
 type Status = (StatusTree, [(OpenSpec, StatusTree)])
 
@@ -147,15 +146,15 @@ forceQualif o = case o of
   OSimple i   -> OQualif i i
   OQualif _ i -> OQualif i i
   
-renameInfo :: Status -> Ident -> Ident -> Info -> Check Info
-renameInfo status m i info =
+renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
+renameInfo 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)
     ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
     ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
     ResParam (Just pp) m -> do
-      pp' <- mapM (renLoc (renParam status)) pp
+      pp' <- renLoc (mapM (renParam status)) pp
       return (ResParam (Just pp') m)
     ResValue t -> do
       t <- renLoc (renameTerm status []) t
@@ -172,7 +171,7 @@ renameInfo status m i info =
     renMaybe ren Nothing  = return Nothing
 
     renLoc ren (L loc x) =
-      checkIn (text "renaming of" <+> ppIdent i <+> ppPosition m loc) $ do
+      checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
         x <- ren x
         return (L loc x)
 
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 49d7efb81..808e4dca8 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
 
    list = Map.toList tree
 
-   oper id trm = (operIdent id, ResOper (Just (L (0,0) (EInt 8))) (Just (L (0,0) trm))) 
+   oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm))) 
    --- impossible type encoding generated opers
 
 getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 1dcae722c..fe9bd5984 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -63,7 +63,7 @@ extendModule gr (name,m)
      let isCompl = isCompleteModule m0
 
      -- build extension in a way depending on whether the old module is complete
-     js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
+     js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
 
      -- if incomplete, throw away extension information
      return $ 
@@ -77,7 +77,7 @@ extendModule gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming. 
 -- AR 24/10/2003
 rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
+rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = 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 gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
         MTInstance (i0,mincl) -> do
           m1 <- lookupModule gr i0
           testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
-          js' <- extendMod gr False (i0, isInherited mincl) i (jments m1) (jments mi)
+          js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
           --- to avoid double inclusions, in instance I of I0 = J0 ** ...
           case extends mi of
             []  -> return $ replaceJudgements mi js'
@@ -110,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
                     [i | i <- is, notElem i infs]
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ showIdent i +++ "remains incomplete")
-      ModInfo mt0 _ fs me' _ ops0 _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -123,7 +123,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
       let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
       let js1 = buildTree (tree2list js_ ++ js0)
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
 
   return (i,mi')
 
@@ -131,12 +131,11 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
 -- and the process is interrupted if unification fails.
 -- If the extended module is incomplete, its judgements are just copied.
 extendMod :: SourceGrammar ->
-             Bool -> (Ident,Ident -> Bool) -> Ident -> 
-             BinTree Ident Info -> BinTree Ident Info -> 
-             Err (BinTree Ident Info)
-extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old 
+             Bool -> (SourceModule,Ident -> Bool) -> Ident -> 
+             BinTree Ident Info -> Err (BinTree Ident Info)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) 
   where
-    try new (c,i)
+    try new (c,i0)
       | not (cond c) = return new
       | otherwise    = case Map.lookup c new of
                          Just j -> case unifyAnyInfo name i j of
@@ -155,6 +154,8 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
                          Nothing-> if isCompl
                                      then return $ updateTree (c,indirInfo name i) new
                                      else return $ updateTree (c,i) new
+      where
+        i = globalizeLoc (msrc mi) i0
 
     indirInfo :: Ident -> Info -> Info
     indirInfo n info = AnyInd b n' where 
@@ -165,6 +166,24 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
+globalizeLoc fpath i =
+  case i of
+    AbsCat mc             -> AbsCat (fmap gl mc)
+    AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+    ResParam mt mv        -> ResParam (fmap gl mt) mv
+    ResValue t            -> ResValue (gl t)
+    ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
+    ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
+    CncCat mc mf mp       -> CncCat (fmap gl mc)  (fmap gl mf) (fmap gl mp)
+    CncFun m mt md        -> CncFun m (fmap gl mt) (fmap gl md)
+    AnyInd b m            -> AnyInd b m
+  where
+    gl (L loc0 x) = loc `seq` L (External fpath loc) x
+      where
+        loc = case loc0 of
+                External _ loc -> loc
+                loc            -> loc
+
 unifyAnyInfo :: Ident -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
   (AbsCat mc1, AbsCat mc2) -> 
@@ -173,9 +192,9 @@ unifyAnyInfo m i j = case (i,j) of
     liftM4 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifMaybe moper1 moper2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
-    liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
-  (ResValue t1, ResValue t2) 
-      | t1==t2    -> return (ResValue t1)
+    liftM2 ResParam (unifMaybeL mt1 mt2) (unifMaybe mv1 mv2)
+  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+      | t1==t2    -> return (ResValue (L l1 t1))
       | otherwise -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t