summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorZubin Duggal <zubin@cmi.ac.in>2020-01-08 16:28:28 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-07-25 00:44:30 -0400
commit02133353e712e98bfbbc6ed32305b137bb3654eb (patch)
tree12909a607dd2910501813fc4d0550913ade367be
parentba205046e4f2ea94b1c978c050b917de4daaf092 (diff)
downloadhaskell-02133353e712e98bfbbc6ed32305b137bb3654eb.tar.gz
Simplify XRec definition
Change `Located X` usage to `XRec pass X` This increases the scope of the LPat experiment to almost all of GHC. Introduce UnXRec and MapXRec classes Fixes #17587 and #18408 Updates haddock submodule Co-authored-by: Philipp Krüger <philipp.krueger1@gmail.com>
Diffstat
-rw-r--r--compiler/GHC/Hs/Binds.hs98
-rw-r--r--compiler/GHC/Hs/Decls.hs128
-rw-r--r--compiler/GHC/Hs/Expr.hs44
-rw-r--r--compiler/GHC/Hs/Expr.hs-boot5
-rw-r--r--compiler/GHC/Hs/Extension.hs57
-rw-r--r--compiler/GHC/Hs/ImpExp.hs14
-rw-r--r--compiler/GHC/Hs/Instances.hs8
-rw-r--r--compiler/GHC/Hs/Pat.hs14
-rw-r--r--compiler/GHC/Hs/Pat.hs-boot2
-rw-r--r--compiler/GHC/Hs/Type.hs80
-rw-r--r--compiler/GHC/Hs/Utils.hs78
-rw-r--r--compiler/GHC/HsToCore/Docs.hs40
-rw-r--r--compiler/GHC/HsToCore/Expr.hs1
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs108
-rw-r--r--compiler/GHC/Parser/PostProcess.hs2
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs20
-rw-r--r--compiler/GHC/Rename/Expr.hs3
-rw-r--r--compiler/GHC/Rename/Module.hs12
-rw-r--r--compiler/GHC/Rename/Names.hs5
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs12
-rw-r--r--ghc/GHCi/UI.hs6
-rw-r--r--ghc/GHCi/UI/Info.hs1
-rw-r--r--testsuite/tests/pmcheck/should_compile/pmc009.hs2
m---------utils/haddock0
24 files changed, 403 insertions, 337 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 08eb6d80b3..07b561ce08 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -20,6 +20,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
module GHC.Hs.Binds where
@@ -68,7 +69,7 @@ Global bindings (where clauses)
type HsLocalBinds id = HsLocalBindsLR id id
-- | Located Haskell local bindings
-type LHsLocalBinds id = Located (HsLocalBinds id)
+type LHsLocalBinds id = XRec id (HsLocalBinds id)
-- | Haskell Local Bindings with separate Left and Right identifier types
--
@@ -101,7 +102,7 @@ type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField
type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField
type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon
-type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
+type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR)
-- | Haskell Value Bindings
@@ -156,7 +157,7 @@ type HsBind id = HsBindLR id id
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
-- | Located Haskell Binding with separate Left and Right identifier types
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
+type LHsBindLR idL idR = XRec idL (HsBindLR idL idR)
{- Note [FunBind vs PatBind]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -240,7 +241,7 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
- fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr
+ fun_id :: XRec idL (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
@@ -371,8 +372,8 @@ type instance XXABExport (GhcPass p) = NoExtCon
data PatSynBind idL idR
= PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs.
-- See Note [Bind free vars]
- psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
- psb_args :: HsPatSynDetails (Located (IdP idR)),
+ psb_id :: XRec idL (IdP idL), -- ^ Name of the pattern synonym
+ psb_args :: HsPatSynDetails (XRec idR (IdP idR)),
-- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
@@ -692,10 +693,10 @@ emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsIn = ValBinds noExtField emptyBag []
emptyValBindsOut = XValBindsLR (NValBinds [] [])
-emptyLHsBinds :: LHsBindsLR idL idR
+emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR
emptyLHsBinds = emptyBag
-isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
+isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool
isEmptyLHsBinds = isEmptyBag
------------
@@ -822,7 +823,7 @@ isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
-- | Located Implicit Parameter Binding
-type LIPBind id = Located (IPBind id)
+type LIPBind id = XRec id (IPBind id)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a
-- list
@@ -841,7 +842,7 @@ type LIPBind id = Located (IPBind id)
data IPBind id
= IPBind
(XCIPBind id)
- (Either (Located HsIPName) (IdP id))
+ (Either (XRec id HsIPName) (IdP id))
(LHsExpr id)
| XIPBind !(XXIPBind id)
@@ -873,7 +874,7 @@ serves for both.
-}
-- | Located Signature
-type LSig pass = Located (Sig pass)
+type LSig pass = XRec pass (Sig pass)
-- | Signatures and pragmas
data Sig pass
@@ -895,7 +896,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
TypeSig
(XTypeSig pass)
- [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
+ [XRec pass (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
(LHsSigWcType pass) -- RHS of the signature; can have wildcards
-- | A pattern synonym type signature
@@ -907,7 +908,7 @@ data Sig pass
-- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
- | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)
+ | PatSynSig (XPatSynSig pass) [XRec pass (IdP pass)] (LHsSigType pass)
-- P :: forall a b. Req => Prov => ty
-- | A signature for a class method
@@ -920,7 +921,7 @@ data Sig pass
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',
-- 'GHC.Parser.Annotation.AnnDcolon'
- | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)
+ | ClassOpSig (XClassOpSig pass) Bool [XRec pass (IdP pass)] (LHsSigType pass)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
@@ -952,7 +953,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| InlineSig (XInlineSig pass)
- (Located (IdP pass)) -- Function name
+ (XRec pass (IdP pass)) -- Function name
InlinePragma -- Never defaultInlinePragma
-- | A specialisation pragma
@@ -968,7 +969,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| SpecSig (XSpecSig pass)
- (Located (IdP pass)) -- Specialise a function or datatype ...
+ (XRec pass (IdP pass)) -- Specialise a function or datatype ...
[LHsSigType pass] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
@@ -998,7 +999,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| MinimalSig (XMinimalSig pass)
- SourceText (LBooleanFormula (Located (IdP pass)))
+ SourceText (LBooleanFormula (XRec pass (IdP pass)))
-- Note [Pragma source text] in GHC.Types.Basic
-- | A "set cost centre" pragma for declarations
@@ -1010,9 +1011,9 @@ data Sig pass
-- > {-# SCC funName "cost_centre_name" #-}
| SCCFunSig (XSCCFunSig pass)
- SourceText -- Note [Pragma source text] in GHC.Types.Basic
- (Located (IdP pass)) -- Function name
- (Maybe (Located StringLiteral))
+ SourceText -- Note [Pragma source text] in GHC.Types.Basic
+ (XRec pass (IdP pass)) -- Function name
+ (Maybe (XRec pass StringLiteral))
-- | A complete match pragma
--
-- > {-# COMPLETE C, D [:: T] #-}
@@ -1022,8 +1023,8 @@ data Sig pass
-- synonym definitions.
| CompleteMatchSig (XCompleteMatchSig pass)
SourceText
- (Located [Located (IdP pass)])
- (Maybe (Located (IdP pass)))
+ (XRec pass [XRec pass (IdP pass)])
+ (Maybe (XRec pass (IdP pass)))
| XSig !(XXSig pass)
type instance XTypeSig (GhcPass p) = NoExtField
@@ -1040,10 +1041,10 @@ type instance XCompleteMatchSig (GhcPass p) = NoExtField
type instance XXSig (GhcPass p) = NoExtCon
-- | Located Fixity Signature
-type LFixitySig pass = Located (FixitySig pass)
+type LFixitySig pass = XRec pass (FixitySig pass)
-- | Fixity Signature
-data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
+data FixitySig pass = FixitySig (XFixitySig pass) [XRec pass (IdP pass)] Fixity
| XFixitySig !(XXFixitySig pass)
type instance XFixitySig (GhcPass p) = NoExtField
@@ -1082,48 +1083,47 @@ isDefaultMethod :: TcSpecPrags -> Bool
isDefaultMethod IsDefaultMethod = True
isDefaultMethod (SpecPrags {}) = False
-
-isFixityLSig :: LSig name -> Bool
-isFixityLSig (L _ (FixSig {})) = True
+isFixityLSig :: forall p. UnXRec p => LSig p -> Bool
+isFixityLSig (unXRec @p -> FixSig {}) = True
isFixityLSig _ = False
-isTypeLSig :: LSig name -> Bool -- Type signatures
-isTypeLSig (L _(TypeSig {})) = True
-isTypeLSig (L _(ClassOpSig {})) = True
-isTypeLSig (L _(IdSig {})) = True
+isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures
+isTypeLSig (unXRec @p -> TypeSig {}) = True
+isTypeLSig (unXRec @p -> ClassOpSig {}) = True
+isTypeLSig (unXRec @p -> IdSig {}) = True
isTypeLSig _ = False
-isSpecLSig :: LSig name -> Bool
-isSpecLSig (L _(SpecSig {})) = True
+isSpecLSig :: forall p. UnXRec p => LSig p -> Bool
+isSpecLSig (unXRec @p -> SpecSig {}) = True
isSpecLSig _ = False
-isSpecInstLSig :: LSig name -> Bool
-isSpecInstLSig (L _ (SpecInstSig {})) = True
+isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool
+isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True
isSpecInstLSig _ = False
-isPragLSig :: LSig name -> Bool
+isPragLSig :: forall p. UnXRec p => LSig p -> Bool
-- Identifies pragmas
-isPragLSig (L _ (SpecSig {})) = True
-isPragLSig (L _ (InlineSig {})) = True
-isPragLSig (L _ (SCCFunSig {})) = True
-isPragLSig (L _ (CompleteMatchSig {})) = True
+isPragLSig (unXRec @p -> SpecSig {}) = True
+isPragLSig (unXRec @p -> InlineSig {}) = True
+isPragLSig (unXRec @p -> SCCFunSig {}) = True
+isPragLSig (unXRec @p -> CompleteMatchSig {}) = True
isPragLSig _ = False
-isInlineLSig :: LSig name -> Bool
+isInlineLSig :: forall p. UnXRec p => LSig p -> Bool
-- Identifies inline pragmas
-isInlineLSig (L _ (InlineSig {})) = True
+isInlineLSig (unXRec @p -> InlineSig {}) = True
isInlineLSig _ = False
-isMinimalLSig :: LSig name -> Bool
-isMinimalLSig (L _ (MinimalSig {})) = True
-isMinimalLSig _ = False
+isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool
+isMinimalLSig (unXRec @p -> MinimalSig {}) = True
+isMinimalLSig _ = False
-isSCCFunSig :: LSig name -> Bool
-isSCCFunSig (L _ (SCCFunSig {})) = True
+isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool
+isSCCFunSig (unXRec @p -> SCCFunSig {}) = True
isSCCFunSig _ = False
-isCompleteMatchSig :: LSig name -> Bool
-isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
+isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool
+isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True
isCompleteMatchSig _ = False
hsSigDoc :: Sig name -> SDoc
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 9759225109..4dea3983a5 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -133,7 +133,7 @@ import Data.Data hiding (TyCon,Fixity, Infix)
************************************************************************
-}
-type LHsDecl p = Located (HsDecl p)
+type LHsDecl p = XRec p (HsDecl p)
-- ^ When in a list this may have
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
@@ -411,13 +411,13 @@ instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
-- | Located Splice Declaration
-type LSpliceDecl pass = Located (SpliceDecl pass)
+type LSpliceDecl pass = XRec pass (SpliceDecl pass)
-- | Splice Declaration
data SpliceDecl p
= SpliceDecl -- Top level splice
(XSpliceDecl p)
- (Located (HsSplice p))
+ (XRec p (HsSplice p))
SpliceExplicitFlag
| XSpliceDecl !(XXSpliceDecl p)
@@ -568,7 +568,7 @@ Interface file code:
-}
-- | Located Declaration of a Type or Class
-type LTyClDecl pass = Located (TyClDecl pass)
+type LTyClDecl pass = XRec pass (TyClDecl pass)
-- | A type or class declaration.
data TyClDecl pass
@@ -592,7 +592,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
- , tcdLName :: Located (IdP pass) -- ^ Type constructor
+ , tcdLName :: XRec pass (IdP pass) -- ^ Type constructor
, tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
-- associated type these
-- include outer binders
@@ -609,16 +609,16 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs
- , tcdLName :: Located (IdP pass) -- ^ Type constructor
+ , tcdLName :: XRec pass (IdP pass) -- ^ Type constructor
, tcdTyVars :: LHsQTyVars pass -- ^ Type variables
-- See Note [TyVar binders for associated declarations]
, tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
, tcdDataDefn :: HsDataDefn pass }
- | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs
- tcdCtxt :: LHsContext pass, -- ^ Context...
- tcdLName :: Located (IdP pass), -- ^ Name of the class
- tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
+ | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs
+ tcdCtxt :: LHsContext pass, -- ^ Context...
+ tcdLName :: XRec pass (IdP pass), -- ^ Name of the class
+ tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
tcdFDs :: [LHsFunDep pass], -- ^ Functional deps
tcdSigs :: [LSig pass], -- ^ Methods' signatures
@@ -637,7 +637,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| XTyClDecl !(XXTyClDecl pass)
-type LHsFunDep pass = Located (FunDep (Located (IdP pass)))
+type LHsFunDep pass = XRec pass (FunDep (XRec pass (IdP pass)))
data DataDeclRn = DataDeclRn
{ tcdDataCusk :: Bool -- ^ does this have a CUSK?
@@ -764,6 +764,8 @@ tyClDeclLName (SynDecl { tcdLName = ln }) = ln
tyClDeclLName (DataDecl { tcdLName = ln }) = ln
tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
+-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it
+-- needs to be polymorphic in the pass
tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName = unLoc . tyClDeclLName
@@ -1095,7 +1097,7 @@ See also Note [Injective type families] in GHC.Core.TyCon
-}
-- | Located type Family Result Signature
-type LFamilyResultSig pass = Located (FamilyResultSig pass)
+type LFamilyResultSig pass = XRec pass (FamilyResultSig pass)
-- | type Family Result Signature
data FamilyResultSig pass = -- see Note [FamilyResultSig]
@@ -1127,13 +1129,13 @@ type instance XXFamilyResultSig (GhcPass _) = NoExtCon
-- | Located type Family Declaration
-type LFamilyDecl pass = Located (FamilyDecl pass)
+type LFamilyDecl pass = XRec pass (FamilyDecl pass)
-- | type Family Declaration
data FamilyDecl pass = FamilyDecl
{ fdExt :: XCFamilyDecl pass
, fdInfo :: FamilyInfo pass -- type/data, closed/open
- , fdLName :: Located (IdP pass) -- type constructor
+ , fdLName :: XRec pass (IdP pass) -- type constructor
, fdTyVars :: LHsQTyVars pass -- type variables
-- See Note [TyVar binders for associated declarations]
, fdFixity :: LexicalFixity -- Fixity used in the declaration
@@ -1155,7 +1157,7 @@ type instance XXFamilyDecl (GhcPass _) = NoExtCon
-- | Located Injectivity Annotation
-type LInjectivityAnn pass = Located (InjectivityAnn pass)
+type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)
-- | If the user supplied an injectivity annotation it is represented using
-- InjectivityAnn. At the moment this is a single injectivity condition - see
@@ -1166,7 +1168,7 @@ type LInjectivityAnn pass = Located (InjectivityAnn pass)
--
-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
data InjectivityAnn pass
- = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)]
+ = InjectivityAnn (XRec pass (IdP pass)) [XRec pass (IdP pass)]
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :
-- 'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar'
@@ -1267,7 +1269,7 @@ data HsDataDefn pass -- The payload of a data type defn
HsDataDefn { dd_ext :: XCHsDataDefn pass,
dd_ND :: NewOrData,
dd_ctxt :: LHsContext pass, -- ^ Context
- dd_cType :: Maybe (Located CType),
+ dd_cType :: Maybe (XRec pass CType),
dd_kindSig:: Maybe (LHsKind pass),
-- ^ Optional kind signature.
--
@@ -1295,7 +1297,7 @@ type instance XCHsDataDefn (GhcPass _) = NoExtField
type instance XXHsDataDefn (GhcPass _) = NoExtCon
-- | Haskell Deriving clause
-type HsDeriving pass = Located [LHsDerivingClause pass]
+type HsDeriving pass = XRec pass [LHsDerivingClause pass]
-- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is
-- plural because one can specify multiple deriving clauses using the
-- @-XDerivingStrategies@ language extension.
@@ -1304,7 +1306,7 @@ type HsDeriving pass = Located [LHsDerivingClause pass]
-- requested to derive, in order. If no deriving clauses were specified,
-- the list is empty.
-type LHsDerivingClause pass = Located (HsDerivingClause pass)
+type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)
-- | A single @deriving@ clause of a data declaration.
--
@@ -1319,7 +1321,7 @@ data HsDerivingClause pass
, deriv_clause_strategy :: Maybe (LDerivStrategy pass)
-- ^ The user-specified strategy (if any) to use when deriving
-- 'deriv_clause_tys'.
- , deriv_clause_tys :: Located [LHsSigType pass]
+ , deriv_clause_tys :: XRec pass [LHsSigType pass]
-- ^ The types to derive.
--
-- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
@@ -1358,11 +1360,11 @@ instance OutputableBndrId p
_ -> (ppDerivStrategy dcs, empty)
-- | Located Standalone Kind Signature
-type LStandaloneKindSig pass = Located (StandaloneKindSig pass)
+type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
data StandaloneKindSig pass
= StandaloneKindSig (XStandaloneKindSig pass)
- (Located (IdP pass)) -- Why a single binder? See #16754
+ (XRec pass (IdP pass)) -- Why a single binder? See #16754
(LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]
| XStandaloneKindSig !(XXStandaloneKindSig pass)
@@ -1399,7 +1401,7 @@ newOrDataToFlavour DataType = DataTypeFlavour
-- | Located data Constructor Declaration
-type LConDecl pass = Located (ConDecl pass)
+type LConDecl pass = XRec pass (ConDecl pass)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when
-- in a GADT constructor list
@@ -1433,13 +1435,13 @@ type LConDecl pass = Located (ConDecl pass)
data ConDecl pass
= ConDeclGADT
{ con_g_ext :: XConDeclGADT pass
- , con_names :: [Located (IdP pass)]
+ , con_names :: [XRec pass (IdP pass)]
-- The next four fields describe the type after the '::'
-- See Note [GADT abstract syntax]
-- The following field is Located to anchor API Annotations,
-- AnnForall and AnnDot.
- , con_forall :: Located Bool -- ^ True <=> explicit forall
+ , con_forall :: XRec pass Bool -- ^ True <=> explicit forall
-- False => hsq_explicit is empty
, con_qvars :: [LHsTyVarBndr Specificity pass]
-- Whether or not there is an /explicit/ forall, we still
@@ -1455,9 +1457,9 @@ data ConDecl pass
| ConDeclH98
{ con_ext :: XConDeclH98 pass
- , con_name :: Located (IdP pass)
+ , con_name :: XRec pass (IdP pass)
- , con_forall :: Located Bool
+ , con_forall :: XRec pass Bool
-- ^ True <=> explicit user-written forall
-- e.g. data T a = forall b. MkT b (b->a)
-- con_ex_tvs = {b}
@@ -1607,7 +1609,7 @@ or contexts in two parts:
-- | Haskell data Constructor Declaration Details
type HsConDeclDetails pass
- = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass])
+ = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
getConNames :: ConDecl GhcRn -> [Located Name]
getConNames ConDeclH98 {con_name = name} = [name]
@@ -1616,7 +1618,7 @@ getConNames ConDeclGADT {con_names = names} = names
getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn
getConArgs d = con_args d
-hsConDeclArgTys :: HsConDeclDetails pass -> [HsScaled pass (LBangType pass)]
+hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)
@@ -1627,7 +1629,7 @@ hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc
-- unrestricted). By the transfer property, projections are then correct in
-- that all the non-projected fields have multiplicity Many, and can be dropped.
-hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
+hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
@@ -1773,7 +1775,7 @@ free-standing `type instance` declaration.
----------------- Type synonym family instances -------------
-- | Located Type Family Instance Equation
-type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
+type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
-- when in a list
@@ -1825,10 +1827,10 @@ type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
type TyFamDefltDecl = TyFamInstDecl
-- | Located type family default declarations.
-type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass)
+type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass)
-- | Located Type Family Instance Declaration
-type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
+type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
-- | Type Family Instance Declaration
newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
@@ -1841,7 +1843,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
----------------- Data family instances -------------
-- | Located Data Family Instance Declaration
-type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
+type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)
-- | Data Family Instance Declaration
newtype DataFamInstDecl pass
@@ -1858,7 +1860,7 @@ newtype DataFamInstDecl pass
----------------- Family instances (common types) -------------
-- | Located Family Instance Equation
-type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
+type LFamInstEqn pass rhs = XRec pass (FamInstEqn pass rhs)
-- | Family Instance Equation
type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)
@@ -1874,7 +1876,7 @@ type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)
data FamEqn pass rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass rhs
- , feqn_tycon :: Located (IdP pass)
+ , feqn_tycon :: XRec pass (IdP pass)
, feqn_bndrs :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars
, feqn_pats :: HsTyPats pass
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
@@ -1892,7 +1894,7 @@ type instance XXFamEqn (GhcPass _) r = NoExtCon
----------------- Class instances -------------
-- | Located Class Instance Declaration
-type LClsInstDecl pass = Located (ClsInstDecl pass)
+type LClsInstDecl pass = XRec pass (ClsInstDecl pass)
-- | Class Instance Declaration
data ClsInstDecl pass
@@ -1905,7 +1907,7 @@ data ClsInstDecl pass
, cid_sigs :: [LSig pass] -- User-supplied pragmatic info
, cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances
, cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances
- , cid_overlap_mode :: Maybe (Located OverlapMode)
+ , cid_overlap_mode :: Maybe (XRec pass OverlapMode)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
-- 'GHC.Parser.Annotation.AnnClose',
@@ -1925,7 +1927,7 @@ type instance XXClsInstDecl (GhcPass _) = NoExtCon
----------------- Instances of all kinds -------------
-- | Located Instance Declaration
-type LInstDecl pass = Located (InstDecl pass)
+type LInstDecl pass = XRec pass (InstDecl pass)
-- | Instance Declaration
data InstDecl pass -- Both class and family instances
@@ -2082,7 +2084,7 @@ instDeclDataFamInsts inst_decls
-}
-- | Located stand-alone 'deriving instance' declaration
-type LDerivDecl pass = Located (DerivDecl pass)
+type LDerivDecl pass = XRec pass (DerivDecl pass)
-- | Stand-alone 'deriving instance' declaration
data DerivDecl pass = DerivDecl
@@ -2100,7 +2102,7 @@ data DerivDecl pass = DerivDecl
-- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer.
, deriv_strategy :: Maybe (LDerivStrategy pass)
- , deriv_overlap_mode :: Maybe (Located OverlapMode)
+ , deriv_overlap_mode :: Maybe (XRec pass OverlapMode)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving',
-- 'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock',
-- 'GHC.Parser.Annotation.AnnAnyClass', 'Api.AnnNewtype',
@@ -2133,7 +2135,7 @@ instance OutputableBndrId p
-}
-- | A 'Located' 'DerivStrategy'.
-type LDerivStrategy pass = Located (DerivStrategy pass)
+type LDerivStrategy pass = XRec pass (DerivStrategy pass)
-- | Which technique the user explicitly requested when deriving an instance.
data DerivStrategy pass
@@ -2199,7 +2201,7 @@ syntax, and that restriction must be checked in the front end.
-}
-- | Located Default Declaration
-type LDefaultDecl pass = Located (DefaultDecl pass)
+type LDefaultDecl pass = XRec pass (DefaultDecl pass)
-- | Default Declaration
data DefaultDecl pass
@@ -2233,19 +2235,19 @@ instance OutputableBndrId p
-- has been used
-- | Located Foreign Declaration
-type LForeignDecl pass = Located (ForeignDecl pass)
+type LForeignDecl pass = XRec pass (ForeignDecl pass)
-- | Foreign Declaration
data ForeignDecl pass
= ForeignImport
{ fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty
- , fd_name :: Located (IdP pass) -- defines this name
+ , fd_name :: XRec pass (IdP pass) -- defines this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fi :: ForeignImport }
| ForeignExport
{ fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty
- , fd_name :: Located (IdP pass) -- uses this name
+ , fd_name :: XRec pass (IdP pass) -- uses this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fe :: ForeignExport }
-- ^
@@ -2370,7 +2372,7 @@ instance Outputable ForeignExport where
-}
-- | Located Rule Declarations
-type LRuleDecls pass = Located (RuleDecls pass)
+type LRuleDecls pass = XRec pass (RuleDecls pass)
-- Note [Pragma source text] in GHC.Types.Basic
-- | Rule Declarations
@@ -2383,14 +2385,14 @@ type instance XCRuleDecls (GhcPass _) = NoExtField
type instance XXRuleDecls (GhcPass _) = NoExtCon
-- | Located Rule Declaration
-type LRuleDecl pass = Located (RuleDecl pass)
+type LRuleDecl pass = XRec pass (RuleDecl pass)
-- | Rule Declaration
data RuleDecl pass
= HsRule -- Source rule
{ rd_ext :: XHsRule pass
-- ^ After renamer, free-vars from the LHS and RHS
- , rd_name :: Located (SourceText,RuleName)
+ , rd_name :: XRec pass (SourceText,RuleName)
-- ^ Note [Pragma source text] in "GHC.Types.Basic"
, rd_act :: Activation
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
@@ -2398,8 +2400,8 @@ data RuleDecl pass
, rd_tmvs :: [LRuleBndr pass]
-- ^ Forall'd term vars, before typechecking; after typechecking
-- this includes all forall'd vars
- , rd_lhs :: Located (HsExpr pass)
- , rd_rhs :: Located (HsExpr pass)
+ , rd_lhs :: XRec pass (HsExpr pass)
+ , rd_rhs :: XRec pass (HsExpr pass)
}
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' :
@@ -2419,16 +2421,16 @@ type instance XHsRule GhcTc = HsRuleRn
type instance XXRuleDecl (GhcPass _) = NoExtCon
-flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
+flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
-- | Located Rule Binder
-type LRuleBndr pass = Located (RuleBndr pass)
+type LRuleBndr pass = XRec pass (RuleBndr pass)
-- | Rule Binder
data RuleBndr pass
- = RuleBndr (XCRuleBndr pass) (Located (IdP pass))
- | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)
+ = RuleBndr (XCRuleBndr pass) (XRec pass (IdP pass))
+ | RuleBndrSig (XRuleBndrSig pass) (XRec pass (IdP pass)) (HsPatSigType pass)
| XRuleBndr !(XXRuleBndr pass)
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
@@ -2513,7 +2515,7 @@ We use exported entities for things to deprecate.
-}
-- | Located Warning Declarations
-type LWarnDecls pass = Located (WarnDecls pass)
+type LWarnDecls pass = XRec pass (WarnDecls pass)
-- Note [Pragma source text] in GHC.Types.Basic
-- | Warning pragma Declarations
@@ -2527,10 +2529,10 @@ type instance XWarnings (GhcPass _) = NoExtField
type instance XXWarnDecls (GhcPass _) = NoExtCon
-- | Located Warning pragma Declaration
-type LWarnDecl pass = Located (WarnDecl pass)
+type LWarnDecl pass = XRec pass (WarnDecl pass)
-- | Warning pragma Declaration
-data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt
+data WarnDecl pass = Warning (XWarning pass) [XRec pass (IdP pass)] WarningTxt
| XWarnDecl !(XXWarnDecl pass)
type instance XWarning (GhcPass _) = NoExtField
@@ -2558,13 +2560,13 @@ instance OutputableBndr (IdP (GhcPass p))
-}
-- | Located Annotation Declaration
-type LAnnDecl pass = Located (AnnDecl pass)
+type LAnnDecl pass = XRec pass (AnnDecl pass)
-- | Annotation Declaration
data AnnDecl pass = HsAnnotation
(XHsAnnotation pass)
SourceText -- Note [Pragma source text] in GHC.Types.Basic
- (AnnProvenance (IdP pass)) (Located (HsExpr pass))
+ (AnnProvenance (IdP pass)) (XRec pass (HsExpr pass))
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
-- 'GHC.Parser.Annotation.AnnType'
-- 'GHC.Parser.Annotation.AnnModule'
@@ -2610,15 +2612,15 @@ pprAnnProvenance (TypeAnnProvenance (L _ name))
-}
-- | Located Role Annotation Declaration
-type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)
+type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)
-- See #8185 for more info about why role annotations are
-- top-level declarations
-- | Role Annotation Declaration
data RoleAnnotDecl pass
= RoleAnnotDecl (XCRoleAnnotDecl pass)
- (Located (IdP pass)) -- type constructor
- [Located (Maybe Role)] -- optional annotations
+ (XRec pass (IdP pass)) -- type constructor
+ [XRec pass (Maybe Role)] -- optional annotations
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',
-- 'GHC.Parser.Annotation.AnnRole'
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 565065e2c2..cb1b75a725 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -74,7 +74,7 @@ import qualified Language.Haskell.TH as TH (Q)
-- * Expressions proper
-- | Located Haskell Expression
-type LHsExpr p = Located (HsExpr p)
+type LHsExpr p = XRec p (HsExpr p)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when
-- in a list
@@ -241,7 +241,7 @@ is Less Cool because
-- | A Haskell expression.
data HsExpr p
= HsVar (XVar p)
- (Located (IdP p)) -- ^ Variable
+ (XRec p (IdP p)) -- ^ Variable
-- See Note [Located RdrNames]
@@ -415,7 +415,7 @@ data HsExpr p
(HsStmtContext GhcRn) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
- (Located [ExprLStmt p]) -- "do":one or more stmts
+ (XRec p [ExprLStmt p]) -- "do":one or more stmts
-- | Syntactic list: [a,b,c,...]
--
@@ -438,7 +438,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| RecordCon
{ rcon_ext :: XRecordCon p
- , rcon_con_name :: Located (IdP p) -- The constructor name;
+ , rcon_con_name :: XRec p (IdP p) -- The constructor name;
-- not used after type checking
, rcon_flds :: HsRecordBinds p } -- The fields
@@ -861,7 +861,7 @@ type instance XXPragE (GhcPass _) = NoExtCon
-- @(,a,)@ is represented by
-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@
-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@
-type LHsTupArg id = Located (HsTupArg id)
+type LHsTupArg id = XRec id (HsTupArg id)
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -880,10 +880,9 @@ type instance XMissing GhcTc = Scaled Type
type instance XXTupArg (GhcPass _) = NoExtCon
-tupArgPresent :: LHsTupArg id -> Bool
+tupArgPresent :: LHsTupArg (GhcPass p) -> Bool
tupArgPresent (L _ (Present {})) = True
tupArgPresent (L _ (Missing {})) = False
-tupArgPresent (L _ (XTupArg {})) = False
{-
Note [Parens in HsSyn]
@@ -1415,7 +1414,7 @@ We re-use HsExpr to represent these.
-}
-- | Located Haskell Command (for arrow syntax)
-type LHsCmd id = Located (HsCmd id)
+type LHsCmd id = XRec id (HsCmd id)
-- | Haskell Command (e.g. a "statement" in an Arrow proc block)
data HsCmd id
@@ -1505,7 +1504,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| HsCmdDo (XCmdDo id) -- Type of the whole expression
- (Located [CmdLStmt id])
+ (XRec id [CmdLStmt id])
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',
-- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',
-- 'GHC.Parser.Annotation.AnnVbar',
@@ -1552,7 +1551,7 @@ argument of a command-forming operator.
-}
-- | Located Haskell Top-level Command
-type LHsCmdTop p = Located (HsCmdTop p)
+type LHsCmdTop p = XRec p (HsCmdTop p)
-- | Haskell Top-level Command
data HsCmdTop p
@@ -1708,7 +1707,7 @@ patterns in each equation.
data MatchGroup p body
= MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result
- , mg_alts :: Located [LMatch p body] -- The alternatives
+ , mg_alts :: XRec p [LMatch p body] -- The alternatives
, mg_origin :: Origin }
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
@@ -1728,7 +1727,7 @@ type instance XMG GhcTc b = MatchGroupTc
type instance XXMatchGroup (GhcPass _) b = NoExtCon
-- | Located Match
-type LMatch id body = Located (Match id body)
+type LMatch id body = XRec id (Match id body)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a
-- list
@@ -1792,12 +1791,11 @@ isInfixMatch match = case m_ctxt match of
FunRhs {mc_fixity = Infix} -> True
_ -> False
-isEmptyMatchGroup :: MatchGroup id body -> Bool
+isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
-isEmptyMatchGroup (XMatchGroup {}) = False
-- | Is there only one RHS in this list of matches?
-isSingletonMatchGroup :: [LMatch id body] -> Bool
+isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool
isSingletonMatchGroup matches
| [L _ match] <- matches
, Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
@@ -1837,7 +1835,7 @@ type instance XCGRHSs (GhcPass _) b = NoExtField
type instance XXGRHSs (GhcPass _) b = NoExtCon
-- | Located Guarded Right-Hand Side
-type LGRHS id body = Located (GRHS id body)
+type LGRHS id body = XRec id (GRHS id body)
-- | Guarded Right Hand Side.
data GRHS p body = GRHS (XCGRHS p body)
@@ -1934,10 +1932,10 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
-}
-- | Located @do@ block Statement
-type LStmt id body = Located (StmtLR id id body)
+type LStmt id body = XRec id (StmtLR id id body)
-- | Located Statement with separate Left and Right id's
-type LStmtLR idL idR body = Located (StmtLR idL idR body)
+type LStmtLR idL idR body = XRec idL (StmtLR idL idR body)
-- | @do@ block Statement
type Stmt id body = StmtLR id id body
@@ -2388,11 +2386,10 @@ Bool flag that is True when the original statement was a BodyStmt, so
that we can pretty-print it correctly.
-}
-instance (Outputable (StmtLR idL idL (LHsExpr idL)),
- Outputable (XXParStmtBlock idL idR))
- => Outputable (ParStmtBlock idL idR) where
+instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),
+ Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))
+ => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where
ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
- ppr (XParStmtBlock x) = ppr x
instance (OutputableBndrId pl, OutputableBndrId pr,
Outputable body)
@@ -2481,7 +2478,8 @@ pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
text "<-" <+>
ppr (HsDo (panic "pprStmt") ctxt (noLoc
(stmts ++
- [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
+ [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]))
+ :: HsExpr (GhcPass idL))
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot
index ccfe2cb65d..7bd7753c56 100644
--- a/compiler/GHC/Hs/Expr.hs-boot
+++ b/compiler/GHC/Hs/Expr.hs-boot
@@ -10,11 +10,10 @@
module GHC.Hs.Expr where
-import GHC.Types.SrcLoc ( Located )
import GHC.Utils.Outputable ( SDoc, Outputable )
import {-# SOURCE #-} GHC.Hs.Pat ( LPat )
import GHC.Types.Basic ( SpliceExplicitFlag(..))
-import GHC.Hs.Extension ( OutputableBndrId, GhcPass )
+import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )
import Data.Kind ( Type )
type role HsExpr nominal
@@ -32,7 +31,7 @@ type family SyntaxExpr (i :: Type)
instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
-type LHsExpr a = Located (HsExpr a)
+type LHsExpr a = XRec a (HsExpr a)
pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 61caa528e0..cb235cdf37 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -32,7 +32,7 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Var
import GHC.Utils.Outputable
-import GHC.Types.SrcLoc (Located)
+import GHC.Types.SrcLoc (Located, unLoc, noLoc)
import Data.Kind
@@ -168,9 +168,58 @@ noExtCon x = case x of {}
-- | GHC's L prefixed variants wrap their vanilla variant in this type family,
-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not
--- interested in location information can define this instance as @f p@.
-type family XRec p (f :: Type -> Type) = r | r -> p f
-type instance XRec (GhcPass p) f = Located (f (GhcPass p))
+-- interested in location information can define this as
+-- @type instance XRec NoLocated a = a@.
+-- See Note [XRec and SrcSpans in the AST]
+type family XRec p a = r | r -> a
+
+type instance XRec (GhcPass p) a = Located a
+
+{-
+Note [XRec and SrcSpans in the AST]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+XRec is meant to replace most of the uses of `Located` in the AST. It is another
+extension point meant to make it easier for non-GHC applications to reuse the
+AST for their own purposes, and not have to deal the hassle of (perhaps) useless
+SrcSpans everywhere.
+
+instead of `Located (HsExpr p)` or similar types, we will now have `XRec p
+(HsExpr p)`
+
+XRec allows annotating certain points in the AST with extra information. This
+maybe be source spans (for GHC), nothing (for TH), types (for HIE files), api
+annotations (for exactprint) or anything else.
+
+This should hopefully bring us one step closer to sharing the AST between GHC
+and TH.
+
+We use the `UnXRec`, `MapXRec` and `WrapXRec` type classes to aid us in writing
+pass-polymorphic code that deals with `XRec`s
+-}
+
+-- | We can strip off the XRec to access the underlying data.
+-- See Note [XRec and SrcSpans in the AST]
+class UnXRec p where
+ unXRec :: XRec p a -> a
+
+-- | We can map over the underlying type contained in an @XRec@ while preserving
+-- the annotation as is.
+-- See Note [XRec and SrcSpans in the AST]
+class MapXRec p where
+ mapXRec :: (a -> b) -> XRec p a -> XRec p b
+
+-- | The trivial wrapper that carries no additional information
+-- @noLoc@ for @GhcPass p@
+-- See Note [XRec and SrcSpans in the AST]
+class WrapXRec p where
+ wrapXRec :: a -> XRec p a
+
+instance UnXRec (GhcPass p) where
+ unXRec = unLoc
+instance MapXRec (GhcPass p) where
+ mapXRec = fmap
+instance WrapXRec (GhcPass p) where
+ wrapXRec = noLoc
{-
Note [NoExtCon and strict fields]
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 48534bc910..190dd63604 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -43,7 +43,7 @@ One per \tr{import} declaration in a module.
-}
-- | Located Import Declaration
-type LImportDecl pass = Located (ImportDecl pass)
+type LImportDecl pass = XRec pass (ImportDecl pass)
-- ^ When in a list this may have
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'
@@ -81,14 +81,14 @@ data ImportDecl pass
ideclExt :: XCImportDecl pass,
ideclSourceSrc :: SourceText,
-- Note [Pragma source text] in GHC.Types.Basic
- ideclName :: Located ModuleName, -- ^ Module name.
+ ideclName :: XRec pass ModuleName, -- ^ Module name.
ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier.
ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import
ideclSafe :: Bool, -- ^ True => safe import
ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.
ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)
- ideclAs :: Maybe (Located ModuleName), -- ^ as Module
- ideclHiding :: Maybe (Bool, Located [LIE pass])
+ ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module
+ ideclHiding :: Maybe (Bool, XRec pass [LIE pass])
-- ^ (True => hiding, names)
}
| XImportDecl !(XXImportDecl pass)
@@ -193,7 +193,7 @@ type LIEWrappedName name = Located (IEWrappedName name)
-- | Located Import or Export
-type LIE pass = Located (IE pass)
+type LIE pass = XRec pass (IE pass)
-- ^ When in a list this may have
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'
@@ -230,7 +230,7 @@ data IE pass
(LIEWrappedName (IdP pass))
IEWildcard
[LIEWrappedName (IdP pass)]
- [Located (FieldLbl (IdP pass))]
+ [XRec pass (FieldLbl (IdP pass))]
-- ^ Imported or exported Thing With given imported or exported
--
-- The thing is a Class/Type and the imported or exported things are
@@ -241,7 +241,7 @@ data IE pass
-- 'GHC.Parser.Annotation.AnnType'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
- | IEModuleContents (XIEModuleContents pass) (Located ModuleName)
+ | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName)
-- ^ Imported or exported module contents
--
-- (Export Only)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index d46f9d7986..1389453195 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -33,6 +33,8 @@ import GHC.Hs.Type
import GHC.Hs.Pat
import GHC.Hs.ImpExp
+import GHC.Types.SrcLoc ( Located )
+
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs-----------------------------------------
@@ -433,9 +435,9 @@ deriving instance Data thing => Data (HsScaled GhcPs thing)
deriving instance Data thing => Data (HsScaled GhcRn thing)
deriving instance Data thing => Data (HsScaled GhcTc thing)
-deriving instance Data (LHsTypeArg GhcPs)
-deriving instance Data (LHsTypeArg GhcRn)
-deriving instance Data (LHsTypeArg GhcTc)
+deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))
+deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))
+deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc)))
-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
deriving instance Data (ConDeclField GhcPs)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index adadcdbd7d..59873ac600 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -78,7 +78,7 @@ import GHC.Types.Name (Name)
-- libraries:
import Data.Data hiding (TyCon,Fixity)
-type LPat p = XRec p Pat
+type LPat p = XRec p (Pat p)
-- | Pattern
--
@@ -93,7 +93,7 @@ data Pat p
-- AZ:TODO above comment needs to be updated
| VarPat (XVarPat p)
- (Located (IdP p)) -- ^ Variable Pattern
+ (XRec p (IdP p)) -- ^ Variable Pattern
-- See Note [Located RdrNames] in GHC.Hs.Expr
| LazyPat (XLazyPat p)
@@ -103,7 +103,7 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| AsPat (XAsPat p)
- (Located (IdP p)) (LPat p) -- ^ As pattern
+ (XRec p (IdP p)) (LPat p) -- ^ As pattern
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -176,7 +176,7 @@ data Pat p
------------ Constructor patterns ---------------
| ConPat {
pat_con_ext :: XConPat p,
- pat_con :: Located (ConLikeP p),
+ pat_con :: XRec p (ConLikeP p),
pat_args :: HsConPatDetails p
}
-- ^ Constructor Pattern
@@ -212,7 +212,7 @@ data Pat p
(XNPat p) -- Overall type of pattern. Might be
-- different than the literal's type
-- if (==) or negate changes the type
- (Located (HsOverLit p)) -- ALWAYS positive
+ (XRec p (HsOverLit p)) -- ALWAYS positive
(Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
-- negative patterns, Nothing
-- otherwise
@@ -224,8 +224,8 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| NPlusKPat (XNPlusKPat p) -- Type of overall pattern
- (Located (IdP p)) -- n+k pattern
- (Located (HsOverLit p)) -- It'll always be an HsIntegral
+ (XRec p (IdP p)) -- n+k pattern
+ (XRec p (HsOverLit p)) -- It'll always be an HsIntegral
(HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat
-- NB: This could be (PostTc ...), but that induced a
-- a new hs-boot file. Not worth it.
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index 1a783e3c7e..e0849375b9 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -15,6 +15,6 @@ import Data.Kind
type role Pat nominal
data Pat (i :: Type)
-type LPat i = XRec i Pat
+type LPat i = XRec i (Pat i)
instance OutputableBndrId p => Outputable (Pat (GhcPass p))
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 6ed5566054..7e88324b8a 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -117,7 +117,7 @@ import Data.Maybe
-}
-- | Located Bang Type
-type LBangType pass = Located (BangType pass)
+type LBangType pass = XRec pass (BangType pass)
-- | Bang Type
--
@@ -127,13 +127,13 @@ type LBangType pass = Located (BangType pass)
-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
type BangType pass = HsType pass -- Bangs are in the HsType data type
-getBangType :: LHsType a -> LHsType a
+getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType (L _ (HsBangTy _ _ lty)) = lty
getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
addCLoc lty lds (HsDocTy x lty lds)
getBangType lty = lty
-getBangStrictness :: LHsType a -> HsSrcBang
+getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang
getBangStrictness (L _ (HsBangTy _ s _)) = s
getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
@@ -304,11 +304,11 @@ quantified in left-to-right order in kind signatures is nice since:
-}
-- | Located Haskell Context
-type LHsContext pass = Located (HsContext pass)
+type LHsContext pass = XRec pass (HsContext pass)
-- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
-noLHsContext :: LHsContext pass
+noLHsContext :: LHsContext (GhcPass p)
-- Use this when there is no context in the original program
-- It would really be more kosher to use a Maybe, to distinguish
-- class () => C a where ...
@@ -320,7 +320,7 @@ noLHsContext = noLoc []
type HsContext pass = [LHsType pass]
-- | Located Haskell Type
-type LHsType pass = Located (HsType pass)
+type LHsType pass = XRec pass (HsType pass)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when
-- in a list
@@ -330,7 +330,7 @@ type LHsType pass = Located (HsType pass)
type HsKind pass = HsType pass
-- | Located Haskell Kind
-type LHsKind pass = Located (HsKind pass)
+type LHsKind pass = XRec pass (HsKind pass)
-- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -362,7 +362,7 @@ type instance XHsForAllInvis (GhcPass _) = NoExtField
type instance XXHsForAllTelescope (GhcPass _) = NoExtCon
-- | Located Haskell Type Variable Binder
-type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass)
+type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)
-- See Note [HsType binders]
-- | Located Haskell Quantified Type Variables
@@ -638,13 +638,13 @@ data HsTyVarBndr flag pass
= UserTyVar -- no explicit kinding
(XUserTyVar pass)
flag
- (Located (IdP pass))
+ (XRec pass (IdP pass))
-- See Note [Located RdrNames] in GHC.Hs.Expr
| KindedTyVar
(XKindedTyVar pass)
flag
- (Located (IdP pass))
+ (XRec pass (IdP pass))
(LHsKind pass) -- The user-supplied kind signature
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
@@ -678,7 +678,7 @@ isHsKindedTyVar (KindedTyVar {}) = True
isHsKindedTyVar (XTyVarBndr {}) = False
-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
-hsTvbAllKinded :: LHsQTyVars pass -> Bool
+hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool
hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
instance NamedThing (HsTyVarBndr flag GhcRn) where
@@ -705,7 +705,7 @@ data HsType pass
| HsTyVar (XTyVar pass)
PromotionFlag -- Whether explicitly promoted,
-- for the pretty printer
- (Located (IdP pass))
+ (XRec pass (IdP pass))
-- Type variable, type constructor, or data constructor
-- see Note [Promotions (HsTyVar)]
-- See Note [Located RdrNames] in GHC.Hs.Expr
@@ -755,7 +755,7 @@ data HsType pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| HsOpTy (XOpTy pass)
- (LHsType pass) (Located (IdP pass)) (LHsType pass)
+ (LHsType pass) (XRec pass (IdP pass)) (LHsType pass)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -771,7 +771,7 @@ data HsType pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| HsIParamTy (XIParamTy pass)
- (Located HsIPName) -- (?x :: ty)
+ (XRec pass HsIPName) -- (?x :: ty)
(LHsType pass) -- Implicit parameters as they occur in
-- contexts
-- ^
@@ -1076,7 +1076,7 @@ data HsTupleSort = HsUnboxedTuple
deriving Data
-- | Located Constructor Declaration Field
-type LConDeclField pass = Located (ConDeclField pass)
+type LConDeclField pass = XRec pass (ConDeclField pass)
-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when
-- in a list
@@ -1117,8 +1117,8 @@ instance (Outputable arg, Outputable rec)
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
hsConDetailsArgs ::
- HsConDetails (LHsType a) (Located [LConDeclField a])
- -> [LHsType a]
+ HsConDetails (LHsType (GhcPass p)) (Located [LConDeclField (GhcPass p)])
+ -> [LHsType (GhcPass p)]
hsConDetailsArgs details = case details of
InfixCon a b -> [a,b]
PrefixCon xs -> xs
@@ -1275,7 +1275,7 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- type S = (F :: res_kind)
-- ^^^^^^^^
--
-hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass)
+hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))
hsTyKindSig lty =
case unLoc lty of
HsParTy _ lty' -> hsTyKindSig lty'
@@ -1283,11 +1283,11 @@ hsTyKindSig lty =
_ -> Nothing
---------------------
-ignoreParens :: LHsType pass -> LHsType pass
+ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
ignoreParens ty = ty
-isLHsForAllTy :: LHsType p -> Bool
+isLHsForAllTy :: LHsType (GhcPass p) -> Bool
isLHsForAllTy (L _ (HsForAllTy {})) = True
isLHsForAllTy _ = False
@@ -1374,7 +1374,7 @@ numVisibleArgs = count is_vis
type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.
-lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan
+lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan
lhsTypeArgSrcSpan arg = case arg of
HsValArg tm -> getLoc tm
HsTypeArg at ty -> at `combineSrcSpans` getLoc ty
@@ -1406,12 +1406,12 @@ The SrcSpan is the span of the original HsPar
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
-splitLHsPatSynTy :: LHsType pass
- -> ( [LHsTyVarBndr Specificity pass] -- universals
- , LHsContext pass -- required constraints
- , [LHsTyVarBndr Specificity pass] -- existentials
- , LHsContext pass -- provided constraints
- , LHsType pass) -- body type
+splitLHsPatSynTy :: LHsType (GhcPass p)
+ -> ( [LHsTyVarBndr Specificity (GhcPass p)] -- universals
+ , LHsContext (GhcPass p) -- required constraints
+ , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials
+ , LHsContext (GhcPass p) -- provided constraints
+ , LHsType (GhcPass p)) -- body type
splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
where
(univs, ty1) = splitLHsForAllTyInvis ty
@@ -1433,8 +1433,8 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
-splitLHsSigmaTyInvis :: LHsType pass
- -> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass)
+splitLHsSigmaTyInvis :: LHsType (GhcPass p)
+ -> ([LHsTyVarBndr Specificity (GhcPass p)], LHsContext (GhcPass p), LHsType (GhcPass p))
splitLHsSigmaTyInvis ty
| (tvs, ty1) <- splitLHsForAllTyInvis ty
, (ctxt, ty2) <- splitLHsQualTy ty1
@@ -1453,8 +1453,8 @@ splitLHsSigmaTyInvis ty
-- Unlike 'splitLHsSigmaTyInvis', this function does not look through
-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
splitLHsSigmaTyInvis_KP ::
- LHsType pass
- -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass)
+ LHsType (GhcPass pass)
+ -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsSigmaTyInvis_KP ty
| (mb_tvbs, ty1) <- splitLHsForAllTyInvis_KP ty
, (mb_ctxt, ty2) <- splitLHsQualTy_KP ty1
@@ -1475,8 +1475,8 @@ splitLHsSigmaTyInvis_KP ty
-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
-- "GHC.Hs.Decls" for why this is important.
splitLHsGADTPrefixTy ::
- LHsType pass
- -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass)
+ LHsType (GhcPass pass)
+ -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsGADTPrefixTy = splitLHsSigmaTyInvis_KP
-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
@@ -1495,7 +1495,7 @@ splitLHsGADTPrefixTy = splitLHsSigmaTyInvis_KP
-- Unlike 'splitLHsSigmaTyInvis', this function does not look through
-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
splitLHsForAllTyInvis ::
- LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsType pass)
+ LHsType (GhcPass pass) -> ([LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass))
splitLHsForAllTyInvis ty
| (mb_tvbs, body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)
= (fromMaybe [] mb_tvbs, body)
@@ -1512,7 +1512,7 @@ splitLHsForAllTyInvis ty
-- Unlike 'splitLHsForAllTyInvis', this function does not look through
-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
splitLHsForAllTyInvis_KP ::
- LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], LHsType pass)
+ LHsType (GhcPass pass) -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass))
splitLHsForAllTyInvis_KP lty@(L _ ty) =
case ty of
HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }
@@ -1526,7 +1526,7 @@ splitLHsForAllTyInvis_KP lty@(L _ ty) =
-- such as @(context => <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
-splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
+splitLHsQualTy :: LHsType (GhcPass pass) -> (LHsContext (GhcPass pass), LHsType (GhcPass pass))
splitLHsQualTy ty
| (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)
= (fromMaybe noLHsContext mb_ctxt, body)
@@ -1535,7 +1535,7 @@ splitLHsQualTy ty
--
-- Unlike 'splitLHsQualTy', this function does not look through
-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
-splitLHsQualTy_KP :: LHsType pass -> (Maybe (LHsContext pass), LHsType pass)
+splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))
= (Just ctxt, body)
splitLHsQualTy_KP body = (Nothing, body)
@@ -1671,7 +1671,7 @@ also forbids them in types involved with `deriving`:
-}
-- | Located Field Occurrence
-type LFieldOcc pass = Located (FieldOcc pass)
+type LFieldOcc pass = XRec pass (FieldOcc pass)
-- | Field Occurrence
--
@@ -2009,7 +2009,7 @@ hsTypeNeedsParens p = go_hs_ty
go_core_ty (CastTy t _) = go_core_ty t
go_core_ty (CoercionTy{}) = False
-maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc
+maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc
-- See Note [Printing promoted type constructors]
-- in GHC.Iface.Type. This code implements the same
-- logic for printing HsType
@@ -2018,7 +2018,7 @@ maybeAddSpace tys doc
, lhsTypeHasLeadingPromotionQuote ty = space <> doc
| otherwise = doc
-lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool
+lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool
lhsTypeHasLeadingPromotionQuote ty
= goL ty
where
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 3e37e7b388..1af11138b9 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -178,9 +178,9 @@ unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
-> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)]
-mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)
- => Origin -> [LMatch name (Located (body name))]
- -> MatchGroup name (Located (body name))
+mkMatchGroup :: ( XMG (GhcPass p) (Located (body (GhcPass p))) ~ NoExtField )
+ => Origin -> [Located (Match (GhcPass p) (Located (body (GhcPass p))))]
+ -> MatchGroup (GhcPass p) (Located (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = noExtField
, mg_alts = mkLocatedList matches
, mg_origin = origin }
@@ -787,9 +787,9 @@ mkPatSynBind name details lpat dir = PatSynBind noExtField psb
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
-isInfixFunBind :: HsBindLR id1 id2 -> Bool
+isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind { fun_matches = MG _ matches _ })
- = any (isInfixMatch . unLoc) (unLoc matches)
+ = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)
isInfixFunBind _ = False
@@ -942,11 +942,11 @@ collectHsBindsBinders :: CollectPass p
-> [IdP p]
collectHsBindsBinders binds = collect_binds False binds []
-collectHsBindListBinders :: CollectPass p
+collectHsBindListBinders :: forall p idR. CollectPass p
=> [LHsBindLR p idR]
-> [IdP p]
-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
-collectHsBindListBinders = foldr (collect_bind False . unLoc) []
+collectHsBindListBinders = foldr (collect_bind False . unXRec @p) []
collect_hs_val_binders :: CollectPass (GhcPass idL)
=> Bool
@@ -956,42 +956,42 @@ collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
= collect_out_binds ps binds
-collect_out_binds :: CollectPass p
+collect_out_binds :: forall p. CollectPass p
=> Bool
-> [(RecFlag, LHsBinds p)]
-> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
-collect_binds :: CollectPass p
+collect_binds :: forall p idR. CollectPass p
=> Bool
-> LHsBindsLR p idR
-> [IdP p]
-> [IdP p]
-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
-collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
+collect_binds ps binds acc = foldr (collect_bind ps . unXRec @p) acc binds
-collect_bind :: CollectPass p
+collect_bind :: forall p idR. CollectPass p
=> Bool
-> HsBindLR p idR
-> [IdP p]
-> [IdP p]
collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
-collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
+collect_bind _ (FunBind { fun_id = f }) acc = unXRec @p f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
-- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk
-collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = ps })) acc
| omitPatSyn = acc
- | otherwise = ps : acc
+ | otherwise = unXRec @p ps : acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc
-collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
+collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [XRec idL (IdP idL)]
-- ^ Used exclusively for the bindings of an instance decl which are all
-- 'FunBinds'
-collectMethodBinders binds = foldr (get . unLoc) [] binds
+collectMethodBinders binds = foldr (get . unXRec @idL) [] binds
where
get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs
@@ -1042,18 +1042,18 @@ collectPatsBinders pats = foldr collect_lpat [] pats
-------------
collect_lpat :: forall pass. (CollectPass pass)
=> LPat pass -> [IdP pass] -> [IdP pass]
-collect_lpat p bndrs = collect_pat (unLoc p) bndrs
+collect_lpat p bndrs = collect_pat (unXRec @pass p) bndrs
collect_pat :: forall p. CollectPass p
=> Pat p
-> [IdP p]
-> [IdP p]
collect_pat pat bndrs = case pat of
- (VarPat _ var) -> unLoc var : bndrs
+ (VarPat _ var) -> unXRec @p var : bndrs
(WildPat _) -> bndrs
(LazyPat _ pat) -> collect_lpat pat bndrs
(BangPat _ pat) -> collect_lpat pat bndrs
- (AsPat _ a pat) -> unLoc a : collect_lpat pat bndrs
+ (AsPat _ a pat) -> unXRec @p a : collect_lpat pat bndrs
(ViewPat _ _ pat) -> collect_lpat pat bndrs
(ParPat _ pat) -> collect_lpat pat bndrs
(ListPat _ pats) -> foldr collect_lpat bndrs pats
@@ -1063,7 +1063,7 @@ collect_pat pat bndrs = case pat of
-- See Note [Dictionary binders in ConPatOut]
(LitPat _ _) -> bndrs
(NPat {}) -> bndrs
- (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs
+ (NPlusKPat _ n _ _ _ _) -> unXRec @p n : bndrs
(SigPat _ pat _) -> collect_lpat pat bndrs
(SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
-> collect_pat pat bndrs
@@ -1076,18 +1076,15 @@ collect_pat pat bndrs = case pat of
--
-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
-- it can reuse the code in GHC for collecting binders.
-class (XRec p Pat ~ Located (Pat p)) => CollectPass p where
+class UnXRec p => CollectPass p where
collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
-instance CollectPass (GhcPass 'Parsed) where
- collectXXPat _ ext = noExtCon ext
-
-instance CollectPass (GhcPass 'Renamed) where
- collectXXPat _ ext = noExtCon ext
-
-instance CollectPass (GhcPass 'Typechecked) where
- collectXXPat _ (CoPat _ pat _) = collect_pat pat
-
+instance IsPass p => CollectPass (GhcPass p) where
+ collectXXPat _ ext =
+ case ghcPass @p of
+ GhcTc -> let CoPat _ pat _ = ext in collect_pat pat
+ GhcRn -> noExtCon ext
+ GhcPs -> noExtCon ext
{-
Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows
@@ -1174,32 +1171,33 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
-------------------
-hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
+hsForeignDeclsBinders :: forall pass. (UnXRec pass, MapXRec pass) => [LForeignDecl pass] -> [XRec pass (IdP pass)]
-- ^ See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
- = [ L decl_loc n
- | L decl_loc (ForeignImport { fd_name = L _ n })
+ = [ mapXRec @pass (const $ unXRec @pass n) fi
+ | fi@(unXRec @pass -> ForeignImport { fd_name = n })
<- foreign_decls]
-------------------
-hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- ^ Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by 'collectHsValBinders'.
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldr addPatSynSelector [] . unionManyBags $ map snd binds
-addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
+addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
- | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind
- = map (unLoc . recordPatSynSelectorId) as ++ sels
+ | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind
+ = map (unXRec @p . recordPatSynSelectorId) as ++ sels
| otherwise = sels
-getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
+getPatSynBinds :: forall id. UnXRec id
+ => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
- , L _ (PatSynBind _ psb) <- bagToList lbinds ]
+ , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]
-------------------
hsLInstDeclBinders :: IsPass p
@@ -1343,7 +1341,7 @@ lStmtsImplicits = hs_lstmts
hs_stmt (BindStmt _ pat _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
- do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
+ do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = []
hs_stmt (LastStmt {}) = []
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 7066405274..0716fe756a 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -1,5 +1,8 @@
-- | Extract docs from the renamer output so they can be serialized.
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
@@ -112,9 +115,7 @@ user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
-getMainDeclBinder :: (CollectPass (GhcPass p))
- => HsDecl (GhcPass p)
- -> [IdP (GhcPass p)]
+getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
@@ -125,13 +126,14 @@ getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ = []
-sigNameNoLoc :: Sig pass -> [IdP pass]
-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig _ n _) = [unLoc n]
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+
+sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc (SpecSig _ n _ _) = [unXRec @pass n]
+sigNameNoLoc (InlineSig _ n _) = [unXRec @pass n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns
sigNameNoLoc _ = []
-- Extract the source location where an instance is defined. This is used
@@ -302,14 +304,14 @@ ungroup group_ =
-- | Collect docs and attach them to the right declarations.
--
-- A declaration may have multiple doc strings attached to it.
-collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
-- ^ This is an example.
collectDocs = go [] Nothing
where
go docs mprev decls = case (decls, mprev) of
- ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds
- ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
- ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds
+ ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds
+ ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
+ ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds
(d : ds, Nothing) -> go docs (Just d) ds
(d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
([] , Nothing) -> []
@@ -318,8 +320,8 @@ collectDocs = go [] Nothing
finished decl docs rest = (decl, reverse docs) : rest
-- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unLoc . fst)
+filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
+filterDecls = filter (isHandled . unXRec @p . fst)
where
isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
@@ -333,12 +335,12 @@ filterDecls = filter (isHandled . unLoc . fst)
-- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses = map (first (mapLoc filterClass))
+filterClasses :: forall p doc. (UnXRec p, MapXRec p) => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
+filterClasses = map (first (mapXRec @p filterClass))
where
filterClass (TyClD x c@(ClassDecl {})) =
TyClD x $ c { tcdSigs =
- filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+ filter (liftA2 (||) (isUserSig . unXRec @p) isMinimalLSig) (tcdSigs c) }
filterClass d = d
-- | Was this signature given by the user?
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 2b959006e0..931527b57a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -102,6 +102,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
+ ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 6325b722e9..5f3e1b808f 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -390,9 +390,8 @@ getRealSpan :: SrcSpan -> Maybe Span
getRealSpan (RealSrcSpan sp _) = Just sp
getRealSpan _ = Nothing
-grhss_span :: GRHSs p body -> SrcSpan
+grhss_span :: GRHSs (GhcPass p) body -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
-grhss_span (XGRHSs _) = panic "XGRHS has no span"
bindingsOnly :: [Context Name] -> HieM [HieAST a]
bindingsOnly [] = pure []
@@ -488,8 +487,8 @@ patScopes rsp useScope patScope xs =
tvScopes
:: TyVarScope
-> Scope
- -> [LHsTyVarBndr flag a]
- -> [TVScoped (LHsTyVarBndr flag a)]
+ -> [LHsTyVarBndr flag (GhcPass a)]
+ -> [TVScoped (LHsTyVarBndr flag (GhcPass a))]
tvScopes tvScope rhsScope xs =
map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
@@ -540,11 +539,11 @@ instance HasLoc a => HasLoc [a] where
loc [] = noSrcSpan
loc xs = foldl1' combineSrcSpans $ map loc xs
-instance HasLoc a => HasLoc (FamEqn s a) where
+instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where
loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
[loc a, loc tvs, loc b, loc c]
- loc _ = noSrcSpan
+
instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
loc (HsValArg tm) = loc tm
loc (HsTypeArg _ ty) = loc ty
@@ -684,7 +683,7 @@ instance ToHie (Located HsWrapper) where
concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
_ -> pure []
-instance HiePass p => HasType (LHsBind (GhcPass p)) where
+instance HiePass p => HasType (Located (HsBind (GhcPass p))) where
getTypeNode (L spn bind) =
case hiePass @p of
HieRn -> makeNode bind spn
@@ -713,7 +712,7 @@ instance HiePass p => HasType (Located (Pat (GhcPass p))) where
-- expression's type is going to be expensive.
--
-- See #16233
-instance HiePass p => HasType (LHsExpr (GhcPass p)) where
+instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where
getTypeNode e@(L spn e') =
case hiePass @p of
HieRn -> makeNode e' spn
@@ -800,7 +799,7 @@ instance HiePass 'Renamed where
instance HiePass 'Typechecked where
hiePass = HieTc
-instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where
+instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
@@ -884,7 +883,7 @@ instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
instance ( HiePass p
, Data body
, ToHie (Located body)
- ) => ToHie (LMatch (GhcPass p) (Located body)) where
+ ) => ToHie (Located (Match (GhcPass p) (Located body))) where
toHie (L span m ) = concatM $ node : case m of
Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
[ toHie mctx
@@ -1006,7 +1005,6 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where
L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
scoped_fds = listScopes pscope fds
-
instance ToHie (TScoped (HsPatSigType GhcRn)) where
toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
@@ -1027,7 +1025,7 @@ instance ( ToHie (Located body)
instance ( ToHie (Located body)
, HiePass a
, Data body
- ) => ToHie (LGRHS (GhcPass a) (Located body)) where
+ ) => ToHie (Located (GRHS (GhcPass a) (Located body))) where
toHie (L span g) = concatM $ node : case g of
GRHS _ guards body ->
[ toHie $ listScopes (mkLScope body) guards
@@ -1038,7 +1036,7 @@ instance ( ToHie (Located body)
HieRn -> makeNode g span
HieTc -> makeNode g span
-instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
+instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
[ toHie $ C Use (L mspan var)
@@ -1176,7 +1174,7 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
]
| otherwise -> []
-instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where
+instance HiePass p => ToHie (Located (HsTupArg (GhcPass p))) where
toHie (L span arg) = concatM $ makeNode arg span : case arg of
Present _ expr ->
[ toHie expr
@@ -1186,7 +1184,7 @@ instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where
instance ( ToHie (Located body)
, Data body
, HiePass p
- ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
+ ) => ToHie (RScoped (Located (Stmt (GhcPass p) (Located body)))) where
toHie (RS scope (L span stmt)) = concatM $ node : case stmt of
LastStmt _ body _ _ ->
[ toHie body
@@ -1222,7 +1220,7 @@ instance ( ToHie (Located body)
HieTc -> makeNode stmt span
HieRn -> makeNode stmt span
-instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where
+instance HiePass p => ToHie (RScoped (Located (HsLocalBinds (GhcPass p)))) where
toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
EmptyLocalBinds _ -> []
HsIPBinds _ ipbinds -> case ipbinds of
@@ -1237,7 +1235,7 @@ instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where
valBinds
]
-instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where
+instance HiePass p => ToHie (RScoped (Located (IPBind (GhcPass p)))) where
toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of
IPBind _ (Left _) expr -> [toHie expr]
IPBind _ (Right v) expr ->
@@ -1277,13 +1275,13 @@ instance ( ToHie (RFContext (Located label))
removeDefSrcSpan :: Name -> Name
removeDefSrcSpan n = setNameLoc n noSrcSpan
-instance ToHie (RFContext (LFieldOcc GhcRn)) where
+instance ToHie (RFContext (Located (FieldOcc GhcRn))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc name _ ->
[ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
]
-instance ToHie (RFContext (LFieldOcc GhcTc)) where
+instance ToHie (RFContext (Located (FieldOcc GhcTc))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc var _ ->
let var' = setVarName var (removeDefSrcSpan $ varName var)
@@ -1324,13 +1322,13 @@ instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
toHie (RecCon rec) = toHie rec
toHie (InfixCon a b) = concatM [ toHie a, toHie b]
-instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where
+instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where
toHie (L span top) = concatM $ makeNode top span : case top of
HsCmdTop _ cmd ->
[ toHie cmd
]
-instance HiePass p => ToHie (LHsCmd (GhcPass p)) where
+instance HiePass p => ToHie (Located (HsCmd (GhcPass p))) where
toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
HsCmdArrApp _ a b _ _ ->
[ toHie a
@@ -1384,7 +1382,7 @@ instance ToHie (TyClGroup GhcRn) where
, toHie instances
]
-instance ToHie (LTyClDecl GhcRn) where
+instance ToHie (Located (TyClDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
FamDecl {tcdFam = fdecl} ->
[ toHie (L span fdecl)
@@ -1429,7 +1427,7 @@ instance ToHie (LTyClDecl GhcRn) where
rhs_scope = foldl1' combineScopes $ map mkScope
[ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
-instance ToHie (LFamilyDecl GhcRn) where
+instance ToHie (Located (FamilyDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
FamilyDecl _ info name vars _ sig inj ->
[ toHie $ C (Decl FamDec $ getRealSpan span) name
@@ -1452,7 +1450,7 @@ instance ToHie (FamilyInfo GhcRn) where
go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
toHie _ = pure []
-instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
+instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where
toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
NoSig _ ->
[]
@@ -1486,7 +1484,7 @@ instance (ToHie rhs, HasLoc rhs)
patsScope = mkScope (loc pats)
rhsScope = mkScope (loc rhs)
-instance ToHie (LInjectivityAnn GhcRn) where
+instance ToHie (Located (InjectivityAnn GhcRn)) where
toHie (L span ann) = concatM $ makeNode ann span : case ann of
InjectivityAnn lhs rhs ->
[ toHie $ C Use lhs
@@ -1501,13 +1499,13 @@ instance ToHie (HsDataDefn GhcRn) where
, toHie derivs
]
-instance ToHie (HsDeriving GhcRn) where
+instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where
toHie (L span clauses) = concatM
[ locOnly span
, toHie clauses
]
-instance ToHie (LHsDerivingClause GhcRn) where
+instance ToHie (Located (HsDerivingClause GhcRn)) where
toHie (L span cl) = concatM $ makeNode cl span : case cl of
HsDerivingClause _ strat (L ispan tys) ->
[ toHie strat
@@ -1528,7 +1526,7 @@ instance ToHie (Located OverlapMode) where
instance ToHie a => ToHie (HsScaled GhcRn a) where
toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
-instance ToHie (LConDecl GhcRn) where
+instance ToHie (Located (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
, con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
@@ -1557,14 +1555,14 @@ instance ToHie (LConDecl GhcRn) where
rhsScope = combineScopes ctxScope argsScope
ctxScope = maybe NoScope mkLScope ctx
argsScope = condecl_scope dets
- where condecl_scope :: HsConDeclDetails p -> Scope
+ where condecl_scope :: HsConDeclDetails (GhcPass p) -> Scope
condecl_scope args = case args of
PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs
InfixCon a b -> combineScopes (mkLScope (hsScaledThing a))
(mkLScope (hsScaledThing b))
RecCon x -> mkLScope x
-instance ToHie (Located [LConDeclField GhcRn]) where
+instance ToHie (Located [Located (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
[ locOnly span
, toHie decls
@@ -1588,7 +1586,7 @@ instance ( HasLoc thing
]
where span = loc a
-instance ToHie (LStandaloneKindSig GhcRn) where
+instance ToHie (Located (StandaloneKindSig GhcRn)) where
toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
instance ToHie (StandaloneKindSig GhcRn) where
@@ -1598,7 +1596,7 @@ instance ToHie (StandaloneKindSig GhcRn) where
, toHie $ TS (ResolvedScopes []) typ
]
-instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where
+instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
toHie (SC (SI styp msp) (L sp sig)) =
case hiePass @p of
HieTc -> pure []
@@ -1644,10 +1642,10 @@ instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where
, toHie $ fmap (C Use) typ
]
-instance ToHie (LHsType GhcRn) where
+instance ToHie (Located (HsType GhcRn)) where
toHie x = toHie $ TS (ResolvedScopes []) x
-instance ToHie (TScoped (LHsType GhcRn)) where
+instance ToHie (TScoped (Located (HsType GhcRn))) where
toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
HsForAllTy _ tele body ->
let scope = mkScope $ getLoc body in
@@ -1731,7 +1729,7 @@ instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsTypeArg _ ty) = toHie ty
toHie (HsArgPar sp) = locOnly sp
-instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
+instance Data flag => ToHie (TVScoped (Located (HsTyVarBndr flag GhcRn))) where
toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
UserTyVar _ _ var ->
[ toHie $ C (TyVarBind sc tsc) var
@@ -1750,13 +1748,13 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
varLoc = loc vars
bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
-instance ToHie (LHsContext GhcRn) where
+instance ToHie (Located [Located (HsType GhcRn)]) where
toHie (L span tys) = concatM $
[ locOnly span
, toHie tys
]
-instance ToHie (LConDeclField GhcRn) where
+instance ToHie (Located (ConDeclField GhcRn)) where
toHie (L span field) = concatM $ makeNode field span : case field of
ConDeclField _ fields typ _ ->
[ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
@@ -1779,7 +1777,7 @@ instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
, toHie c
]
-instance ToHie (LSpliceDecl GhcRn) where
+instance ToHie (Located (SpliceDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
SpliceDecl _ splice _ ->
[ toHie splice
@@ -1833,14 +1831,14 @@ instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where
GhcTc -> case x of
HsSplicedT _ -> []
-instance ToHie (LRoleAnnotDecl GhcRn) where
+instance ToHie (Located (RoleAnnotDecl GhcRn)) where
toHie (L span annot) = concatM $ makeNode annot span : case annot of
RoleAnnotDecl _ var roles ->
[ toHie $ C Use var
, concatMapM (locOnly . getLoc) roles
]
-instance ToHie (LInstDecl GhcRn) where
+instance ToHie (Located (InstDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ClsInstD _ d ->
[ toHie $ L span d
@@ -1852,7 +1850,7 @@ instance ToHie (LInstDecl GhcRn) where
[ toHie $ L span d
]
-instance ToHie (LClsInstDecl GhcRn) where
+instance ToHie (Located (ClsInstDecl GhcRn)) where
toHie (L span decl) = concatM
[ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
, toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
@@ -1864,10 +1862,10 @@ instance ToHie (LClsInstDecl GhcRn) where
, toHie $ cid_overlap_mode decl
]
-instance ToHie (LDataFamInstDecl GhcRn) where
+instance ToHie (Located (DataFamInstDecl GhcRn)) where
toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
-instance ToHie (LTyFamInstDecl GhcRn) where
+instance ToHie (Located (TyFamInstDecl GhcRn)) where
toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
instance ToHie (Context a)
@@ -1877,7 +1875,7 @@ instance ToHie (Context a)
, toHie $ C Use b
]
-instance ToHie (LDerivDecl GhcRn) where
+instance ToHie (Located (DerivDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
DerivDecl _ typ strat overlap ->
[ toHie $ TS (ResolvedScopes []) typ
@@ -1885,19 +1883,19 @@ instance ToHie (LDerivDecl GhcRn) where
, toHie overlap
]
-instance ToHie (LFixitySig GhcRn) where
+instance ToHie (Located (FixitySig GhcRn)) where
toHie (L span sig) = concatM $ makeNode sig span : case sig of
FixitySig _ vars _ ->
[ toHie $ map (C Use) vars
]
-instance ToHie (LDefaultDecl GhcRn) where
+instance ToHie (Located (DefaultDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
DefaultDecl _ typs ->
[ toHie typs
]
-instance ToHie (LForeignDecl GhcRn) where
+instance ToHie (Located (ForeignDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
[ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
@@ -1923,19 +1921,19 @@ instance ToHie ForeignExport where
, locOnly b
]
-instance ToHie (LWarnDecls GhcRn) where
+instance ToHie (Located (WarnDecls GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
Warnings _ _ warnings ->
[ toHie warnings
]
-instance ToHie (LWarnDecl GhcRn) where
+instance ToHie (Located (WarnDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
Warning _ vars _ ->
[ toHie $ map (C Use) vars
]
-instance ToHie (LAnnDecl GhcRn) where
+instance ToHie (Located (AnnDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
HsAnnotation _ _ prov expr ->
[ toHie prov
@@ -1947,13 +1945,13 @@ instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
toHie (TypeAnnProvenance a) = toHie $ C Use a
toHie ModuleAnnProvenance = pure []
-instance ToHie (LRuleDecls GhcRn) where
+instance ToHie (Located (RuleDecls GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
HsRules _ _ rules ->
[ toHie rules
]
-instance ToHie (LRuleDecl GhcRn) where
+instance ToHie (Located (RuleDecl GhcRn)) where
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNode r span
, locOnly $ getLoc rname
@@ -1967,7 +1965,7 @@ instance ToHie (LRuleDecl GhcRn) where
exprA_sc = mkLScope exprA
exprB_sc = mkLScope exprB
-instance ToHie (RScoped (LRuleBndr GhcRn)) where
+instance ToHie (RScoped (Located (RuleBndr GhcRn))) where
toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
RuleBndr _ var ->
[ toHie $ C (ValBind RegularBind sc Nothing) var
@@ -1977,7 +1975,7 @@ instance ToHie (RScoped (LRuleBndr GhcRn)) where
, toHie $ TS (ResolvedScopes [sc]) typ
]
-instance ToHie (LImportDecl GhcRn) where
+instance ToHie (Located (ImportDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
[ toHie $ IEC Import name
@@ -1992,7 +1990,7 @@ instance ToHie (LImportDecl GhcRn) where
where
c = if hiding then ImportHiding else Import
-instance ToHie (IEContext (LIE GhcRn)) where
+instance ToHie (IEContext (Located (IE GhcRn))) where
toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
IEVar _ n ->
[ toHie $ IEC c n
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 3cf5b30b06..1ceea73d88 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2529,7 +2529,7 @@ mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon con flds
= RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds }
-mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg
+mk_rec_fields :: [Located (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg
mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
, rec_dotdot = Just (L s (length fs)) }
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index e109fada55..8201aeee3c 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE RankNTypes #-}
{- | This module implements 'addHaddockToModule', which inserts Haddock
comments accumulated during parsing into the AST (#17544).
@@ -52,6 +53,7 @@ module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where
import GHC.Prelude hiding (mod)
import GHC.Hs
+
import GHC.Types.SrcLoc
import GHC.Driver.Session ( WarningFlag(..) )
import GHC.Utils.Outputable hiding ( (<>) )
@@ -301,7 +303,7 @@ instance HasHaddock (Located HsModule) where
-- import I (a, b, c) -- do not use here!
--
-- Imports cannot have documentation comments anyway.
-instance HasHaddock (Located [LIE GhcPs]) where
+instance HasHaddock (Located [Located (IE GhcPs)]) where
addHaddock (L l_exports exports) =
extendHdkA l_exports $ do
exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports
@@ -309,7 +311,7 @@ instance HasHaddock (Located [LIE GhcPs]) where
pure $ L l_exports exports'
-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
-instance HasHaddock (LIE GhcPs) where
+instance HasHaddock (Located (IE GhcPs)) where
addHaddock a = a <$ registerHdkA a
{- Add Haddock items to a list of non-Haddock items.
@@ -386,7 +388,7 @@ addHaddockInterleaveItems layout_info get_doc_item = go
let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
in hoistHdkA (inLocRange loc_range)
-instance HasHaddock (LHsDecl GhcPs) where
+instance HasHaddock (Located (HsDecl GhcPs)) where
addHaddock ldecl =
extendHdkA (getLoc ldecl) $
traverse @Located addHaddock ldecl
@@ -594,7 +596,7 @@ instance HasHaddock (HsDataDefn GhcPs) where
-- Process the deriving clauses of a data/newtype declaration.
-- Not used for standalone deriving.
-instance HasHaddock (HsDeriving GhcPs) where
+instance HasHaddock (Located [Located (HsDerivingClause GhcPs)]) where
addHaddock lderivs =
extendHdkA (getLoc lderivs) $
traverse @Located addHaddock lderivs
@@ -606,7 +608,7 @@ instance HasHaddock (HsDeriving GhcPs) where
-- deriving (Ord {- ^ Comment on Ord N -}) via Down N
--
-- Not used for standalone deriving.
-instance HasHaddock (LHsDerivingClause GhcPs) where
+instance HasHaddock (Located (HsDerivingClause GhcPs)) where
addHaddock lderiv =
extendHdkA (getLoc lderiv) $
for @Located lderiv $ \deriv ->
@@ -668,7 +670,7 @@ instance HasHaddock (LHsDerivingClause GhcPs) where
-- bool_field :: Bool } -- ^ Comment on bool_field
-- -> T
--
-instance HasHaddock (LConDecl GhcPs) where
+instance HasHaddock (Located (ConDecl GhcPs)) where
addHaddock (L l_con_decl con_decl) =
extendHdkA l_con_decl $
case con_decl of
@@ -920,10 +922,10 @@ We implement this in two steps:
instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a
-instance HasHaddock (LHsSigWcType GhcPs) where
+instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
-instance HasHaddock (LHsSigType GhcPs) where
+instance HasHaddock a => HasHaddock (HsImplicitBndrs GhcPs a) where
addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t
-- Process a type, adding documentation comments to function arguments
@@ -953,7 +955,7 @@ instance HasHaddock (LHsSigType GhcPs) where
--
-- This is achieved by simply ignoring (not registering the location of) the
-- function arrow (->).
-instance HasHaddock (LHsType GhcPs) where
+instance HasHaddock (Located (HsType GhcPs)) where
addHaddock (L l t) =
extendHdkA l $
case t of
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 6814752963..69f9d6de58 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -439,6 +439,7 @@ rnCmdArgs (arg:args)
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = wrapLocFstM rnCmdTop'
where
+ rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' (HsCmdTop _ cmd)
= do { (cmd', fvCmd) <- rnLCmd cmd
; let cmd_names = [arrAName, composeAName, firstAName] ++
@@ -1871,7 +1872,7 @@ hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat
, is_body_stmt = False}) = not (isIrrefutableHsPat pat)
hasRefutablePattern _ = False
-isLetStmt :: LStmt a b -> Bool
+isLetStmt :: LStmt (GhcPass a) b -> Bool
isLetStmt (L _ LetStmt{}) = True
isLetStmt _ = False
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index aeb94f5d10..15775b8cf2 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1717,7 +1717,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
cls_doc = ClassDeclCtx lcls
-- Does the data type declaration include a CUSK?
-data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool
+data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
{ -- See Note [Unlifted Newtypes and CUSKs], and for a broader
-- picture, see Note [Implementation of UnliftedNewtypes].
@@ -2128,7 +2128,7 @@ rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt, con_args = args
- , con_doc = mb_doc })
+ , con_doc = mb_doc, con_forall = forall })
= do { _ <- addLocM checkConName name
; new_name <- lookupLocatedTopBndrRn name
; mb_doc' <- rnMbLHsDoc mb_doc
@@ -2155,11 +2155,12 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
; return (decl { con_ext = noExtField
, con_name = new_name, con_ex_tvs = new_ex_tvs
, con_mb_cxt = new_context, con_args = new_args
- , con_doc = mb_doc' },
+ , con_doc = mb_doc'
+ , con_forall = forall }, -- Remove when #18311 is fixed
all_fvs) }}
rnConDecl decl@(ConDeclGADT { con_names = names
- , con_forall = L _ explicit_forall
+ , con_forall = forall@(L _ explicit_forall)
, con_qvars = explicit_tkvs
, con_mb_cxt = mcxt
, con_args = args
@@ -2197,7 +2198,8 @@ rnConDecl decl@(ConDeclGADT { con_names = names
; return (decl { con_g_ext = implicit_tkvs, con_names = new_names
, con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
, con_args = new_args, con_res_ty = new_res_ty
- , con_doc = mb_doc' },
+ , con_doc = mb_doc'
+ , con_forall = forall }, -- Remove when #18311 is fixed
all_fvs) } }
-- This case is only used for prefix GADT constructors generated by GHC's
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 677e695420..d339a841cc 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -385,7 +385,9 @@ rnImportDecl this_mod
warnUnqualifiedImport decl iface
let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'
- , ideclHiding = new_imp_details })
+ , ideclHiding = new_imp_details
+ , ideclName = ideclName decl
+ , ideclAs = ideclAs decl })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
@@ -1393,6 +1395,7 @@ findImportUsage imports used_gres
import_usage :: ImportMap
import_usage = mkImportMap used_gres
+ unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name])
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, used_gres, nameSetElemsStable unused_imps)
where
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 902829fb68..7a388d7263 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -6,6 +6,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Typechecking @foreign@ declarations
--
@@ -68,13 +72,13 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
-- Defines a binding
-isForeignImport :: LForeignDecl name -> Bool
-isForeignImport (L _ (ForeignImport {})) = True
+isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
+isForeignImport (unXRec @name -> ForeignImport {}) = True
isForeignImport _ = False
-- Exports a binding
-isForeignExport :: LForeignDecl name -> Bool
-isForeignExport (L _ (ForeignExport {})) = True
+isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
+isForeignExport (unXRec @name -> ForeignExport {}) = True
isForeignExport _ = False
{-
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 8e7a7485a2..7180bc71ac 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -9,6 +9,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
--
@@ -1255,7 +1256,9 @@ runStmt input step = do
mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
mk_stmt loc bind =
- let l = L loc
+ let
+ l :: a -> Located a
+ l = L loc
in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) []))))
-- | Clean up the GHCi environment after a statement has run
@@ -2797,6 +2800,7 @@ showDynFlags show_all dflags = do
text "warning settings:" $$
nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
where
+ setting :: String -> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc
setting prefix noPrefix test flag
| quiet = empty
| is_on = text prefix <> text name
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 7304c20cee..2b035e4428 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -349,6 +349,7 @@ processAllTypeCheckedModule tcm = do
getTypeLPat (L spn pat) =
pure (Just (getMaybeId pat,spn,hsPatType pat))
where
+ getMaybeId :: Pat GhcTc -> Maybe Id
getMaybeId (VarPat _ (L _ vid)) = Just vid
getMaybeId _ = Nothing
diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.hs b/testsuite/tests/pmcheck/should_compile/pmc009.hs
index 6f089b86e9..f38fe80f99 100644
--- a/testsuite/tests/pmcheck/should_compile/pmc009.hs
+++ b/testsuite/tests/pmcheck/should_compile/pmc009.hs
@@ -2,7 +2,7 @@ module HsUtils where
import GHC.Hs.Binds
import GHC.Types.SrcLoc
-addPatSynSelector:: LHsBind p -> [a]
+addPatSynSelector:: GenLocated l (HsBindLR idL idR) -> [a]
addPatSynSelector bind
| PatSynBind _ _ <- unLoc bind
= []
diff --git a/utils/haddock b/utils/haddock
-Subproject 904dce0cafe0a241dd3ef355775db47fc12f434
+Subproject 7e6628febc482b4ad451f49ad416722375d1b17
View Lorry Controller Status