[Git][ghc/ghc][wip/T23536-teo] Make template-haskell a stage1 package
Teo Camarasu (@teo)
gitlab at gitlab.haskell.org
Tue Mar 26 10:21:18 UTC 2024
Teo Camarasu pushed to branch wip/T23536-teo at Glasgow Haskell Compiler / GHC
Commits:
ebec0964 by Teo Camarasu at 2024-03-26T10:21:02+00:00
Make template-haskell a stage1 package
We enable building stage1 ghc with the boot
version of template-haskell (and all its dependencies).
Both template-haskell and ghc-boot-th are promoted to stage1 packages.
We add CPP to the modules converting between TH and GHC ASTs
to deal with differences between TH versions.
The canonical list of language extensions lives in `ghc-boot-th`.
As this is a dependency of template-haskell, we must use the boot
version when building stage1 GHC.
In that case, we add a duplicate list of language extensions
to `ghc-boot` with the full list of language extensions for the in-tree
version of GHC.
Resolves #23536
- - - - -
14 changed files:
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/ghc.cabal.in
- hadrian/src/Rules/CabalReinstall.hs
- hadrian/src/Rules/Dependencies.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-boot/GHC/LanguageExtensions.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH/Binary.hs
- libraries/ghci/ghci.cabal.in
Changes:
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -45,7 +45,7 @@ import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List.NonEmpty (NonEmpty(..))
-import GHC.LanguageExtensions.Type
+import GHC.LanguageExtensions
import qualified GHC.Utils.Outputable as O
import GHC.Hs.Extension
import GHC.Types.Unique.Map
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -11,6 +11,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -161,6 +162,14 @@ type MetaM a = ReaderT MetaWrappers DsM a
getPlatform :: MetaM Platform
getPlatform = targetPlatform <$> getDynFlags
+#if MIN_VERSION_template_haskell(2,21,0)
+type BndrVis = TH.BndrVis
+type THArgPat = TH.ArgPat
+#else
+type THArgPat = TH.Pat
+type BndrVis = ()
+#endif
+
-----------------------------------------------------------------------------
dsBracket :: HsBracketTc -> DsM CoreExpr
-- See Note [Desugaring Brackets]
@@ -513,7 +522,7 @@ repKiSigD (L loc kisig) =
-------------------------
repDataDefn :: Core TH.Name
- -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))])
+ -> Either (Core [(M (TH.TyVarBndr BndrVis))])
-- the repTyClD case
(Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-- the repDataFamInstD case
@@ -536,7 +545,7 @@ repDataDefn tc opts
derivs1 }
}
-repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr BndrVis))]
-> LHsType GhcRn
-> MetaM (Core (M TH.Dec))
repSynDecl tc bndrs ty
@@ -789,8 +798,12 @@ rep_fix_d loc (FixitySig ns_spec names (Fixity _ prec dir))
InfixN -> infixNWithSpecDName
; let do_one name
= do { MkC name' <- lookupLOcc name
+#if MIN_VERSION_template_haskell(2,22,0)
; MkC ns_spec' <- repNamespaceSpecifier ns_spec
; dec <- rep2 rep_fn [prec', ns_spec', name']
+#else
+ ; dec <- rep2 rep_fn [prec', name']
+#endif
; return (loc,dec) }
; mapM do_one names }
@@ -1195,16 +1208,20 @@ rep_flag :: Specificity -> MetaM (Core TH.Specificity)
rep_flag SpecifiedSpec = rep2_nw specifiedSpecName []
rep_flag InferredSpec = rep2_nw inferredSpecName []
-instance RepTV (HsBndrVis GhcRn) TH.BndrVis where
+instance RepTV (HsBndrVis GhcRn) BndrVis where
tyVarBndrName = tyVarBndrVisTyConName
repPlainTV (MkC nm) vis = do { (MkC vis') <- rep_bndr_vis vis
; rep2 plainBndrTVName [nm, vis'] }
repKindedTV (MkC nm) vis (MkC ki) = do { (MkC vis') <- rep_bndr_vis vis
; rep2 kindedBndrTVName [nm, vis', ki] }
-rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis)
+rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core BndrVis)
+#if MIN_VERSION_template_haskell(2,21,0)
rep_bndr_vis (HsBndrRequired _) = rep2_nw bndrReqName []
rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName []
+#else
+rep_bndr_vis _ = rep2_nw bndrReqName []
+#endif
addHsOuterFamEqnTyVarBinds ::
HsOuterFamEqnTyVarBndrs GhcRn
@@ -1311,7 +1328,7 @@ addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside
addQTyVarBinds :: FreshOrReuse
-> LHsQTyVars GhcRn -- the binders to be added
- -> (Core [(M (TH.TyVarBndr TH.BndrVis))] -> MetaM (Core (M a))) -- action in the ext env
+ -> (Core [(M (TH.TyVarBndr BndrVis))] -> MetaM (Core (M a))) -- action in the ext env
-> MetaM (Core (M a))
addQTyVarBinds fresh_or_reuse qtvs thing_inside =
let HsQTvs { hsq_ext = imp_tvs
@@ -2101,10 +2118,10 @@ repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repLP p = repP (unLoc p)
-- Process a list of arg patterns
-repLMPs :: [LArgPat GhcRn] -> MetaM (Core ([M TH.ArgPat]))
+repLMPs :: [LArgPat GhcRn] -> MetaM (Core ([M THArgPat]))
repLMPs ps = repListM argPatTyConName repLMP ps
-repLMP :: LArgPat GhcRn -> MetaM (Core (M TH.ArgPat))
+repLMP :: LArgPat GhcRn -> MetaM (Core (M THArgPat))
repLMP (L _ (VisPat _ p)) = do {p' <- repLP p; repAPvis p'}
repLMP (L _ (InvisPat _ t)) = do {t' <- repLTy (hstp_body t); repAPinvis t'}
@@ -2417,10 +2434,10 @@ repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat))
repPtype (MkC t) = rep2 typePName [t]
-repAPvis :: Core (M TH.Pat) -> MetaM (Core (M TH.ArgPat))
+repAPvis :: Core (M TH.Pat) -> MetaM (Core (M THArgPat))
repAPvis (MkC t) = rep2 visAPName [t]
-repAPinvis :: Core (M TH.Type) -> MetaM (Core (M TH.ArgPat))
+repAPinvis :: Core (M TH.Type) -> MetaM (Core (M THArgPat))
repAPinvis (MkC t) = rep2 invisAPName [t]
--------------- Expressions -----------------
@@ -2446,7 +2463,7 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y]
repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
-repLam :: Core [(M TH.ArgPat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
+repLam :: Core [(M THArgPat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repLam (MkC ps) (MkC e) = rep2 lamArgEName [ps, e]
repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
@@ -2583,7 +2600,7 @@ repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [(M TH.ArgPat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
+repClause :: Core [(M THArgPat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseArgName [ps, bod, ds]
-------------- Dec -----------------------------
@@ -2596,7 +2613,7 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Bool -- ^ @True@ for a @type data@ declaration.
-- See Note [Type data declarations] in GHC.Rename.Module
-> Core (M TH.Cxt) -> Core TH.Name
- -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))])
+ -> Either (Core [(M (TH.TyVarBndr BndrVis))])
(Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
-> MetaM (Core (M TH.Dec))
@@ -2608,7 +2625,7 @@ repData _ (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
= rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
repNewtype :: Core (M TH.Cxt) -> Core TH.Name
- -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))])
+ -> Either (Core [(M (TH.TyVarBndr BndrVis))])
(Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
-> MetaM (Core (M TH.Dec))
@@ -2619,7 +2636,7 @@ repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
-repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr BndrVis))]
-> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
@@ -2677,14 +2694,15 @@ repOverlap mb =
nothing = coreNothing overlapTyConName
just = coreJust overlapTyConName
-
+#if MIN_VERSION_template_haskell(2,22,0)
repNamespaceSpecifier :: NamespaceSpecifier -> MetaM (Core (TH.NamespaceSpecifier))
repNamespaceSpecifier ns_spec = case ns_spec of
NoNamespaceSpecifier{} -> dataCon noNamespaceSpecifierDataConName
TypeNamespaceSpecifier{} -> dataCon typeNamespaceSpecifierDataConName
DataNamespaceSpecifier{} -> dataCon dataNamespaceSpecifierDataConName
+#endif
-repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr BndrVis))]
-> Core [TH.FunDep] -> Core [(M TH.Dec)]
-> MetaM (Core (M TH.Dec))
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
@@ -2739,13 +2757,13 @@ repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
repTySynInst (MkC eqn)
= rep2 tySynInstDName [eqn]
-repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr BndrVis))]
-> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
= rep2 dataFamilyDName [nm, tvs, kind]
repOpenFamilyD :: Core TH.Name
- -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+ -> Core [(M (TH.TyVarBndr BndrVis))]
-> Core (M TH.FamilyResultSig)
-> Core (Maybe TH.InjectivityAnn)
-> MetaM (Core (M TH.Dec))
@@ -2753,7 +2771,7 @@ repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
= rep2 openTypeFamilyDName [nm, tvs, result, inj]
repClosedFamilyD :: Core TH.Name
- -> Core [(M (TH.TyVarBndr TH.BndrVis))]
+ -> Core [(M (TH.TyVarBndr BndrVis))]
-> Core (M TH.FamilyResultSig)
-> Core (Maybe TH.InjectivityAnn)
-> Core [(M TH.TySynEqn)]
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1514,10 +1514,11 @@ instance TH.Quasi TcM where
th_state_var <- fmap tcg_th_state getGblEnv
updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
- qIsExtEnabled = xoptM
+ -- TODO: factor out toEnum/fromEnum stuff
+ qIsExtEnabled = xoptM . toEnum . fromEnum
qExtsEnabled =
- EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+ map (toEnum . fromEnum) . EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
qPutDoc doc_loc s = do
th_doc_var <- tcg_th_docs <$> getGblEnv
@@ -2002,7 +2003,9 @@ getThing th_name
ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
+#if MIN_VERSION_template_haskell(2,21,0)
ppr_ns (TH.Name _ (TH.NameG (TH.FldName {}) _pkg _mod)) = text "fld"
+#endif
ppr_ns _ = panic "reify/ppr_ns"
reify :: TH.Name -> TcM TH.Info
@@ -2674,6 +2677,14 @@ reifyCxt = mapM reifyType
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
+#if MIN_VERSION_template_haskell(2,21,0)
+type BndrVis = TH.BndrVis
+#else
+type BndrVis = ()
+deriving instance Foldable TH.TyVarBndr
+deriving instance Traversable TH.TyVarBndr
+#endif
+
class ReifyFlag flag flag' | flag -> flag' where
reifyFlag :: flag -> flag'
@@ -2684,15 +2695,19 @@ instance ReifyFlag Specificity TH.Specificity where
reifyFlag SpecifiedSpec = TH.SpecifiedSpec
reifyFlag InferredSpec = TH.InferredSpec
-instance ReifyFlag TyConBndrVis (Maybe TH.BndrVis) where
+instance ReifyFlag TyConBndrVis (Maybe BndrVis) where
+#if MIN_VERSION_template_haskell(2,21,0)
reifyFlag AnonTCB = Just TH.BndrReq
reifyFlag (NamedTCB Required) = Just TH.BndrReq
reifyFlag (NamedTCB (Invisible _)) =
Nothing -- See Note [Reifying invisible type variable binders] and #22828.
+#else
+ reifyFlag _ = Nothing
+#endif
-- Currently does not return invisible type variable binders (@k-binders).
-- See Note [Reifying invisible type variable binders] and #22828.
-reifyTyConBinders :: TyCon -> TcM [TH.TyVarBndr TH.BndrVis]
+reifyTyConBinders :: TyCon -> TcM [TH.TyVarBndr BndrVis]
reifyTyConBinders tc = fmap (mapMaybe get_bndr) (reifyTyVarBndrs (tyConBinders tc))
where
get_bndr :: TH.TyVarBndr (Maybe flag) -> Maybe (TH.TyVarBndr flag)
@@ -2801,8 +2816,10 @@ reifyName thing
mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
| OccName.isVarOcc occ = TH.mkNameG_v
| OccName.isTcOcc occ = TH.mkNameG_tc
+#if MIN_VERSION_template_haskell(2,21,0)
| Just con_fs <- OccName.fieldOcc_maybe occ
= \ pkg mod occ -> TH.mkNameG_fld pkg mod (unpackFS con_fs) occ
+#endif
| otherwise = pprPanic "reifyName" (ppr name)
reifyFieldLabel :: FieldLabel -> TH.Name
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -164,6 +165,10 @@ wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of
Left err -> Left err
Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
+#if !MIN_VERSION_template_haskell(2,21,0)
+type BndrVis = ()
+#endif
+
{-
Note [Source locations within TH splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -243,19 +248,31 @@ cvtDec (TH.KiSigD nm ki)
; let sig' = StandaloneKindSig noAnn nm' ki'
; returnJustLA $ Hs.KindSigD noExtField sig' }
-cvtDec (TH.InfixD fx th_ns_spec nm)
+cvtDec (TH.InfixD fx
+#if MIN_VERSION_template_haskell(2,22,0)
+ th_ns_spec
+#endif
+ nm)
-- Fixity signatures are allowed for variables, constructors, and types
-- the renamer automatically looks for types during renaming, even when
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameN nm
; returnJustLA (Hs.SigD noExtField (FixSig noAnn
- (FixitySig ns_spec [nm'] (cvtFixity fx)))) }
+ (FixitySig
+#if MIN_VERSION_template_haskell(2,22,0)
+ ns_spec
+#else
+ Hs.NoNamespaceSpecifier
+#endif
+ [nm'] (cvtFixity fx)))) }
where
+#if MIN_VERSION_template_haskell(2,22,0)
ns_spec = case th_ns_spec of
TH.NoNamespaceSpecifier -> Hs.NoNamespaceSpecifier
TH.TypeNamespaceSpecifier -> Hs.TypeNamespaceSpecifier noAnn
TH.DataNamespaceSpecifier -> Hs.DataNamespaceSpecifier noAnn
+#endif
cvtDec (TH.DefaultD tys)
= do { tys' <- traverse cvtType tys
@@ -469,7 +486,7 @@ cvtDec (TH.ImplicitParamBindD _ _)
= failWith InvalidImplicitParamBinding
-- Convert a @data@ declaration.
-cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
+cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr BndrVis]
-> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtDataDec = cvtGenDataDec False
@@ -477,14 +494,14 @@ cvtDataDec = cvtGenDataDec False
-- Convert a @type data@ declaration.
-- These have neither contexts nor derived clauses.
-- See Note [Type data declarations] in GHC.Rename.Module.
-cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con]
+cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr BndrVis] -> Maybe TH.Kind -> [TH.Con]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtTypeDataDec tc tvs ksig constrs
= cvtGenDataDec True [] tc tvs ksig constrs []
-- Convert a @data@ or @type data@ declaration (flagged by the Bool arg).
-- See Note [Type data declarations] in GHC.Rename.Module.
-cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
+cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr BndrVis]
-> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs
@@ -538,6 +555,20 @@ cvtDataDefnCons type_data ksig constrs
c:_ -> c
; mapM (cvtConstr first_datacon_name con_name) constrs }
+#if !MIN_VERSION_template_haskell(2,21,0)
+get_cons_names :: TH.Con -> [TH.Name]
+get_cons_names (TH.NormalC n _) = [n]
+get_cons_names (TH.RecC n _) = [n]
+get_cons_names (TH.InfixC _ n _) = [n]
+get_cons_names (TH.ForallC _ _ con) = get_cons_names con
+-- GadtC can have multiple names, e.g
+-- > data Bar a where
+-- > MkBar1, MkBar2 :: a -> Bar a
+-- Will have one GadtC with [MkBar1, MkBar2] as names
+get_cons_names (TH.GadtC ns _ _) = ns
+get_cons_names (TH.RecGadtC ns _ _) = ns
+#endif
+
----------------
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
@@ -590,7 +621,7 @@ cvt_ci_decs declDescr decs
; return (listToBag binds', sigs', fams', ats', adts') }
----------------
-cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr BndrVis]
-> CvtM ( LHsContext GhcPs
, LocatedN RdrName
, LHsQTyVars GhcPs)
@@ -954,12 +985,14 @@ cvtPragmaD (CompleteP cls mty)
; mty' <- traverse tconNameN mty
; returnJustLA $ Hs.SigD noExtField
$ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
+#if MIN_VERSION_template_haskell(2,22,0)
cvtPragmaD (SCCP nm str) = do
nm' <- vcNameN nm
str' <- traverse (\s ->
returnLA $ StringLiteral NoSourceText (mkFastString s) Nothing) str
returnJustLA $ Hs.SigD noExtField
$ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str'
+#endif
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
@@ -1165,12 +1198,17 @@ cvtl e = wrapLA (cvt e)
(L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
(L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs
+
+#if MIN_VERSION_template_haskell(2,21,0)
cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e
; return $ HsTypedSplice [] e' }
cvt (TypedBracketE e) = do { e' <- cvtl e
; return $ HsTypedBracket noAnn e' }
+#endif
+#if MIN_VERSION_template_haskell(2,22,0)
cvt (TypeE t) = do { t' <- cvtType t
; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') }
+#endif
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
@@ -1416,6 +1454,7 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
quotedSourceText :: String -> SourceText
quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\""
+#if MIN_VERSION_template_haskell(2,22,0)
cvtArgPats :: [TH.ArgPat] -> CvtM [Hs.LArgPat GhcPs]
cvtArgPats pats = mapM cvtArgPat pats
@@ -1427,6 +1466,18 @@ cvtap (VisAP pat) = do { pat' <- cvtPat pat
; pure (VisPat noExtField pat')}
cvtap (InvisAP t) = do { t' <- cvtType t
; pure (InvisPat noAnn (mkHsTyPat noAnn t'))}
+#else
+cvtArgPats :: [TH.Pat] -> CvtM [Hs.LArgPat GhcPs]
+cvtArgPats pats = mapM cvtArgPat pats
+
+cvtArgPat :: TH.Pat -> CvtM (Hs.LArgPat GhcPs)
+cvtArgPat pat = wrapLA (cvtap pat)
+
+cvtap :: TH.Pat -> CvtM (Hs.ArgPat GhcPs)
+cvtap pat = do { pat' <- cvtPat pat
+ ; pure (VisPat noExtField pat')}
+#endif
+
cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
cvtPats pats = mapM cvtPat pats
@@ -1498,8 +1549,10 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noAnn e' p'}
+#if MIN_VERSION_template_haskell(2,22,0)
cvtp (TypeP t) = do { t' <- cvtType t
; return $ EmbTyPat noAnn (mkHsTyPat noAnn t') }
+#endif
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
@@ -1533,7 +1586,7 @@ cvtOpAppP x op y
-----------------------------------------------------------
-- Types and type variables
-class CvtFlag flag flag' | flag -> flag' where
+class CvtFlag flag flag' where
cvtFlag :: flag -> flag'
instance CvtFlag () () where
@@ -1543,9 +1596,14 @@ instance CvtFlag TH.Specificity Hs.Specificity where
cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec
cvtFlag TH.InferredSpec = Hs.InferredSpec
+#if MIN_VERSION_template_haskell(2,21,0)
instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where
cvtFlag TH.BndrReq = HsBndrRequired noExtField
cvtFlag TH.BndrInvis = HsBndrInvisible noAnn
+#else
+instance CvtFlag () (HsBndrVis GhcPs) where
+ cvtFlag () = HsBndrRequired noExtField
+#endif
cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs tvs = mapM cvt_tv tvs
@@ -2212,7 +2270,9 @@ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
mk_ghc_ns TH.DataName = OccName.dataName
mk_ghc_ns TH.TcClsName = OccName.tcClsName
mk_ghc_ns TH.VarName = OccName.varName
+#if MIN_VERSION_template_haskell(2,22,0)
mk_ghc_ns (TH.FldName con) = OccName.fieldName (fsLit con)
+#endif
mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -115,7 +115,7 @@ Library
containers >= 0.6.2.1 && < 0.8,
array >= 0.1 && < 0.6,
filepath >= 1 && < 1.6,
- template-haskell == 2.22.*,
+ template-haskell >= 2.20 && < 2.23,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
=====================================
hadrian/src/Rules/CabalReinstall.hs
=====================================
@@ -25,7 +25,7 @@ The libdir of the reinstalled GHC points to the libdir of the stage 2 compiler (
-- | We don't support reinstalling these
cabalExcludedPackages :: [Package]
-cabalExcludedPackages = [array, base, deepseq, filepath, ghcBignum, ghcBootTh, ghcPrim, integerGmp, integerSimple, pretty, templateHaskell]
+cabalExcludedPackages = [array, base, deepseq, filepath, ghcBignum, ghcPrim, integerGmp, integerSimple, pretty, templateHaskell]
cabalBuildRules :: Rules ()
=====================================
hadrian/src/Rules/Dependencies.hs
=====================================
@@ -35,7 +35,10 @@ extra_dependencies =
where
th_internal = (templateHaskell, "Language.Haskell.TH.Lib.Internal")
- dep (p1, m1) (p2, m2) s = do
+ dep (p1, m1) (p2, m2) s =
+ -- We use the boot compiler's `template-haskell` library when building stage0,
+ -- so we don't need to register dependencies.
+ if isStage0 s then pure [] else do
let context = Context s p1 (error "extra_dependencies: way not set") (error "extra_dependencies: iplace not set")
ways <- interpretInContext context getLibraryWays
mapM (\way -> (,) <$> path s way p1 m1 <*> path s way p2 m2) (S.toList ways)
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -74,7 +74,7 @@ needDocDeps = do
-- logic to determine the versions of packages shipped with GHC.
let templatedCabalFiles = map pkgCabalFile
[ ghcBoot
- , ghcBootTh
+ -- , ghcBootTh
, ghci
, compiler
, ghcHeap
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -93,7 +93,6 @@ stage0Packages = do
, ghc
, runGhc
, ghcBoot
- , ghcBootTh
, ghcPlatform
, ghcHeap
, ghcToolchain
@@ -108,7 +107,6 @@ stage0Packages = do
, parsec
, semaphoreCompat
, time
- , templateHaskell
, text
, transformers
, unlit
@@ -143,6 +141,7 @@ stage1Packages = do
, deepseq
, exceptions
, ghc
+ , ghcBootTh
, ghcBignum
, ghcCompact
, ghcExperimental
@@ -156,6 +155,7 @@ stage1Packages = do
, pretty
, rts
, semaphoreCompat
+ , templateHaskell
, stm
, unlit
, xhtml
=====================================
libraries/ghc-boot/GHC/LanguageExtensions.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module re-exports the 'Extension' type along with an orphan 'Binary'
@@ -9,9 +11,161 @@
-- which has no dependencies outside of @base at . For this reason
-- @template-haskell@ depends upon @ghc-boot-th@, not @ghc-boot at .
--
-module GHC.LanguageExtensions ( module GHC.LanguageExtensions.Type ) where
+-- When building the stage1 GHC, we have a potentially old version of
+-- @ghc-boot-th@, which comes with an old list of extensions.
+-- In that case, we define the current list of extensions here, and export that.
+module GHC.LanguageExtensions
+ ( Extension(..)
+ )
+ where
+import Prelude -- See note [Why do we import Prelude here?]
import Data.Binary
+import GHC.Generics
+#if MIN_VERSION_ghc_boot_th(9,11,0)
import GHC.LanguageExtensions.Type
+#else
+
+data Extension
+-- See Note [Updating flag description in the User's Guide] in
+-- GHC.Driver.Session
+ = Cpp
+ | OverlappingInstances
+ | UndecidableInstances
+ | IncoherentInstances
+ | UndecidableSuperClasses
+ | MonomorphismRestriction
+ | MonoLocalBinds
+ | DeepSubsumption
+ | RelaxedPolyRec -- Deprecated
+ | ExtendedDefaultRules -- Use GHC's extended rules for defaulting
+ | ForeignFunctionInterface
+ | UnliftedFFITypes
+ | InterruptibleFFI
+ | CApiFFI
+ | GHCForeignImportPrim
+ | JavaScriptFFI
+ | ParallelArrays -- Syntactic support for parallel arrays
+ | Arrows -- Arrow-notation syntax
+ | TemplateHaskell
+ | TemplateHaskellQuotes -- subset of TH supported by stage1, no splice
+ | QualifiedDo
+ | QuasiQuotes
+ | ImplicitParams
+ | ImplicitPrelude
+ | ScopedTypeVariables
+ | AllowAmbiguousTypes
+ | UnboxedTuples
+ | UnboxedSums
+ | UnliftedNewtypes
+ | UnliftedDatatypes
+ | BangPatterns
+ | TypeFamilies
+ | TypeFamilyDependencies
+ | TypeInType -- Deprecated
+ | OverloadedStrings
+ | OverloadedLists
+ | NumDecimals
+ | DisambiguateRecordFields
+ | RecordWildCards
+ | NamedFieldPuns
+ | ViewPatterns
+ | GADTs
+ | GADTSyntax
+ | NPlusKPatterns
+ | DoAndIfThenElse
+ | BlockArguments
+ | RebindableSyntax
+ | ConstraintKinds
+ | PolyKinds -- Kind polymorphism
+ | DataKinds -- Datatype promotion
+ | TypeData -- allow @type data@ definitions
+ | InstanceSigs
+ | ApplicativeDo
+ | LinearTypes
+ | RequiredTypeArguments -- Visible forall (VDQ) in types of terms
+
+ | StandaloneDeriving
+ | DeriveDataTypeable
+ | AutoDeriveTypeable -- Automatic derivation of Typeable
+ | DeriveFunctor
+ | DeriveTraversable
+ | DeriveFoldable
+ | DeriveGeneric -- Allow deriving Generic/1
+ | DefaultSignatures -- Allow extra signatures for defmeths
+ | DeriveAnyClass -- Allow deriving any class
+ | DeriveLift -- Allow deriving Lift
+ | DerivingStrategies
+ | DerivingVia -- Derive through equal representation
+
+ | TypeSynonymInstances
+ | FlexibleContexts
+ | FlexibleInstances
+ | ConstrainedClassMethods
+ | MultiParamTypeClasses
+ | NullaryTypeClasses
+ | FunctionalDependencies
+ | UnicodeSyntax
+ | ExistentialQuantification
+ | MagicHash
+ | EmptyDataDecls
+ | KindSignatures
+ | RoleAnnotations
+ | ParallelListComp
+ | TransformListComp
+ | MonadComprehensions
+ | GeneralizedNewtypeDeriving
+ | RecursiveDo
+ | PostfixOperators
+ | TupleSections
+ | PatternGuards
+ | LiberalTypeSynonyms
+ | RankNTypes
+ | ImpredicativeTypes
+ | TypeOperators
+ | ExplicitNamespaces
+ | PackageImports
+ | ExplicitForAll
+ | AlternativeLayoutRule
+ | AlternativeLayoutRuleTransitional
+ | DatatypeContexts
+ | NondecreasingIndentation
+ | RelaxedLayout
+ | TraditionalRecordSyntax
+ | LambdaCase
+ | MultiWayIf
+ | BinaryLiterals
+ | NegativeLiterals
+ | HexFloatLiterals
+ | DuplicateRecordFields
+ | OverloadedLabels
+ | EmptyCase
+ | PatternSynonyms
+ | PartialTypeSignatures
+ | NamedWildCards
+ | StaticPointers
+ | TypeApplications
+ | Strict
+ | StrictData
+ | EmptyDataDeriving
+ | NumericUnderscores
+ | QuantifiedConstraints
+ | StarIsType
+ | ImportQualifiedPost
+ | CUSKs
+ | StandaloneKindSignatures
+ | LexicalNegation
+ | FieldSelectors
+ | OverloadedRecordDot
+ | OverloadedRecordUpdate
+ | TypeAbstractions
+ | ExtendedLiterals
+ | ListTuplePuns
+ deriving (Eq, Enum, Show, Generic, Bounded)
+-- 'Ord' and 'Bounded' are provided for GHC API users (see discussions
+-- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/826).
+instance Ord Extension where compare a b = compare (fromEnum a) (fromEnum b)
+#endif
instance Binary Extension
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -81,7 +81,7 @@ Library
filepath >= 1.3 && < 1.6,
deepseq >= 1.4 && < 1.6,
ghc-platform >= 0.1,
- ghc-boot-th == @ProjectVersionMunged@
+ ghc-boot-th
if !os(windows)
build-depends:
unix >= 2.7 && < 2.9
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -32,7 +32,9 @@ import GHCi.TH.Binary () -- For Binary instances
import GHCi.BreakArray
import GHCi.ResolvedBCO
-import GHC.LanguageExtensions
+-- Import the ghc-boot-th version of the extension list because when building
+-- stage1, we want to use the list bundled with `template-haskell`.
+import GHC.LanguageExtensions.Type
import qualified GHC.Exts.Heap as Heap
import GHC.ForeignSrcLang
import GHC.Fingerprint
@@ -58,6 +60,9 @@ import System.Exit
import System.IO
import System.IO.Error
+-- orphan instance
+instance Binary Extension
+
-- -----------------------------------------------------------------------------
-- The RPC protocol between GHC and the interactive server
=====================================
libraries/ghci/GHCi/TH/Binary.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
-- This module is full of orphans, unfortunately
module GHCi.TH.Binary () where
@@ -27,17 +28,23 @@ instance Binary TH.Info
instance Binary TH.Type
instance Binary TH.TyLit
instance Binary TH.Specificity
+#if MIN_VERSION_template_haskell(2,21,0)
instance Binary TH.BndrVis
+#endif
instance Binary flag => Binary (TH.TyVarBndr flag)
instance Binary TH.Role
instance Binary TH.Lit
instance Binary TH.Range
instance Binary TH.Stmt
instance Binary TH.Pat
+#if MIN_VERSION_template_haskell(2,22,0)
instance Binary TH.ArgPat
+#endif
instance Binary TH.Exp
instance Binary TH.Dec
+#if MIN_VERSION_template_haskell(2,22,0)
instance Binary TH.NamespaceSpecifier
+#endif
instance Binary TH.Overlap
instance Binary TH.DerivClause
instance Binary TH.DerivStrategy
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -83,8 +83,9 @@ library
deepseq >= 1.4 && < 1.6,
filepath >= 1.4 && < 1.6,
ghc-boot == @ProjectVersionMunged@,
+ ghc-boot ,
ghc-heap == @ProjectVersionMunged@,
- template-haskell == 2.22.*,
+ template-haskell >= 2.20 && < 2.23,
transformers >= 0.5 && < 0.7
if !os(windows)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebec09643c6d6aa5dbcc7a1d1fcd292d2d635807
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebec09643c6d6aa5dbcc7a1d1fcd292d2d635807
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/20240326/57c4ad7b/attachment-0001.html>
More information about the ghc-commits
mailing list