diff options
author | romes <rodrigo.m.mesquita@gmail.com> | 2022-06-14 00:14:16 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-07-06 13:50:27 -0400 |
commit | 371c5ecf6898294f4e5bf91784dc794e7e16b7cc (patch) | |
tree | 85ff46ffd1af9b075d3291780058791167d3f32e | |
parent | acc1816b9153f134a3308d13b90d67bfcb123d87 (diff) | |
download | haskell-371c5ecf6898294f4e5bf91784dc794e7e16b7cc.tar.gz |
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
-rw-r--r-- | compiler/GHC/Hs/Instances.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Rename/HsType.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 2 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Extension.hs | 7 | ||||
-rw-r--r-- | 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 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 |