diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2023-01-31 11:41:04 +0100 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2023-01-31 11:41:04 +0100 |
| commit | 5da40ae13359f4fac3dfe5ff30ac33c469b730d5 (patch) | |
| tree | c54b2fc2d32687d78ad358f36196e32a530ad68b /compiler/GHC/ThToHs.hs | |
| parent | bc038c3bd45ee99db9fba23a823a906735740200 (diff) | |
| download | haskell-wip/instd-quantifications.tar.gz | |
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
Diffstat (limited to 'compiler/GHC/ThToHs.hs')
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 21 |
1 files changed, 16 insertions, 5 deletions
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 |