From 06a463d0f3b82ef04d03a8152ac6464aadbf8b86 Mon Sep 17 00:00:00 2001
From: Andreas Abel <andreas.abel@ifi.lmu.de>
Date: Wed, 7 Oct 2020 19:18:03 +0200
Subject: [PATCH] [ #214 ] Error location also for non-unique  Bar.Bar::=...

The previous code would override the error location of the rule name Bar
with a no-position location of category Bar.
---
 source/src/BNFC/CF.hs                           | 15 +++++++++------
 source/src/BNFC/GetCF.hs                        | 17 +++++++++++------
 .../succeed-lbnf/duplicate-label-same-cat.cf    |  2 ++
 .../succeed-lbnf/duplicate-label-same-cat.out   |  3 ++-
 4 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/source/src/BNFC/CF.hs b/source/src/BNFC/CF.hs
index db813f7e..f21d5378 100644
--- a/source/src/BNFC/CF.hs
+++ b/source/src/BNFC/CF.hs
@@ -306,7 +306,7 @@ data Position
     { posFile    :: FilePath  -- ^ Name of the grammar file.
     , posLine    :: Int       -- ^ Line in the grammar file.
     , posColumn  :: Int       -- ^ Column in the grammar file.
-    } deriving Show
+    } deriving (Show, Eq, Ord)
 
 prettyPosition :: Position -> String
 prettyPosition = \case
@@ -535,13 +535,16 @@ firstEntry cf =
 
 -- aggressively ban nonunique names (AR 31/5/2012)
 
--- | Categories and constructors.
+-- | Constructors and categories.
 allNames :: CF -> [RString]
-allNames cf = map (WithPosition NoPosition) (allCatsIdNorm cf) ++
+allNames cf =
   [ f | f <- map funRule $ cfgRules cf
       , not $ isNilCons f
       , not $ isCoercion f
-  ]
+  ] ++
+  allCatsIdNorm cf
+    -- Put the categories after the labels so that the error location
+    -- for a non-unique name is at the label rather than the category.
 
 -- | Get all elements with more than one occurrence.
 filterNonUnique :: (Ord a) => [a] -> [a]
@@ -598,8 +601,8 @@ allParserCats :: CFG f -> [Cat]
 allParserCats = allCats (== Parsable)
 
 -- | Gets all normalized identified Categories
-allCatsIdNorm :: CF -> [String]
-allCatsIdNorm = nub . map (identCat . normCat . valCat) . cfgRules
+allCatsIdNorm :: CF -> [RString]
+allCatsIdNorm = nub . map (fmap (identCat . normCat) . valRCat) . cfgRules
 
 -- | Get all normalized Cat
 allCatsNorm :: CF -> [Cat]
diff --git a/source/src/BNFC/GetCF.hs b/source/src/BNFC/GetCF.hs
index 05d5533b..365c6bcc 100644
--- a/source/src/BNFC/GetCF.hs
+++ b/source/src/BNFC/GetCF.hs
@@ -112,13 +112,13 @@ parseCFP opts target content = do
     ns | target `elem` [ TargetCpp , TargetCppNoStl , TargetJava ]
        -> dieUnlessForce $ unlines $ concat
             [ [ "ERROR: names not unique:" ]
-            , map (("  " ++) . blendInPosition) ns
+            , printNames ns
             , [ "This is an error in the backend " ++ show target ++ "." ]
             ]
        | otherwise
        -> putStrLn $ unlines $ concat
             [ [ "Warning: names not unique:" ]
-            , map (("  " ++) . blendInPosition) ns
+            , printNames ns
             , [ "This can be an error in some backends." ]
             ]
 
@@ -127,14 +127,14 @@ parseCFP opts target content = do
     [] -> return ()
     ns | target `elem` [ TargetJava ]
        -> dieUnlessForce $ unlines $ concat
-            [ [ "ERROR: names not unique ignoring case: " ]
-            , map (("  " ++) . blendInPosition) ns
+            [ [ "ERROR: names not unique ignoring case:" ]
+            , printNames ns
             , [ "This is an error in the backend " ++ show target ++ "."]
             ]
        | otherwise
        -> putStr $ unlines $ concat
             [ [ "Warning: names not unique ignoring case:" ]
-            , map (("  " ++) . blendInPosition) ns
+            , printNames ns
             , [ "This can be an error in some backends." ]
             ]
 
@@ -158,7 +158,7 @@ parseCFP opts target content = do
             [ [ "Lower case rule labels need a definition."
               , "ERROR: undefined rule label(s):"
               ]
-            , map (("  " ++) . blendInPosition) xs
+            , printNames xs
             ]
 
   -- Print warnings if user defined nullable tokens.
@@ -185,6 +185,11 @@ parseCFP opts target content = do
         "Aborting.  (Use option --force to continue despite errors.)"
       exitFailure
 
+  printNames :: [RString] -> [String]
+  printNames = map (("  " ++) . blendInPosition) . List.sortOn lexicoGraphic
+    where
+    lexicoGraphic (WithPosition pos x) = (pos,x)
+
 die :: String -> IO a
 die msg = do
   hPutStrLn stderr msg
diff --git a/testing/succeed-lbnf/duplicate-label-same-cat.cf b/testing/succeed-lbnf/duplicate-label-same-cat.cf
index d9c8bff0..df5f044f 100644
--- a/testing/succeed-lbnf/duplicate-label-same-cat.cf
+++ b/testing/succeed-lbnf/duplicate-label-same-cat.cf
@@ -1,2 +1,4 @@
 Foo.  Bar ::= "foo";
 Foo.  Bar ::= "foz";
+
+Baz.  Baz ::= "baz";
diff --git a/testing/succeed-lbnf/duplicate-label-same-cat.out b/testing/succeed-lbnf/duplicate-label-same-cat.out
index 2c178a39..978706b0 100644
--- a/testing/succeed-lbnf/duplicate-label-same-cat.out
+++ b/testing/succeed-lbnf/duplicate-label-same-cat.out
@@ -1,5 +1,6 @@
-Warning: names not unique: 
+Warning: names not unique:
   succeed-lbnf/duplicate-label-same-cat.cf:1:1: Foo
+  succeed-lbnf/duplicate-label-same-cat.cf:4:1: Baz
 This can be an error in some backends.
 
 2 rules accepted