Add structured error messages for GHC.Tc.TyCl.PatSyn

Tracking ticket: #20117

MR: !10158

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

14 files changed, 175 insertions, 60 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 432163d6f1..519c03991f 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1481,6 +1481,32 @@ instance Diagnostic TcRnMessage where
           , text "(Indeed, I sometimes struggle even printing this correctly,"
           , text " due to its ill-scoped nature.)"
           ]
+    TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $
+      vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
+           , hang (text "Pattern-bound variable")
+                2 (ppr arg <+> dcolon <+> ppr (idType arg))
+           , nest 2 $
+             hang (text "has a type that mentions pattern-bound coercion"
+                   <> plural bad_co_list <> colon)
+                2 (pprWithCommas ppr bad_co_list)
+           , text "Hint: use -fprint-explicit-coercions to see the coercions"
+           , text "Probable fix: add a pattern signature" ]
+      where
+        bad_co_list = NE.toList bad_co_ne
+    TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $
+      hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
+                , text "namely" <+> quotes (ppr pat_ty) ])
+        2 (text "mentions existential type variable" <> plural bad_tvs
+           <+> pprQuotedList bad_tvs)
+    TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $
+      hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
+            <+> speakNOf decl_arity (text "argument"))
+         2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+    TcRnPatSynInvalidRhs ps_name lpat args reason -> mkSimpleDecorated $
+      vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
+                   <+> quotes (ppr ps_name) <> colon)
+                2 (pprPatSynInvalidRhsReason ps_name lpat args reason)
+           , text "RHS pattern:" <+> ppr lpat ]
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1965,6 +1991,14 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnSkolemEscape{}
       -> ErrorWithoutFlag
+    TcRnPatSynEscapedCoercion{}
+      -> ErrorWithoutFlag
+    TcRnPatSynExistentialInResult{}
+      -> ErrorWithoutFlag
+    TcRnPatSynArityMismatch{}
+      -> ErrorWithoutFlag
+    TcRnPatSynInvalidRhs{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -2467,6 +2501,14 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnSkolemEscape{}
       -> noHints
+    TcRnPatSynEscapedCoercion{}
+      -> noHints
+    TcRnPatSynExistentialInResult{}
+      -> noHints
+    TcRnPatSynArityMismatch{}
+      -> noHints
+    TcRnPatSynInvalidRhs{}
+      -> noHints
 
   diagnosticCode = constructorCode
 
@@ -4561,3 +4603,18 @@ pprUninferrableTyvarCtx = \case
   UninfTyCtx_Sig exp_kind full_hs_ty ->
     hang (text "the kind" <+> ppr exp_kind) 2
          (text "of the type signature:" <+> ppr full_hs_ty)
+
+pprPatSynInvalidRhsReason :: Name -> LPat GhcRn -> [LIdP GhcRn] -> PatSynInvalidRhsReason -> SDoc
+pprPatSynInvalidRhsReason name pat args = \case
+  PatSynNotInvertible p ->
+    text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+    $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+              <+> text "pattern synonym, e.g.")
+           2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+                    <+> ppr pat <+> text "where")
+                 2 (pp_name <+> pp_args <+> equals <+> text "..."))
+    where
+      pp_name = ppr name
+      pp_args = hsep (map ppr args)
+  PatSynUnboundVar var ->
+    quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index d84aca8146..8c3505221d 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -95,6 +95,7 @@ module GHC.Tc.Errors.Types (
   , WrongThingSort(..)
   , StageCheckReason(..)
   , UninferrableTyvarCtx(..)
+  , PatSynInvalidRhsReason(..)
   ) where
 
 import GHC.Prelude
@@ -108,7 +109,7 @@ import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
                            , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing
                            , FixedRuntimeRepOrigin(..), InstanceWhat )
 import GHC.Tc.Types.Rank (Rank)
-import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
+import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType, TcSigmaType)
 import GHC.Types.Avail (AvailInfo)
 import GHC.Types.Error
 import GHC.Types.Hint (UntickedPromotedThing(..))
@@ -118,7 +119,7 @@ import qualified GHC.Types.Name.Occurrence as OccName
 import GHC.Types.Name.Reader
 import GHC.Types.SrcLoc
 import GHC.Types.TyThing (TyThing)
-import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)
+import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar)
 import GHC.Types.Var.Env (TidyEnv)
 import GHC.Types.Var.Set (TyVarSet, VarSet)
 import GHC.Unit.Types (Module)
@@ -3293,6 +3294,52 @@ data TcRnMessage where
     -> !Type -- ^ The type in which they occur.
     -> TcRnMessage
 
+  {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from
+    a pattern synonym into a type.
+    See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn
+
+    Test cases:
+      T14507
+  -}
+  TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable
+                            -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions
+                            -> TcRnMessage
+
+  {-| TcRnPatSynExistentialInResult is an error indicating that the result type
+    of a pattern synonym mentions an existential type variable.
+
+    Test cases:
+      PatSynExistential
+  -}
+  TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym
+                                -> !TcSigmaType -- ^ The result type
+                                -> ![TyVar] -- ^ The escaped existential variables
+                                -> TcRnMessage
+
+  {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a
+    pattern synonym's equation differs from the number of parameters in its
+    signature.
+
+    Test cases:
+      PatSynArity
+  -}
+  TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym
+                          -> !Arity -- ^ The number of equation arguments
+                          -> !Arity -- ^ The difference
+                          -> TcRnMessage
+
+  {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the
+    right hand side of a pattern synonym is invalid.
+
+    Test cases:
+      unidir, T14112
+  -}
+  TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym
+                       -> !(LPat GhcRn) -- ^ The pattern
+                       -> ![LIdP GhcRn] -- ^ The LHS args
+                       -> !PatSynInvalidRhsReason -- ^ The number of equation arguments
+                       -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -4582,3 +4629,8 @@ data UninferrableTyvarCtx
   | UninfTyCtx_TyfamRhs TcType
   | UninfTyCtx_TysynRhs TcType
   | UninfTyCtx_Sig TcType (LHsSigType GhcRn)
+
+data PatSynInvalidRhsReason
+  = PatSynNotInvertible !(Pat GhcRn)
+  | PatSynUnboundVar !Name
+  deriving (Generic)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 82fa7db1f7..c61c471bac 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -41,7 +41,6 @@ import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
 import GHC.Core.Predicate
 
 import GHC.Builtin.Types.Prim
-import GHC.Types.Error
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.SrcLoc
@@ -68,6 +67,7 @@ import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
 import Data.Maybe( mapMaybe )
 import Control.Monad ( zipWithM )
 import Data.List( partition, mapAccumL )
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
 
 {-
 ************************************************************************
@@ -185,10 +185,11 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
        -- Report coercions that escape
        -- See Note [Coercions that escape]
        ; args <- mapM zonkId args
-       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
-                              , let bad_cos = filterDVarSet isId $
-                                              (tyCoVarsOfTypeDSet (idType arg))
-                              , not (isEmptyDVarSet bad_cos) ]
+       ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $
+                           nonEmpty $
+                           dVarSetElems $
+                           filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg))
+             bad_args = mapMaybe bad_arg (args ++ prov_dicts)
        ; mapM_ dependentArgErr bad_args
 
        -- Report un-quantifiable type variables:
@@ -236,22 +237,11 @@ mkProvEvidence ev_id
     pred = evVarPred ev_id
     eq_con_args = [evId ev_id]
 
-dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+dependentArgErr :: (Id, NonEmpty CoVar) -> TcM ()
 -- See Note [Coercions that escape]
 dependentArgErr (arg, bad_cos)
   = failWithTc $  -- fail here: otherwise we get downstream errors
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
-         , hang (text "Pattern-bound variable")
-              2 (ppr arg <+> dcolon <+> ppr (idType arg))
-         , nest 2 $
-           hang (text "has a type that mentions pattern-bound coercion"
-                 <> plural bad_co_list <> colon)
-              2 (pprWithCommas ppr bad_co_list)
-         , text "Hint: use -fprint-explicit-coercions to see the coercions"
-         , text "Probable fix: add a pattern signature" ]
-  where
-    bad_co_list = dVarSetElems bad_cos
+    TcRnPatSynEscapedCoercion arg bad_cos
 
 {- Note [Type variables whose kind is captured]
 ~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -405,11 +395,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        -- The existential 'x' should not appear in the result type
        -- Can't check this until we know P's arity (decl_arity above)
        ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
-       ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
-                   , text "namely" <+> quotes (ppr pat_ty) ])
-            2 (text "mentions existential type variable" <> plural bad_tvs
-               <+> pprQuotedList bad_tvs)
+       ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs
 
          -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig
        ; let univ_fvs = closeOverKinds $
@@ -679,10 +665,7 @@ collectPatSynArgInfo details =
 
 wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
 wrongNumberOfParmsErr name decl_arity missing
-  = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
-          <+> speakNOf decl_arity (text "argument"))
-       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+  = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing
 
 -------------------------
 -- Shared by both tcInferPatSyn and tcCheckPatSyn
@@ -921,11 +904,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
   = return emptyBag
 
   | Left why <- mb_match_group       -- Can't invert the pattern
-  = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
-                 <+> quotes (ppr ps_name) <> colon)
-              2 why
-         , text "RHS pattern:" <+> ppr lpat ]
+  = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why
 
   | Right match_group <- mb_match_group  -- Bidirectional
   = do { patsyn <- tcLookupPatSyn ps_name
@@ -975,7 +954,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
     mb_match_group
        = case dir of
            ExplicitBidirectional explicit_mg -> Right explicit_mg
-           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
            Unidirectional -> panic "tcPatSynBuilderBind"
 
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -1019,8 +998,8 @@ add_void need_dummy_arg ty
   | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty
   | otherwise      = ty
 
-tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
-            -> Either SDoc (LHsExpr GhcRn)
+tcPatToExpr :: [LocatedN Name] -> LPat GhcRn
+            -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
 -- Given a /pattern/, return an /expression/ that builds a value
 -- that matches the pattern.  E.g. if the pattern is (Just [x]),
 -- the expression is (Just [x]).  They look the same, but the
@@ -1029,13 +1008,13 @@ tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
 --
 -- Returns (Left r) if the pattern is not invertible, for reason r.
 -- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr name args pat = go pat
+tcPatToExpr args pat = go pat
   where
     lhsVars = mkNameSet (map unLoc args)
 
     -- Make a prefix con for prefix and infix patterns for simplicity
     mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
-                    -> Either SDoc (HsExpr GhcRn)
+                    -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
     mkPrefixConExpr lcon@(L loc _) pats
       = do { exprs <- mapM go pats
            ; let con = L (l2l loc) (HsVar noExtField lcon)
@@ -1043,18 +1022,18 @@ tcPatToExpr name args pat = go pat
            }
 
     mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
-                    -> Either SDoc (HsExpr GhcRn)
+                    -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
     mkRecordConExpr con (HsRecFields fields dd)
       = do { exprFields <- mapM go' fields
            ; return (RecordCon noExtField con (HsRecFields exprFields dd)) }
 
-    go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
+    go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
     go' (L l rf) = L l <$> traverse go rf
 
-    go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
+    go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
     go (L loc p) = L loc <$> go1 p
 
-    go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
+    go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
     go1 (ConPat NoExtField con info)
       = case info of
           PrefixCon _ ps -> mkPrefixConExpr con ps
@@ -1068,7 +1047,7 @@ tcPatToExpr name args pat = go pat
         | var `elemNameSet` lhsVars
         = return $ HsVar noExtField (L l var)
         | otherwise
-        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
+        = Left (PatSynUnboundVar var)
     go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
     go1 (ListPat _ pats)
       = do { exprs <- mapM go pats
@@ -1105,19 +1084,7 @@ tcPatToExpr name args pat = go pat
     go1 p@(AsPat {})                         = notInvertible p
     go1 p@(NPlusKPat {})                     = notInvertible p
 
-    notInvertible p = Left (not_invertible_msg p)
-
-    not_invertible_msg p
-      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
-      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
-                <+> text "pattern synonym, e.g.")
-             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
-                      <+> ppr pat <+> text "where")
-                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
-      where
-        pp_name = ppr name
-        pp_args = hsep (map ppr args)
-
+    notInvertible p = Left (PatSynNotInvertible p)
 
 {- Note [Builder for a bidirectional pattern synonym]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index a5c751ed3d..ce26d95a72 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -542,6 +542,11 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnCannotDefaultKindVar"                      = 79924
   GhcDiagnosticCode "TcRnUninferrableTyvar"                         = 16220
   GhcDiagnosticCode "TcRnSkolemEscape"                              = 71451
+  GhcDiagnosticCode "TcRnPatSynEscapedCoercion"                     = 88986
+  GhcDiagnosticCode "TcRnPatSynExistentialInResult"                 = 33973
+  GhcDiagnosticCode "TcRnPatSynArityMismatch"                       = 18365
+  GhcDiagnosticCode "PatSynNotInvertible"                           = 69317
+  GhcDiagnosticCode "PatSynUnboundVar"                              = 28572
 
   -- IllegalNewtypeReason
   GhcDiagnosticCode "DoesNotHaveSingleField"                        = 23517
@@ -711,6 +716,7 @@ type family ConRecursInto con where
   ConRecursInto "TcRnNotInScope"           = 'Just NotInScopeError
   ConRecursInto "TcRnIllegalNewtype"       = 'Just IllegalNewtypeReason
   ConRecursInto "TcRnHsigShapeMismatch"    = 'Just HsigShapeMismatchReason
+  ConRecursInto "TcRnPatSynInvalidRhs"     = 'Just PatSynInvalidRhsReason
 
     --
     -- TH errors
diff --git a/testsuite/tests/patsyn/should_fail/T14112.stderr b/testsuite/tests/patsyn/should_fail/T14112.stderr
index bd0b9543af..833eee188b 100644
--- a/testsuite/tests/patsyn/should_fail/T14112.stderr
+++ b/testsuite/tests/patsyn/should_fail/T14112.stderr
@@ -1,5 +1,5 @@
 
-T14112.hs:5:21: error:
+T14112.hs:5:21: error: [GHC-69317]
     Invalid right-hand side of bidirectional pattern synonym ‘MyJust1’:
       Pattern ‘!a’ is not invertible
       Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
diff --git a/testsuite/tests/patsyn/should_fail/T14507.stderr b/testsuite/tests/patsyn/should_fail/T14507.stderr
index d3dfa0a04f..85c42b8771 100644
--- a/testsuite/tests/patsyn/should_fail/T14507.stderr
+++ b/testsuite/tests/patsyn/should_fail/T14507.stderr
@@ -1,5 +1,5 @@
 
-T14507.hs:21:1: error:
+T14507.hs:21:1: error: [GHC-88986]
     • Iceland Jack!  Iceland Jack! Stop torturing me!
       Pattern-bound variable x :: TypeRep a
         has a type that mentions pattern-bound coercion: co
diff --git a/testsuite/tests/patsyn/should_fail/unidir.stderr b/testsuite/tests/patsyn/should_fail/unidir.stderr
index ba3799d201..649dc9cf05 100644
--- a/testsuite/tests/patsyn/should_fail/unidir.stderr
+++ b/testsuite/tests/patsyn/should_fail/unidir.stderr
@@ -1,5 +1,5 @@
 
-unidir.hs:4:18: error:
+unidir.hs:4:18: error: [GHC-69317]
     Invalid right-hand side of bidirectional pattern synonym ‘Head’:
       Pattern ‘_’ is not invertible
       Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
diff --git a/testsuite/tests/typecheck/should_fail/PatSynArity.hs b/testsuite/tests/typecheck/should_fail/PatSynArity.hs
new file mode 100644
index 0000000000..4f09dbdcc7
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynArity.hs
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynArity where
+
+pattern P :: Int -> (Int, Int)
+pattern P a b = (a, b)
diff --git a/testsuite/tests/typecheck/should_fail/PatSynArity.stderr b/testsuite/tests/typecheck/should_fail/PatSynArity.stderr
new file mode 100644
index 0000000000..502255ad4b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynArity.stderr
@@ -0,0 +1,4 @@
+PatSynArity.hs:6:1: [GHC-18365]
+     Pattern synonym ‘P’ has two arguments
+        but its type signature has 1 fewer arrows
+     In the declaration for pattern synonym ‘P’
diff --git a/testsuite/tests/typecheck/should_fail/PatSynExistential.hs b/testsuite/tests/typecheck/should_fail/PatSynExistential.hs
new file mode 100644
index 0000000000..ddfaa2ad16
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynExistential.hs
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynExistential where
+
+pattern P :: () => forall x. x -> Maybe x
+pattern P <- _
diff --git a/testsuite/tests/typecheck/should_fail/PatSynExistential.stderr b/testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
new file mode 100644
index 0000000000..326974dc55
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
@@ -0,0 +1,4 @@
+PatSynExistential.hs:6:1: [GHC-33973]
+     The result type of the signature for ‘P’, namely ‘x -> Maybe x’
+        mentions existential type variable ‘x’
+     In the declaration for pattern synonym ‘P’
diff --git a/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs b/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
new file mode 100644
index 0000000000..961713096a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynUnboundVar where
+
+pattern P :: Int -> (Int, Int)
+pattern P a = (a, b)
diff --git a/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr b/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
new file mode 100644
index 0000000000..f65114aa99
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
@@ -0,0 +1,4 @@
+PatSynUnboundVar.hs:6:15: [GHC-28572]
+    Invalid right-hand side of bidirectional pattern synonym ‘P’:
+      ‘b’ is not bound by the LHS of the pattern synonym
+    RHS pattern: (a, b)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 94f0cdfa77..209f292737 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -672,3 +672,6 @@ test('T22924a', normal, compile_fail, [''])
 test('T22924b', normal, compile_fail, [''])
 test('T22940', normal, compile_fail, [''])
 test('T19627', normal, compile_fail, [''])
+test('PatSynExistential', normal, compile_fail, [''])
+test('PatSynArity', normal, compile_fail, [''])
+test('PatSynUnboundVar', normal, compile_fail, [''])