TH: handle explicit quantification in instanceswip/instd-quantifications

This patch adds support for explicitly-written quantification in
typeclass instances, such as:

  instance forall k (a :: k). C a
  deriving instance forall k (a :: k). D a

It does so by adding a field of type `Maybe (TyVarBndr ())`
to both the `InstanceD` and `StandaloneDerivD` constructors of the
Template Haskell `Dec` datatype, and making appropriate use of it to
ensure that spliced declarations don't silently drop the user-written
quantification.

Fixes #21794

Updates haddock submodule

35 files changed, 291 insertions, 113 deletions

diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index bea3b9715f..89563c904b 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -70,8 +70,8 @@ templateHaskellNames = [
     bindSName, letSName, noBindSName, parSName, recSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
-    classDName, instanceWithOverlapDName,
-    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
+    classDName, instanceWithAllDName,
+    standaloneDerivWithAllDName, sigDName, kiSigDName, forImpDName,
     pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
     pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -356,9 +356,9 @@ recSName    = libFun (fsLit "recS")    recSIdKey
 
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
-    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
+    instanceWithAllDName, sigDName, kiSigDName, forImpDName, pragInlDName,
     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
+    pragAnnDName, standaloneDerivWithAllDName, defaultSigDName, defaultDName,
     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
@@ -370,8 +370,8 @@ newtypeDName                     = libFun (fsLit "newtypeD")
 typeDataDName                    = libFun (fsLit "typeDataD")                    typeDataDIdKey
 tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
 classDName                       = libFun (fsLit "classD")                       classDIdKey
-instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+instanceWithAllDName             = libFun (fsLit "instanceWithAllD")             instanceWithAllIdKey
+standaloneDerivWithAllDName      = libFun (fsLit "standaloneDerivWithAllD")      standaloneDerivWithAllDIdKey
 sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
 kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey
 defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey
@@ -884,11 +884,11 @@ recSIdKey        = mkPreludeMiscIdUnique 315
 
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
-    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
+    instanceWithAllIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
     pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
     pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
-    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithAllDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
     kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique
@@ -898,7 +898,7 @@ dataDIdKey                        = mkPreludeMiscIdUnique 322
 newtypeDIdKey                     = mkPreludeMiscIdUnique 323
 tySynDIdKey                       = mkPreludeMiscIdUnique 324
 classDIdKey                       = mkPreludeMiscIdUnique 325
-instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326
+instanceWithAllIdKey              = mkPreludeMiscIdUnique 326
 instanceDIdKey                    = mkPreludeMiscIdUnique 327
 sigDIdKey                         = mkPreludeMiscIdUnique 328
 forImpDIdKey                      = mkPreludeMiscIdUnique 329
@@ -918,7 +918,7 @@ infixLDIdKey                      = mkPreludeMiscIdUnique 342
 infixRDIdKey                      = mkPreludeMiscIdUnique 343
 infixNDIdKey                      = mkPreludeMiscIdUnique 344
 roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345
-standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
+standaloneDerivWithAllDIdKey      = mkPreludeMiscIdUnique 346
 defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
 patSynDIdKey                      = mkPreludeMiscIdUnique 348
 patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 313b8e8fe2..cee953df01 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -61,7 +61,8 @@ module GHC.Hs.Type (
 
         mkAnonWildCardTy, pprAnonWildCard,
 
-        hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
+        hsOuterTyVarNames, hsOuterTyVarBndrs,
+        hsOuterExplicitBndrs, mapHsOuterImplicit,
         mkHsOuterImplicit, mkHsOuterExplicit,
         mkHsImplicitSigType, mkHsExplicitSigType,
         mkHsWildCardBndrs, mkHsPatSigType,
@@ -106,7 +107,7 @@ import GHC.Types.Id ( Id )
 import GHC.Types.SourceText
 import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName )
 import GHC.Types.Name.Reader ( RdrName )
-import GHC.Types.Var ( VarBndr, visArgTypeLike )
+import GHC.Types.Var ( VarBndr(..), visArgTypeLike )
 import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
 import GHC.Core.Ppr ( pprOccWithTick)
@@ -237,6 +238,11 @@ hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]
 hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs
 hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs})       = hsLTyVarNames bndrs
 
+hsOuterTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcRn -> [LHsTyVarBndr Specificity GhcRn]
+hsOuterTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs})
+  = [ noLocA $ UserTyVar noAnn SpecifiedSpec (noLocA tv) | tv <- imp_tvs ]
+hsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
+
 hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)
                      -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
 hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
@@ -765,7 +771,7 @@ splitLHsQualTy_KP body = (Nothing, body)
 
 -- | Decompose a type class instance type (of the form
 -- @forall <tvs>. context => instance_head@) into its constituent parts.
--- Note that the @[Name]@s returned correspond to either:
+-- Note that the @HsOuterTyVarBndrs@s returned correspond to either:
 --
 -- * The implicitly bound type variables (if the type lacks an outermost
 --   @forall@), or
@@ -777,9 +783,11 @@ splitLHsQualTy_KP body = (Nothing, body)
 -- See @Note [No nested foralls or contexts in instance types]@
 -- for why this is important.
 splitLHsInstDeclTy :: LHsSigType GhcRn
-                   -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
+                   -> ( HsOuterTyVarBndrs Specificity GhcRn
+                      , Maybe (LHsContext GhcRn)
+                      , LHsType GhcRn)
 splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =
-  (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)
+  (outer_bndrs, mb_cxt, body_ty)
   where
     (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty
 
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 63094c21dd..70b5d78cd9 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -643,7 +643,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                          , cid_datafam_insts = adts
                          , cid_overlap_mode = overlap
                          })
-  = addSimpleTyVarBinds FreshNamesOnly tvs $
+  = withOuterForallBinders tv_outer $ \tvs ->
             -- We must bring the type variables into scope, so their
             -- occurrences don't fail, even though the binders don't
             -- appear in the resulting data structure
@@ -661,22 +661,39 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                ; adts1  <- mapM (repDataFamInstD . unLoc) adts
                ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
                ; rOver  <- repOverlap (fmap unLoc overlap)
-               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+               ; decls2 <- repInst rOver tvs cxt1 inst_ty1 decls1
                ; wrapGenSyms ss decls2 }
  where
-   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+    (tv_outer, cxt, inst_ty) = splitLHsInstDeclTy ty
 
 repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                                        , deriv_type     = ty }))
-  = do { dec <- repDerivStrategy strat  $ \strat' ->
-                addSimpleTyVarBinds FreshNamesOnly tvs $
+  = do { dec <- repDerivStrategy strat $ \strat' ->
+                withOuterForallBinders tv_outer $ \tvs ->
                 do { cxt'     <- repLContext cxt
                    ; inst_ty' <- repLTy inst_ty
-                   ; repDeriv strat' cxt' inst_ty' }
+                   ; repDeriv strat' tvs cxt' inst_ty' }
        ; return (locA loc, dec) }
   where
-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+    (tv_outer, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+
+-- | Utility function for 'repClsInstD' and 'repStandaloneDerivD':
+-- bind some type variables from an outer forall, and pass them to the thing inside.
+withOuterForallBinders :: HsOuterTyVarBndrs Specificity GhcRn
+                       -> ( Core (Maybe [M (TH.TyVarBndr ())]) -> MetaM (Core (M r)) )
+                       -> MetaM (Core (M r))
+withOuterForallBinders tv_outer thing_inside =
+  addHsTyVarBinds FreshNamesOnly tv_bndrs $ \tvs' ->
+  do { elt_ty <- wrapName tyVarBndrUnitTyConName
+     ; let !tvs'' = case tv_outer of
+              HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+              HsOuterExplicit {} -> coreJust'    (mkListTy elt_ty) tvs'
+     ; thing_inside tvs'' }
+  where
+    tv_bndrs :: [LHsTyVarBndr () GhcRn]
+    tv_bndrs = fmap (fmap $ setHsTyVarBndrFlag ()) -- set visibility flag to ()
+             $ hsOuterTyVarBndrs tv_outer
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
 repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -2566,9 +2583,10 @@ repTySyn (MkC nm) (MkC tvs) (MkC rhs)
   = rep2 tySynDName [nm, tvs, rhs]
 
 repInst :: Core (Maybe TH.Overlap) ->
+           Core (Maybe [M (TH.TyVarBndr ())]) ->
            Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
-                                                              [o, cxt, ty, ds]
+repInst (MkC o) (MkC tvs) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithAllDName
+                                                              [o, tvs, cxt, ty, ds]
 
 repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
                  -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))
@@ -2625,10 +2643,12 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
   = rep2 classDName [cxt, cls, tvs, fds, ds]
 
 repDeriv :: Core (Maybe (M TH.DerivStrategy))
-         -> Core (M TH.Cxt) -> Core (M TH.Type)
+         -> Core (Maybe [M (TH.TyVarBndr ())])
+         -> Core (M TH.Cxt)
+         -> Core (M TH.Type)
          -> MetaM (Core (M TH.Dec))
-repDeriv (MkC ds) (MkC cxt) (MkC ty)
-  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+repDeriv (MkC ds) (MkC tvs) (MkC cxt) (MkC ty)
+  = rep2 standaloneDerivWithAllDName [ds, tvs, cxt, ty]
 
 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
            -> Core TH.Phases -> MetaM (Core (M TH.Dec))
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index fc6846e566..50792c1c95 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -604,7 +604,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                            , cid_datafam_insts = adts })
   = do { checkInferredVars ctxt inf_err inst_ty
        ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
-       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+       ; let (ktv_bndrs, _, head_ty') = splitLHsInstDeclTy inst_ty'
+             ktv_names = hsOuterTyVarNames ktv_bndrs
              -- Check if there are any nested `forall`s or contexts, which are
              -- illegal in the type of an instance declaration (see
              -- Note [No nested foralls or contexts in instance types] in
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 239a55ee6e..125accd0ec 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -2470,14 +2470,17 @@ reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
                               -- includes only *visible* tvs
                    -> ClsInst -> TcM TH.Dec
 reifyClassInstance is_poly_tvs i
-  = do { cxt <- reifyCxt theta
+  = do { th_tvs <- reifyTyVarBndrs [ Bndr tv () | tv <- tvs ]
+           -- Quantified type variables in an instance are always
+           -- invisible and specified.
+       ; cxt <- reifyCxt theta
        ; let vis_types = filterOutInvisibleTypes cls_tc types
        ; thtypes <- reifyTypes vis_types
        ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
        ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
-       ; return $ (TH.InstanceD over cxt head_ty []) }
+       ; return $ (TH.InstanceD over (Just th_tvs) cxt head_ty []) }
   where
-     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
+     (tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
      cls_tc   = classTyCon cls
      dfun     = instanceDFunId i
      over     = case overlapMode (is_flag i) of
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 498a17694f..bd0acf382b 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -308,13 +308,17 @@ cvtDec (ClassD ctxt cl tvs fds decs)
                               -- no docs in TH ^^
         }
 
-cvtDec (InstanceD o ctxt ty decs)
+cvtDec (InstanceD o tv_bndrs ctxt ty decs)
   = do  { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs
         ; for_ (nonEmpty fams') $ \ bad_fams ->
             failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams)
+        ; tv_bndrs' <- traverse (cvtTvs . map mk_spec) tv_bndrs
         ; ctxt' <- cvtContext funPrec ctxt
         ; (L loc ty') <- cvtType ty
-        ; let inst_ty' = L loc $ mkHsImplicitSigType $
+        ; let mk_sig_type = case tv_bndrs' of
+                              Nothing  -> mkHsImplicitSigType
+                              Just tvs -> mkHsExplicitSigType noAnn tvs
+        ; let inst_ty' = L loc $ mk_sig_type $
                          mkHsQualTy ctxt loc ctxt' $ L loc ty'
         ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
           ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
@@ -411,11 +415,15 @@ cvtDec (TH.RoleAnnotD tc roles)
        ; returnJustLA
                    $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }
 
-cvtDec (TH.StandaloneDerivD ds cxt ty)
-  = do { cxt' <- cvtContext funPrec cxt
+cvtDec (TH.StandaloneDerivD ds tv_bndrs cxt ty)
+  = do { tv_bndrs' <- traverse (cvtTvs . map mk_spec) tv_bndrs
+       ; cxt' <- cvtContext funPrec cxt
        ; ds'  <- traverse cvtDerivStrategy ds
        ; (L loc ty') <- cvtType ty
-       ; let inst_ty' = L loc $ mkHsImplicitSigType $
+       ; let mk_sig_type = case tv_bndrs' of
+                             Nothing  -> mkHsImplicitSigType
+                             Just tvs -> mkHsExplicitSigType noAnn tvs
+       ; let inst_ty' = L loc $ mk_sig_type $
                         mkHsQualTy cxt loc cxt' $ L loc ty'
        ; returnJustLA $ DerivD noExtField $
          DerivDecl { deriv_ext = noAnn
@@ -1502,6 +1510,9 @@ cvt_tv (TH.KindedTV nm fl ki)
        ; ki' <- cvtKind ki
        ; returnLA $ KindedTyVar noAnn fl' nm' ki' }
 
+mk_spec :: TH.TyVarBndr () -> TH.TyVarBndr TH.Specificity
+mk_spec = fmap $ const TH.SpecifiedSpec
+
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
 cvtRole TH.RepresentationalR = Just Coercion.Representational
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index e95abc0855..b5ab76a86e 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -698,8 +698,8 @@ data VarBndr var argf = Bndr var argf
 --
 -- A 'TyVarBinder' is a binder with only TyVar
 type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag
-type InvisTyBinder  = VarBndr TyCoVar   Specificity
-type ReqTyBinder    = VarBndr TyCoVar   ()
+type InvisTyBinder  = VarBndr TyCoVar Specificity
+type ReqTyBinder    = VarBndr TyCoVar ()
 
 type TyVarBinder    = VarBndr TyVar   ForAllTyFlag
 type InvisTVBinder  = VarBndr TyVar   Specificity
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index 6d94368456..11a73c3332 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -26,6 +26,16 @@ Runtime system
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
+``template-haskell`` library
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- The constructors ``InstanceD`` and ``StandaloneDerivD`` now take one extra
+  argument, of type ``Maybe (TyVarBndr ())``, in order to handle
+  instances with user-written quantification, such as: ::
+
+    instance forall k (a :: k). C a
+    deriving instance forall k (a :: k). D a
+
 
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index b52de5b0d3..4e2fa1ab50 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -91,7 +91,7 @@ module Language.Haskell.TH.Lib (
     stockStrategy, anyclassStrategy, newtypeStrategy,
     viaStrategy, DerivStrategy(..),
     -- **** Class
-    classD, instanceD, instanceWithOverlapD, Overlap(..),
+    classD, instanceD, instanceWithOverlapD, instanceWithAllD, Overlap(..),
     sigD, kiSigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD,
 
     -- **** Role annotations
@@ -165,6 +165,7 @@ import Language.Haskell.TH.Lib.Internal hiding
 
   , derivClause
   , standaloneDerivWithStrategyD
+  , standaloneDerivWithAllD
 
   , doE
   , mdoE
@@ -331,10 +332,20 @@ derivClause mds p = do
   return $ DerivClause mds p'
 
 standaloneDerivWithStrategyD :: Quote m => Maybe DerivStrategy -> m Cxt -> m Type -> m Dec
-standaloneDerivWithStrategyD mds ctxt ty = do
+standaloneDerivWithStrategyD mds ctxt ty =
+  standaloneDerivWithAllD mds Nothing ctxt ty
+
+standaloneDerivWithAllD :: Quote m
+                        => Maybe DerivStrategy
+                        -> Maybe [m (TyVarBndr ())]
+                        -> m Cxt
+                        -> m Type
+                        -> m Dec
+standaloneDerivWithAllD mds mtvs ctxt ty = do
+  mtvs' <- traverse sequenceA mtvs
   ctxt' <- ctxt
   ty'   <- ty
-  return $ StandaloneDerivD mds ctxt' ty'
+  return $ StandaloneDerivD mds mtvs' ctxt' ty'
 
 -------------------------------------------------------------------------------
 -- * Bytes literals
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 35bca47d25..547b879fc9 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -462,14 +462,16 @@ instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec
 instanceD = instanceWithOverlapD Nothing
 
 instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec
-instanceWithOverlapD o ctxt ty decs =
+instanceWithOverlapD o ctxt ty decs = instanceWithAllD o Nothing ctxt ty decs
+
+instanceWithAllD :: Quote m => Maybe Overlap -> Maybe [m (TyVarBndr ())] -> m Cxt -> m Type -> [m Dec] -> m Dec
+instanceWithAllD o ty_bndrs ctxt ty decs =
   do
+    ty_bndrs1 <- traverse sequenceA ty_bndrs
     ctxt1 <- ctxt
     decs1 <- sequenceA decs
     ty1   <- ty
-    pure $ InstanceD o ctxt1 ty1 decs1
-
-
+    pure $ InstanceD o ty_bndrs1 ctxt1 ty1 decs1
 
 sigD :: Quote m => Name -> m Type -> m Dec
 sigD fun ty = liftA (SigD fun) $ ty
@@ -599,12 +601,16 @@ standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec
 standaloneDerivD = standaloneDerivWithStrategyD Nothing
 
 standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec
-standaloneDerivWithStrategyD mdsq ctxtq tyq =
+standaloneDerivWithStrategyD mdsq ctxtq tyq = standaloneDerivWithAllD mdsq Nothing ctxtq tyq
+
+standaloneDerivWithAllD :: Quote m => Maybe (m DerivStrategy) -> Maybe [m (TyVarBndr ())] -> m Cxt -> m Type -> m Dec
+standaloneDerivWithAllD mdsq ty_bndrsq ctxtq tyq =
   do
-    mds  <- sequenceA mdsq
-    ctxt <- ctxtq
-    ty   <- tyq
-    pure $ StandaloneDerivD mds ctxt ty
+    mds      <- sequenceA mdsq
+    ty_bndrs <- traverse sequenceA ty_bndrsq
+    ctxt     <- ctxtq
+    ty       <- tyq
+    pure $ StandaloneDerivD mds ty_bndrs ctxt ty
 
 defaultSigD :: Quote m => Name -> m Type -> m Dec
 defaultSigD n tyq =
@@ -1056,21 +1062,21 @@ withDecDoc doc dec = do
     doc_loc (PatSynSigD n _)                               = Just $ DeclDoc n
 
     -- For instances we just pass along the full type
-    doc_loc (InstanceD _ _ t _)           = Just $ InstDoc t
+    doc_loc (InstanceD _ _ _ t _)         = Just $ InstDoc t
     doc_loc (DataInstD _ _ t _ _ _)       = Just $ InstDoc t
     doc_loc (NewtypeInstD _ _ t _ _ _)    = Just $ InstDoc t
     doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t
 
     -- Declarations that can't have documentation attached to
     -- ValDs that aren't a simple variable pattern
-    doc_loc (ValD _ _ _)             = Nothing
-    doc_loc (KiSigD _ _)             = Nothing
-    doc_loc (PragmaD _)              = Nothing
-    doc_loc (RoleAnnotD _ _)         = Nothing
-    doc_loc (StandaloneDerivD _ _ _) = Nothing
-    doc_loc (DefaultSigD _ _)        = Nothing
-    doc_loc (ImplicitParamBindD _ _) = Nothing
-    doc_loc (DefaultD _)             = Nothing
+    doc_loc (ValD _ _ _)               = Nothing
+    doc_loc (KiSigD _ _)               = Nothing
+    doc_loc (PragmaD _)                = Nothing
+    doc_loc (RoleAnnotD _ _)           = Nothing
+    doc_loc (StandaloneDerivD _ _ _ _) = Nothing
+    doc_loc (DefaultSigD _ _)          = Nothing
+    doc_loc (ImplicitParamBindD _ _)   = Nothing
+    doc_loc (DefaultD _)               = Nothing
 
 -- | Variant of 'withDecDoc' that applies the same documentation to
 -- multiple declarations. Useful for documenting quoted declarations.
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index cedb974976..8a9536d996 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -97,10 +97,9 @@ pprPatSynType :: PatSynType -> Doc
 pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
   | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')
   | null uniTys, null reqs  = noreqs <+> ppr ty'
-  | null reqs               = pprForallBndrs uniTys <+> noreqs <+> ppr ty'
+  | null reqs               = ppr_invis_forall_bndrs uniTys <+> noreqs <+> ppr ty'
   | otherwise               = ppr ty
   where noreqs = text "() =>"
-        pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "."
 pprPatSynType ty            = ppr ty
 
 ------------------------------
@@ -404,9 +403,13 @@ ppr_dec _ (TypeDataD t xs ksig cs)
 ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
-ppr_dec _ (InstanceD o ctxt i ds) =
-        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
-                                  $$ where_clause ds
+ppr_dec _ (InstanceD o tvs ctxt i ds)
+  =   text "instance"
+  <+> maybe empty ppr_overlap o
+  <+> maybe empty ppr_invis_forall_bndrs tvs
+  <+> pprCxt ctxt
+  <+> ppr i
+  $$ where_clause ds
 ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
 ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k
 ppr_dec _ (ForeignD f)  = ppr f
@@ -452,10 +455,11 @@ ppr_dec _ (ClosedTypeFamilyD tfhead eqns)
       = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs
 ppr_dec _ (RoleAnnotD name roles)
   = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
-ppr_dec _ (StandaloneDerivD ds cxt ty)
+ppr_dec _ (StandaloneDerivD ds tvs cxt ty)
   = hsep [ text "deriving"
          , maybe empty ppr_deriv_strategy ds
          , text "instance"
+         , maybe empty ppr_invis_forall_bndrs tvs
          , pprCxt cxt
          , ppr ty ]
 ppr_dec _ (DefaultSigD n ty)
@@ -473,6 +477,13 @@ ppr_dec _ (PatSynSigD name ty)
 ppr_dec _ (ImplicitParamBindD n e)
   = hsep [text ('?' : n), text "=", ppr e]
 
+ppr_invis_forall_bndrs :: Ppr a => [a] -> Doc
+ppr_invis_forall_bndrs bndrs
+  | null bndrs
+  = empty
+  | otherwise
+  = text "forall" <+> fsep (map ppr bndrs) <> char '.'
+
 ppr_deriv_strategy :: DerivStrategy -> Doc
 ppr_deriv_strategy ds =
   case ds of
@@ -565,7 +576,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
              | otherwise          = empty
 
 ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc
-ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."
+ppr_bndrs (Just bndrs) = ppr_invis_forall_bndrs bndrs
 ppr_bndrs Nothing = empty
 
 ------------------------------
@@ -623,17 +634,12 @@ instance Ppr Pragma where
        = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
     ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)
        = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
-             , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs
-                                               <+> ppr lhs
+             , nest 4 $ maybe empty ppr_invis_forall_bndrs ty_bndrs
+                     <+> ppr_tm_forall ty_bndrs
+                     <+> ppr lhs
              , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
-      where ppr_ty_forall Nothing      = empty
-            ppr_ty_forall (Just bndrs) = text "forall"
-                                         <+> fsep (map ppr bndrs)
-                                         <+> char '.'
-            ppr_tm_forall Nothing | null tm_bndrs = empty
-            ppr_tm_forall _ = text "forall"
-                              <+> fsep (map ppr tm_bndrs)
-                              <+> char '.'
+      where ppr_tm_forall Nothing | null tm_bndrs = empty
+            ppr_tm_forall _ = ppr_invis_forall_bndrs tm_bndrs
     ppr (AnnP tgt expr)
        = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
       where target1 ModuleAnnotation    = text "module"
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 0304eb130b..cc80700a16 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2409,8 +2409,8 @@ data Dec
   | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@
   | ClassD Cxt Name [TyVarBndr ()]
          [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@
-  | InstanceD (Maybe Overlap) Cxt Type [Dec]
-                                  -- ^ @{ instance {\-\# OVERLAPS \#-\}
+  | InstanceD (Maybe Overlap) (Maybe [TyVarBndr ()]) Cxt Type [Dec]
+                                  -- ^ @{ instance {\-\# OVERLAPS \#-\} forall w .
                                   --        Show w => Show [w] where ds }@
   | SigD Name Type                -- ^ @{ length :: [a] -> Int }@
   | KiSigD Name Kind              -- ^ @{ type TypeRep :: k -> Type }@
@@ -2451,8 +2451,8 @@ data Dec
        -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
 
   | RoleAnnotD Name [Role]     -- ^ @{ type role T nominal representational }@
-  | StandaloneDerivD (Maybe DerivStrategy) Cxt Type
-       -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@
+  | StandaloneDerivD (Maybe DerivStrategy) (Maybe [TyVarBndr ()]) Cxt Type
+       -- ^ @{ deriving stock instance forall a. Ord a => Ord (Foo a) }@
   | DefaultSigD Name Type      -- ^ @{ default size :: Data a => a -> Int }@
 
   -- | Pattern Synonyms
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index bf63b6e689..4bda633e5e 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -2,12 +2,22 @@
 
 ## 2.20.0.0
 
-  * The `Ppr.pprInfixT` function has gained a `Precedence` argument. 
+  * The `Ppr.pprInfixT` function has gained a `Precedence` argument.
+
   * The values of named precedence levels like `Ppr.appPrec` have changed.
 
   * Add `TypeDataD` constructor to the `Dec` type for `type data`
     declarations (GHC proposal #106).
 
+  * The constructors `InstanceD` and `StandaloneDerivD` now take one extra
+    argument, of type `Maybe (TyVarBndr ())`, in order to handle
+    instances with user-written quantification, such as:
+
+    ```
+    instance forall k (a :: k). C a
+    deriving instance forall k (a :: k). D a
+    ```
+
 ## 2.19.0.0
 
   * Add `DefaultD` constructor to support Haskell `default` declarations.
diff --git a/testsuite/tests/ghci/scripts/T4127.stdout b/testsuite/tests/ghci/scripts/T4127.stdout
index 3d2fad2539..25582bf484 100644
--- a/testsuite/tests/ghci/scripts/T4127.stdout
+++ b/testsuite/tests/ghci/scripts/T4127.stdout
@@ -1 +1 @@
-[InstanceD Nothing [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.Prim.(,)) (VarT a_0))) [ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]]
+[InstanceD Nothing Nothing [] (AppT (ConT GHC.Base.Monad) (AppT (ConT GHC.Tuple.Prim.(,)) (VarT a_0))) [ValD (VarP GHC.Base.>>=) (NormalB (VarE GHC.Err.undefined)) []]]
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
index 1f0052da51..604343c83d 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs
@@ -11,6 +11,6 @@ mkSimpleClass name = do
         TyConI (DataD [] dname [] Nothing cs _) <- reify name
         ((NormalC conname []):_) <- return cs
         ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
-        return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
+        return [InstanceD Nothing Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
             [Clause [] (NormalB (ConE conname)) []]]]
 
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
index 50e7930c2d..b039d32353 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs
@@ -13,6 +13,6 @@ mkSimpleClass name = do
         TyConI (DataD [] dname [] Nothing cs _) <- reify name
         ((NormalC conname []):_) <- return cs
         ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
-        return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
+        return [InstanceD Nothing Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
             [Clause [] (NormalB (ConE conname)) []]]]
 
diff --git a/testsuite/tests/th/T11629.hs b/testsuite/tests/th/T11629.hs
index 11373fd4cb..11ea28a5fe 100644
--- a/testsuite/tests/th/T11629.hs
+++ b/testsuite/tests/th/T11629.hs
@@ -21,8 +21,8 @@ instance E '[True, False]
 instance E '[False, True]
 
 do
-  let getType (InstanceD _ _ ty _) = ty
-      getType _                    = error "getType: only defined for InstanceD"
+  let getType (InstanceD _ _ _ ty _) = ty
+      getType _                      = error "getType: only defined for InstanceD"
 
       failMsg a ty1 ty2 = fail $ "example " ++ a
         ++ ": ty1 /= ty2, where\n ty1 = "
diff --git a/testsuite/tests/th/T14888.stderr b/testsuite/tests/th/T14888.stderr
index fe77220edc..211b3f86e1 100644
--- a/testsuite/tests/th/T14888.stderr
+++ b/testsuite/tests/th/T14888.stderr
@@ -7,4 +7,4 @@ T14888.hs:18:22-60: Splicing expression
     "class T14888.Functor' (f_0 :: * -> *)
     where {T14888.fmap' :: forall (a_1 :: *) (b_2 :: *) .
                            (a_1 -> b_2) -> f_0 a_1 -> f_0 b_2}
-instance T14888.Functor' ((->) r_3)"
+instance forall (r_3 :: *). T14888.Functor' ((->) r_3)"
diff --git a/testsuite/tests/th/T1835.stdout b/testsuite/tests/th/T1835.stdout
index 5b21c0352c..1b87b76e3b 100644
--- a/testsuite/tests/th/T1835.stdout
+++ b/testsuite/tests/th/T1835.stdout
@@ -1,8 +1,8 @@
 class GHC.Classes.Eq a_0 => Main.MyClass (a_0 :: *)
 instance Main.MyClass Main.Foo
 instance Main.MyClass Main.Baz
-instance GHC.Classes.Eq a_1 => Main.MyClass (Main.Quux a_1)
-instance GHC.Classes.Ord a_2 => Main.MyClass (Main.Quux2 a_2)
+instance forall (a_1 :: *). GHC.Classes.Eq a_1 => Main.MyClass (Main.Quux a_1)
+instance forall (a_2 :: *). GHC.Classes.Ord a_2 => Main.MyClass (Main.Quux2 a_2)
 True
 True
 True
diff --git a/testsuite/tests/th/T21794.hs b/testsuite/tests/th/T21794.hs
new file mode 100644
index 0000000000..5b342df00d
--- /dev/null
+++ b/testsuite/tests/th/T21794.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T21794 where
+
+import Data.Kind
+$([d|
+        data P = L | R
+        data T (a :: P) where
+                A :: T a
+                B :: T R
+
+        type TConstraint = forall a . T a -> Constraint
+
+        type ForAllA1 :: TConstraint -> Constraint
+        class (forall a . constr @a A) => ForAllA1 constr
+        instance forall (constr :: TConstraint) . (forall a . constr @a A) => ForAllA1 constr
+
+        type ForAllA2 :: TConstraint -> Constraint
+        class (forall a . constr @a A) => ForAllA2 constr
+        deriving anyclass instance forall (constr :: TConstraint) . (forall a . constr @a A) => ForAllA2 constr
+
+   |])
+
+
+$([d|
+        type C :: forall {k} {l}. k -> l -> Constraint
+        class C a b
+
+        instance forall k (a :: k) (b :: Type). C a k
+   |])
\ No newline at end of file
diff --git a/testsuite/tests/th/T21794.stderr b/testsuite/tests/th/T21794.stderr
new file mode 100644
index 0000000000..4dddefab08
--- /dev/null
+++ b/testsuite/tests/th/T21794.stderr
@@ -0,0 +1,46 @@
+T21794.hs:(19,2)-(35,6): Splicing declarations
+    [d| type ForAllA1 :: TConstraint -> Constraint
+        type ForAllA2 :: TConstraint -> Constraint
+        
+        data P = L | R
+        data T (a :: P)
+          where
+            A :: T a
+            B :: T R
+        type TConstraint = forall a. T a -> Constraint
+        class (forall a. constr @a A) => ForAllA1 constr
+        class (forall a. constr @a A) => ForAllA2 constr
+        
+        instance forall (constr :: TConstraint). (forall a. constr @a A) =>
+                                                 ForAllA1 constr
+        
+        deriving anyclass instance forall (constr :: TConstraint). (forall a.
+                                                                    constr @a A) =>
+                                                                   ForAllA2 constr |]
+  ======>
+    data P = L | R
+    data T (a :: P)
+      where
+        A :: T a
+        B :: T 'R
+    type TConstraint = forall a. T a -> Constraint
+    type ForAllA1 :: TConstraint -> Constraint
+    class (forall a. constr @a 'A) => ForAllA1 constr
+    instance forall (constr :: TConstraint). (forall a.
+                                              constr @a 'A) =>
+                                             ForAllA1 constr
+    type ForAllA2 :: TConstraint -> Constraint
+    class (forall a. constr @a 'A) => ForAllA2 constr
+    deriving anyclass instance forall (constr :: TConstraint). (forall a.
+                                                                constr @a 'A) =>
+                                                               ForAllA2 constr
+T21794.hs:(38,2)-(43,6): Splicing declarations
+    [d| type C :: forall {k} {l}. k -> l -> Constraint
+        
+        class C a b
+        
+        instance forall k (a :: k) (b :: Type). C a k |]
+  ======>
+    type C :: forall {k} {l}. k -> l -> Constraint
+    class C a b
+    instance forall k (a :: k) (b :: Type). C a k
diff --git a/testsuite/tests/th/T5452.hs b/testsuite/tests/th/T5452.hs
index c1de6e8642..86f01f37bd 100644
--- a/testsuite/tests/th/T5452.hs
+++ b/testsuite/tests/th/T5452.hs
@@ -11,8 +11,8 @@ class D (f :: Type -> Type)
 instance C ((,) Int)
 
 $(do { ClassI _ [inst_dec] <- reify ''C
-     ; let InstanceD o cxt (AppT _ ty) _ = inst_dec
-     ; return [InstanceD o cxt
+     ; let InstanceD o tvs cxt (AppT _ ty) _ = inst_dec
+     ; return [InstanceD o tvs cxt
                          (foldl AppT (ConT ''D) [ty]) 
                          []
               ] })
diff --git a/testsuite/tests/th/T5700a.hs b/testsuite/tests/th/T5700a.hs
index 39d39b16a1..d35b56e76c 100644
--- a/testsuite/tests/th/T5700a.hs
+++ b/testsuite/tests/th/T5700a.hs
@@ -8,8 +8,8 @@ class C a where
 
 mkC :: Name -> Q [Dec]
 mkC n = return
-  [InstanceD Nothing [] (AppT (ConT ''C) (ConT n))
+  [InstanceD Nothing Nothing [] (AppT (ConT ''C) (ConT n))
     [ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []],
-      PragmaD (InlineP 'inlinable Inline FunLike AllPhases)    
-    ] 
+      PragmaD (InlineP 'inlinable Inline FunLike AllPhases)
+    ]
   ]
diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs
index 66992014f9..29f3d2f90a 100644
--- a/testsuite/tests/th/T5886a.hs
+++ b/testsuite/tests/th/T5886a.hs
@@ -11,5 +11,5 @@ class C α where
   type AT α ∷ Type
 
 bang ∷ DecsQ
-bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
+bang = return [InstanceD Nothing Nothing [] (AppT (ConT ''C) (ConT ''Int))
                 [TySynInstD (TySynEqn Nothing (AppT (ConT ''AT) (ConT ''Int)) (ConT ''Int))]]
diff --git a/testsuite/tests/th/T7064.stdout b/testsuite/tests/th/T7064.stdout
index b5f8c47103..17dd4f8dfb 100644
--- a/testsuite/tests/th/T7064.stdout
+++ b/testsuite/tests/th/T7064.stdout
@@ -19,8 +19,8 @@ instance GHC.Classes.Eq a_0 => GHC.Classes.Eq (T_1 a_0)
     GHC.Real.fromIntegral
     = GHC.Base.id :: a_0 -> a_0 #-}
 {-# RULES "rule2" [1]
-    forall (x_0 :: a_1) . GHC.Real.fromIntegral x_0
+    forall (x_0 :: a_1). GHC.Real.fromIntegral x_0
     = x_0 #-}
 {-# RULES "rule3" [~1]
-    forall (x_0 :: a_1) . GHC.Real.fromIntegral x_0
+    forall (x_0 :: a_1). GHC.Real.fromIntegral x_0
     = x_0 #-}
diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs
index d28a59e87c..eccd0a95a9 100644
--- a/testsuite/tests/th/T7532a.hs
+++ b/testsuite/tests/th/T7532a.hs
@@ -10,6 +10,6 @@ class C a where
 
 bang' :: DecsQ
 bang' = return [
-     InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
+     InstanceD Nothing Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
          DataInstD [] Nothing (AppT (ConT ''D) (ConT ''Int)) Nothing [
              NormalC (mkName "T") []] []]]
diff --git a/testsuite/tests/th/T8100.hs b/testsuite/tests/th/T8100.hs
index 3551251299..2925007f56 100644
--- a/testsuite/tests/th/T8100.hs
+++ b/testsuite/tests/th/T8100.hs
@@ -9,8 +9,8 @@ data Bar = Bar Int
 
 $( do decs <- [d| deriving instance Eq a => Eq (Foo a)
                   deriving instance Ord a => Ord (Foo a) |]
-      return ( StandaloneDerivD Nothing [] (ConT ''Eq `AppT` ConT ''Bar)
-             : StandaloneDerivD Nothing [] (ConT ''Ord `AppT` ConT ''Bar)
+      return ( StandaloneDerivD Nothing Nothing [] (ConT ''Eq `AppT` ConT ''Bar)
+             : StandaloneDerivD Nothing Nothing [] (ConT ''Ord `AppT` ConT ''Bar)
              : decs ) )
 
 blah :: Ord a => Foo a -> Foo a -> Ordering
diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout
index 13e058d15c..f6c1db5013 100644
--- a/testsuite/tests/th/T8625.stdout
+++ b/testsuite/tests/th/T8625.stdout
@@ -1,2 +1,2 @@
-[InstanceD Nothing [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
+[InstanceD Nothing Nothing [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
 [SigD f_4 (ForallT [] [AppT (AppT EqualityT (VarT y_2)) (AppT (AppT ArrowT (VarT t_3)) (VarT t_3))] (AppT (AppT ArrowT (VarT y_2)) (VarT t_3))),FunD f_4 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr
index 0817e4b7a6..9c2bd1604f 100644
--- a/testsuite/tests/th/T8761.stderr
+++ b/testsuite/tests/th/T8761.stderr
@@ -124,8 +124,8 @@ T8761.hs:(71,1)-(105,39): Splicing declarations
 pattern T8761.P :: GHC.Types.Bool
 pattern T8761.Pe :: () => forall (a_0 :: *) . a_0 -> T8761.Ex
 pattern T8761.Pu :: forall (a_0 :: *) . a_0 -> a_0
-pattern T8761.Pue :: forall (a_0 :: *) . () => forall (b_1 :: *) .
-                                               a_0 -> b_1 -> (a_0, T8761.Ex)
+pattern T8761.Pue :: forall (a_0 :: *). () => forall (b_1 :: *) .
+                                              a_0 -> b_1 -> (a_0, T8761.Ex)
 pattern T8761.Pur :: forall (a_0 :: *) . (GHC.Num.Num a_0,
                                           GHC.Classes.Eq a_0) =>
                      a_0 -> [a_0]
@@ -141,10 +141,10 @@ pattern T8761.Purep :: forall (a_0 :: *) . (GHC.Num.Num a_0,
                        a_0 -> b_1 -> ([a_0], T8761.ExProv)
 pattern T8761.Pep :: () => forall (a_0 :: *) . GHC.Show.Show a_0 =>
                            a_0 -> T8761.ExProv
-pattern T8761.Pup :: forall (a_0 :: *) . () => GHC.Show.Show a_0 =>
-                                               a_0 -> T8761.UnivProv a_0
-pattern T8761.Puep :: forall (a_0 :: *) . () => forall (b_1 :: *) . GHC.Show.Show b_1 =>
-                                                a_0 -> b_1 -> (T8761.ExProv, a_0)
+pattern T8761.Pup :: forall (a_0 :: *). () => GHC.Show.Show a_0 =>
+                                              a_0 -> T8761.UnivProv a_0
+pattern T8761.Puep :: forall (a_0 :: *). () => forall (b_1 :: *) . GHC.Show.Show b_1 =>
+                                               a_0 -> b_1 -> (T8761.ExProv, a_0)
 T8761.hs:(108,1)-(117,25): Splicing declarations
     do infos <- mapM
                   reify
diff --git a/testsuite/tests/th/T8953.stderr b/testsuite/tests/th/T8953.stderr
index ba19e035b9..e95917763b 100644
--- a/testsuite/tests/th/T8953.stderr
+++ b/testsuite/tests/th/T8953.stderr
@@ -9,8 +9,10 @@ T8953.a :: Data.Proxy.Proxy (Data.Proxy.Proxy :: * -> *)
 T8953.b :: Data.Proxy.Proxy (Data.Proxy.Proxy :: (* -> *) -> *)
 type T8953.StarProxy (a_0 :: *) = Data.Proxy.Proxy a_0
 class T8953.PC (a_0 :: k_1)
-instance T8953.PC (Data.Proxy.Proxy :: (k_2 -> *) -> *)
-instance T8953.PC (a_3 :: *)
+instance forall (k_2 :: *). T8953.PC (Data.Proxy.Proxy :: (k_2 ->
+                                                           *) ->
+                                                          *)
+instance forall (a_3 :: *). T8953.PC (a_3 :: *)
 type family T8953.F (a_0 :: *) :: k_1
 type instance T8953.F GHC.Types.Char = T8953.G (T8953.T1 :: * ->
                                                             (* -> *) -> *)
diff --git a/testsuite/tests/th/T9262.stderr b/testsuite/tests/th/T9262.stderr
index 8a18eadb2a..391c9720f0 100644
--- a/testsuite/tests/th/T9262.stderr
+++ b/testsuite/tests/th/T9262.stderr
@@ -1 +1 @@
-instance GHC.Classes.Eq a_0 => GHC.Classes.Eq [a_0]
+instance forall (a_0 :: *). GHC.Classes.Eq a_0 => GHC.Classes.Eq [a_0]
diff --git a/testsuite/tests/th/TH_ExplicitForAllRules.stdout b/testsuite/tests/th/TH_ExplicitForAllRules.stdout
index 635fce750e..754641e9d7 100644
--- a/testsuite/tests/th/TH_ExplicitForAllRules.stdout
+++ b/testsuite/tests/th/TH_ExplicitForAllRules.stdout
@@ -1,3 +1,3 @@
 {-# RULES "example"
-    forall a_0 . forall (x_1 :: a_0) . GHC.Base.id x_1
-    = x_1 #-}
\ No newline at end of file
+    forall a_0. forall (x_1 :: a_0). GHC.Base.id x_1
+    = x_1 #-}
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
index 0fe28a5676..8488b9af81 100644
--- a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
+++ b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
@@ -3,7 +3,7 @@ data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a
     = TH_reifyExplicitForAllFams.MkF a_1
 class TH_reifyExplicitForAllFams.C (a_0 :: *)
     where {type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *}
-instance TH_reifyExplicitForAllFams.C [a_2]
+instance forall (a_2 :: *). TH_reifyExplicitForAllFams.C [a_2]
 type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
 type instance forall (a_2 :: *)
                      (b_3 :: *). TH_reifyExplicitForAllFams.G [a_2]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 971fb39056..947e1067c7 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -556,4 +556,5 @@ test('T21920', normal, compile_and_run, [''])
 test('T21723', normal, compile_and_run, [''])
 test('T21942', normal, compile_and_run, [''])
 test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T21794', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_fun_par', normal, compile, [''])
diff --git a/utils/haddock b/utils/haddock
-Subproject 519a95998b09a2c9c7a42c3a0cf2ca0c4358bb4
+Subproject b50bc29c190ca0f6ca35a6fcbd1657b0d28753c