TTG for HsTyLit

Add TTG parameter to `HsTyLit` to move the GHC-specific `SourceText`
fields to the extension point and out of the base AST.

Progress towards #21592

7 files changed, 39 insertions, 15 deletions

diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index ef849a17bb..a0c588413b 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -494,6 +494,11 @@ deriving instance Data (HsType GhcPs)
 deriving instance Data (HsType GhcRn)
 deriving instance Data (HsType GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (HsTyLit p)
+deriving instance Data (HsTyLit GhcPs)
+deriving instance Data (HsTyLit GhcRn)
+deriving instance Data (HsTyLit GhcTc)
+
 -- deriving instance Data (HsLinearArrowTokens p)
 deriving instance Data (HsLinearArrowTokens GhcPs)
 deriving instance Data (HsLinearArrowTokens GhcRn)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 73709e2849..73c7652dec 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -339,6 +339,12 @@ type instance XWildCardTy      (GhcPass _) = NoExtField
 type instance XXType         (GhcPass _) = HsCoreTy
 
 
+type instance XNumTy         (GhcPass _) = SourceText
+type instance XStrTy         (GhcPass _) = SourceText
+type instance XCharTy        (GhcPass _) = SourceText
+type instance XXTyLit        (GhcPass _) = DataConCantHappen
+
+
 oneDataConHsTy :: HsType GhcRn
 oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)
 
@@ -991,7 +997,8 @@ instance (OutputableBndrId p)
     ppr (HsPS { hsps_body = ty }) = ppr ty
 
 
-instance Outputable HsTyLit where
+instance (OutputableBndrId p)
+       => Outputable (HsTyLit (GhcPass p)) where
     ppr = ppr_tylit
 
 instance Outputable HsIPName where
@@ -1020,7 +1027,7 @@ instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (Ge
   pprPrefixOcc = pprPrefixOcc . unLoc
 
 
-ppr_tylit :: HsTyLit -> SDoc
+ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc
 ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)
 ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))
 ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 5ba188cbd8..a77ca82c7d 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1429,7 +1429,7 @@ repTy (HsIParamTy _ n t) = do
 
 repTy ty                      = notHandled (ThExoticFormOfType ty)
 
-repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
+repTyLit :: HsTyLit (GhcPass p) -> MetaM (Core (M TH.TyLit))
 repTyLit (HsNumTy _ i) = do
                          platform <- getPlatform
                          rep2 numTyLitName [mkIntegerExpr platform i]
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index eacfe233dc..ca83adcd01 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -703,12 +703,13 @@ rnHsTyKi env sumTy@(HsSumTy x tys)
        ; return (HsSumTy x tys', fvs) }
 
 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi env tyLit@(HsTyLit _ t)
+rnHsTyKi env tyLit@(HsTyLit src t)
   = do { data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env tyLit))
        ; when (negLit t) (addErr negLitErr)
-       ; return (HsTyLit noExtField t, emptyFVs) }
+       ; return (HsTyLit src (rnHsTyLit t), emptyFVs) }
   where
+    negLit :: HsTyLit (GhcPass p) -> Bool
     negLit (HsStrTy _ _) = False
     negLit (HsNumTy _ i) = i < 0
     negLit (HsCharTy _ _) = False
@@ -779,6 +780,13 @@ rnHsTyKi env (HsWildCardTy _)
   = do { checkAnonWildCard env
        ; return (HsWildCardTy noExtField, emptyFVs) }
 
+
+rnHsTyLit :: HsTyLit GhcPs -> HsTyLit GhcRn
+rnHsTyLit (HsStrTy x s) = HsStrTy x s
+rnHsTyLit (HsNumTy x i) = HsNumTy x i
+rnHsTyLit (HsCharTy x c) = HsCharTy x c
+
+
 rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
 rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)
 rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 52861159d5..04ba20804f 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1829,7 +1829,7 @@ split_ty_app ty = go ty []
     go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
     go f as           = return (f,as)
 
-cvtTyLit :: TH.TyLit -> HsTyLit
+cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p)
 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 74cdbb07e0..7bc4685194 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -662,6 +662,13 @@ type family XWildCardTy      x
 type family XXType           x
 
 -- ---------------------------------------------------------------------
+-- HsTyLit type families
+type family XNumTy           x
+type family XStrTy           x
+type family XCharTy          x
+type family XXTyLit          x
+
+-- ---------------------------------------------------------------------
 -- HsForAllTelescope type families
 type family XHsForAllVis        x
 type family XHsForAllInvis      x
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index 9bd8aa90e2..8d3ed8b4dc 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -63,7 +63,6 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice )
 import Language.Haskell.Syntax.Extension
 import Language.Haskell.Syntax.Basic
 
-import GHC.Types.SourceText
 import GHC.Types.Name.Reader ( RdrName )
 import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),
                          SrcStrictness(..), SrcUnpackedness(..) )
@@ -885,7 +884,7 @@ data HsType pass
 
       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
 
-  | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.
+  | HsTyLit (XTyLit pass) (HsTyLit pass)      -- A promoted numeric literal.
       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None
 
       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
@@ -909,14 +908,12 @@ data HsType pass
 type HsCoreTy = Type
 
 
--- Note [Literal source text] in GHC.Types.Basic for SourceText fields in
--- the following
 -- | Haskell Type Literal
-data HsTyLit
-  = HsNumTy SourceText Integer
-  | HsStrTy SourceText FastString
-  | HsCharTy SourceText Char
-    deriving Data
+data HsTyLit pass
+  = HsNumTy  (XNumTy pass) Integer
+  | HsStrTy  (XStrTy pass) FastString
+  | HsCharTy (XCharTy pass) Char
+  | XTyLit   !(XXTyLit pass)
 
 -- | Denotes the type of arrows in the surface language
 data HsArrow pass