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.

9 files changed, 66 insertions, 44 deletions

diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 981037827..78ad3e53f 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -107,7 +107,7 @@ sizeInfo i = case i of
   AbsFun mt mi me mb -> 1 + msize mt + 
     sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
-    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just ps <- [mp], L _ (_,co) <- ps]
+    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
   ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 32ddfe6ad..7c79be361 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -31,9 +31,9 @@ instance Binary a => Binary (MGrammar a) where
   get = fmap mGrammar get

 

 instance Binary a => Binary (ModInfo a) where

-  put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi)

-  get    = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get

-              return (ModInfo mtype mstatus flags extend mwith opens med jments)

+  put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi)

+  get    = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get

+              return (ModInfo mtype mstatus flags extend mwith opens med src jments)

 

 instance Binary ModuleType where

   put MTAbstract       = putWord8 0

@@ -109,6 +109,16 @@ instance Binary Info where
              8 -> get >>= \(x,y)     -> return (AnyInd x y)

              _ -> decodingError

 

+instance Binary Location where

+  put NoLoc          = putWord8 0

+  put (Local x y)    = putWord8 1 >> put (x,y)

+  put (External x y) = putWord8 2 >> put (x,y)

+  get = do tag <- getWord8

+           case tag of

+             0 ->                   return NoLoc

+             1 -> get >>= \(x,y) -> return (Local x y)

+             2 -> get >>= \(x,y) -> return (External x y)

+

 instance Binary a => Binary (L a) where

   put (L x y) = put (x,y)

   get = get >>= \(x,y) -> return (L x y)

@@ -261,7 +271,7 @@ instance Binary Label where
 

 decodeModHeader :: FilePath -> IO SourceModule

 decodeModHeader fpath = do

-  (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath

-  return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty)

+  (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath

+  return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)

 

 decodingError = fail "This GFO file was compiled with different version of GF"

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 93ae10b4a..10f7a71fd 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -19,15 +19,17 @@ import GF.Grammar.Macros
 import GF.Infra.Ident
 import GF.Infra.Modules
 import GF.Infra.Option
+import GF.Infra.UseIO
 
 import GF.Data.Operations
 
 import Data.Char
 import Data.List
 import qualified Data.ByteString.Char8 as BS
+import System.FilePath
 
-getCF :: String -> String -> Err SourceGrammar
-getCF name = fmap (cf2gf name) . pCF
+getCF :: FilePath -> String -> Err SourceGrammar
+getCF fpath = fmap (cf2gf fpath) . pCF
 
 ---------------------
 -- the parser -------
@@ -50,9 +52,9 @@ getCFRule :: String -> Err [CFRule]
 getCFRule s = getcf (wrds s) where
   getcf ws = case ws of
     fun : cat : a : its | isArrow a -> 
-      Ok [L (0,0) (init fun, (cat, map mkIt its))]
+      Ok [L NoLoc (init fun, (cat, map mkIt its))]
     cat : a : its | isArrow a -> 
-      Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+      Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
     _ -> Bad (" invalid rule:" +++ s)
   isArrow a = elem a ["->", "::="] 
   mkIt w = case w of
@@ -80,13 +82,14 @@ type CFFun = String
 -- the compiler ----------
 --------------------------
 
-cf2gf :: String -> CF -> SourceGrammar
-cf2gf name cf = mGrammar [
+cf2gf :: FilePath -> CF -> SourceGrammar
+cf2gf fpath cf = mGrammar [
   (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
-          (emptyModInfo{mtype = MTAbstract,       jments = abs})),
-  (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
+          (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
+  (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
   ]
  where
+   name = justModuleName fpath
    (abs,cnc,cat) = cf2grammar cf
    aname = identS $ name ++ "Abs"
    cname = identS name
@@ -99,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
   cat   = case rules of
             (L _ (_,(c,_))):_ -> c  -- the value category of the first rule
             _ -> error "empty CF" 
-  cats  = [(cat, AbsCat (Just (L (0,0) []))) | 
+  cats  = [(cat, AbsCat (Just (L NoLoc []))) | 
              cat <- nub (concat (map cf2cat rules))] ----notPredef cat
   lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
   (funs,lins) = unzip (map cf2rule rules)
diff --git a/src/compiler/GF/Grammar/EBNF.hs b/src/compiler/GF/Grammar/EBNF.hs
index 11a2b3c4b..e5cbf6c7f 100644
--- a/src/compiler/GF/Grammar/EBNF.hs
+++ b/src/compiler/GF/Grammar/EBNF.hs
@@ -24,13 +24,14 @@ import GF.Grammar.Grammar
 
 import Data.Char
 import Data.List
+import System.FilePath
 
 
 
 -- AR 18/4/2000 - 31/3/2004
 
-getEBNF :: String -> String -> Err SourceGrammar
-getEBNF name = fmap (cf2gf name . ebnf2cf) . pEBNF
+getEBNF :: FilePath -> String -> Err SourceGrammar
+getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF
 
 type EBNF = [ERule]
 type ERule = (ECat, ERHS)
@@ -54,7 +55,7 @@ type CFJustRule = (CFCat, CFRHS)
 
 ebnf2cf :: EBNF -> [CFRule]
 ebnf2cf ebnf = 
-  [L (0,0) (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
+  [L NoLoc (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
     mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i)
 
 normEBNF :: EBNF -> [CFJustRule]
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index ae29ab6d5..627355033 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -20,7 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
         SourceModule,
         mapSourceModule,
         Info(..),
-        L(..), unLoc,
+        Location(..), L(..), unLoc,
         Type,
         Cat,
         Fun,
@@ -80,7 +80,7 @@ data Info =
  | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
- | ResParam (Maybe [L Param]) (Maybe [Term])     -- ^ (/RES/) the second parameter is list of all possible values
+ | ResParam (Maybe (L [Param])) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
  | ResValue (L Type)                             -- ^ (/RES/) to mark parameter constructors for lookup
  | ResOper  (Maybe (L Type)) (Maybe (L Term))    -- ^ (/RES/)
 
@@ -94,8 +94,14 @@ data Info =
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
   deriving Show
 
-data L a = L (Int,Int) a  -- location information
-  deriving (Eq,Show)
+data Location 
+  = NoLoc
+  | Local Int Int
+  | External FilePath Location
+  deriving (Show,Eq,Ord)
+
+data L a = L Location a  -- location information
+  deriving Show
 
 instance Functor L where
   fmap f (L loc x) = L loc (f x)
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 435280963..651fde4d0 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -191,7 +191,7 @@ lookupCatContext gr m c = do
 -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
 -- notice that it only gives the modules that are reachable and the opers that are included
 
-allOpers :: SourceGrammar -> [((Ident,Ident),Type,(Int,Int))]
+allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)]
 allOpers gr = 
   [((mo,op),typ,loc) | 
       (mo,minc)  <- reachable,
@@ -212,7 +212,7 @@ allOpers gr =
     _ -> []
 
 --- not for dependent types
-allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,(Int,Int))]
+allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)]
 allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
   isProdTo t typ = eqProd typ t || case typ of
     Prod _ _ a b -> isProdTo t b
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 30795cecb..38b22aaa2 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -560,7 +560,7 @@ allDependencies ism b =
     pts i = case i of
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
-      ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,cont) <- ps, (_,_,t) <- cont]
+      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
       CncCat pty _ _ -> [pty]
       CncFun _   pt _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
       AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 23974f6b1..26b7e123b 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -5,7 +5,7 @@ module GF.Grammar.Parser
          , pModDef
          , pModHeader
          , pExp
-	 , pTopDef
+         , pTopDef
          ) where
 
 import GF.Infra.Ident
@@ -118,14 +118,14 @@ ModDef
                                       defs <- case buildAnyTree id jments of
                                                 Ok x    -> return x
                                                 Bad msg -> fail msg
-                                      return (id, ModInfo mtype mstat opts extends with opens [] defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -251,9 +251,9 @@ DataDef
 
 ParamDef :: { [(Ident,Info)] }
 ParamDef
-  : Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) :
-                              [(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] }
-  | Ident                   { [($1, ResParam Nothing Nothing)] }
+  : Posn Ident '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
+                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
+  | Posn Ident                   Posn { [($2, ResParam Nothing Nothing)] }
 
 OperDef :: { [(Ident,Info)] }
 OperDef
@@ -679,7 +679,7 @@ checkInfoType mt jment@(id,info) =
     AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
     CncCat pty pd ppn  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
     CncFun _   pd ppn  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
-    ResParam pparam _  -> ifResource mt (maybe [] locAll pparam)
+    ResParam pparam _  -> ifResource mt (locPerh pparam)
     ResValue ty        -> ifResource mt (locL ty)
     ResOper  pty pt    -> ifOper mt pty pt
     ResOverload _ xs   -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
@@ -688,8 +688,8 @@ checkInfoType mt jment@(id,info) =
     locAll xs = [loc | L loc x <- xs]
     locL (L loc x) = [loc]
     
-    illegal ((s,e):_) = failLoc (Pn s 0) "illegal definition"
-    illegal _         = return jment
+    illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
+    illegal _             = return jment
 
     ifAbstract MTAbstract     locs = return jment
     ifAbstract _              locs = illegal locs
@@ -729,6 +729,6 @@ mkAlts cs = case cs of
      _ -> fail "no strs from pattern"
 
 mkL :: Posn -> Posn -> x -> L x
-mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
+mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 
 }
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 5fa9121fc..ce8562db7 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -17,7 +17,7 @@ module GF.Grammar.Printer
            , ppPatt

            , ppValue

            , ppConstrs

-           , ppPosition

+           , ppLocation

            , ppQIdent

            ) where

 

@@ -38,7 +38,7 @@ ppGrammar :: SourceGrammar -> Doc
 ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr

 

 ppModule :: TermPrintQual -> SourceModule -> Doc

-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments) =

+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =

     hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr

     where

       defs = Map.toList jments

@@ -97,8 +97,8 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) =
 ppJudgement q (id, ResParam pparams _) = 

   text "param" <+> ppIdent id <+>

   (case pparams of

-     Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))

-     _       -> empty) <+> semi

+     Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))

+     _             -> empty) <+> semi

 ppJudgement q (id, ResValue pvalue) = empty

 ppJudgement q (id, ResOper  ptype pexp) =

   text "oper" <+> ppIdent id <+>

@@ -269,12 +269,14 @@ ppBind (Implicit,v) = braces (ppIdent v)
 

 ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y

 

-ppParam q (L _ (id,cxt)) = ppIdent id <+> hsep (map (ppDDecl q) cxt)

+ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)

 

-ppPosition :: Ident -> (Int,Int) -> Doc

-ppPosition m (b,e)

-  | b == e    = text "in" <+> ppIdent m <> text ".gf, line"  <+> int b

-  | otherwise = text "in" <+> ppIdent m <> text ".gf, lines" <+> int b <> text "-" <> int e

+ppLocation :: FilePath -> Location -> Doc

+ppLocation fpath NoLoc          = text fpath

+ppLocation fpath (External p l) = ppLocation p l

+ppLocation fpath (Local b e)

+  | b == e    = text fpath <> colon <> int b

+  | otherwise = text fpath <> colon <> int b <> text "-" <> int e

 

 commaPunct f ds = (hcat (punctuate comma (map f ds)))