store and propagate the exact source location for all judgements in the grammar. It may not be used accurately in the error messages yet

7 files changed, 156 insertions, 142 deletions

diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 1febdcd46..ff34ae38a 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,positions mi)

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

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

+  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)

 

 instance Binary ModuleType where

   put MTAbstract       = putWord8 0

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

              _ -> decodingError

 

+instance Binary a => Binary (L a) where

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

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

+

 instance Binary BindType where

   put Explicit = putWord8 0

   put Implicit = putWord8 1

@@ -258,6 +262,6 @@ 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 Map.empty)

+  return (m,ModInfo mtype mstatus flags extend mwith opens med 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 e883d0552..06f67234b 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -50,9 +50,9 @@ getCFRule :: String -> Err [CFRule]
 getCFRule s = getcf (wrds s) where
   getcf ws = case ws of
     fun : cat : a : its | isArrow a -> 
-      Ok [(init fun, (cat, map mkIt its))]
+      Ok [L (0,0) (init fun, (cat, map mkIt its))]
     cat : a : its | isArrow a -> 
-      Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+      Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
     _ -> Bad (" invalid rule:" +++ s)
   isArrow a = elem a ["->", "::="] 
   mkIt w = case w of
@@ -69,7 +69,7 @@ getCFRule s = getcf (wrds s) where
 
 type CF = [CFRule]
 
-type CFRule = (CFFun, (CFCat, [CFItem]))
+type CFRule = L (CFFun, (CFCat, [CFItem]))
 
 type CFItem = Either CFCat String
 
@@ -97,27 +97,27 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
   abs   = cats ++ funs
   conc  = lincats ++ lins
   cat   = case rules of
-            (_,(c,_)):_ -> c  -- the value category of the first rule
+            (L _ (_,(c,_))):_ -> c  -- the value category of the first rule
             _ -> error "empty CF" 
-  cats  = [(cat, AbsCat (Just [])) | 
+  cats  = [(cat, AbsCat (Just (L (0,0) []))) | 
              cat <- nub (concat (map cf2cat rules))] ----notPredef cat
-  lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _) <- cats]
+  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
   (funs,lins) = unzip (map cf2rule rules)
 
 cf2cat :: CFRule -> [Ident]
-cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
+cf2cat (L loc (_,(cat, items))) = map identS $ cat : [c | Left c <- items]
 
 cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
-cf2rule (fun, (cat, items)) = (def,ldef) where
+cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
   f     = identS fun
-  def   = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing)
+  def   = (f, AbsFun (Just (L loc (mkProd args' (Cn (identS cat)) []))) Nothing Nothing)
   args0 = zip (map (identS . ("x" ++) . show) [0..]) items
   args  = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
   args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]
   ldef  = (f, CncFun 
                Nothing 
-               (Just (mkAbs (map fst args) 
-                      (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
+               (Just (L loc (mkAbs (map fst args) 
+                      (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
                Nothing)
   mkIt (v, Left _) = P (Vr v) theLinLabel
   mkIt (_, Right a) = K a
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 371e0ac08..4aa2ace51 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -20,6 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
         SourceModule,
         mapSourceModule,
         Info(..),
+        L(..), unLoc,
         Type,
         Cat,
         Fun,
@@ -75,24 +76,33 @@ mapSourceModule f (i,mi) = (i, f mi)
 -- and indirection to module (/INDIR/)
 data Info =
 -- judgements in abstract syntax
-   AbsCat   (Maybe Context)
- | AbsFun   (Maybe Type) (Maybe Int) (Maybe [Equation])  -- ^ (/ABS/) type, arrity and definition of function
+   AbsCat   (Maybe (L Context))                                -- ^ (/ABS/) context of a category
+ | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation])  -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
- | ResParam (Maybe [Param]) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue Type                             -- ^ (/RES/) to mark parameter constructors for lookup
- | ResOper  (Maybe Type) (Maybe Term)        -- ^ (/RES/)
+ | 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/)
 
- | ResOverload [Ident] [(Type,Term)]         -- ^ (/RES/) idents: modules inherited
+ | ResOverload [Ident] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe Type)                 (Maybe Term) (Maybe Term)  -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term)  -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term))  -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
   deriving Show
 
+data L a = L (Int,Int) a  -- location information
+  deriving (Eq,Show)
+
+instance Functor L where
+  fmap f (L loc x) = L loc (f x)
+
+unLoc :: L a -> a
+unLoc (L _ x) = x
+
 type Type = Term
 type Cat  = QIdent
 type Fun  = QIdent
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 14f1ab498..90d8263cd 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -67,13 +67,13 @@ lookupResDef gr m c
       mo <- lookupModule gr m
       info <- lookupIdentInfo mo c
       case info of
-        ResOper _ (Just t) -> return t
+        ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q m c)
-        CncCat (Just ty) _ _ -> lock c ty
+        CncCat (Just (L _ ty)) _ _ -> lock c ty
         CncCat _ _ _         -> lock c defLinType
       
-        CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr
-        CncFun _                (Just tr) _ -> return tr
+        CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
+        CncFun _                (Just (L _ tr)) _ -> return tr
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (QC m c)
@@ -85,7 +85,7 @@ lookupResType gr m c = do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    ResOper (Just t) _ -> return t
+    ResOper (Just (L _ t)) _ -> return t
 
     -- used in reused concrete
     CncCat _ _ _ -> return typeType
@@ -94,7 +94,7 @@ lookupResType gr m c = do
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr n c
     ResParam _ _      -> return typePType
-    ResValue t        -> return t
+    ResValue (L _ t)  -> return t
     _   -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
 
 lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
@@ -105,7 +105,7 @@ lookupOverload gr m c = do
       ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverload gr x c) os
             return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | 
-                      (ty,tr) <- tysts] ++ 
+                      (L _ ty,L _ tr) <- tysts] ++ 
                      concat tss
 
       AnyInd _ n  -> lookupOverload gr n c
@@ -153,7 +153,7 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    AbsFun _ a d -> return (a,d)
+    AbsFun _ a d -> return (a,fmap (map unLoc) d)
     AnyInd _ n   -> lookupAbsDef gr n c
     _            -> return (Nothing,Nothing)
 
@@ -163,9 +163,9 @@ lookupLincat gr m c = do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    CncCat (Just t) _ _ -> return t
-    AnyInd _ n          -> lookupLincat gr n c
-    _                   -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    CncCat (Just (L _ t)) _ _ -> return t
+    AnyInd _ n                -> lookupLincat gr n c
+    _                         -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -173,9 +173,9 @@ lookupFunType gr m c = do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    AbsFun (Just t) _ _  -> return t
-    AnyInd _ n           -> lookupFunType gr n c
-    _                    -> Bad (render (text "cannot find type of" <+> ppIdent c))
+    AbsFun (Just (L _ t)) _ _ -> return t
+    AnyInd _ n                -> lookupFunType gr n c
+    _                         -> Bad (render (text "cannot find type of" <+> ppIdent c))
 
 -- | this is needed at compile time
 lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -183,6 +183,6 @@ lookupCatContext gr m c = do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    AbsCat (Just co) -> return co
-    AnyInd _ n       -> lookupCatContext gr n c
-    _                -> Bad (render (text "unknown category" <+> ppIdent c))
+    AbsCat (Just (L _ co)) -> return co
+    AnyInd _ n             -> lookupCatContext gr n c
+    _                      -> Bad (render (text "unknown category" <+> ppIdent c))
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index ef68b740d..5282b30b1 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -607,15 +607,15 @@ allDependencies ism b =
       Q n c | ism n -> [c]
       QC n c | ism n -> [c]
       _ -> collectOp opersIn t
-    opty (Just ty) = opersIn ty
+    opty (Just (L _ ty)) = opersIn ty
     opty _ = []
     pts i = case i of
       ResOper pty pt -> [pty,pt]
-      ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont]
+      ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,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
-      AbsCat (Just co) -> [Just ty | (_,_,ty) <- co]
+      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
       _              -> []
 
 topoSortJments :: SourceModule -> Err [(Ident,Info)]
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 2346953a9..16cea88b8 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -113,23 +113,17 @@ ModDef
                                           (extends,with,content) = $4
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       mapM_ (checkInfoType mtype) jments
-                                      defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of
+                                      defs <- case buildAnyTree id jments of
                                                 Ok x    -> return x
                                                 Bad msg -> fail msg
-                                      let poss  = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments]
-                                          fname = showIdent id ++ ".gf"
-                                          
-                                          mkSrcSpan :: (Posn, Posn) -> (Int,Int)
-					  mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2)
-
-                                      return (id, ModInfo mtype mstat opts extends with opens [] defs poss)  }
+                                      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 emptyBinTree) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -164,7 +158,7 @@ ModOpen
 
 ModBody :: { ( [(Ident,MInclude)]
              , Maybe (Ident,MInclude,[(Ident,Ident)])
-             , Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options)
+             , Maybe ([OpenSpec],[(Ident,Info)],Options)
              ) }
 ModBody
   : ListIncluded '**' Included 'with' ListInst '**' ModContent  { ($1, Just (fst $3,snd $3,$5), Just $7) }
@@ -176,12 +170,12 @@ ModBody
   |                                                 ModContent  { ([], Nothing,                 Just $1) }
   | ModBody ';'                                                 { $1                                     }
 
-ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) }
+ModContent :: { ([OpenSpec],[(Ident,Info)],Options) }
 ModContent
   :                      '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
   | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
 
-ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] }
+ListTopDef :: { [Either [(Ident,Info)] Options] }
 ListTopDef
   : {- empty -}       { []      } 
   | TopDef ListTopDef { $1 : $2 }
@@ -216,7 +210,7 @@ Included
   | Ident     '[' ListIdent ']' { ($1,MIOnly   $3) }
   | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
 
-TopDef :: { Either [(Ident,SrcSpan,Info)] Options }
+TopDef :: { Either [(Ident,Info)] Options }
 TopDef
   : 'cat'             ListCatDef      { Left  $2 }
   | 'fun'             ListFunDef      { Left  $2 }
@@ -224,56 +218,56 @@ TopDef
   | 'data'            ListDataDef     { Left  $2 }
   | 'param'           ListParamDef    { Left  $2 }
   | 'oper'            ListOperDef     { Left  $2 }
-  | 'lincat'          ListTermDef     { Left  [(f, pos, CncCat (Just e) Nothing    Nothing   ) | (f,pos,e) <- $2] }
-  | 'lindef'          ListTermDef     { Left  [(f, pos, CncCat Nothing    (Just e) Nothing   ) | (f,pos,e) <- $2] }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing   ) | (f,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing   ) | (f,e) <- $2] }
   | 'lin'             ListLinDef      { Left  $2 }
-  | 'printname' 'cat' ListTermDef     { Left  [(f, pos, CncCat Nothing    Nothing (Just e)) | (f,pos,e) <- $3] }
-  | 'printname' 'fun' ListTermDef     { Left  [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e)) | (f,e) <- $3] }
+  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
   | 'flags'           ListFlagDef     { Right $2 }
 
-CatDef :: { [(Ident,SrcSpan,Info)] }
+CatDef :: { [(Ident,Info)] }
 CatDef
-  : Posn Ident ListDDecl                         Posn { [($2, ($1,$4), AbsCat (Just $3))]        }
-  | Posn '[' Ident ListDDecl ']'                 Posn { listCatDef $3 ($1,$6) $4 0                 }
-  | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) }
+  : Posn Ident ListDDecl                         Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))]           }
+  | Posn '[' Ident ListDDecl ']'                 Posn { listCatDef (mkL $1 $6 ($3,$4,0))               }
+  | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) }
 
-FunDef :: { [(Ident,SrcSpan,Info)] }
+FunDef :: { [(Ident,Info)] }
 FunDef
-  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] } 
+  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just [])) | fun <- $2] } 
 
-DefDef :: { [(Ident,SrcSpan,Info)] }
+DefDef :: { [(Ident,Info)] }
 DefDef
-  : Posn ListName '=' Exp         Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] }
-  | Posn Name ListPatt '=' Exp    Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] }
+  : Posn ListName '=' Exp         Posn { [(f, AbsFun Nothing (Just 0)           (Just [mkL $1 $5 ([],$4)])) | f <- $2] }
+  | Posn Name ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]))] }
 
-DataDef :: { [(Ident,SrcSpan,Info)] }
+DataDef :: { [(Ident,Info)] }
 DataDef
-  : Posn Ident '=' ListDataConstr Posn { ($2,   ($1,$5), AbsCat Nothing) :
-                                         [(fun, ($1,$5), AbsFun Nothing   Nothing Nothing) | fun <- $4] }
-  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), ($1,$5), AbsCat Nothing) :
-                                         [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }                                         
+  : Posn Ident '=' ListDataConstr Posn { ($2,   AbsCat Nothing) :
+                                         [(fun, AbsFun Nothing   Nothing Nothing) | fun <- $4] }
+  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), AbsCat Nothing) :
+                                         [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing) | fun <- $2] }                                         
 
-ParamDef :: { [(Ident,SrcSpan,Info)] }
+ParamDef :: { [(Ident,Info)] }
 ParamDef
-  : Posn Ident '=' ListParConstr Posn {  ($2, ($1,$5), ResParam (Just $4) Nothing) :
-                                        [(f,  ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] }
-  | Posn Ident                   Posn { [($2, ($1,$3), ResParam Nothing   Nothing)] }
+  : 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)] }
 
-OperDef :: { [(Ident,SrcSpan,Info)] }
+OperDef :: { [(Ident,Info)] }
 OperDef
-  : Posn ListName ':' Exp         Posn { [(i, ($1,$5), info) | i <- $2,   info <- mkOverload (Just $4) Nothing  ] } 
-  | Posn ListName '=' Exp         Posn { [(i, ($1,$5), info) | i <- $2,   info <- mkOverload Nothing   (Just $4)] }
-  | Posn Name ListArg '=' Exp     Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing   (Just (mkAbs $3 $5))] }
-  | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2,   info <- mkOverload (Just $4) (Just $6)] }
+  : Posn ListName ':' Exp         Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $5 $4)) Nothing  ] } 
+  | Posn ListName '=' Exp         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 $4))] }
+  | Posn Name ListArg '=' Exp     Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 $5)))] }
+  | Posn ListName ':' Exp '=' Exp Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
 
-LinDef :: { [(Ident,SrcSpan,Info)] }
+LinDef :: { [(Ident,Info)] }
 LinDef
-  : Posn ListName '=' Exp         Posn { [(f,  ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] }
-  | Posn Name ListArg '=' Exp     Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] }
+  : Posn ListName '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
+  | Posn Name ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] }
 
-TermDef :: { [(Ident,SrcSpan,Term)] }
+TermDef :: { [(Ident,L Term)] }
 TermDef
-  : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } 
+  : Posn ListName '=' Exp Posn { [(i,mkL $1 $5 $4) | i <- $2] } 
 
 FlagDef :: { Options }
 FlagDef
@@ -286,46 +280,46 @@ ListDataConstr
   : Ident                    { [$1]    }
   | Ident '|' ListDataConstr { $1 : $3 }
 
-ParConstr :: { Param }
+ParConstr :: { L Param }
 ParConstr
-  : Ident ListDDecl { ($1,$2) } 
+  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) } 
 
-ListLinDef :: { [(Ident,SrcSpan,Info)] }
+ListLinDef :: { [(Ident,Info)] }
 ListLinDef
   : LinDef ';'            { $1       } 
   | LinDef ';' ListLinDef { $1 ++ $3 }
 
-ListDefDef :: { [(Ident,SrcSpan,Info)] }
+ListDefDef :: { [(Ident,Info)] }
 ListDefDef
   : DefDef ';'            { $1       } 
   | DefDef ';' ListDefDef { $1 ++ $3 }
 
-ListOperDef :: { [(Ident,SrcSpan,Info)] }
+ListOperDef :: { [(Ident,Info)] }
 ListOperDef
   : OperDef ';'             { $1       } 
   | OperDef ';' ListOperDef { $1 ++ $3 }
 
-ListCatDef :: { [(Ident,SrcSpan,Info)] }
+ListCatDef :: { [(Ident,Info)] }
 ListCatDef
   : CatDef ';'            { $1       } 
   | CatDef ';' ListCatDef { $1 ++ $3 }
 
-ListFunDef :: { [(Ident,SrcSpan,Info)] }
+ListFunDef :: { [(Ident,Info)] }
 ListFunDef
   : FunDef ';'            { $1       }
   | FunDef ';' ListFunDef { $1 ++ $3 }
 
-ListDataDef :: { [(Ident,SrcSpan,Info)] }
+ListDataDef :: { [(Ident,Info)] }
 ListDataDef
   : DataDef ';'             { $1       } 
   | DataDef ';' ListDataDef { $1 ++ $3 }
 
-ListParamDef :: { [(Ident,SrcSpan,Info)] }
+ListParamDef :: { [(Ident,Info)] }
 ListParamDef
   : ParamDef ';'              { $1       } 
   | ParamDef ';' ListParamDef { $1 ++ $3 }
 
-ListTermDef :: { [(Ident,SrcSpan,Term)] }
+ListTermDef :: { [(Ident,L Term)] }
 ListTermDef
   : TermDef ';'             { $1       } 
   | TermDef ';' ListTermDef { $1 ++ $3 }
@@ -335,7 +329,7 @@ ListFlagDef
   : FlagDef ';'               { $1               } 
   | FlagDef ';' ListFlagDef   { addOptions $1 $3 }
 
-ListParConstr :: { [Param] }
+ListParConstr :: { [L Param] }
 ListParConstr
   : ParConstr                   { [$1]    }
   | ParConstr '|' ListParConstr { $1 : $3 }
@@ -620,16 +614,16 @@ mkBaseId = prefixId (BS.pack "Base")
 prefixId :: BS.ByteString -> Ident -> Ident
 prefixId pref id = identC (BS.append pref (ident2bs id))
 
-listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)]
-listCatDef id pos cont size = [catd,nilfund,consfund]
+listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
+listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
   where
     listId = mkListId id
     baseId = mkBaseId id
     consId = mkConsId id
 
-    catd     = (listId, pos, AbsCat (Just cont'))
-    nilfund  = (baseId, pos, AbsFun (Just niltyp)  Nothing Nothing)
-    consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
+    catd     = (listId, AbsCat (Just (L loc cont')))
+    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing Nothing)
+    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing)
 
     cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
     xs = map (\(b,x,t) -> Vr x) cont'
@@ -656,16 +650,16 @@ mkR fs@(f:_) =
     tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
     tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
 
-mkOverload pdt pdf@(Just df) =
+mkOverload pdt pdf@(Just (L loc df)) =
   case appForm df of
     (keyw, ts@(_:_)) | isOverloading keyw -> 
        case last ts of
-         R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]]
+         R fs -> [ResOverload [m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
          _    -> [ResOper pdt pdf]
     _         -> [ResOper pdt pdf]
 
      -- to enable separare type signature --- not type-checked
-mkOverload pdt@(Just df) pdf =
+mkOverload pdt@(Just (L _ df)) pdf =
   case appForm df of
     (keyw, ts@(_:_)) | isOverloading keyw ->
        case last ts of
@@ -680,29 +674,26 @@ isOverloading t =
     _                                      -> False
 
 
-type SrcSpan = (Posn,Posn)
-
-
-checkInfoType MTAbstract       (id,pos,info) =
+checkInfoType MTAbstract       (id,info) =
   case info of
     AbsCat _     -> return ()
     AbsFun _ _ _ -> return ()
-    _            -> failLoc (fst pos) "illegal definition in abstract module" 
-checkInfoType MTResource       (id,pos,info) =
+    _            -> failLoc (getInfoPos info) "illegal definition in abstract module" 
+checkInfoType MTResource       (id,info) =
   case info of
     ResParam _ _ -> return ()
     ResValue _   -> return ()
     ResOper  _ _ -> return ()
     ResOverload _ _ -> return ()
-    _            -> failLoc (fst pos) "illegal definition in resource module" 
-checkInfoType MTInterface      (id,pos,info) =
+    _            -> failLoc (getInfoPos info) "illegal definition in resource module" 
+checkInfoType MTInterface      (id,info) =
   case info of
     ResParam _ _ -> return ()
     ResValue _   -> return ()
     ResOper  _ _ -> return ()
     ResOverload _ _ -> return ()
-    _            -> failLoc (fst pos) "illegal definition in interface module" 
-checkInfoType (MTConcrete _)   (id,pos,info) =
+    _            -> failLoc (getInfoPos info) "illegal definition in interface module" 
+checkInfoType (MTConcrete _)   (id,info) =
   case info of
     CncCat _ _ _ -> return ()
     CncFun _ _ _ -> return ()
@@ -710,14 +701,15 @@ checkInfoType (MTConcrete _)   (id,pos,info) =
     ResValue _   -> return ()
     ResOper  _ _ -> return ()
     ResOverload _ _ -> return ()
-    _            -> failLoc (fst pos) "illegal definition in concrete module" 
-checkInfoType (MTInstance _)   (id,pos,info) =
+    _            -> failLoc (getInfoPos info) "illegal definition in concrete module" 
+checkInfoType (MTInstance _)   (id,info) =
   case info of
     ResParam _ _ -> return ()
     ResValue _   -> return ()
     ResOper  _ _ -> return ()
-    _            -> failLoc (fst pos) "illegal definition in instance module" 
+    _            -> failLoc (getInfoPos info) "illegal definition in instance module" 
 
+getInfoPos = undefined
 
 mkAlts cs = case cs of
   _:_ -> do
@@ -741,5 +733,7 @@ mkAlts cs = case cs of
      PM m c -> return (Q m c) --- for macros; not yet complete
      _ -> fail "no strs from pattern"
 
-}
+mkL :: Posn -> Posn -> x -> L x
+mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
 
+}
\ No newline at end of file
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 15afef865..1db1eb4f3 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -16,6 +16,7 @@ module GF.Grammar.Printer
            , ppPatt

            , ppValue

            , ppConstrs

+           , ppPosition

            ) where

 

 import GF.Infra.Ident

@@ -32,7 +33,7 @@ import qualified Data.Map as Map
 data TermPrintQual = Qualified | Unqualified

 

 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

@@ -74,15 +75,15 @@ ppOptions opts =
 ppJudgement q (id, AbsCat pcont ) =

   text "cat" <+> ppIdent id <+>

   (case pcont of

-     Just cont -> hsep (map (ppDecl q) cont)

-     Nothing   -> empty) <+> semi

+     Just (L _ cont) -> hsep (map (ppDecl q) cont)

+     Nothing         -> empty) <+> semi

 ppJudgement q (id, AbsFun ptype _ pexp) =

   (case ptype of

-     Just typ   -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi

-     Nothing    -> empty) $$

+     Just (L _ typ) -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi

+     Nothing        -> empty) $$

   (case pexp of

      Just []  -> empty

-     Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]

+     Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs]

      Nothing  -> empty)

 ppJudgement q (id, ResParam pparams _) = 

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

@@ -92,31 +93,31 @@ ppJudgement q (id, ResParam pparams _) =
 ppJudgement q (id, ResValue pvalue) = empty

 ppJudgement q (id, ResOper  ptype pexp) =

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

-  (case ptype of {Just t -> colon  <+> ppTerm q 0 t; Nothing -> empty} $$

-   case pexp  of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi

+  (case ptype of {Just (L _ t) -> colon  <+> ppTerm q 0 t; Nothing -> empty} $$

+   case pexp  of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi

 ppJudgement q (id, ResOverload ids defs) =

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

   (text "overload" <+> lbrace $$

-   nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$

+   nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (L _ ty,L _ e) <- defs]) $$

    rbrace) <+> semi

 ppJudgement q (id, CncCat  ptype pexp pprn) =

   (case ptype of

-     Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

-     Nothing  -> empty) $$

+     Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

+     Nothing        -> empty) $$

   (case pexp of

-     Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

-     Nothing  -> empty) $$

+     Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

+     Nothing        -> empty) $$

   (case pprn of

-     Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

-     Nothing  -> empty)

+     Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty)

 ppJudgement q (id, CncFun  ptype pdef pprn) =

   (case pdef of

-     Just e  -> let (xs,e') = getAbs e

-              in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi

-     Nothing -> empty) $$

+     Just (L _ e) -> let (xs,e') = getAbs e

+                     in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi

+     Nothing      -> empty) $$

   (case pprn of

-     Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

-     Nothing  -> empty)

+     Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

+     Nothing        -> empty)

 ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi

 

 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)

@@ -257,7 +258,12 @@ ppBind (Implicit,v) = braces (ppIdent v)
 

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

 

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

+ppParam q (L _ (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

 

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