compiler/GHC/Tc/Gen/Pat.hs

@@ -1058,7 +1058,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
           -- 'tcDataConPat'.)
         ; let
             bad_arg_tys :: [(Int, Scaled Type)]
-            bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing)
+            bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> not (typeHasFixedRuntimeRep arg_ty))
                         $ zip [0..] arg_tys'
         ; massertPpr (null bad_arg_tys) $
             vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep"

compiler/GHC/Tc/Instance/FunDeps.hs

@@ -527,7 +527,7 @@ also know `t2` and the other way.
 closeWrtFunDeps is used
  - when checking the coverage condition for an instance declaration
  - when determining which tyvars are unquantifiable during generalization, in
-   GHC.Tc.Solver.decideMonoTyVars.
+   GHC.Tc.Solver.decidePromotedTyVars.
 
 Note [Equality superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/Tc/Solver/Monad.hs

@@ -169,7 +169,6 @@ import GHC.Core.Reduction
 import GHC.Core.Class
 import GHC.Core.TyCon
 
-import GHC.Types.Error ( mkPlainError, noHints )
 import GHC.Types.Name
 import GHC.Types.TyThing
 import GHC.Types.Name.Reader
@@ -1886,19 +1885,10 @@ solverDepthError loc ty
               ; return (ty, env0) }
        ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
              tidy_ty      = tidyType tidy_env ty
-             msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-               vcat [ text "Reduction stack overflow; size =" <+> ppr depth
-                      , hang (text "When simplifying the following type:")
-                           2 (ppr tidy_ty)
-                      , note ]
+             msg = TcRnSolverDepthError tidy_ty depth
        ; TcM.failWithTcM (tidy_env, msg) }
   where
     depth = ctLocDepth loc
-    note = vcat
-      [ text "Use -freduction-depth=0 to disable this check"
-      , text "(any upper bound you could choose might fail unpredictably with"
-      , text " minor updates to GHC, so disabling the check is recommended if"
-      , text " you're sure that type checking should terminate)" ]
 
 {-
 ************************************************************************

compiler/GHC/Tc/TyCl.hs

@@ -34,13 +34,7 @@ import GHC.Driver.Config.HsToCore
 
 import GHC.Hs
 
-import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..)
-                           , IllegalNewtypeReason (..)
-                           , UninferrableTyVarCtx (..)
-                           , BadFieldAnnotationReason (..)
-                           , RoleValidationFailedReason (..)
-                           , DisabledClassExtension (..)
-                           , TyFamsDisabledReason (..) )
+import GHC.Tc.Errors.Types
 import GHC.Tc.TyCl.Build
 import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
                     , reportUnsolvedEqualities )
@@ -2690,7 +2684,10 @@ tcClassATs :: Name                    -- The class name (not knot-tied)
            -> TcM [ClassATItem]
 tcClassATs class_name cls ats at_defs
   = do {  -- Complain about associated type defaults for non associated-types
-         sequence_ [ failWithTc (TcRnBadAssociatedType class_name n)
+         sequence_ [ failWithTc $ TcRnIllegalInstance
+                                $ IllegalFamilyInstance $ InvalidAssoc
+                                $ InvalidAssocDefault
+                                $ AssocDefaultNotAssoc class_name n
                    | n <- map at_def_tycon at_defs
                    , not (n `elemNameSet` at_names) ]
        ; mapM tc_at ats }
@@ -2724,7 +2721,9 @@ tcDefaultAssocDecl _ []
   = return Nothing  -- No default declaration
 
 tcDefaultAssocDecl _ (d1:_:_)
-  = failWithTc (TcRnMultiAssocTyFamDefaults (tyFamInstDeclName (unLoc d1)))
+  = failWithTc $ TcRnIllegalInstance $ IllegalFamilyInstance
+               $ InvalidAssoc $ InvalidAssocDefault $
+      AssocMultipleDefaults (tyFamInstDeclName (unLoc d1))
 
 tcDefaultAssocDecl fam_tc
   [L loc (TyFamInstDecl { tfid_eqn =
@@ -2742,11 +2741,14 @@ tcDefaultAssocDecl fam_tc
 
        -- Kind of family check
        ; assert (fam_tc_name == tc_name) $
-         checkTc (isTypeFamilyTyCon fam_tc) (TcRnFamilyCategoryMismatch fam_tc)
+         checkTc (isTypeFamilyTyCon fam_tc) $
+         TcRnIllegalInstance $ IllegalFamilyInstance $
+           FamilyCategoryMismatch fam_tc
 
        -- Arity check
-       ; checkTc (vis_pats == vis_arity)
-                 (TcRnFamilyArityMismatch fam_tc vis_arity)
+       ; checkTc (vis_pats == vis_arity) $
+         TcRnIllegalInstance $ IllegalFamilyInstance $
+           FamilyArityMismatch fam_tc vis_arity
 
        -- Typecheck RHS
        --
@@ -3215,7 +3217,8 @@ checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats =
        --    type family F a where { G Int = Bool }
        let tc_fam_tc_name = getName tc_fam_tc
      ; checkTc (tc_fam_tc_name == eqn_tc_name) $
-               TcRnTyFamNameMismatch tc_fam_tc_name eqn_tc_name
+               TcRnIllegalInstance $ IllegalFamilyInstance $
+               TyFamNameMismatch tc_fam_tc_name eqn_tc_name
 
        -- Check the arity of visible arguments
        -- If we wait until validity checking, we'll get kind errors
@@ -3223,7 +3226,8 @@ checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats =
      ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc)
            vis_pats  = numVisibleArgs hs_pats
      ; checkTc (vis_pats == vis_arity) $
-               TcRnFamilyArityMismatch tc_fam_tc vis_arity
+        TcRnIllegalInstance $ IllegalFamilyInstance $
+        FamilyArityMismatch tc_fam_tc vis_arity
      }
 
 {- Note [Instantiating a family tycon]
@@ -4823,8 +4827,10 @@ checkValidClass cls
 
     check_at (ATI fam_tc m_dflt_rhs)
       = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs)
-           ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
-                     (TcRnAssocNoClassTyVar cls fam_tc)
+           ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) $
+              TcRnIllegalInstance $ IllegalFamilyInstance $
+                InvalidAssoc $ InvalidAssocInstance $
+                AssocNoClassTyVar cls fam_tc
                         -- Check that the associated type mentions at least
                         -- one of the class type variables
                         -- The check is disabled for nullary type classes,

compiler/GHC/Tc/TyCl/Class.hs

@@ -601,6 +601,8 @@ warnMissingAT name
        -- hs-boot and signatures never need to provide complete "definitions"
        -- of any sort, as they aren't really defining anything, but just
        -- constraining items which are defined elsewhere.
-       ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name
-       ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia
+       ; let diag = TcRnIllegalInstance $ IllegalFamilyInstance
+                  $ InvalidAssoc $ InvalidAssocInstance
+                  $ AssocInstanceMissing name
+       ; diagnosticTc  (warn && hsc_src == HsSrcFile) diag
                        }

compiler/GHC/Tc/TyCl/Instance.hs

@@ -594,11 +594,15 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
     tcAddTyFamInstCtxt decl  $
     do { let fam_lname = feqn_tycon eqn
        ; fam_tc <- tcLookupLocatedTyCon fam_lname
-       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+       ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc
 
          -- (0) Check it's an open type family
-       ; checkTc (isTypeFamilyTyCon fam_tc)     (TcRnFamilyCategoryMismatch fam_tc)
-       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (TcRnNotOpenFamily fam_tc)
+       ; checkTc (isTypeFamilyTyCon fam_tc) $
+           TcRnIllegalInstance $ IllegalFamilyInstance $
+             FamilyCategoryMismatch fam_tc
+       ; checkTc (isOpenTypeFamilyTyCon fam_tc) $
+           TcRnIllegalInstance $ IllegalFamilyInstance $
+             NotAnOpenFamilyTyCon fam_tc
 
          -- (1) do the work of verifying the synonym group
          -- For some reason we don't have a location for the equation
@@ -617,9 +621,9 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
 
 
 ---------------------
-tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
+tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcM ()
 -- Used for both type and data families
-tcFamInstDeclChecks mb_clsinfo fam_tc
+tcFamInstDeclChecks mb_clsinfo ty_or_data fam_tc
   = do { -- Type family instances require -XTypeFamilies
          -- and can't (currently) be in an hs-boot file
        ; traceTc "tcFamInstDecl" (ppr fam_tc)
@@ -632,13 +636,17 @@ tcFamInstDeclChecks mb_clsinfo fam_tc
            HsSrcFile               ->
              return ()
 
-       -- Check that it is a family TyCon, and that
-       -- oplevel type instances are not for associated types.
-       ; checkTc (isFamilyTyCon fam_tc) (TcRnIllegalFamilyInstance fam_tc)
+       -- Check that it is a family TyCon
+       ; checkTc (isFamilyTyCon fam_tc) $
+          TcRnIllegalInstance $ IllegalFamilyInstance $
+            NotAFamilyTyCon ty_or_data fam_tc
 
+       -- Check that top-level type instances are not for associated types.
        ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl
-               isTyConAssoc fam_tc)            -- but an associated type
-              (addErr $ TcRnMissingClassAssoc fam_tc)
+               isTyConAssoc fam_tc) $          -- but an associated type
+          addErr $ TcRnIllegalInstance $ IllegalFamilyInstance
+                 $ InvalidAssoc $ InvalidAssocInstance
+                 $ AssocInstanceNotInAClass fam_tc
        }
 
 {- Note [Associated type instances]
@@ -693,10 +701,12 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
     tcAddDataFamInstCtxt decl  $
     do { fam_tc <- tcLookupLocatedTyCon lfam_name
 
-       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+       ; tcFamInstDeclChecks mb_clsinfo IAmData fam_tc
 
        -- Check that the family declaration is for the right kind
-       ; checkTc (isDataFamilyTyCon fam_tc) (TcRnFamilyCategoryMismatch fam_tc)
+       ; checkTc (isDataFamilyTyCon fam_tc) $
+          TcRnIllegalInstance $ IllegalFamilyInstance $
+            FamilyCategoryMismatch fam_tc
        ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons
           -- Do /not/ check that the number of patterns = tyConArity fam_tc
           -- See [Arity of data families] in GHC.Core.FamInstEnv

compiler/GHC/Tc/Utils/TcMType.hs

@@ -1717,7 +1717,7 @@ we leave it alone.
 
 Note that not *every* variable with a higher level will get
 generalised, either due to the monomorphism restriction or other
-quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars
+quirks. See, for example, the code in GHC.Tc.Solver.decidePromotedTyVars
 and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude
 certain otherwise-eligible variables from being generalised.
 

compiler/GHC/Tc/Utils/TcType.hs

@@ -2001,8 +2001,8 @@ being the )
 -}
 
 tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
--- (tcSplitIOType_maybe t) returns Just (IO,t',co)
---              if co : t ~ IO t'
+-- (tcSplitIOType_maybe t) returns Just (IO,t')
+--              if t = IO t'
 --              returns Nothing otherwise
 tcSplitIOType_maybe ty
   = case tcSplitTyConApp_maybe ty of

compiler/GHC/Tc/Validity.hs

@@ -53,8 +53,6 @@ import GHC.Core.TyCo.Ppr
 import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches
                            , InjectivityCheckResult(..) )
 
-import GHC.Iface.Type    ( pprIfaceType, pprIfaceTypeApp )
-import GHC.CoreToIface   ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )
 import GHC.Hs
 import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
@@ -64,7 +62,7 @@ import GHC.Types.Basic   ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension )
 import GHC.Types.Name
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
-import GHC.Types.Var     ( VarBndr(..), isInvisibleFunArg, mkTyVar )
+import GHC.Types.Var     ( VarBndr(..), isInvisibleFunArg, mkTyVar, tyVarName )
 import GHC.Types.SourceFile
 import GHC.Types.SrcLoc
 import GHC.Types.TyThing ( TyThing(..) )
@@ -84,7 +82,6 @@ import Control.Monad
 import Data.Foldable
 import Data.Function
 import Data.List        ( (\\) )
-import qualified Data.List.NonEmpty as NE
 
 {-
 ************************************************************************
@@ -1454,7 +1451,8 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
   -- Abstract classes cannot have instances, except in hs-boot or signature files.
   | isAbstractClass clas
   , hs_src == HsSrcFile
-  = failWithTc (TcRnAbstractClassInst clas)
+  = fail_with_inst_err $ IllegalInstanceHead
+                       $ InstHeadAbstractClass clas
 
   -- Complain about hand-written instances of built-in classes
   -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.
@@ -1466,7 +1464,7 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
   , not (hs_src == HsigFile)
     -- Note [Instances of built-in classes in signature files]
   , hand_written_bindings
-  = failWithTc $ TcRnSpecialClassInst clas False
+  = fail_with_inst_err $ IllegalSpecialClassInstance clas False
 
   -- Handwritten instances of KnownNat/KnownChar/KnownSymbol
   -- are forbidden outside of signature files (#12837).
@@ -1474,7 +1472,7 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
   | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ]
   , (not (hs_src == HsigFile) && hand_written_bindings) || derived_instance
     -- Note [Instances of built-in classes in signature files]
-  = failWithTc $ TcRnSpecialClassInst clas False
+  = fail_with_inst_err $ IllegalSpecialClassInstance clas False
 
   -- For the most part we don't allow
   -- instances for (~), (~~), or Coercible;
@@ -1484,12 +1482,13 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
     [ heqTyConName, eqTyConName, coercibleTyConName
     , withDictClassName, unsatisfiableClassName ]
   , not quantified_constraint
-  = failWithTc $ TcRnSpecialClassInst clas False
+  = fail_with_inst_err $ IllegalSpecialClassInstance clas False
 
   -- Check for hand-written Generic instances (disallowed in Safe Haskell)
   | clas_nm `elem` genericClassNames
   , hand_written_bindings
-  =  do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True)
+  =  do { when (safeLanguageOn dflags) $
+           fail_with_inst_err $ IllegalSpecialClassInstance clas True
         ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) }
 
   | clas_nm == hasFieldClassName
@@ -1504,12 +1503,19 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
 
   -- Check language restrictions on the args to the class
   | check_h98_arg_shape
-  , Just illegalType <- mb_ty_args_type
-  = failWithTc (TcRnIllegalInstanceDecl clas cls_args illegalType)
+  , Just illegal_head <- mb_ty_args_type
+  = fail_with_inst_err $ IllegalInstanceHead illegal_head
 
   | otherwise
   = pure ()
   where
+
+    fail_with_inst_err err =
+      failWithTc $ TcRnIllegalInstance
+                 $ IllegalClassInstance
+                    (TypeThing $ mkClassPred clas cls_args)
+                 $ err
+
     clas_nm = getName clas
     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
 
@@ -1546,16 +1552,16 @@ check_special_inst_head dflags hs_src ctxt clas cls_args
     mb_ty_args_type
       | not (xopt LangExt.TypeSynonymInstances dflags)
       , not (all tcInstHeadTyNotSynonym ty_args)
-      = Just IllegalInstanceHeadTypeSynonym
+      = Just InstHeadTySynArgs
 
       | not (xopt LangExt.FlexibleInstances dflags)
       , not (all tcInstHeadTyAppAllTyVars ty_args)
-      = Just IllegalInstanceHeadNonTyVarArgs
+      = Just InstHeadNonTyVarArgs
 
       | length ty_args /= 1
       , not (xopt LangExt.MultiParamTypeClasses dflags)
       , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
-      = Just IllegalMultiParamInstance
+      = Just InstHeadMultiParam
 
       | otherwise
       = Nothing
@@ -1639,7 +1645,9 @@ checkHasFieldInst cls tys@[_k_ty, lbl_ty, r_ty, _a_ty] =
          | otherwise
          -> add_err $ IllegalHasFieldInstanceTyConHasFields tc lbl_ty
   where
-    add_err err = addErrTc $ TcRnIllegalInstanceDecl cls tys
+    add_err err = addErrTc $ TcRnIllegalInstance
+                           $ IllegalClassInstance
+                               (TypeThing $ mkClassPred cls tys)
                            $ IllegalHasFieldInstance err
 
 checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
@@ -1946,9 +1954,9 @@ if we find a constraint tuple.
 checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
 checkValidInstance ctxt hs_type ty = case tau of
   -- See Note [Instances and constraint synonyms]
-  TyConApp tc inst_tys -> case tyConClass_maybe tc of
-    Nothing -> failWithTc (TcRnIllegalClassInst (tyConFlavour tc))
-    Just clas -> do
+  TyConApp tc inst_tys
+    | Just clas <- tyConClass_maybe tc
+    -> do
         { setSrcSpanA head_loc $
           checkValidInstHead ctxt clas inst_tys
 
@@ -1979,16 +1987,21 @@ checkValidInstance ctxt hs_type ty = case tau of
             IsValid
               -> return ()   -- Check succeeded
             NotValid coverageInstErr
-              -> addErrTc $ TcRnIllegalInstanceDecl clas inst_tys
-                          $ IllegalInstanceFailsCoverageCondition coverageInstErr
-
-        ; traceTc "End checkValidInstance }" empty
-
-        ; return () }
-  _ -> failWithTc (TcRnNoClassInstHead tau)
+              -> addErrTc $ mk_err
+                          $ IllegalInstanceFailsCoverageCondition clas coverageInstErr
+
+        ; traceTc "End checkValidInstance }" empty }
+    | otherwise
+    -> failWithTc $ mk_err $ IllegalInstanceHead
+                           $ InstHeadNonClass (Just tc)
+  _ -> failWithTc $ mk_err $ IllegalInstanceHead
+                           $ InstHeadNonClass Nothing
   where
     (theta, tau) = splitInstTyForValidity ty
 
+    mk_err err = TcRnIllegalInstance
+               $ IllegalClassInstance (TypeThing tau) err
+
         -- The location of the "head" of the instance
     head_loc = getLoc (getLHsInstDeclHead hs_type)
 
@@ -2222,10 +2235,11 @@ checkValidAssocTyFamDeflt fam_tc pats =
     extract_tv pat pat_vis =
       case getTyVar_maybe pat of
         Just tv -> pure tv
-        Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-          pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $
-          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")
-             2 (vcat [ppr_eqn, suggestion])
+        Nothing -> failWithTc $ TcRnIllegalInstance
+                              $ IllegalFamilyInstance
+                              $ InvalidAssoc $ InvalidAssocDefault
+                              $ AssocDefaultBadArgs fam_tc pats
+                              $ AssocDefaultNonTyVarArg (pat, pat_vis)
 
     -- Checks that no type variables in an associated default declaration are
     -- duplicated. If that is the case, throw an error.
@@ -2239,23 +2253,13 @@ checkValidAssocTyFamDeflt fam_tc pats =
     check_all_distinct_tvs cpt_tvs_vis =
       let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in
       traverse_
-        (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
-               mkTcRnUnknownMessage $ mkPlainError noHints $
-               pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $
-               hang (text "Illegal duplicate variable"
-                       <+> quotes (ppr pat_tv) <+> text "in:")
-                  2 (vcat [ppr_eqn, suggestion]))
+        (\d -> failWithTc $ TcRnIllegalInstance
+                          $ IllegalFamilyInstance
+                          $ InvalidAssoc $ InvalidAssocDefault
+                          $ AssocDefaultBadArgs fam_tc pats
+                          $ AssocDefaultDuplicateTyVars d)
         dups
 
-    ppr_eqn :: SDoc
-    ppr_eqn =
-      quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)
-                <+> equals <+> text "...")
-
-    suggestion :: SDoc
-    suggestion = text "The arguments to" <+> quotes (ppr fam_tc)
-             <+> text "must all be distinct type variables"
-
 checkFamInstRhs :: TyCon -> [Type]         -- LHS
                 -> [(TyCon, [Type])]       -- type family calls in RHS
                 -> [TcRnMessage]
@@ -2300,15 +2304,14 @@ checkFamPatBinders fam_tc qtvs pats rhs
          -- In both cases, 'k' is not bound on the LHS, but is used on the RHS
          -- We catch the former in kcDeclHeader, and the latter right here
          -- See Note [Check type-family instance binders]
-       ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")
-                               (text "bound on the LHS of")
+       ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs)))
+                   bad_rhs_tvs
 
          -- Check for explicitly forall'd variable that is not bound on LHS
          --    data instance forall a.  T Int = MkT Int
          -- See Note [Unused explicitly bound variables in a family pattern]
          -- See Note [Check type-family instance binders]
-       ; check_tvs bad_qtvs (text "bound by a forall")
-                            (text "used in")
+       ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs
        }
   where
     cpt_tvs     = tyCoVarsOfTypes pats
@@ -2329,20 +2332,10 @@ checkFamPatBinders fam_tc qtvs pats rhs
                   -- Used on RHS but not bound on LHS
     dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs
 
-    check_tvs tvs what what2
-      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-        hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs
-              <+> isOrAre tvs <+> what <> comma)
-           2 (vcat [ text "but not" <+> what2 <+> text "the family instance"
-                   , mk_extra tvs ])
-
-    -- mk_extra: #7536: give a decent error message for
-    --         type T a = Int
-    --         type instance F (T a) = a
-    mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $
-                   hang (text "The real LHS (expanding synonyms) is:")
-                      2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))
-
+    check_tvs mk_err tvs
+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $
+        TcRnIllegalInstance $ IllegalFamilyInstance $
+        mk_err (map tyVarName tvs)
 
 -- | Checks that a list of type patterns is valid in a matching (LHS)
 -- position of a class instances or type/data family instance.
@@ -2361,19 +2354,13 @@ checkValidTypePats tc pat_ty_args
        -- Ensure that no type family applications occur a type pattern
        ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of
             [] -> pure ()
-            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-               ty_fam_inst_illegal_err tf_is_invis_arg
-                                       (mkTyConApp tf_tc tf_args) }
+            ((tf_is_invis_arg, tf_tc, tf_args):_) ->
+              failWithTc $ TcRnIllegalInstance $
+                IllegalFamilyApplicationInInstance inst_ty
+                  tf_is_invis_arg tf_tc tf_args }
   where
     inst_ty = mkTyConApp tc pat_ty_args
 
-    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
-    ty_fam_inst_illegal_err invis_arg ty
-      = pprWithExplicitKindsWhen invis_arg $
-        hang (text "Illegal type synonym family application"
-                <+> quotes (ppr ty) <+> text "in instance" <> colon)
-           2 (ppr inst_ty)
-
 -------------------------
 checkConsistentFamInst :: AssocInstInfo
                        -> TyCon     -- ^ Family tycon
@@ -2397,8 +2384,10 @@ checkConsistentFamInst (InClsInst { ai_class = clas
        -- Check that the associated type indeed comes from this class
        -- See [Mismatched class methods and associated type families]
        -- in TcInstDecls.
-       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)
-                 (TcRnBadAssociatedType (className clas) (tyConName fam_tc))
+       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) $
+          TcRnIllegalInstance $ IllegalFamilyInstance $
+            InvalidAssoc $ InvalidAssocInstance $
+            AssocNotInThisClass clas fam_tc
 
        ; check_match arg_triples
        }
@@ -2413,29 +2402,12 @@ checkConsistentFamInst (InClsInst { ai_class = clas
                                ax_arg_tys
                   , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ]
 
-    pp_wrong_at_arg vis
-      = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $
-        vcat [ text "Type indexes must match class instance head"
-             , text "Expected:" <+> pp_expected_ty
-             , text "  Actual:" <+> pp_actual_ty ]
-
     -- Fiddling around to arrange that wildcards unconditionally print as "_"
     -- We only need to print the LHS, not the RHS at all
     -- See Note [Printing conflicts with class header]
     (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs
     (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs)
 
-    pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
-                     toIfaceTcArgs fam_tc $
-                     [ case lookupVarEnv mini_env at_tv of
-                         Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty
-                         Nothing         -> mk_wildcard at_tv
-                     | at_tv <- tyConTyVars fam_tc ]
-
-    pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
-                   toIfaceTcArgs fam_tc $
-                   tidyTypes tidy_env2 ax_arg_tys
-
     mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv))
     tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan
 
@@ -2450,7 +2422,17 @@ checkConsistentFamInst (InClsInst { ai_class = clas
       , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1
       = go lr_subst1 rl_subst1 triples
       | otherwise
-      = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis)
+      = addErrTc $ TcRnIllegalInstance $ IllegalFamilyInstance
+                 $ InvalidAssoc $ InvalidAssocInstance
+                 $ AssocTyVarsDontMatch vis fam_tc exp_tys act_tys
+
+    -- Expected/actual family argument types (for error messages)
+    exp_tys =
+      [ case lookupVarEnv mini_env at_tv of
+          Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty
+          Nothing         -> mk_wildcard at_tv
+      | at_tv <- tyConTyVars fam_tc ]
+    act_tys = tidyTypes tidy_env2 ax_arg_tys
 
     -- The /scoped/ type variables from the class-instance header
     -- should not be alpha-renamed.  Inferred ones can be.
@@ -2878,19 +2860,12 @@ checkTyConTelescope :: TyCon -> TcM ()
 checkTyConTelescope tc
   | bad_scope
   = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]
-    addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")
-              2 pp_tc_kind
-         , extra
-         , hang (text "Perhaps try this order instead:")
-              2 (pprTyVars sorted_tvs) ]
+    addErr $ TcRnBadTyConTelescope tc
 
   | otherwise
   = return ()
   where
     tcbs = tyConBinders tc
-    tvs  = binderVars tcbs
-    sorted_tvs = scopedSort tvs
 
     (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs
 
@@ -2901,34 +2876,3 @@ checkTyConTelescope tc
       where
         tv = binderVar tcb
         fkvs = tyCoVarsOfType (tyVarKind tv)
-
-    inferred_tvs  = [ binderVar tcb
-                    | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ]
-    specified_tvs = [ binderVar tcb
-                    | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ]
-
-    pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)
-    pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)
-
-    pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)
-    ppr_untidy ty = pprIfaceType (toIfaceType ty)
-      -- We need ppr_untidy here because pprType will tidy the type, which
-      -- will turn the bogus kind we are trying to report
-      --     T :: forall (a::k) k (b::k) -> blah
-      -- into a misleadingly sanitised version
-      --     T :: forall (a::k) k1 (b::k1) -> blah
-
-    extra
-      | null inferred_tvs && null specified_tvs
-      = empty
-      | null inferred_tvs
-      = hang (text "NB: Specified variables")
-           2 (sep [pp_spec, text "always come first"])
-      | null specified_tvs
-      = hang (text "NB: Inferred variables")
-           2 (sep [pp_inf, text "always come first"])
-      | otherwise
-      = hang (text "NB: Inferred variables")
-           2 (vcat [ sep [ pp_inf, text "always come first"]
-                   , sep [text "then Specified variables", pp_spec]])
-

compiler/GHC/Tc/Zonk/Type.hs

@@ -1194,7 +1194,7 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
        new_ty <- zonkTcTypeToTypeX ty
        new_ids <- mapSndM zonkExpr ids
 
-       massert (isLiftedTypeKind (typeKind new_stack_tys))
+       massert (definitelyLiftedType new_stack_tys)
          -- desugarer assumes that this is not representation-polymorphic...
          -- but indeed it should always be lifted due to the typing
          -- rules for arrows

compiler/GHC/Types/Error/Codes.hs

@@ -329,6 +329,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "RepresentationalEq"                            = 10283
 
   -- Typechecker/renamer diagnostic codes
+  GhcDiagnosticCode "TcRnSolverDepthError"                          = 40404
   GhcDiagnosticCode "TcRnRedundantConstraints"                      = 30606
   GhcDiagnosticCode "TcRnInaccessibleCode"                          = 40564
   GhcDiagnosticCode "TcRnInaccessibleCoAxBranch"                    = 28129
@@ -371,8 +372,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig"               = 64414
   GhcDiagnosticCode "TcRnOverloadedSig"                             = 16675
   GhcDiagnosticCode "TcRnTupleConstraintInst"                       = 69012
-  GhcDiagnosticCode "TcRnAbstractClassInst"                         = 51758
-  GhcDiagnosticCode "TcRnNoClassInstHead"                           = 56538
   GhcDiagnosticCode "TcRnUserTypeError"                             = 47403
   GhcDiagnosticCode "TcRnConstraintInKind"                          = 01259
   GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg"              = 19590
@@ -384,9 +383,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint"                 = 80003
   GhcDiagnosticCode "TcRnIllegalImplicitParam"                      = 75863
   GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind"            = 75844
-  GhcDiagnosticCode "TcRnIllegalClassInst"                          = 53946
   GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg"               = 45474
-  GhcDiagnosticCode "TcRnBadAssociatedType"                         = 38351
   GhcDiagnosticCode "TcRnForAllRankErr"                             = 91510
   GhcDiagnosticCode "TcRnMonomorphicBindings"                       = 55524
   GhcDiagnosticCode "TcRnOrphanInstance"                            = 90177
@@ -422,7 +419,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnPartialTypeSignatures"                     = 60661
   GhcDiagnosticCode "TcRnLazyGADTPattern"                           = 87005
   GhcDiagnosticCode "TcRnArrowProcGADTPattern"                      = 64525
-  GhcDiagnosticCode "TcRnSpecialClassInst"                          = 97044
   GhcDiagnosticCode "TcRnForallIdentifier"                          = 64088
   GhcDiagnosticCode "TcRnTypeEqualityOutOfScope"                    = 12003
   GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators"             = 58520
@@ -489,15 +485,11 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding"        = 28587
   GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod"         = 72520
   GhcDiagnosticCode "TcRnBadMethodErr"                              = 46284
-  GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration"   = 08585
   GhcDiagnosticCode "TcRnIllegalTypeData"                           = 15013
   GhcDiagnosticCode "TcRnTypeDataForbids"                           = 67297
   GhcDiagnosticCode "TcRnInterfaceLookupError"                      = 52243
   GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef"                     = 06201
   GhcDiagnosticCode "TcRnMisplacedInstSig"                          = 06202
-  GhcDiagnosticCode "TcRnIllegalFamilyInstance"                     = 06204
-  GhcDiagnosticCode "TcRnMissingClassAssoc"                         = 06205
-  GhcDiagnosticCode "TcRnNotOpenFamily"                             = 06207
   GhcDiagnosticCode "TcRnCapturedTermName"                          = 54201
   GhcDiagnosticCode "TcRnBindingOfExistingName"                     = 58805
   GhcDiagnosticCode "TcRnMultipleFixityDecls"                       = 50419
@@ -511,12 +503,10 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnUnexpectedDefaultSig"                      = 40700
   GhcDiagnosticCode "TcRnDuplicateMinimalSig"                       = 85346
   GhcDiagnosticCode "TcRnLoopySuperclassSolve"                      = 36038
-  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = 12222
   GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl"          = 95159
   GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl"                  = 65669
   GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig"               = 45906
   GhcDiagnosticCode "TcRnIllegalRuleLhs"                            = 63294
-  GhcDiagnosticCode "TcRnBadAssocRhs"                               = 53634
   GhcDiagnosticCode "TcRnDuplicateRoleAnnot"                        = 97170
   GhcDiagnosticCode "TcRnDuplicateKindSig"                          = 43371
   GhcDiagnosticCode "TcRnIllegalDerivStrategy"                      = 87139
@@ -535,7 +525,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnPatSynEscapedCoercion"                     = 88986
   GhcDiagnosticCode "TcRnPatSynExistentialInResult"                 = 33973
   GhcDiagnosticCode "TcRnPatSynArityMismatch"                       = 18365
-  GhcDiagnosticCode "TcRnMultiAssocTyFamDefaults"                   = 59128
   GhcDiagnosticCode "TcRnTyFamDepsDisabled"                         = 43991
   GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl"                   = 60012
   GhcDiagnosticCode "TcRnPartialFieldSelector"                      = 82712
@@ -544,7 +533,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnTyFamResultDisabled"                       = 44012
   GhcDiagnosticCode "TcRnCommonFieldResultTypeMismatch"             = 31004
   GhcDiagnosticCode "TcRnCommonFieldTypeMismatch"                   = 91827
-  GhcDiagnosticCode "TcRnAssocNoClassTyVar"                         = 55912
   GhcDiagnosticCode "TcRnDataConParentTypeMismatch"                 = 45219
   GhcDiagnosticCode "TcRnGADTsDisabled"                             = 23894
   GhcDiagnosticCode "TcRnExistentialQuantificationDisabled"         = 25709
@@ -552,14 +540,11 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnMultipleConForNewtype"                     = 16409
   GhcDiagnosticCode "TcRnKindSignaturesDisabled"                    = 49378
   GhcDiagnosticCode "TcRnEmptyDataDeclsDisabled"                    = 32478
-  GhcDiagnosticCode "TcRnFamilyCategoryMismatch"                    = 52347
-  GhcDiagnosticCode "TcRnFamilyArityMismatch"                       = 12985
   GhcDiagnosticCode "TcRnRoleMismatch"                              = 29178
   GhcDiagnosticCode "TcRnRoleCountMismatch"                         = 54298
   GhcDiagnosticCode "TcRnIllegalRoleAnnotation"                     = 77192
   GhcDiagnosticCode "TcRnRoleAnnotationsDisabled"                   = 17779
   GhcDiagnosticCode "TcRnIncoherentRoles"                           = 18273
-  GhcDiagnosticCode "TcRnTyFamNameMismatch"                         = 88221
   GhcDiagnosticCode "TcRnTypeSynonymCycle"                          = 97522
   GhcDiagnosticCode "TcRnSelfImport"                                = 43281
   GhcDiagnosticCode "TcRnNoExplicitImportList"                      = 16029
@@ -591,6 +576,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnSimplifiableConstraint"                    = 62412
   GhcDiagnosticCode "TcRnIllegalQuasiQuotes"                        = 77343
   GhcDiagnosticCode "TcRnImplicitRhsQuantification"                 = 16382
+  GhcDiagnosticCode "TcRnBadTyConTelescope"                         = 87279
   GhcDiagnosticCode "TcRnPatersonCondFailure"                       = 22979
 
   -- TcRnTypeApplicationsDisabled
@@ -691,18 +677,50 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "UnusedImportNone"                              = 66111
   GhcDiagnosticCode "UnusedImportSome"                              = 38856
 
-  -- TcRnIllegalInstanceDecl
-  GhcDiagnosticCode "IllegalInstanceHeadTypeSynonym"                = 93557
-  GhcDiagnosticCode "IllegalInstanceHeadNonTyVarArgs"               = 48406
-  GhcDiagnosticCode "IllegalMultiParamInstance"                     = 91901
+  -- TcRnIllegalInstance
+  GhcDiagnosticCode "IllegalFamilyApplicationInInstance"            = 73138
+
+  -- TcRnIllegalClassInstance/IllegalClassInstanceReason
+  GhcDiagnosticCode "IllegalSpecialClassInstance"                   = 97044
   GhcDiagnosticCode "IllegalInstanceFailsCoverageCondition"         = 21572
 
-  -- TcRnIllegalHasFieldInstance
+    -- IllegalInstanceHead
+  GhcDiagnosticCode "InstHeadAbstractClass"                         = 51758
+  GhcDiagnosticCode "InstHeadNonClass"                              = 53946
+  GhcDiagnosticCode "InstHeadTySynArgs"                             = 93557
+  GhcDiagnosticCode "InstHeadNonTyVarArgs"                          = 48406
+  GhcDiagnosticCode "InstHeadMultiParam"                            = 91901
+
+    -- IllegalHasFieldInstance
   GhcDiagnosticCode "IllegalHasFieldInstanceNotATyCon"              = 88994
   GhcDiagnosticCode "IllegalHasFieldInstanceFamilyTyCon"            = 70743
   GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasFields"         = 43406
   GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasField"          = 30836
 
+  -- TcRnIllegalFamilyInstance/IllegalFamilyInstanceReason
+  GhcDiagnosticCode "NotAFamilyTyCon"                               = 06204
+  GhcDiagnosticCode "NotAnOpenFamilyTyCon"                          = 06207
+  GhcDiagnosticCode "FamilyCategoryMismatch"                        = 52347
+  GhcDiagnosticCode "FamilyArityMismatch"                           = 12985
+  GhcDiagnosticCode "TyFamNameMismatch"                             = 88221
+  GhcDiagnosticCode "FamInstRHSOutOfScopeTyVars"                    = 53634
+  GhcDiagnosticCode "FamInstLHSUnusedBoundTyVars"                   = 30337
+
+    -- InvalidAssocInstance
+  GhcDiagnosticCode "AssocInstanceMissing"                          = 08585
+  GhcDiagnosticCode "AssocInstanceNotInAClass"                      = 06205
+  GhcDiagnosticCode "AssocNotInThisClass"                           = 38351
+  GhcDiagnosticCode "AssocNoClassTyVar"                             = 55912
+  GhcDiagnosticCode "AssocTyVarsDontMatch"                          = 95424
+
+    -- InvalidAssocDefault
+  GhcDiagnosticCode "AssocDefaultNotAssoc"                          = 78822
+  GhcDiagnosticCode "AssocMultipleDefaults"                         = 59128
+
+    -- AssocDefaultBadArgs
+  GhcDiagnosticCode "AssocDefaultNonTyVarArg"                       = 41522
+  GhcDiagnosticCode "AssocDefaultDuplicateTyVars"                   = 48178
+
   -- Diagnostic codes for the foreign function interface
   GhcDiagnosticCode "NotADataType"                                  = 31136
   GhcDiagnosticCode "NewtypeDataConNotInScope"                      = 72317
@@ -840,6 +858,10 @@ type family GhcDiagnosticCode c = n | n -> c where
   -- and this includes outdated diagnostic codes for errors that GHC
   -- no longer reports. These are collected below.
 
+  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = 12222
+  GhcDiagnosticCode "TcRnNoClassInstHead"                           = 56538
+    -- The above two are subsumed by InstHeadNonClass [GHC-53946]
+
   GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027
   GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639
   GhcDiagnosticCode "TcRnMixedSelectors"                            = 40887
@@ -927,12 +949,24 @@ type family ConRecursInto con where
   ConRecursInto "TcRnImportLookup"         = 'Just ImportLookupReason
   ConRecursInto "TcRnUnusedImport"         = 'Just UnusedImportReason
   ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition
-  ConRecursInto "TcRnIllegalInstanceDecl"    = 'Just IllegalInstanceReason
+  ConRecursInto "TcRnIllegalInstance"        = 'Just IllegalInstanceReason
   ConRecursInto "TcRnTypeApplicationsDisabled" = 'Just TypeApplication
 
     -- Illegal instance reasons
+  ConRecursInto "IllegalClassInstance"        = 'Just IllegalClassInstanceReason
+  ConRecursInto "IllegalFamilyInstance"       = 'Just IllegalFamilyInstanceReason
+
+      -- Illegal class instance reasons
+
+  ConRecursInto "IllegalInstanceHead"         = 'Just IllegalInstanceHeadReason
+  ConRecursInto "IllegalHasFieldInstance"     = 'Just IllegalHasFieldInstance
+
+      -- Illegal family instance reasons
 
-  ConRecursInto "IllegalHasFieldInstance" = 'Just IllegalHasFieldInstance
+  ConRecursInto "InvalidAssoc"                = 'Just InvalidAssoc
+  ConRecursInto "InvalidAssocInstance"        = 'Just InvalidAssocInstance
+  ConRecursInto "InvalidAssocDefault"         = 'Just InvalidAssocDefault
+  ConRecursInto "AssocDefaultBadArgs"         = 'Just AssocDefaultBadArgs
 
     --
     -- TH errors

compiler/GHC/Types/Hint.hs

@@ -250,7 +250,6 @@ data GhcHint
     -}
   | SuggestAddToHSigExportList !Name !(Maybe Module)
     {-| Suggests increasing the limit for the number of iterations in the simplifier.
-
     -}
   | SuggestIncreaseSimplifierIterations
     {-| Suggests to explicitly import 'Type' from the 'Data.Kind' module, because
@@ -455,6 +454,9 @@ data GhcHint
     Name -- ^ ... to this method
     String -- ^ Documentation URL
 
+    {-| Suggest to increase the solver maximum reduction depth -}
+  | SuggestIncreaseReductionDepth
+
     {-| Suggest removing a method implementation when a superclass defines the
       canonical version of that method.
     -}

compiler/GHC/Types/Hint/Ppr.hs

@@ -238,6 +238,12 @@ instance Outputable GhcHint where
       -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe."
     SuggestRemoveRecordWildcard
       -> text "Omit the" <+> quotes (text "..")
+    SuggestIncreaseReductionDepth ->
+      vcat
+        [ text "Use -freduction-depth=0 to disable this check"
+        , text "(any upper bound you could choose might fail unpredictably with"
+        , text " minor updates to GHC, so disabling the check is recommended if"
+        , text " you're sure that type checking should terminate)" ]
     SuggestMoveNonCanonicalDefinition lhs rhs refURL ->
       text "Move definition from" <+>
       quotes (pprPrefixUnqual rhs) <+>

docs/users_guide/flags.py

@@ -50,7 +50,7 @@ import sphinx
 from sphinx import addnodes
 from sphinx.domains.std import GenericObject
 from sphinx.errors import SphinxError
-from distutils.version import LooseVersion
+from packaging.version import parse
 from utils import build_table_from_list
 
 import os.path
@@ -628,8 +628,8 @@ def purge_flags(app, env, docname):
 
 def setup(app):
     # The override argument to add_directive_to_domain is only supported by >= 1.8
-    sphinx_version = LooseVersion(sphinx.__version__)
-    override_arg = {'override': True} if sphinx_version >= LooseVersion('1.8') else {}
+    sphinx_version = parse(sphinx.__version__)
+    override_arg = {'override': True} if sphinx_version >= parse('1.8') else {}
 
     # Add ghc-flag directive, and override the class with our own
     app.add_object_type('ghc-flag', 'ghc-flag')

hadrian/src/Rules/Generate.hs

@@ -327,6 +327,9 @@ rtsCabalFlags = mconcat
   where
     flag = interpolateCabalFlag
 
+ghcPrimCabalFlags :: Interpolations
+ghcPrimCabalFlags = interpolateCabalFlag "CabalNeedLibatomic" NeedLibatomic
+
 packageVersions :: Interpolations
 packageVersions = foldMap f [ base, ghcPrim, compiler, ghc, cabal, templateHaskell, ghcCompact, array ]
   where
@@ -346,6 +349,7 @@ templateRules :: Rules ()
 templateRules = do
   templateRule "compiler/ghc.cabal" $ projectVersion
   templateRule "rts/rts.cabal" $ rtsCabalFlags
+  templateRule "libraries/ghc-prim/ghc-prim.cabal" $ ghcPrimCabalFlags
   templateRule "driver/ghci/ghci-wrapper.cabal" $ projectVersion
   templateRule "ghc/ghc-bin.cabal" $ projectVersion
   templateRule "utils/iserv/iserv.cabal" $ projectVersion

hadrian/src/Settings/Builders/Haddock.hs

@@ -50,6 +50,10 @@ haddockBuilderArgs = mconcat
         baseUrlTemplate <- expr (docsBaseUrl <$> userSetting defaultDocArgs)
         let baseUrl p = substituteTemplate baseUrlTemplate p
         ghcOpts  <- haddockGhcArgs
+        -- These are the options which are necessary to perform the build. Additional
+        -- options such as `--hyperlinked-source`, `--hoogle`, `--quickjump` are
+        -- added by the `extraArgs` field in the flavour. The defaults are provided
+        -- by `defaultHaddockExtraArgs`.
         mconcat
             [ arg "--verbosity=0"
             , arg $ "-B" ++ root -/- stageString Stage1 -/- "lib"
@@ -57,9 +61,6 @@ haddockBuilderArgs = mconcat
             , arg $ "--odir=" ++ takeDirectory output
             , arg $ "--dump-interface=" ++ output
             , arg "--html"
-            , arg "--hyperlinked-source"
-            , arg "--hoogle"
-            , arg "--quickjump"
             , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version
                     ++ ": " ++ synopsis
             , arg $ "--prologue=" ++ takeDirectory output -/- "haddock-prologue.txt"

hadrian/src/Settings/Default.hs

@@ -7,7 +7,7 @@ module Settings.Default (
 
     -- * Default command line arguments for various builders
     SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs,
-    defaultExtraArgs,
+    defaultExtraArgs, defaultHaddockExtraArgs,
 
     -- * Default build flavour and BigNum backend
     defaultFlavour, defaultBignumBackend
@@ -219,7 +219,13 @@ sourceArgs SourceArgs {..} = builder Ghc ? mconcat
 
 -- | All default command line arguments.
 defaultExtraArgs :: Args
-defaultExtraArgs = sourceArgs defaultSourceArgs
+defaultExtraArgs =
+  mconcat [ sourceArgs defaultSourceArgs, defaultHaddockExtraArgs ]
+
+defaultHaddockExtraArgs :: Args
+defaultHaddockExtraArgs = builder (Haddock BuildPackage) ?
+  mconcat [ arg "--hyperlinked-source", arg "--hoogle", arg "--quickjump" ]
+
 
 -- | Default source arguments, e.g. optimisation settings.
 defaultSourceArgs :: SourceArgs

hadrian/src/Settings/Default.hs-boot

 module Settings.Default (
     SourceArgs (..), sourceArgs, defaultBuilderArgs, defaultPackageArgs,
-    defaultExtraArgs, defaultLibraryWays, defaultRtsWays,
+    defaultExtraArgs, defaultHaddockExtraArgs, defaultLibraryWays, defaultRtsWays,
     defaultFlavour, defaultBignumBackend
     ) where
 
@@ -15,7 +15,7 @@ data SourceArgs = SourceArgs
 
 sourceArgs :: SourceArgs -> Args
 
-defaultBuilderArgs, defaultPackageArgs, defaultExtraArgs :: Args
+defaultBuilderArgs, defaultPackageArgs, defaultExtraArgs, defaultHaddockExtraArgs :: Args
 defaultLibraryWays, defaultRtsWays :: Ways
 defaultFlavour :: Flavour
 defaultBignumBackend :: String

hadrian/src/Settings/Flavours/Benchmark.hs

@@ -10,7 +10,7 @@ import {-# SOURCE #-} Settings.Default
 benchmarkFlavour :: Flavour
 benchmarkFlavour = defaultFlavour
     { name = "bench"
-    , extraArgs = benchmarkArgs
+    , extraArgs = benchmarkArgs <> defaultHaddockExtraArgs
     , libraryWays = pure $ Set.fromList [vanilla]
     , rtsWays = Set.fromList <$> mconcat [pure [vanilla], targetSupportsThreadedRts ? pure [threaded]] }
 

hadrian/src/Settings/Flavours/Development.hs

@@ -12,7 +12,7 @@ import {-# SOURCE #-} Settings.Default
 developmentFlavour :: Stage -> Flavour
 developmentFlavour ghcStage = defaultFlavour
     { name = "devel" ++ stageString ghcStage
-    , extraArgs = developmentArgs ghcStage
+    , extraArgs = developmentArgs ghcStage <> defaultHaddockExtraArgs
     , libraryWays = pure $ Set.fromList [vanilla]
     , rtsWays = Set.fromList <$> mconcat [pure [vanilla, debug], targetSupportsThreadedRts ? pure [threaded, threadedDebug]]
     , dynamicGhcPrograms = return False