[commit: ghc] master: Identify fields by selector when type-checking (fixes #13644) (72b00c3)
git at git.haskell.org
git at git.haskell.org
Thu Sep 21 16:09:54 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/72b00c34c73ff6c63ee4928006b0cc60034a7638/ghc
>---------------------------------------------------------------
commit 72b00c34c73ff6c63ee4928006b0cc60034a7638
Author: Adam Gundry <adam at well-typed.com>
Date: Tue Sep 19 19:03:16 2017 -0400
Identify fields by selector when type-checking (fixes #13644)
Test Plan: new test for #13847, and the test for #13644 now passes
Reviewers: mpickering, austin, bgamari, simonpj
Reviewed By: mpickering, simonpj
Subscribers: simonpj, rwbarton, thomie
GHC Trac Issues: #13644, #13847
Differential Revision: https://phabricator.haskell.org/D3988
>---------------------------------------------------------------
72b00c34c73ff6c63ee4928006b0cc60034a7638
compiler/typecheck/TcExpr.hs | 9 +++++----
compiler/typecheck/TcPat.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 | 3 ++-
6 files changed, 24 insertions(+), 9 deletions(-)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 4b9bcd1..4eb5dd1 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -2353,7 +2353,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)
@@ -2375,7 +2375,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))
@@ -2394,11 +2395,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/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index f2188af..c5e367e 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -985,14 +985,15 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv
thing_inside
= do { sel' <- tcLookupId sel
- ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)
+ ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+ (occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'
pun), res) }
- find_field_ty :: FieldLabelString -> TcM TcType
- find_field_ty lbl
- = case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of
+ find_field_ty :: Name -> FieldLabelString -> TcM TcType
+ find_field_ty sel lbl
+ = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of
-- No matching field; chances are this field label comes from some
-- other record type (or maybe none). If this happens, just fail,
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 f7f7719..9feee3d 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -125,6 +125,7 @@ test('T12681', normal, multimod_compile_fail, ['T12681','-v0'])
test('T12686', normal, compile_fail, [''])
test('T11592', normal, compile_fail, [''])
test('T12879', normal, compile_fail, [''])
-test('T13644', expect_broken(13644), multimod_compile_fail, ['T13644','-v0'])
+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'])
More information about the ghc-commits
mailing list