[Git][ghc/ghc][wip/instd-quantifications] TH: handle explicit quantification in instances

sheaf (@sheaf) gitlab at gitlab.haskell.org
Fri Jan 27 16:06:18 UTC 2023



sheaf pushed to branch wip/instd-quantifications at Glasgow Haskell Compiler / GHC


Commits:
772269ad by sheaf at 2023-01-27T17:06:13+01:00
TH: handle explicit quantification in instances

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 Specificity)`
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

- - - - -


15 changed files:

- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Var.hs
- docs/users_guide/9.8.1-notes.rst
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- + testsuite/tests/th/T21794.hs
- + testsuite/tests/th/T21794.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
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


=====================================
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 at 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
 


=====================================
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 $
+  = addHsTyVarBinds FreshNamesOnly tv_bndrs $ \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
@@ -653,7 +653,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
             -- For example, the method names should be bound to
             -- the selector Ids, not to fresh names (#5410)
             --
-            do { cxt1     <- repLContext cxt
+            do { elt_ty <- wrapName tyVarBndrSpecTyConName
+               ; tvs'' <- return $ case tv_outer of
+                             HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+                             HsOuterExplicit {} -> coreJust' (mkListTy elt_ty) tvs'
+               ; cxt1     <- repLContext cxt
                ; inst_ty1 <- repLTy inst_ty
           -- See Note [Scoped type variables in quotes]
                ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
@@ -661,22 +665,28 @@ 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
+    tv_bndrs = hsOuterTyVarBndrs tv_outer
 
 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 { cxt'     <- repLContext cxt
+  = do { dec <- repDerivStrategy strat $ \strat' ->
+                addHsTyVarBinds FreshNamesOnly tv_bndrs $ \tvs' ->
+                do { elt_ty <- wrapName tyVarBndrSpecTyConName
+                   ; tvs'' <- return $ case tv_outer of
+                                 HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+                                 HsOuterExplicit {} -> coreJust' (mkListTy elt_ty) tvs'
+                   ; 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)
+    tv_bndrs = hsOuterTyVarBndrs tv_outer
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
 repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -2566,9 +2576,10 @@ repTySyn (MkC nm) (MkC tvs) (MkC rhs)
   = rep2 tySynDName [nm, tvs, rhs]
 
 repInst :: Core (Maybe TH.Overlap) ->
+           Core (Maybe [M (TH.TyVarBndr TH.Specificity)]) ->
            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 +2636,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 TH.Specificity)])
+         -> 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))


=====================================
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


=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2470,12 +2470,13 @@ 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 <- error "TODO: Not sure what to do here" -- reifyTyVarBndrs tvs
+       ; 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 th_tvs cxt head_ty []) }
   where
      (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
      cls_tc   = classTyCon cls


=====================================
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 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 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


=====================================
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


=====================================
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 Specificity)``, 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
 ~~~~~~~~~~~~~~~~~~~~


=====================================
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 Specificity)]
+                        -> 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


=====================================
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 Specificity)] -> 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 Specificity)] -> 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.


=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -404,9 +404,14 @@ 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
+ppr_dec _ (InstanceD o tvs ctxt i ds) =
+        text "instance" <+> maybe empty ppr_overlap o <+> ppr_ty_forall tvs <+> pprCxt ctxt <+> ppr i
                                   $$ where_clause ds
+
+      where ppr_ty_forall Nothing      = empty
+            ppr_ty_forall (Just bndrs) = text "forall"
+                                         <+> fsep (map ppr bndrs)
+                                         <+> char '.'
 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,12 +457,16 @@ 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_forall tvs
          , pprCxt cxt
          , ppr ty ]
+      where ppr_forall bndrs = hsep [ text "forall"
+                                    , fsep (map ppr bndrs)
+                                    , char '.' ]
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
 ppr_dec _ (PatSynD name args dir pat)


=====================================
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 Specificity]) 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 Specificity]) Cxt Type
+       -- ^ @{ deriving stock instance forall a. Ord a => Ord (Foo a) }@
   | DefaultSigD Name Type      -- ^ @{ default size :: Data a => a -> Int }@
 
   -- | Pattern Synonyms


=====================================
testsuite/tests/th/T21794.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# 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
+
+   |])


=====================================
testsuite/tests/th/T21794.stderr
=====================================
@@ -0,0 +1,36 @@
+T21794.hs:(18,2)-(34,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


=====================================
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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/772269ad42a4cd285c06de0e21bbd17e98316b67

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/772269ad42a4cd285c06de0e21bbd17e98316b67
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230127/c673e889/attachment-0001.html>


More information about the ghc-commits mailing list