More refactoring in TcValidity

This patch responds to Trac #15334 by making it an error to
write an instance declaration for a tuple constraint like
(Eq [a], Show [a]).

I then discovered that instance validity checking was
scattered betweeen TcInstDcls and TcValidity, so I took
the time to bring it all together, into
  TcValidity.checkValidInstHead

In doing so I discovered that there are lot of special
cases.   I have not changed them, but at least they are
all laid out clearly now.

17 files changed, 197 insertions, 145 deletions

diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 12ebfad4c3..ca8263ba3a 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1795,10 +1795,10 @@ instDeclDataFamInsts inst_decls
 ************************************************************************
 -}
 
--- | Located Deriving Declaration
+-- | Located stand-alone 'deriving instance' declaration
 type LDerivDecl pass = Located (DerivDecl pass)
 
--- | Deriving Declaration
+-- | Stand-alone 'deriving instance' declaration
 data DerivDecl pass = DerivDecl
         { deriv_ext          :: XCDerivDecl pass
         , deriv_type         :: LHsSigWcType pass
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index b96581e482..56c1987852 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -95,7 +95,7 @@ module TysWiredIn (
         liftedTypeKindTyConName,
 
         -- * Equality predicates
-        heqTyCon, heqClass, heqDataCon,
+        heqTyCon, heqTyConName, heqClass, heqDataCon,
         coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,
 
         -- * RuntimeRep and friends
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index b044d1fa3d..37bfa18192 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -613,12 +613,13 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
     addErrCtxt (standaloneCtxt deriv_ty)  $
     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
        ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat
+             ctxt           = TcType.InstDeclCtxt True
        ; traceTc "Deriving strategy (standalone deriving)" $
            vcat [ppr mb_deriv_strat, ppr deriv_ty]
        ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
-           <- tcDerivStrategy TcType.InstDeclCtxt mb_deriv_strat $ do
+           <- tcDerivStrategy ctxt mb_deriv_strat $ do
                 (tvs, deriv_ctxt, cls, inst_tys)
-                  <- tcStandaloneDerivInstType deriv_ty
+                  <- tcStandaloneDerivInstType ctxt deriv_ty
                 pure (tvs, (deriv_ctxt, cls, inst_tys))
        ; checkTc (not (null inst_tys')) derivingNullaryErr
        ; let inst_ty' = last inst_tys'
@@ -709,9 +710,9 @@ deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"
 -- Note that this will never return @'InferContext' 'Nothing'@, as that can
 -- only happen with @deriving@ clauses.
 tcStandaloneDerivInstType
-  :: LHsSigWcType GhcRn
+  :: UserTypeCtxt -> LHsSigWcType GhcRn
   -> TcM ([TyVar], DerivContext, Class, [Type])
-tcStandaloneDerivInstType
+tcStandaloneDerivInstType ctxt
     (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = HsIBRn
                                                         { hsib_vars   = vars
                                                         , hsib_closed = closed }
@@ -720,7 +721,7 @@ tcStandaloneDerivInstType
   , L _ [wc_pred] <- theta
   , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
   = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
-         <- tc_hs_cls_inst_ty $
+         <- tcHsClsInstType ctxt $
             HsIB { hsib_ext = HsIBRn { hsib_vars = vars
                                      , hsib_closed = closed }
                  , hsib_body
@@ -731,13 +732,12 @@ tcStandaloneDerivInstType
        pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
   | otherwise
   = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
-         <- tc_hs_cls_inst_ty deriv_ty
+         <- tcHsClsInstType ctxt deriv_ty
        pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
-  where
-    tc_hs_cls_inst_ty = tcHsClsInstType TcType.InstDeclCtxt
-tcStandaloneDerivInstType (HsWC _ (XHsImplicitBndrs _))
+
+tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
   = panic "tcStandaloneDerivInstType"
-tcStandaloneDerivInstType (XHsWildCardBndrs _)
+tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
   = panic "tcStandaloneDerivInstType"
 
 warnUselessTypeable :: TcM ()
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 1d9997822d..cee92caca8 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -53,8 +53,6 @@ import Class
 import Var
 import VarEnv
 import VarSet
-import PrelNames  ( typeableClassName, genericClassNames
-                  , knownNatClassName, knownSymbolClassName )
 import Bag
 import BasicTypes
 import DynFlags
@@ -475,7 +473,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                   , cid_datafam_insts = adts }))
   = setSrcSpan loc                      $
     addErrCtxt (instDeclCtxt1 poly_ty)  $
-    do  { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
+    do  { (tyvars, theta, clas, inst_tys)
+             <- tcHsClsInstType (InstDeclCtxt False) poly_ty
+             -- NB: tcHsClsInstType does checkValidInstance
+
         ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
               mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
               mb_info    = Just (clas, tyvars, mini_env)
@@ -516,60 +517,15 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                      , ib_extensions = []
                                      , ib_derived = False } }
 
-        ; doClsInstErrorChecks inst_info
+         -- In hs-boot files there should be no bindings
+        ; is_boot <- tcIsHsBootOrSig
+        ; let no_binds = isEmptyLHsBinds binds && null uprags
+        ; failIfTc (is_boot && not no_binds) badBootDeclErr
 
         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
                  , deriv_infos ) }
 tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
 
-doClsInstErrorChecks :: InstInfo GhcRn -> TcM ()
-doClsInstErrorChecks inst_info
- = do { traceTc "doClsInstErrorChecks" (ppr ispec)
-      ; dflags <- getDynFlags
-      ; is_boot <- tcIsHsBootOrSig
-
-         -- In hs-boot files there should be no bindings
-      ; failIfTc (is_boot && not no_binds) badBootDeclErr
-
-         -- If not in an hs-boot file, abstract classes cannot have
-         -- instances declared
-      ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr
-
-         -- Handwritten instances of any rejected
-         -- class is always forbidden
-         -- #12837
-      ; failIfTc (clas_nm `elem` rejectedClassNames) clas_err
-
-         -- Check for hand-written Generic instances (disallowed in Safe Haskell)
-      ; when (clas_nm `elem` genericClassNames) $
-        do { failIfTc (safeLanguageOn dflags) gen_inst_err
-           ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
-  }
-  where
-    ispec    = iSpec inst_info
-    binds    = iBinds inst_info
-    no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)
-    clas_nm  = is_cls_nm ispec
-    clas     = is_cls ispec
-
-    gen_inst_err = hang (text ("Generic instances can only be "
-                            ++ "derived in Safe Haskell.") $+$
-                         text "Replace the following instance:")
-                      2 (pprInstanceHdr ispec)
-
-    abstractClassInstErr =
-        text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm)
-
-    -- Report an error or a warning for certain class instances.
-    -- If we are working on an .hs-boot file, we just report a warning,
-    -- and ignore the instance.  We do this, to give users a chance to fix
-    -- their code.
-    rejectedClassNames = [ typeableClassName
-                         , knownNatClassName
-                         , knownSymbolClassName ]
-    clas_err = text "Class" <+> quotes (ppr clas_nm)
-                    <+> text "does not support user-specified instances"
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 75e9fab53f..a1c3d43f2a 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1483,7 +1483,7 @@ kcDataDefn mb_kind_env
 
         ; let inner_res_kind' = substTyAddInScope skol_subst inner_res_kind
               tv_prs          = zip (map tyVarName tvs_to_skolemise) tvs'
-              skol_info       = SigSkol InstDeclCtxt exp_res_kind tv_prs
+              skol_info       = SigSkol (InstDeclCtxt False) exp_res_kind tv_prs
 
         ; (ev_binds, (_, new_args, co))
             <- solveEqualities $
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 00bae72117..31d759ec5d 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -608,7 +608,9 @@ data UserTypeCtxt
                         --      f x :: t = ....
   | ForSigCtxt Name     -- Foreign import or export signature
   | DefaultDeclCtxt     -- Types in a default declaration
-  | InstDeclCtxt        -- An instance declaration
+  | InstDeclCtxt Bool   -- An instance declaration
+                        --    True:  stand-alone deriving
+                        --    False: vanilla instance declaration
   | SpecInstCtxt        -- SPECIALISE instance pragma
   | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
   | GenSigCtxt          -- Higher-rank or impredicative situations
@@ -654,7 +656,8 @@ pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature"
 pprUserTypeCtxt ResSigCtxt        = text "a result type signature"
 pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n)
 pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration"
-pprUserTypeCtxt InstDeclCtxt      = text "an instance declaration"
+pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration"
+pprUserTypeCtxt (InstDeclCtxt True)  = text "a stand-alone deriving instance declaration"
 pprUserTypeCtxt SpecInstCtxt      = text "a SPECIALISE instance pragma"
 pprUserTypeCtxt GenSigCtxt        = text "a type expected by the context"
 pprUserTypeCtxt GhciCtxt          = text "a type in a GHCi command"
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index d51fa9d4b6..8a3aaade85 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -30,6 +30,7 @@ import TcSimplify ( simplifyAmbiguityCheck )
 import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..) )
 import TyCoRep
 import TcType hiding ( sizeType, sizeTypes )
+import TysWiredIn ( heqTyConName, coercibleTyConName )
 import PrelNames
 import Type
 import Coercion
@@ -58,6 +59,7 @@ import ListSetOps
 import SrcLoc
 import Outputable
 import Module
+import Bag         ( emptyBag )
 import Unique      ( mkAlphaTyVarUnique )
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -411,12 +413,12 @@ expectedKindInCtxt ThBrackCtxt     = AnythingKind
 expectedKindInCtxt GhciCtxt        = AnythingKind
 -- The types in a 'default' decl can have varying kinds
 -- See Note [Extended defaults]" in TcEnv
-expectedKindInCtxt DefaultDeclCtxt = AnythingKind
-expectedKindInCtxt TypeAppCtxt     = AnythingKind
-expectedKindInCtxt (ForSigCtxt _)  = TheKind liftedTypeKind
-expectedKindInCtxt InstDeclCtxt    = TheKind constraintKind
-expectedKindInCtxt SpecInstCtxt    = TheKind constraintKind
-expectedKindInCtxt _               = OpenKind
+expectedKindInCtxt DefaultDeclCtxt     = AnythingKind
+expectedKindInCtxt TypeAppCtxt         = AnythingKind
+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
+expectedKindInCtxt _                   = OpenKind
 
 {-
 Note [Higher rank types]
@@ -764,7 +766,7 @@ check_pred_help under_syn env dflags ctxt pred
                            -- didn't do so before, so I'm leaving it for now
                            return ()
 
-      ForAllPred _ theta head -> check_quant_pred env dflags pred theta head
+      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head
       IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred
 
 check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()
@@ -775,21 +777,23 @@ check_eq_pred env dflags pred
               || xopt LangExt.GADTs dflags)
              (eqPredTyErr env pred)
 
-check_quant_pred :: TidyEnv -> DynFlags -> PredType
-                 -> ThetaType -> PredType -> TcM ()
-check_quant_pred env dflags pred theta head_pred
-  = addErrCtxt (text "In the quantified constraint"
-                <+> quotes (ppr pred)) $
-    do { checkTcM head_ok (badQuantHeadErr env pred)
-
+check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> ThetaType -> PredType -> TcM ()
+check_quant_pred env dflags _ctxt pred theta head_pred
+  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $
+    do { -- Check the instance head
+         case classifyPredType head_pred of
+            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys
+                                 -- SigmaCtxt tells checkValidInstHead that
+                                 -- this is the head of a quantified constraint
+            IrredPred {}      | hasTyVarHead head_pred
+                              -> return ()
+            _                 -> failWithTcM (badQuantHeadErr env pred)
+
+         -- Check for termination
        ; unless (xopt LangExt.UndecidableInstances dflags) $
          checkInstTermination theta head_pred
     }
-  where
-    head_ok = case classifyPredType head_pred of
-                 ClassPred {} -> True
-                 IrredPred {} -> hasTyVarHead head_pred
-                 _            -> False
 
 check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
 check_tuple_pred under_syn env dflags ctxt pred ts
@@ -874,10 +878,10 @@ check_class_pred env dflags ctxt pred cls tys
     undecidable_ok    = xopt LangExt.UndecidableInstances dflags
     arg_tys_ok = case ctxt of
         SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
-        InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
+        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
                                 -- Further checks on head and theta
                                 -- in checkInstTermination
-        _            -> checkValidClsArgs flexible_contexts cls tys
+        _               -> checkValidClsArgs flexible_contexts cls tys
 
 checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
                                  -> Class -> [TcType] -> TcM ()
@@ -1110,36 +1114,94 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
 checkValidInstHead ctxt clas cls_args
-  = do { dflags <- getDynFlags
+  = do { dflags   <- getDynFlags
+       ; this_mod <- getModule
+       ; is_boot  <- tcIsHsBootOrSig
+       ; check_valid_inst_head dflags this_mod is_boot ctxt clas cls_args }
+
+check_valid_inst_head :: DynFlags -> Module -> Bool
+                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()
+-- Wow!  There are a surprising number of ad-hoc special cases here.
+check_valid_inst_head dflags this_mod is_boot ctxt clas cls_args
+
+  -- If not in an hs-boot file, abstract classes cannot have instances
+  | isAbstractClass clas
+  , not is_boot
+  = failWithTc abstract_class_msg
+
+  -- For Typeable, don't complain about instances for
+  -- standalone deriving; they are no-ops, and we warn about
+  -- it in TcDeriv.deriveStandalone
+  | clas_nm == typeableClassName
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- Handwritten instances of KnownNat/KnownSymbol class
+  -- are always forbidden (#12837)
+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- For the most part we don't allow instances for Coercible;
+  -- but we DO want to allow them in quantified constraints:
+  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
+  | clas_nm == coercibleTyConName
+  , not quantified_constraint
+  = failWithTc rejected_class_msg
+
+  -- Handwritten instances of other nonminal-equality classes
+  -- is forbidden, except in the defining module to allow
+  --    instance a ~~ b => a ~ b
+  -- which occurs in Data.Type.Equality
+  | clas_nm `elem` [ heqTyConName, eqTyConName]
+  , nameModule clas_nm /= this_mod
+  = failWithTc rejected_class_msg
+
+  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
+  | clas_nm `elem` genericClassNames
+  , hand_written_bindings
+  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err
+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+
+  | clas_nm == hasFieldClassName
+  = checkHasFieldInst clas cls_args
+
+  | isCTupleClass clas
+  = failWithTc tuple_class_msg
+
+  -- Check language restrictions on the args to the class
+  | check_h98_arg_shape
+  , Just msg <- mb_ty_args_msg
+  = failWithTc (instTypeErr clas cls_args msg)
 
-       ; mod <- getModule
-       ; checkTc (getUnique clas `notElem` abstractClassKeys ||
-                  nameModule (getName clas) == mod)
-                 (instTypeErr clas cls_args abstract_class_msg)
-
-       ; when (clas `hasKey` hasFieldClassNameKey) $
-             checkHasFieldInst clas cls_args
-
-           -- Check language restrictions;
-           -- but not for SPECIALISE instance pragmas or deriving clauses
-       ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
-       ; unless (spec_inst_prag || deriv_clause) $
-         do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
-                       all tcInstHeadTyNotSynonym ty_args)
-                 (instTypeErr clas cls_args head_type_synonym_msg)
-            ; checkTc (xopt LangExt.FlexibleInstances dflags ||
-                       all tcInstHeadTyAppAllTyVars ty_args)
-                 (instTypeErr clas cls_args head_type_args_tyvars_msg)
-            ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
-                       lengthIs ty_args 1 ||  -- Only count type arguments
-                       (xopt LangExt.NullaryTypeClasses dflags &&
-                        null ty_args))
-                 (instTypeErr clas cls_args head_one_type_msg) }
-
-       ; mapM_ checkValidTypePat ty_args }
+  | otherwise
+  = mapM_ checkValidTypePat ty_args
   where
-    spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
-    deriv_clause   = case ctxt of { DerivClauseCtxt -> True; _ -> False }
+    clas_nm = getName clas
+    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
+
+    hand_written_bindings
+        = case ctxt of
+            InstDeclCtxt stand_alone -> not stand_alone
+            SpecInstCtxt             -> False
+            DerivClauseCtxt          -> False
+            _                        -> True
+
+    check_h98_arg_shape = case ctxt of
+                            SpecInstCtxt    -> False
+                            DerivClauseCtxt -> False
+                            SigmaCtxt       -> False
+                            _               -> True
+        -- SigmaCtxt: once we are in quantified-constraint land, we
+        -- aren't so picky about enforcing H98-language restrictions
+        -- E.g. we want to allow a head like Coercible (m a) (m b)
+
+
+    -- When we are looking at the head of a quantified constraint,
+    -- check_quant_pred sets ctxt to SigmaCtxt
+    quantified_constraint = case ctxt of
+                              SigmaCtxt -> True
+                              _         -> False
 
     head_type_synonym_msg = parens (
                 text "All instance types must be of the form (T t1 ... tn)" $$
@@ -1152,12 +1214,35 @@ checkValidInstHead ctxt clas cls_args
                 text "and each type variable appears at most once in the instance head.",
                 text "Use FlexibleInstances if you want to disable this."])
 
-    head_one_type_msg = parens (
-                text "Only one type can be given in an instance head." $$
-                text "Use MultiParamTypeClasses if you want to allow more, or zero.")
+    head_one_type_msg = parens $
+                        text "Only one type can be given in an instance head." $$
+                        text "Use MultiParamTypeClasses if you want to allow more, or zero."
+
+    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)
+                         <+> text "does not support user-specified instances"
+    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"
+
+    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")
+
+    abstract_class_msg = text "Cannot define instance for abstract class"
+                         <+> quotes (ppr clas_nm)
 
-    abstract_class_msg =
-                text "Manual instances of this class are not permitted."
+    mb_ty_args_msg
+      | not (xopt LangExt.TypeSynonymInstances dflags)
+      , not (all tcInstHeadTyNotSynonym ty_args)
+      = Just head_type_synonym_msg
+
+      | not (xopt LangExt.FlexibleInstances dflags)
+      , not (all tcInstHeadTyAppAllTyVars ty_args)
+      = Just head_type_args_tyvars_msg
+
+      | length ty_args /= 1
+      , not (xopt LangExt.MultiParamTypeClasses dflags)
+      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
+      = Just head_one_type_msg
+
+      | otherwise
+      = Nothing
 
 tcInstHeadTyNotSynonym :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
@@ -1202,12 +1287,6 @@ dropCasts ty                = ty  -- LitTy, TyVarTy, CoercionTy
 dropCastsB :: TyVarBinder -> TyVarBinder
 dropCastsB b = b   -- Don't bother in the kind of a forall
 
-abstractClassKeys :: [Unique]
-abstractClassKeys = [ heqTyConKey
-                    , eqTyConKey
-                    , coercibleTyConKey
-                    ] -- See Note [Equality class instances]
-
 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
 instTypeErr cls tys msg
   = hang (hang (text "Illegal instance declaration for")
@@ -1374,7 +1453,9 @@ checkValidInstance ctxt hs_type ty
   = failWithTc (text "Arity mis-match in instance head")
 
   | otherwise
-  = do  { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
+  = do  { setSrcSpan head_loc $
+          checkValidInstHead ctxt clas inst_tys
+
         ; traceTc "checkValidInstance {" (ppr ty)
 
         ; env0 <- tcInitTidyEnv
diff --git a/testsuite/tests/deriving/should_fail/T14916.stderr b/testsuite/tests/deriving/should_fail/T14916.stderr
index 2a6cca187d..81f94650f5 100644
--- a/testsuite/tests/deriving/should_fail/T14916.stderr
+++ b/testsuite/tests/deriving/should_fail/T14916.stderr
@@ -1,10 +1,8 @@
 
 T14916.hs:7:24: error:
-    • Illegal instance declaration for ‘A ~ A’
-        Manual instances of this class are not permitted.
+    • Class ‘~’ does not support user-specified instances
     • In the data declaration for ‘A’
 
 T14916.hs:8:24: error:
-    • Illegal instance declaration for ‘Coercible B B’
-        Manual instances of this class are not permitted.
+    • Class ‘Coercible’ does not support user-specified instances
     • In the data declaration for ‘B’
diff --git a/testsuite/tests/deriving/should_fail/T9687.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr
index a98f775bee..4c3dfe8255 100644
--- a/testsuite/tests/deriving/should_fail/T9687.stderr
+++ b/testsuite/tests/deriving/should_fail/T9687.stderr
@@ -1,5 +1,5 @@
 
-T9687.hs:4:1: error:
+T9687.hs:4:10: error:
     • Class ‘Typeable’ does not support user-specified instances
     • In the instance declaration for
         ‘Typeable (a, b, c, d, e, f, g, h)’
diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/polykinds/T8132.stderr
index a1aaa1319a..f53a78cd6d 100644
--- a/testsuite/tests/polykinds/T8132.stderr
+++ b/testsuite/tests/polykinds/T8132.stderr
@@ -1,4 +1,4 @@
 
-T8132.hs:7:1: error:
+T8132.hs:7:10: error:
     • Class ‘Typeable’ does not support user-specified instances
     • In the instance declaration for ‘Typeable K’
diff --git a/testsuite/tests/quantified-constraints/T15334.hs b/testsuite/tests/quantified-constraints/T15334.hs
new file mode 100644
index 0000000000..88d7c3f376
--- /dev/null
+++ b/testsuite/tests/quantified-constraints/T15334.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MultiParamTypeClasses, PolyKinds, QuantifiedConstraints, RankNTypes #-}
+
+module T15334 where
+
+class C m a
+class D m a
+
+f :: (forall a. Eq a => (C m a, D m a)) => m a
+f = undefined
diff --git a/testsuite/tests/quantified-constraints/T15334.stderr b/testsuite/tests/quantified-constraints/T15334.stderr
new file mode 100644
index 0000000000..902d7a71e5
--- /dev/null
+++ b/testsuite/tests/quantified-constraints/T15334.stderr
@@ -0,0 +1,6 @@
+
+T15334.hs:8:6: error:
+    • You can't specify an instance for a tuple constraint
+    • In the quantified constraint ‘forall a. Eq a => (C m a, D m a)’
+      In the type signature:
+        f :: (forall a. Eq a => (C m a, D m a)) => m a
diff --git a/testsuite/tests/quantified-constraints/all.T b/testsuite/tests/quantified-constraints/all.T
index 3145f47cf1..833a667ea9 100644
--- a/testsuite/tests/quantified-constraints/all.T
+++ b/testsuite/tests/quantified-constraints/all.T
@@ -15,3 +15,4 @@ test('T15290', normal, compile, [''])
 test('T15290a', normal, compile_fail, [''])
 test('T15290b', normal, compile_fail, [''])
 test('T15316', normal, compile_fail, [''])
+test('T15334', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T12837.stderr b/testsuite/tests/typecheck/should_fail/T12837.stderr
index 893575f08c..bf2e89b72a 100644
--- a/testsuite/tests/typecheck/should_fail/T12837.stderr
+++ b/testsuite/tests/typecheck/should_fail/T12837.stderr
@@ -1,12 +1,12 @@
 
-T12837.hs:10:1: error:
+T12837.hs:10:10: error:
     • Class ‘Typeable’ does not support user-specified instances
     • In the instance declaration for ‘Typeable K’
-    
-T12837.hs:11:1: error:
+
+T12837.hs:11:10: error:
     • Class ‘KnownNat’ does not support user-specified instances
     • In the instance declaration for ‘KnownNat n’
 
-T12837.hs:12:1: error:
+T12837.hs:12:10: error:
     • Class ‘KnownSymbol’ does not support user-specified instances
     • In the instance declaration for ‘KnownSymbol n’
diff --git a/testsuite/tests/typecheck/should_fail/T13068.stderr b/testsuite/tests/typecheck/should_fail/T13068.stderr
index c161209001..6ecf1871c6 100644
--- a/testsuite/tests/typecheck/should_fail/T13068.stderr
+++ b/testsuite/tests/typecheck/should_fail/T13068.stderr
@@ -1,6 +1,6 @@
 [1 of 4] Compiling T13068[boot]     ( T13068.hs-boot, T13068.o-boot )
 [2 of 4] Compiling T13068a          ( T13068a.hs, T13068a.o )
 
-T13068a.hs:3:1: error:
+T13068a.hs:3:10: error:
     • Cannot define instance for abstract class ‘C’
     • In the instance declaration for ‘C Int’
diff --git a/testsuite/tests/typecheck/should_fail/T14390.stderr b/testsuite/tests/typecheck/should_fail/T14390.stderr
index 0dd72a1e3e..5604de5177 100644
--- a/testsuite/tests/typecheck/should_fail/T14390.stderr
+++ b/testsuite/tests/typecheck/should_fail/T14390.stderr
@@ -1,5 +1,4 @@
 
 T14390.hs:4:10: error:
-    • Illegal instance declaration for ‘Int ~~ Int’
-        Manual instances of this class are not permitted.
+    • Class ‘~~’ does not support user-specified instances
     • In the instance declaration for ‘(~~) Int Int’
diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr
index b121f91c65..b8e4c6e5a8 100644
--- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr
+++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr
@@ -1,5 +1,4 @@
 
 TcCoercibleFail2.hs:5:10: error:
-    Illegal instance declaration for ‘Coercible () ()’
-      Manual instances of this class are not permitted.
-    In the instance declaration for ‘Coercible () ()’
+    • Class ‘Coercible’ does not support user-specified instances
+    • In the instance declaration for ‘Coercible () ()’