[ close #214 ] File position info with error messages and warnings

Identifiers are now lexed as position tokens, this information is
propagated into various declarations forms (e.g. Rule).

This allows to equip error messages with position information, which
should contribute to the clarity of the error messages, and in
particular make the error for lower case rule names less confusing.

Consider #214 fixed.

source/src/AbsBNF.hs

@@ -5,12 +5,12 @@
 
 module AbsBNF where
 
-import Prelude (Char, Double, Integer, String)
+import Prelude (Char, Double, Int, Integer, String)
 import qualified Prelude as C (Eq, Ord, Show, Read)
 import qualified Data.String
 
-newtype Identifier = Identifier String
-  deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString)
+newtype Identifier = Identifier ((Int, Int), String)
+  deriving (C.Eq, C.Ord, C.Show, C.Read)
 
 data LGrammar = LGr [LDef]
   deriving (C.Eq, C.Ord, C.Show, C.Read)

source/src/BNF.cf

@@ -161,7 +161,7 @@ coercions Reg 3;
 
 -- LBNF identifiers
 
-token Identifier letter (letter | digit | '_')* ;
+position token Identifier letter (letter | digit | '_')* ;
 
 -- Comments in BNF source
 comment "--"      ;

source/src/BNFC/Backend/Agda.hs

@@ -234,7 +234,7 @@ cf2AgdaAST time tokenText mod amod pmod cf = vsep $
   -- The user-defined token categories (including Ident).
   tcats :: [(TokenCat, Bool)]
   tcats = (if hasIdent cf then ((catIdent, False) :) else id)
-    [ (name, b) | TokenReg name b _ <- cfgPragmas cf ]
+    [ (wpThing name, b) | TokenReg name b _ <- cfgPragmas cf ]
   -- Bind printers for the following categories (involves lists and literals).
   printerCats :: [Cat]
   printerCats = concat
@@ -660,7 +660,7 @@ definedRules :: CF -> Doc
 definedRules cf = vsep [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
   where
     mkDef f xs e = vcat $ map text $ concat
-      [ [ unwords [ mkDefName f, ":", typeToHaskell' "→" t ]
+      [ [ unwords [ mkDefName f, ":", typeToHaskell' "→" $ wpThing t ]
         | t <- maybeToList $ sigLookup f cf
         ]
       , [ unwords $ concat

source/src/BNFC/Backend/C/CFtoBisonC.hs

@@ -305,13 +305,13 @@ constructRule rp cf env rules nt = (nt,[(p, generateAction rp (identCat (normCat
 -- "make_ListFoo($1, $2);"
 -- >>> generateAction NoRecordPositions "ListFoo" "(:)" True ["$1","$2"]
 -- "make_ListFoo($2, $1);"
-generateAction :: RecordPositions -> String -> Fun -> Bool -> [MetaVar] -> Action
+generateAction :: IsFun a => RecordPositions -> String -> a -> Bool -> [MetaVar] -> Action
 generateAction rp nt f b ms
   | isCoercion f = unwords ms ++ ";" ++ loc
   | isNilFun f   = "0;"
   | isOneFun f   = concat ["make_", nt, "(", intercalate ", " ms', ", 0);"]
   | isConsFun f  = concat ["make_", nt, "(", intercalate ", " ms', ");"]
-  | otherwise    = concat ["make_", f, "(", intercalate ", " ms', ");", loc]
+  | otherwise    = concat ["make_", funName f, "(", intercalate ", " ms', ");", loc]
  where
   ms' = if b then reverse ms else ms
   loc = if rp == RecordPositions then " $$->line_number = @$.first_line; $$->char_number = @$.first_column;" else ""

source/src/BNFC/Backend/C/CFtoCAbs.hs

@@ -104,10 +104,10 @@ mkHFile rp cf = unlines $ concat
   prForward _ = ""
   getRules cf = map testRule (cfgRules cf)
   getClasses = map show . filter isDataCat
-  testRule (Rule f c _ _)
+  testRule (Rule f (WithPosition _ c) _ _)
     | isList c && isConsFun f = identCat (normCat c)
     | otherwise = "_"
-  definedConstructors = [ (f, xs, e) | FunDef f xs e <- cfgPragmas cf ]
+  definedConstructors = [ (funName f, xs, e) | FunDef f xs e <- cfgPragmas cf ]
 
 -- | For @define@d constructors, make a CPP definition.
 --

source/src/BNFC/Backend/C/CFtoCPrinter.hs

@@ -427,16 +427,17 @@ renderX sep' = "render" <> char sc <> parens (text sep)
 
 prPrintRule :: Rule -> [String]
 prPrintRule r@(Rule fun _ cats _) | not (isCoercion fun) = concat
-  [ [ "  case is_" ++ fun ++ ":"
+  [ [ "  case is_" ++ f ++ ":"
     , "    if (_i_ > " ++ show p ++ ") renderC(_L_PAREN);"
     ]
-  , map (prPrintCat fun) $ numVars cats
+  , map (prPrintCat f) $ numVars cats
   , [ "    if (_i_ > " ++ show p ++ ") renderC(_R_PAREN);"
     , "    break;"
     , ""
     ]
   ]
   where
+    f = funName fun
     p = precRule r
 prPrintRule _ = []
 
@@ -525,21 +526,22 @@ prShowData (cat, rules) = unlines $
 prShowRule :: Rule -> String
 prShowRule (Rule fun _ cats _) | not (isCoercion fun) = unlines
   [
-   "  case is_" ++ fun ++ ":",
+   "  case is_" ++ f ++ ":",
    "  " ++ lparen,
-   "    bufAppendS(\"" ++ fun ++ "\");\n",
+   "    bufAppendS(\"" ++ f ++ "\");\n",
    "  " ++ optspace,
    cats',
    "  " ++ rparen,
    "    break;"
   ]
    where
+    f = funName fun
     (optspace, lparen, rparen) = if allTerms cats
       then ("","","")
       else ("  bufAppendC(' ');\n", "  bufAppendC('(');\n","  bufAppendC(')');\n")
     cats' = if allTerms cats
         then ""
-        else concat (insertSpaces (map (prShowCat fun) (lefts $ numVars cats)))
+        else concat (insertSpaces (map (prShowCat f) (lefts $ numVars cats)))
     insertSpaces [] = []
     insertSpaces (x:[]) = [x]
     insertSpaces (x:xs) = if x == ""

source/src/BNFC/Backend/C/CFtoCSkel.hs

@@ -215,8 +215,8 @@ prData (cat, rules)
 --     break;
 -- <BLANKLINE>
 prPrintRule :: Rule -> Doc
-prPrintRule (Rule fun _c cats _)
-  | isCoercion fun = ""
+prPrintRule (Rule f _c cats _)
+  | isCoercion f   = ""
   | otherwise      = nest 2 $ vcat
     [ text $ "case is_" ++ fun ++ ":"
     , nest 2 (vcat
@@ -226,6 +226,7 @@ prPrintRule (Rule fun _c cats _)
         ])
     ]
   where
+    fun = funName f
     cats' = vcat $ map (prCat fun) (lefts (numVars cats))
 
 -- Prints the actual instance-variable visiting.

source/src/BNFC/Backend/C/RegToFlex.hs

@@ -45,7 +45,7 @@ prPrec :: Int -> Int -> [String] -> [String]
 prPrec i j = if j<i then parenth else id
 
 instance Print Identifier where
-  prt _ (Identifier i) = [i]
+  prt _ (Identifier (_, i)) = [i]
 
 instance Print Reg where
   prt i e = case e of

source/src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs

@@ -201,7 +201,7 @@ constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ re
                  else (False,r0),
      let (p,m) = generatePatterns cf env r])
  where
-   ruleName r = case funRule r of
+   ruleName r = case funName $ funRule r of
      "(:)" -> identCat (normCat nt)
      "(:[])" -> identCat (normCat nt)
      z -> z

source/src/BNFC/Backend/CPP/PrettyPrinter.hs

@@ -47,7 +47,7 @@ cf2CPPPrinter useStl inPackage cf =
 
 positionRules :: CF -> [(Cat,[Rule])]
 positionRules cf =
-  [ (TokenCat cat, [ Rule cat (TokenCat cat) (map (Left . TokenCat) [catString, catInteger]) Parsable ])
+  [ (TokenCat cat, [ Rule (noPosition cat) (noPosition $ TokenCat cat) (map (Left . TokenCat) [catString, catInteger]) Parsable ])
   | cat <- filter (isPositionCat cf) $ map fst (tokenPragmas cf)
   ]
 
@@ -200,14 +200,14 @@ prDataH (cat, rules) =
  else abstract ++ concatMap prRuleH rules
  where
    cl = identCat (normCat cat)
-   abstract = case lookupRule (show cat) rules of
+   abstract = case lookupRule (noPosition $ show cat) rules of
     Just _ -> ""
     Nothing ->  "  void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"
 
 --Prints all the methods to visit a rule.
-prRuleH :: Rule -> String
+prRuleH :: IsFun f => Rul f -> String
 prRuleH (Rule fun _ _ _) | isProperLabel fun = concat
-  ["  void visit", fun, "(", fun, " *p);\n"]
+  ["  void visit", funName fun, "(", funName fun, " *p);\n"]
 prRuleH _ = ""
 
 {- **** Implementation (.C) File Methods **** -}
@@ -398,14 +398,14 @@ prPrintData _ inPackage _cf (cat, rules) = -- Not a list
     abstract ++ concatMap (prPrintRule inPackage) rules
   where
   cl = identCat (normCat cat)
-  abstract = case lookupRule (show cat) rules of
+  abstract = case lookupRule (noPosition $ show cat) rules of
     Just _ -> ""
     Nothing ->  "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl +++ "*p) {} //abstract class\n\n"
 
 -- | Generate pretty printer visitor for a list category:
 --
 -- >>> let c = Cat "C" ; lc = ListCat c
--- >>> let rules = [Rule "[]" lc [] Parsable, Rule "(:)" lc [Left c, Right "-", Left lc] Parsable]
+-- >>> let rules = [npRule "[]" lc [] Parsable, npRule "(:)" lc [Left c, Right "-", Left lc] Parsable]
 -- >>> genPrintVisitorList (lc, rules)
 -- void PrintAbsyn::visitListC(ListC *listc)
 -- {
@@ -417,7 +417,7 @@ prPrintData _ inPackage _cf (cat, rules) = -- Not a list
 -- }
 --
 -- >>> let c2 = CoercCat "C" 2 ; lc2 = ListCat c2
--- >>> let rules2 = rules ++ [Rule "[]" lc2 [] Parsable, Rule "(:)" lc2 [Left c2, Right "+", Left lc2] Parsable]
+-- >>> let rules2 = rules ++ [npRule "[]" lc2 [] Parsable, npRule "(:)" lc2 [Left c2, Right "+", Left lc2] Parsable]
 -- >>> genPrintVisitorList (lc, rules2)
 -- void PrintAbsyn::visitListC(ListC *listc)
 -- {
@@ -501,7 +501,7 @@ genPrintVisitorListNoStl _ = error "genPrintVisitorListNoStl expects a ListCat"
 prPrintRule :: Maybe String -> Rule -> String
 prPrintRule inPackage r@(Rule fun _ cats _) | isProperLabel fun = unlines
   [
-   "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun +++ "*" ++ fnm ++ ")",
+   "void PrintAbsyn::visit" ++ funName fun ++ "(" ++ funName fun +++ "*" ++ fnm ++ ")",
    "{",
    "  int oldi = _i_;",
    lparen,
@@ -591,13 +591,13 @@ prShowData _ (cat, rules) =  --Not a list:
   abstract ++ concatMap prShowRule rules
   where
     cl = identCat (normCat cat)
-    abstract = case lookupRule (show cat) rules of
+    abstract = case lookupRule (noPosition $ show cat) rules of
       Just _ -> ""
       Nothing ->  "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ " *p) {} //abstract class\n\n"
 
 --This prints all the methods for Abstract Syntax tree rules.
-prShowRule :: Rule -> String
-prShowRule (Rule fun _ cats _) | isProperLabel fun = concat
+prShowRule :: IsFun f => Rul f -> String
+prShowRule (Rule f _ cats _) | isProperLabel f = concat
   [
    "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun +++ "*" ++ fnm ++ ")\n",
    "{\n",
@@ -609,6 +609,7 @@ prShowRule (Rule fun _ cats _) | isProperLabel fun = concat
    "}\n"
   ]
    where
+    fun = funName f
     (optspace, lparen, rparen, cats')
       | null [ () | Left _ <- cats ]  -- @all isRight cats@, but Data.Either.isRight requires base >= 4.7
                   = ("", "", "", "")

source/src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs

@@ -153,10 +153,10 @@ definedRules cf =
         unBase (BaseT x) = show $ normCat $ strToCat x
 
     rule f xs e =
-        case checkDefinition' list ctx f xs e of
+        case runTypeChecker $ checkDefinition' list ctx f xs e of
         Left err -> error $ "Panic! This should have been caught already:\n" ++ err
         Right (args,(e',t)) -> unlines
-            [ cppType t ++ " " ++ f ++ "_ (" ++
+            [ cppType t ++ " " ++ funName f ++ "_ (" ++
                 intercalate ", " (map cppArg args) ++ ") {"
             , "  return " ++ cppExp e' ++ ";"
             , "}"
@@ -326,7 +326,7 @@ rulesForBison rp inPackage cf env = map mkOne (ruleGroups cf) ++ posRules
 constructRule ::
   RecordPositions -> Maybe String -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
 constructRule rp inPackage cf env rules nt =
-  (nt,[(p, generateAction rp inPackage nt (ruleName r) b m +++ result) |
+  (nt,[(p, generateAction rp inPackage nt (funName $ ruleName r) b m +++ result) |
      r0 <- rules,
      let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
                    then (True,revSepListRule r0)

source/src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs

@@ -119,7 +119,7 @@ prTokenBaseType useWCF =  unlinesInline [
 prToken :: Namespace -> Bool -> String -> String
 prToken namespace useWCF name = unlinesInline [
   prDataContract useWCF [],
-  "  public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType",
+  "  public class " ++ name ++ " : " ++ identifier namespace ("TokenBaseType" :: String),
   "  {",
   "    public " ++ name ++ "(string str) : base(str)",
   "    {",

source/src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs

@@ -354,7 +354,7 @@ prRule namespace maybeElse r@(Rule fun _c cats _)
       cats' = case cats of
         [] -> ""
         _  -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats))
-      fnm = '_' : map toLower fun
+      fnm = '_' : map toLower (funName fun)
 
       getPrec (Right {}) = 0
       getPrec (Left  c)  = precCat c
@@ -405,7 +405,7 @@ shData namespace user (cat, rules)
     ]
 
 shRule :: Namespace -> Rule -> String
-shRule namespace (Rule fun _c cats _)
+shRule namespace (Rule f _c cats _)
   | not (isCoercion fun || isDefinedRule fun) = unlinesInline [
     "      if(p is " ++ identifier namespace fun ++ ")",
     "      {",
@@ -417,6 +417,7 @@ shRule namespace (Rule fun _c cats _)
     "      }"
     ]
   where
+    fun = funName f
     cats' | allTerms cats = ""
           | otherwise     = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats))
     lparen | allTerms cats = ""
@@ -426,7 +427,7 @@ shRule namespace (Rule fun _c cats _)
     allTerms [] = True
     allTerms ((Left {}):_) = False
     allTerms (_:zs) = allTerms zs
-    fnm = '_' : map toLower fun
+    fnm = '_' : map toLower (funName fun)
 shRule _nm _ = ""
 
 shList :: [UserDef] -> Cat -> [Rule] -> String

source/src/BNFC/Backend/CSharp/CFtoGPPG.hs

@@ -108,7 +108,7 @@ definedRules _ cf = unlinesInline [
         unBase (BaseT x) = show$normCat$strToCat x
 
     rule f xs e =
-      case checkDefinition' list ctx f xs e of
+      case runTypeChecker $ checkDefinition' list ctx f xs e of
         Left err -> error $ "Panic! This should have been caught already:\n" ++ err
         Right (_,(_,_)) -> unlinesInline [
           "Defined Rule goes here"
@@ -203,7 +203,7 @@ constructRule namespace cf env rules nt =
                  else (False,r0),
      let (p,m) = generatePatterns cf env r b])
   where
-    ruleName r = case funRule r of
+    ruleName r = case funName $ funRule r of
       ---- "(:)" -> identCat nt
       ---- "(:[])" -> identCat nt
       z -> z

source/src/BNFC/Backend/CSharp/CSharpUtils.hs

@@ -84,10 +84,12 @@ toString :: String -> String
 toString v = if isUserDefined v then ".ToString()" else ""
 
 -- Prepends namespace ".Absyn." to typ unless it is one of the basetypes
-identifier :: Namespace -> String -> String
-identifier namespace typ
+identifier :: IsFun a => Namespace -> a -> String
+identifier namespace f
   | typ `elem` (map snd basetypes) = typ
   | otherwise                      = namespace ++ ".Absyn." ++ typ
+  where
+  typ = funName f
 
 -- Removes empty lines, and removes the line-break at the end.
 -- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks.

source/src/BNFC/Backend/CSharp/RegToGPLEX.hs

@@ -44,7 +44,7 @@ prPrec :: Int -> Int -> [String] -> [String]
 prPrec i j = if j<i then parenth else id
 
 instance Print Identifier where
-  prt _ (Identifier i) = [i]
+  prt _ (Identifier (_, i)) = [i]
 
 instance Print Reg where
   prt i e = case e of

source/src/BNFC/Backend/Common/NamedVariables.hs

@@ -165,7 +165,7 @@ fixCoercions rs = nub (fixAll rs rs)
     else fixCoercion cat cats
   fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]
   fixAll _ [] = []
-  fixAll top ((cat,_):cats) = if isCoercion (show cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!
+  fixAll top ((cat,_):cats) = if isCoercion (noPosition $ show cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!
     then fixAll top cats
     else (normCat cat, fixCoercion cat top) : fixAll top cats
 

source/src/BNFC/Backend/Common/OOAbstract.hs

@@ -85,16 +85,16 @@ cf2cabs cf = CAbs {
   (pos,  toks) = partition (isPositionCat cf) $ map fst $ tokenPragmas cf
   (lists,cats) = partition isList $ allCatsNorm cf
   testRule (Rule f c _ _)
-   | isList c  = Nothing
-   | f == "_"  = Nothing
-   | otherwise = Just f
+   | isList (wpThing c)  = Nothing
+   | funName f == "_"  = Nothing
+   | otherwise = Just $ funName f
   normSig (c,fcs) =
     (identCat c,[(f, classVars (map (status . identCat) cs)) | (f,cs) <- fcs])
   posdata =
     [("Visitable",  -- to give superclass
      [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos]
   status cat = (cat, notElem cat (map fst basetypes ++ toks))
-  defs = [f | FunDef f _ _ <- cfgPragmas cf]
+  defs = [ funName f | FunDef f _ _ <- cfgPragmas cf]
 
   classVars :: [(String,Bool)] -> [(String,Bool,String)]
   classVars cs =

source/src/BNFC/Backend/Haskell/CFtoAbstract.hs

@@ -238,7 +238,7 @@ definedRules :: Bool -> CF -> [Doc]
 definedRules functor cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
   where
     mkDef f xs e = vcat $ map text $ concat
-      [ [ unwords [ mkDefName f, "::", typeToHaskell t ]
+      [ [ unwords [ mkDefName f, "::", typeToHaskell $ wpThing t ]
         | not functor  -- TODO: make type signatures work with --functor
         , t <- maybeToList $ sigLookup f cf
         ]

source/src/BNFC/Backend/Haskell/CFtoAlex2.hs

@@ -322,7 +322,7 @@ prPrec :: Int -> Int -> [String] -> [String]
 prPrec i j = if j<i then parenth else id
 
 instance Print Identifier where
-  prt _ (Identifier i) = [i]
+  prt _ (Identifier (_, i)) = [i]
 
 instance Print Reg where
   prt i e = case e of