diff options
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/T11010.stderr | 5 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/T18856.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/T18856.stderr | 14 | ||||
| -rw-r--r-- | testsuite/tests/patsyn/should_fail/all.T | 3 |
5 files changed, 40 insertions, 7 deletions
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 79d3f97077..e470b21ce6 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -31,9 +31,9 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn -import GHC.Types.Name.Set import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString @@ -422,14 +422,22 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; tc_patsyn_finish lname dir is_infix lpat' (univ_bndrs, req_theta, ev_binds, req_dicts) (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', (map scaledThing arg_tys)) + (args', map scaledThing arg_tys) pat_ty rec_fields } where tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc) + -- Look up the variable actually bound by lpat + -- and check that it has the expected type tc_arg subst arg_name arg_ty - = do { -- Look up the variable actually bound by lpat - -- and check that it has the expected type - arg_id <- tcLookupId arg_name + = setSrcSpan (nameSrcSpan arg_name) $ + -- Set the SrcSpan to be the binding site of the Id (#18856) + -- e.g. pattern P :: Int -> Maybe (Int,Bool) + -- pattern P x = Just (x,True) + -- Before unifying x's actual type with its expected type, in tc_arg, set + -- location to x's binding site in lpat, namely the 'x' in Just (x,True). + -- Else the error message location is wherever tcCheckPat finished, + -- namely the right-hand corner of the pattern + do { arg_id <- tcLookupId arg_name ; wrap <- tcSubTypeSigma GenSigCtxt (idType arg_id) (substTyUnchecked subst arg_ty) diff --git a/testsuite/tests/patsyn/should_fail/T11010.stderr b/testsuite/tests/patsyn/should_fail/T11010.stderr index 28216760ee..af081b6a36 100644 --- a/testsuite/tests/patsyn/should_fail/T11010.stderr +++ b/testsuite/tests/patsyn/should_fail/T11010.stderr @@ -1,5 +1,5 @@ -T11010.hs:9:36: error: +T11010.hs:9:34: error: • Couldn't match type ‘a1’ with ‘Int’ Expected: a -> b Actual: a1 -> b @@ -12,3 +12,6 @@ T11010.hs:9:36: error: • Relevant bindings include x :: Expr a1 (bound at T11010.hs:9:36) f :: a1 -> b (bound at T11010.hs:9:34) + | +9 | pattern IntFun str f x = Fun str f x + | ^ diff --git a/testsuite/tests/patsyn/should_fail/T18856.hs b/testsuite/tests/patsyn/should_fail/T18856.hs new file mode 100644 index 0000000000..780a734d53 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T18856.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T18856 where + +pattern P :: Int -> Bool -> (Int, Bool, [(Bool,Bool)]) +pattern P p q <- (q, p, [(True,False)]) + diff --git a/testsuite/tests/patsyn/should_fail/T18856.stderr b/testsuite/tests/patsyn/should_fail/T18856.stderr new file mode 100644 index 0000000000..ceee029102 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T18856.stderr @@ -0,0 +1,14 @@ + +T18856.hs:6:19: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Int’ + • In the declaration for pattern synonym ‘P’ + | +6 | pattern P p q <- (q, p, [(True,False)]) + | ^ + +T18856.hs:6:22: error: + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the declaration for pattern synonym ‘P’ + | +6 | pattern P p q <- (q, p, [(True,False)]) + | ^ diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 02cc2cec2c..5faea83c88 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -9,7 +9,7 @@ test('T9705-2', normal, compile_fail, ['']) test('unboxed-bind', normal, compile_fail, ['']) test('unboxed-wrapper-naked', normal, compile_fail, ['']) test('T10873', normal, compile_fail, ['']) -test('T11010', normal, compile_fail, ['']) +test('T11010', normal, compile_fail, ['-fdiagnostics-show-caret']) test('records-check-sels', normal, compile_fail, ['']) test('records-no-uni-update', normal, compile_fail, ['']) test('records-no-uni-update2', normal, compile_fail, ['']) @@ -47,3 +47,4 @@ test('T15692', normal, compile, ['']) # It has -fdefer-type-errors inside test('T15694', normal, compile_fail, ['']) test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14552', normal, compile_fail, ['']) +test('T18856', normal, compile_fail, ['-fdiagnostics-show-caret']) |