Improve pattern synonym error messages (add `PatSynOrigin`)

Adds a new data constructor `PatSynOrigin Bool Name` to the `CtOrigin`
data type. This allows for better error messages when the origin of a
wanted constraint is a pattern synonym declaration.

Fixes T10873.

Reviewers: mpickering, simonpj, austin, thomie, bgamari

Reviewed By: simonpj, thomie, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1866

GHC Trac Issues: #10873

6 files changed, 75 insertions, 10 deletions

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index daae2021e8..15cacafeba 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 06f2042597..9b28758949 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 3864f1a493..c642397c28 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 0000000000..c947442751
--- /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 0000000000..766b2e0279
--- /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 a091882e18..a9ba4479f0 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, [''])