diff options
author | Adam Gundry <adam@well-typed.com> | 2017-09-14 15:58:11 +0100 |
---|---|---|
committer | Adam Gundry <adam@well-typed.com> | 2017-09-18 22:08:52 +0100 |
commit | d42fe23f7435afc796bde415fd252151a2871f9c (patch) | |
tree | 883bcd033114030473f408040fba93ae9e33d0a8 | |
parent | 52110a7966848538583acb65f6e064aadc751260 (diff) | |
download | haskell-d42fe23f7435afc796bde415fd252151a2871f9c.tar.gz |
Identify fields by selector when type-checking expressions (fixes #13847)wip/T13644
-rw-r--r-- | compiler/typecheck/TcExpr.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T13847.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T13847.stderr | 6 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T13847A.hs | 2 | ||||
-rw-r--r-- | 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 0ff7d1e0d9..bcfcf17db2 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 0000000000..09c67de54f --- /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 0000000000..52edbf5acf --- /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 0000000000..e3e54a8f18 --- /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 a98d127859..9feee3d922 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']) |