From 371c5ecf6898294f4e5bf91784dc794e7e16b7cc Mon Sep 17 00:00:00 2001
From: romes <rodrigo.m.mesquita@gmail.com>
Date: Tue, 14 Jun 2022 00:14:16 +0200
Subject: [PATCH] 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
---
compiler/GHC/Hs/Instances.hs | 5 +++++
compiler/GHC/Hs/Type.hs | 11 +++++++++--
compiler/GHC/HsToCore/Quote.hs | 2 +-
compiler/GHC/Rename/HsType.hs | 12 ++++++++++--
compiler/GHC/ThToHs.hs | 2 +-
compiler/Language/Haskell/Syntax/Extension.hs | 7 +++++++
compiler/Language/Haskell/Syntax/Type.hs | 15 ++++++---------
7 files changed, 39 insertions(+), 15 deletions(-)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index ef849a17bb0c..a0c588413b3e 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 73709e2849ae..73c7652dec6a 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 5ba188cbd852..a77ca82c7daf 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 eacfe233dce4..ca83adcd01fb 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 52861159d5b0..04ba20804f24 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 74cdbb07e097..7bc468519460 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -661,6 +661,13 @@ type family XTyLit x
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
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index 9bd8aa90e2c3..8d3ed8b4dc2e 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
--
GitLab