diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index daae2021e807f12723117cffac70ff2b89b11178..15cacafeba5ce73c0dfee0907eb3e5249b8075d2 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -27,6 +27,7 @@ import TyCon import Class import DataCon import TcEvidence +import HsBinds ( PatSynBind(..) ) import Name import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) import PrelNames ( typeableClassName, hasKey, ptrRepLiftedDataConKey @@ -1820,6 +1821,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = vcat [ no_inst_msg , nest 2 extra_note , vcat (pp_givens givens) + , in_other_words , ppWhen (has_ambig_tvs && not (null unifiers && null givens)) (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) @@ -1863,6 +1865,18 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) , text "These potential instance" <> plural unifiers <+> text "exist:"] + in_other_words + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_id = (L _ name) + , psb_def = (L _ pat) } <- orig + -- Here we check if the "required" context is empty, otherwise + -- the "In other words" is not strictly true + , null [ n | (_, SigSkol (PatSynCtxt n) _, _, _) <- givens, name == n ] + = vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ] + | otherwise = empty + -- Report "potential instances" only when the constraint arises -- directly from the user's use of an overloaded function want_potential (TypeEqOrigin {}) = False @@ -1870,7 +1884,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) add_to_ctxt_fixes has_ambig_tvs | not has_ambig_tvs && all_tyvars - , (orig:origs) <- usefulContext ctxt pred + , (orig:origs) <- usefulContext ctxt ct = [sep [ text "add" <+> pprParendType pred <+> text "to the context of" , nest 2 $ ppr_skol orig $$ @@ -2000,11 +2014,11 @@ Once these conditions are satisfied, we can safely say that ambiguity prevents the constraint from being solved. -} -usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo] -usefulContext ctxt pred +usefulContext :: ReportErrCtxt -> Ct -> [SkolemInfo] +usefulContext ctxt ct = go (cec_encl ctxt) where - pred_tvs = tyCoVarsOfType pred + pred_tvs = tyCoVarsOfType $ ctPred ct go [] = [] go (ic : ics) | implausible ic = rest @@ -2019,9 +2033,18 @@ usefulContext ctxt pred | implausible_info (ic_info ic) = True | otherwise = False - implausible_info (SigSkol (InfSigCtxt {}) _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature! + implausible_info (SigSkol (InfSigCtxt {} ) _) = True + implausible_info (SigSkol (PatSynCtxt name) _) + | (ProvCtxtOrigin PSB{ psb_id = (L _ name') }) <- ctOrigin ct + , name == name' = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature, or to + -- a pattern synonym signature when its "provided" context is the origin of + -- the wanted constraint. For example, + -- pattern Pat :: () => Show a => a -> Maybe a + -- pattern Pat x = Just x + -- This declaration should not give the possible fix: + -- add (Show a) to the "required" context of the signature for `Pat' show_fixes :: [SDoc] -> SDoc show_fixes [] = empty diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 06f20425979f67e0ff8c01347f6415406942bd06..9b2875894905510f36402eb5b0a9b3c07b8bf8cf 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -216,13 +216,13 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, tcCheckPatSynDecl :: PatSynBind Name Name -> TcPatSynInfo -> TcM (LHsBinds Id, TcGblEnv) -tcCheckPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir } +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details + , psb_def = lpat, psb_dir = dir } TPSI{ patsig_univ_tvs = univ_tvs, patsig_prov = prov_theta , patsig_ex_tvs = ex_tvs, patsig_req = req_theta , patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty } = addPatSynCtxt lname $ - do { let origin = PatOrigin -- TODO + do { let origin = ProvCtxtOrigin psb skol_info = SigSkol (PatSynCtxt name) (mkCheckExpType $ mkFunTys arg_tys pat_ty) decl_arity = length arg_names diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 3864f1a493ada0975af2d92b27ea0dfbc96f1846..c642397c285df5e7d0039dde608860af089a4390 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2713,6 +2713,9 @@ data CtOrigin | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty | PatOrigin -- Instantiating a polytyped pattern at a constructor + | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature + (PatSynBind Name Name) -- Information about the pattern synonym, in particular + -- the name and the right-hand side | RecordUpdOrigin | ViewPatOrigin @@ -2949,6 +2952,10 @@ pprCtOrigin (Shouldn'tHappenOrigin note) , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at" , text "https://ghc.haskell.org/trac/ghc/wiki/ReportABug >>" ] +pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) + = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") + 2 (text "the signature of" <+> quotes (ppr name)) + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin diff --git a/testsuite/tests/patsyn/should_fail/T10873.hs b/testsuite/tests/patsyn/should_fail/T10873.hs new file mode 100644 index 0000000000000000000000000000000000000000..c947442751dc7fd16f3a7e57f4e6549d595302fc --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T10873.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, GADTs #-} + +module T10873 where + +pattern Pat1 :: () => Show a => a -> Maybe a +pattern Pat1 x <- Just x + +data T a where MkT :: (Ord a) => a -> T a +pattern Pat2 :: (Enum a) => Show a => a -> T a +pattern Pat2 x <- MkT x diff --git a/testsuite/tests/patsyn/should_fail/T10873.stderr b/testsuite/tests/patsyn/should_fail/T10873.stderr new file mode 100644 index 0000000000000000000000000000000000000000..766b2e02798dc40f602b6168f3e8a14786533206 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/T10873.stderr @@ -0,0 +1,24 @@ + +T10873.hs:6:24: error: + • No instance for (Show a) + arising from the "provided" constraints claimed by + the signature of ‘Pat1’ + In other words, a successful match on the pattern + Just x + does not provide the constraint (Show a) + • In the declaration for pattern synonym ‘Pat1’ + +T10873.hs:10:23: error: + • Could not deduce (Show a) + arising from the "provided" constraints claimed by + the signature of ‘Pat2’ + from the context: Enum a + bound by the type signature for pattern synonym ‘Pat2’: + a -> T a + at T10873.hs:10:9-12 + or from: Ord a + bound by a pattern with constructor: + MkT :: forall a. Ord a => a -> T a, + in a pattern synonym declaration + at T10873.hs:10:19-23 + • In the declaration for pattern synonym ‘Pat2’ diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index a091882e1889907d386185aea76cceeacd9596e7..a9ba4479f0c0003ceb1d361eba3ac6a320313b47 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -8,6 +8,7 @@ test('T9705-1', normal, compile_fail, ['']) 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('records-check-sels', normal, compile_fail, ['']) test('records-no-uni-update', normal, compile_fail, [''])