[commit: ghc] master: Fixed issue with detection of duplicate record fields (d294218)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d2942184c8cc53cb3b50f78a7ecff930c3e5861f/ghc

>---------------------------------------------------------------

commit d2942184c8cc53cb3b50f78a7ecff930c3e5861f
Author: Gintautas Miliauskas <gintautas.miliauskas at gmail.com>
Date:   Thu Jul 24 14:45:26 2014 +0200

    Fixed issue with detection of duplicate record fields
    
    Duplicate record fields would not be detected when given a type
    with multiple data constructors, and the first data constructor
    had a record field r1 and any consecutive data constructors
    had multiple fields named r1.
    
    This fixes #9156 and was reviewed in https://phabricator.haskell.org/D87


>---------------------------------------------------------------

d2942184c8cc53cb3b50f78a7ecff930c3e5861f
 compiler/hsSyn/HsUtils.lhs                      | 31 +++++++++++++++----------
 testsuite/tests/rename/should_compile/all.T     |  2 ++
 testsuite/tests/rename/should_compile/rn068.hs  |  5 ++++
 testsuite/tests/rename/should_fail/T9156.hs     |  4 ++++
 testsuite/tests/rename/should_fail/T9156.stderr |  5 ++++
 testsuite/tests/rename/should_fail/all.T        |  1 +
 6 files changed, 36 insertions(+), 12 deletions(-)

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 42838ef..e12daf4 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -1,3 +1,5 @@
+> {-# LANGUAGE ScopedTypeVariables #-}
+
 %
 % (c) The University of Glasgow, 1992-2006
 %
@@ -100,7 +102,10 @@ import FastString
 import Util
 import Bag
 import Outputable
+
 import Data.Either
+import Data.Function
+import Data.List
 \end{code}
 
 
@@ -743,24 +748,26 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
 
 -------------------
-hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
+hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name]
   -- See hsLTyClDeclBinders for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
-hsConDeclsBinders cons
-  = snd (foldl do_one ([], []) cons)
-  where
-    do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name
-                                            , con_details = RecCon flds }))
-	= (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc)
-	where
+hsConDeclsBinders cons = go id cons
+  where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name]
+        go _ [] = []
+        go remSeen (r:rs) =
           -- don't re-mangle the location of field names, because we don't
           -- have a record of the full location of the field declaration anyway
-	  new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
-			       (map cd_fld_name flds)
+          case r of
+             -- remove only the first occurrence of any seen field in order to
+             -- avoid circumventing detection of duplicate fields (#9156)
+             L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) ->
+               (L loc name) : r' ++ go remSeen' rs
+                  where r' = remSeen (map cd_fld_name flds)
+                        remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r']
+             L loc (ConDecl { con_name = L _ name }) ->
+                (L loc name) : go remSeen rs
 
-    do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name }))
-	= (flds_seen, L loc name : acc)
 \end{code}
 
 Note [Binders in family instances]
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 4ed92bd..d104df4 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -110,6 +110,8 @@ test('rn067',
      extra_clean(['Rn067_A.hi', 'Rn067_A.o']),
      multimod_compile, ['rn067', '-v0'])
 
+test('rn068', normal, compile, [''])
+
 test('T1972', normal, compile, [''])
 test('T2205', normal, compile, [''])
 
diff --git a/testsuite/tests/rename/should_compile/rn068.hs b/testsuite/tests/rename/should_compile/rn068.hs
new file mode 100644
index 0000000..83ed851
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/rn068.hs
@@ -0,0 +1,5 @@
+module Foo where
+
+data A = A1 { a, b :: Int }
+       | A2 { a, b :: Int }
+       | A3 { a, b :: Int }
diff --git a/testsuite/tests/rename/should_fail/T9156.hs b/testsuite/tests/rename/should_fail/T9156.hs
new file mode 100644
index 0000000..f4ffd1a
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T9156.hs
@@ -0,0 +1,4 @@
+module T9156 where
+
+data D = D1 { f1 :: Int }
+       | D2 { f1, f1 :: Int }
diff --git a/testsuite/tests/rename/should_fail/T9156.stderr b/testsuite/tests/rename/should_fail/T9156.stderr
new file mode 100644
index 0000000..361ed37
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T9156.stderr
@@ -0,0 +1,5 @@
+
+T9156.hs:4:19:
+    Multiple declarations of ‘f1’
+    Declared at: T9156.hs:3:15
+                 T9156.hs:4:19
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 0f60ff6..d1bf2b6 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -114,4 +114,5 @@ test('T8448', normal, compile_fail, [''])
 test('T9006',
      extra_clean(['T9006a.hi', 'T9006a.o']),
      multimod_compile_fail, ['T9006', '-v0'])
+test('T9156', normal, compile_fail, [''])
 test('T9177', normal, compile_fail, [''])