[Git][ghc/ghc][wip/T23536-teo] Make template-haskell a stage1 package

Teo Camarasu (@teo) gitlab at gitlab.haskell.org
Tue Mar 26 17:16:33 UTC 2024



Teo Camarasu pushed to branch wip/T23536-teo at Glasgow Haskell Compiler / GHC


Commits:
72ad09ed by Teo Camarasu at 2024-03-26T17:06:32+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. We avoid duplicating the file by using an in-tree symlink.

Resolves #23536

- - - - -


15 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/Dependencies.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-boot/GHC/LanguageExtensions.hs
- + libraries/ghc-boot/GHC/LanguageExtensions/Type.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,13 @@ 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
+                   ; void $ return ns_spec -- to avoid CPP incurred unused variable warning
+                   ; dec <- rep2 rep_fn [prec', name']
+#endif
                    ; return (loc,dec) }
        ; mapM do_one names }
 
@@ -1195,16 +1209,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 +1329,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 +2119,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 +2435,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 +2464,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 +2601,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 +2614,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 +2626,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 +2637,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 +2695,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 +2758,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 +2772,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
=====================================
@@ -157,6 +157,7 @@ import Data.IORef
 import GHC.Parser.HaddockLex (lexHsDoc)
 import GHC.Parser (parseIdentifier)
 import GHC.Rename.Doc (rnHsDoc)
+import GHC.LanguageExtensions
 
 
 
@@ -1514,10 +1515,10 @@ 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
+  qIsExtEnabled = xoptM . migrateExt
 
   qExtsEnabled =
-    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+    map unmigrateExt . 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 _ = Just ()
+#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/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/Rules/ToolArgs.hs
=====================================
@@ -158,7 +158,6 @@ toolTargets = [ binary
               -- , ghc     -- # depends on ghc library
               -- , runGhc  -- # depends on ghc library
               , ghcBoot
-              , ghcBootTh
               , ghcPlatform
               , ghcToolchain
               , ghcToolchainBin
@@ -172,7 +171,6 @@ toolTargets = [ binary
               , mtl
               , parsec
               , time
-              , templateHaskell
               , text
               , transformers
               , semaphoreCompat


=====================================
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 PackageImports #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | This module re-exports the 'Extension' type along with an orphan 'Binary'
@@ -9,9 +11,39 @@
 -- 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(..)
+  , migrateExt
+  , unmigrateExt
+  )
+  where
 
+import Prelude -- See note [Why do we import Prelude here?]
 import Data.Binary
-import GHC.LanguageExtensions.Type
+import qualified "ghc-boot-th" GHC.LanguageExtensions.Type as TH
+#if MIN_VERSION_ghc_boot_th(9,11,0)
+import "ghc-boot-th" GHC.LanguageExtensions.Type (Extension(..))
+#else
+import Text.Read (readMaybe)
+import Data.Maybe (fromMaybe)
+import GHC.LanguageExtensions.Type (Extension(..))
+#endif
 
 instance Binary Extension
+instance Read Extension
+
+migrateExt :: TH.Extension -> Extension
+unmigrateExt :: Extension -> TH.Extension
+#if MIN_VERSION_ghc_boot_th(9,11,0)
+migrateExt = id
+unmigrateExt = id
+#else
+errStr :: String
+errStr = "unsupported language extension encountered in TH while bootstrapping"
+instance Read TH.Extension
+migrateExt = fromMaybe (error errStr) . readMaybe . show
+unmigrateExt = fromMaybe (error errStr) . readMaybe. show
+#endif


=====================================
libraries/ghc-boot/GHC/LanguageExtensions/Type.hs
=====================================
@@ -0,0 +1 @@
+../../../../libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
\ No newline at end of file


=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -56,12 +56,14 @@ Library
             GHC.UniqueSubdir
             GHC.Version
 
+    other-modules:
+            GHC.LanguageExtensions.Type
+
     -- reexport modules from ghc-boot-th so that packages don't have to import
     -- both ghc-boot and ghc-boot-th. It makes the dependency graph easier to
     -- understand and to refactor.
     reexported-modules:
-              GHC.LanguageExtensions.Type
-            , GHC.ForeignSrcLang.Type
+              GHC.ForeignSrcLang.Type
             , GHC.Lexeme
 
     -- reexport platform modules from ghc-platform
@@ -81,7 +83,7 @@ Library
                    filepath   >= 1.3 && < 1.6,
                    deepseq    >= 1.4 && < 1.6,
                    ghc-platform >= 0.1,
-                   ghc-boot-th == @ProjectVersionMunged@
+                   ghc-boot-th >= 9.6 && <= @ProjectVersionMunged@
     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-th      >= 9.6 && <= @ProjectVersionMunged@,
         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/72ad09edcd4d008bb2670dd1f154a6ed04f436a4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72ad09edcd4d008bb2670dd1f154a6ed04f436a4
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/d9287b1a/attachment-0001.html>


More information about the ghc-commits mailing list