[commit: ghc] wip/T13644: Identify fields by selector when type-checking expressions (fixes #13847) (d42fe23)

[git at git.haskell.org]

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

On branch  : wip/T13644
Link       : http://ghc.haskell.org/trac/ghc/changeset/d42fe23f7435afc796bde415fd252151a2871f9c/ghc

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

commit d42fe23f7435afc796bde415fd252151a2871f9c
Author: Adam Gundry <adam at well-typed.com>
Date:   Thu Sep 14 15:58:11 2017 +0100

    Identify fields by selector when type-checking expressions (fixes #13847)


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

d42fe23f7435afc796bde415fd252151a2871f9c
 compiler/typecheck/TcExpr.hs                     | 9 +++++----
 testsuite/tests/rename/should_fail/T13847.hs     | 4 ++++
 testsuite/tests/rename/should_fail/T13847.stderr | 6 ++++++
 testsuite/tests/rename/should_fail/T13847A.hs    | 2 ++
 testsuite/tests/rename/should_fail/all.T         | 1 +
 5 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 0ff7d1e..bcfcf17 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -2351,7 +2351,7 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
   = do  { mb_binds <- mapM do_bind rbinds
         ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
-    fields = map flLabel $ conLikeFieldLabels con_like
+    fields = map flSelector $ conLikeFieldLabels con_like
     flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
 
     do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
@@ -2373,7 +2373,8 @@ tcRecordUpd
 
 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
   where
-    flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
 
     do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
             -> TcM (Maybe (LHsRecUpdField GhcTcId))
@@ -2392,11 +2393,11 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
                                                (selectorFieldOcc (unLoc f')))
                                    , hsRecFieldArg = rhs' }))) }
 
-tcRecordField :: ConLike -> Assoc FieldLabelString Type
+tcRecordField :: ConLike -> Assoc Name Type
               -> LFieldOcc GhcRn -> LHsExpr GhcRn
               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
 tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
-  | Just field_ty <- assocMaybe flds_w_tys field_lbl
+  | Just field_ty <- assocMaybe flds_w_tys sel_name
       = addErrCtxt (fieldCtxt field_lbl) $
         do { rhs' <- tcPolyExprNC rhs field_ty
            ; let field_id = mkUserLocal (nameOccName sel_name)
diff --git a/testsuite/tests/rename/should_fail/T13847.hs b/testsuite/tests/rename/should_fail/T13847.hs
new file mode 100644
index 0000000..09c67de
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T13847.hs
@@ -0,0 +1,4 @@
+module Main where
+import qualified T13847A as A
+foo = "foo"
+main = print $ A.foo $ A.A { foo = () }
diff --git a/testsuite/tests/rename/should_fail/T13847.stderr b/testsuite/tests/rename/should_fail/T13847.stderr
new file mode 100644
index 0000000..52edbf5
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T13847.stderr
@@ -0,0 +1,6 @@
+
+T13847.hs:4:24: error:
+    • Constructor ‘A.A’ does not have field ‘foo’
+    • In the second argument of ‘($)’, namely ‘A.A {foo = ()}’
+      In the second argument of ‘($)’, namely ‘A.foo $ A.A {foo = ()}’
+      In the expression: print $ A.foo $ A.A {foo = ()}
diff --git a/testsuite/tests/rename/should_fail/T13847A.hs b/testsuite/tests/rename/should_fail/T13847A.hs
new file mode 100644
index 0000000..e3e54a8
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T13847A.hs
@@ -0,0 +1,2 @@
+module T13847A where
+data A = A { foo :: () }
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index a98d127..9feee3d 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -128,3 +128,4 @@ test('T12879', normal, compile_fail, [''])
 test('T13644', normal, multimod_compile_fail, ['T13644','-v0'])
 test('T13568', normal, multimod_compile_fail, ['T13568','-v0'])
 test('T13947', normal, compile_fail, [''])
+test('T13847', normal, multimod_compile_fail, ['T13847','-v0'])