Improve error message (issue #144)

It should now say: bnfc: syntax error at line 1, column 20 before `)'
BNFC · Jun 25, 2015 · af9885e · af9885e
1 parent 2245dd3
commit af9885e
Show file tree

Hide file tree

Showing 9 changed files with 382 additions and 538 deletions.
diff --git a/source/src/AbsBNF.hs b/source/src/AbsBNF.hs
@@ -7,118 +7,95 @@ module AbsBNF where
 
 
 
-newtype Ident = Ident String deriving (Eq,Ord,Show,Read)
-data LGrammar =
-   LGr [LDef]
-  deriving (Eq,Ord,Show,Read)
-
-data LDef =
-   DefAll Def
- | DefSome [Ident] Def
- | LDefView [Ident]
-  deriving (Eq,Ord,Show,Read)
-
-data Grammar =
-   Grammar [Def]
-  deriving (Eq,Ord,Show,Read)
-
-data Def =
-   Rule Label Cat [Item]
- | Comment String
- | Comments String String
- | Internal Label Cat [Item]
- | Token Ident Reg
- | PosToken Ident Reg
- | Entryp [Ident]
- | Separator MinimumSize Cat String
- | Terminator MinimumSize Cat String
- | Delimiters Cat String String Separation MinimumSize
- | Coercions Ident Integer
- | Rules Ident [RHS]
- | Function Ident [Arg] Exp
- | Layout [String]
- | LayoutStop [String]
- | LayoutTop
-  deriving (Eq,Ord,Show,Read)
-
-data Item =
-   Terminal String
- | NTerminal Cat
-  deriving (Eq,Ord,Show,Read)
-
-data Cat =
-   ListCat Cat
- | IdCat Ident
-  deriving (Eq,Ord,Show,Read)
-
-data Label =
-   LabNoP LabelId
- | LabP LabelId [ProfItem]
- | LabPF LabelId LabelId [ProfItem]
- | LabF LabelId LabelId
-  deriving (Eq,Ord,Show,Read)
-
-data LabelId =
-   Id Ident
- | Wild
- | ListE
- | ListCons
- | ListOne
-  deriving (Eq,Ord,Show,Read)
-
-data ProfItem =
-   ProfIt [IntList] [Integer]
-  deriving (Eq,Ord,Show,Read)
-
-data IntList =
-   Ints [Integer]
-  deriving (Eq,Ord,Show,Read)
-
-data Separation =
-   SepNone
- | SepTerm String
- | SepSepar String
-  deriving (Eq,Ord,Show,Read)
-
-data Arg =
-   Arg Ident
-  deriving (Eq,Ord,Show,Read)
-
-data Exp =
-   Cons Exp Exp
- | App Ident [Exp]
- | Var Ident
- | LitInt Integer
- | LitChar Char
- | LitString String
- | LitDouble Double
- | List [Exp]
-  deriving (Eq,Ord,Show,Read)
-
-data RHS =
-   RHS [Item]
-  deriving (Eq,Ord,Show,Read)
-
-data MinimumSize =
-   MNonempty
- | MEmpty
-  deriving (Eq,Ord,Show,Read)
-
-data Reg =
-   RSeq Reg Reg
- | RAlt Reg Reg
- | RMinus Reg Reg
- | RStar Reg
- | RPlus Reg
- | ROpt Reg
- | REps
- | RChar Char
- | RAlts String
- | RSeqs String
- | RDigit
- | RLetter
- | RUpper
- | RLower
- | RAny
-  deriving (Eq,Ord,Show,Read)
+newtype Ident = Ident String deriving (Eq, Ord, Show, Read)
+data LGrammar = LGr [LDef]
+  deriving (Eq, Ord, Show, Read)
+
+data LDef = DefAll Def | DefSome [Ident] Def | LDefView [Ident]
+  deriving (Eq, Ord, Show, Read)
+
+data Grammar = Grammar [Def]
+  deriving (Eq, Ord, Show, Read)
+
+data Def
+    = Rule Label Cat [Item]
+    | Comment String
+    | Comments String String
+    | Internal Label Cat [Item]
+    | Token Ident Reg
+    | PosToken Ident Reg
+    | Entryp [Ident]
+    | Separator MinimumSize Cat String
+    | Terminator MinimumSize Cat String
+    | Delimiters Cat String String Separation MinimumSize
+    | Coercions Ident Integer
+    | Rules Ident [RHS]
+    | Function Ident [Arg] Exp
+    | Layout [String]
+    | LayoutStop [String]
+    | LayoutTop
+  deriving (Eq, Ord, Show, Read)
+
+data Item = Terminal String | NTerminal Cat
+  deriving (Eq, Ord, Show, Read)
+
+data Cat = ListCat Cat | IdCat Ident
+  deriving (Eq, Ord, Show, Read)
+
+data Label
+    = LabNoP LabelId
+    | LabP LabelId [ProfItem]
+    | LabPF LabelId LabelId [ProfItem]
+    | LabF LabelId LabelId
+  deriving (Eq, Ord, Show, Read)
+
+data LabelId = Id Ident | Wild | ListE | ListCons | ListOne
+  deriving (Eq, Ord, Show, Read)
+
+data ProfItem = ProfIt [IntList] [Integer]
+  deriving (Eq, Ord, Show, Read)
+
+data IntList = Ints [Integer]
+  deriving (Eq, Ord, Show, Read)
+
+data Separation = SepNone | SepTerm String | SepSepar String
+  deriving (Eq, Ord, Show, Read)
+
+data Arg = Arg Ident
+  deriving (Eq, Ord, Show, Read)
+
+data Exp
+    = Cons Exp Exp
+    | App Ident [Exp]
+    | Var Ident
+    | LitInt Integer
+    | LitChar Char
+    | LitString String
+    | LitDouble Double
+    | List [Exp]
+  deriving (Eq, Ord, Show, Read)
+
+data RHS = RHS [Item]
+  deriving (Eq, Ord, Show, Read)
+
+data MinimumSize = MNonempty | MEmpty
+  deriving (Eq, Ord, Show, Read)
+
+data Reg
+    = RSeq Reg Reg
+    | RAlt Reg Reg
+    | RMinus Reg Reg
+    | RStar Reg
+    | RPlus Reg
+    | ROpt Reg
+    | REps
+    | RChar Char
+    | RAlts String
+    | RSeqs String
+    | RDigit
+    | RLetter
+    | RUpper
+    | RLower
+    | RAny
+  deriving (Eq, Ord, Show, Read)
 
diff --git a/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs b/source/src/BNFC/Backend/Haskell/CFtoAlex3.hs
@@ -122,10 +122,12 @@ restOfAlex _ shareStrings byteStrings cf = [
   " | Err Posn",
   "  deriving (Eq,Show,Ord)",
   "",
+  "printPosn :: Posn -> String",
+  "printPosn (Pn _ l c) = \"line \" ++ show l ++ \", column \" ++ show c",
+  "",
   "tokenPos :: [Token] -> String",
-  "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",
-  "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",
-  "tokenPos _ = \"end of file\"",
+  "tokenPos (t:_) = printPosn (tokenPosn t)",
+  "tokenPos [] = \"end of file\"",
   "",
   "tokenPosn :: Token -> Posn",
   "tokenPosn (PT p _) = p",
@@ -148,6 +150,7 @@ restOfAlex _ shareStrings byteStrings cf = [
   "  PT _ (TV s)   -> s",
   "  PT _ (TD s)   -> s",
   "  PT _ (TC s)   -> s",
+  "  Err _         -> \"#error\"",
   userDefTokenPrint,
   "",
   "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",

diff --git a/source/src/BNFC/Backend/Haskell/CFtoHappy.hs b/source/src/BNFC/Backend/Haskell/CFtoHappy.hs
@@ -242,7 +242,7 @@ finalize byteStrings cf = unlines $
      "  case ts of",
      "    [] -> []",
      "    [Err _] -> \" due to lexer error\"",
-     "    _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))",
+     "    t:_ -> \" before `\" ++ " ++ stringUnpack ++ "(prToken t) ++ \"'\"",
      "",
      "myLexer = tokens"
    ] ++ definedRules cf ++ [ "}" ]

diff --git a/source/src/BNFC/GetCF.hs b/source/src/BNFC/GetCF.hs
@@ -77,7 +77,7 @@ parseCFP opts target content = do
 
   where
     runErr (Ok a) = return a
-    runErr (Bad msg) = fail msg
+    runErr (Bad msg) = error msg
 
 {-
     case filter (not . isDefinedRule) $ notUniqueFuns cf of
@@ -159,12 +159,12 @@ removeDelims xs = (ys ++ map delimToSep ds,
     (ds,ys) = partition isDelim xs
     isDelim (Abs.Delimiters{}) = True
     isDelim _ = False
-    
+
     inlineDelim :: Abs.Def -> Either Cat String ->  [Either Cat String]
     inlineDelim (Abs.Delimiters cat open close _ _) (Left c)
       | c == ListCat (transCat cat) = [Right open, Left c, Right close]
     inlineDelim _ x = [x]
-    
+
     inlineDelim' :: Abs.Def -> RuleP -> RuleP
     inlineDelim' d@(Abs.Delimiters cat _ _ _ _) r@(Rule f c rhs)
       | c == ListCat (transCat cat) = r
@@ -176,7 +176,7 @@ removeDelims xs = (ys ++ map delimToSep ds,
     delimToSep (Abs.Delimiters cat _ _ (Abs.SepSepar s) sz) = Abs.Separator  sz cat s
     delimToSep (Abs.Delimiters cat _ _  Abs.SepNone     sz) = Abs.Terminator sz cat ""
     delimToSep x = x
-    
+
 transDef :: Abs.Def -> [Either Pragma RuleP]
 transDef x = case x of
  Abs.Rule label cat items ->

diff --git a/source/src/LexBNF.x b/source/src/LexBNF.x
@@ -58,10 +58,12 @@ data Token =
  | Err Posn
   deriving (Eq,Show,Ord)
 
+printPosn :: Posn -> String
+printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c
+
 tokenPos :: [Token] -> String
-tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
-tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
-tokenPos _ = "end of file"
+tokenPos (t:_) = printPosn (tokenPosn t)
+tokenPos [] = "end of file"
 
 tokenPosn :: Token -> Posn
 tokenPosn (PT p _) = p
@@ -79,12 +81,12 @@ mkPosToken t@(PT p _) = (posLineCol p, prToken t)
 prToken :: Token -> String
 prToken t = case t of
   PT _ (TS s _) -> s
-  PT _ (TL s)   -> s
+  PT _ (TL s)   -> show s
   PT _ (TI s)   -> s
   PT _ (TV s)   -> s
   PT _ (TD s)   -> s
   PT _ (TC s)   -> s
-  Err _ -> "#Error"
+  Err _         -> "#error"
 
 
 data BTree = N | B String Tok BTree BTree deriving (Show)