From d53908623bc1ca4e6390d8337533689344b74826 Mon Sep 17 00:00:00 2001
From: Hassan Al-Awwadi <hassan.awwadi@gmail.com>
Date: Thu, 10 Oct 2024 12:55:57 +0200
Subject: [PATCH] Put RdrName in the foExt field of FieldOcc
The main purpose of this commit is to rip RdrName out of FieldOcc, in
accordance with #21592, and as a side note it has simplified the method
we use to deal with ambiguity somewhat.
To do the first, we make FieldOccs store (LIdP p) instead of always
storing Located RdrName, and moved the readername to the extension
points where necessary.
For the second, well, we just turn an ambiguous RdrName into a unbound
Name through mkUnboundName. Later during disambiguateRecordBinds of the
type checking phase, we will try and do type-directed disambiguation based
on the rdrName field (for now), so this hack works out fine.
See Note [Ambiguous FieldOcc in record updates] for more details.
There are two additional minor changes in this commit:
* The HsRecSel constructor of HsExpr has been moved to the extension
constuctors, since its really GHC specific.
* HsProjection no longer has a Located DotFieldOcc as a field, but just a
regular DotFieldOcc, since DotFieldOcc already wraps a located
FieldLabelString
co-authored by: @Jade <Jade512@proton.me>
@alt-romes <rodrigo.m.mesquita@gmail.com>
(cherry picked from commit 1587cccfe7c3c1db3ccc48437b47ccb6ae215701)
---
compiler/GHC/Hs/Binds.hs | 3 +-
compiler/GHC/Hs/Expr.hs | 40 ++++--
compiler/GHC/Hs/Extension.hs | 2 +-
compiler/GHC/Hs/Instances.hs | 6 -
compiler/GHC/Hs/Pat.hs | 11 --
compiler/GHC/Hs/Syn/Type.hs | 2 +-
compiler/GHC/Hs/Type.hs | 114 +++++++++---------
compiler/GHC/Hs/Utils.hs | 8 +-
compiler/GHC/HsToCore/Docs.hs | 2 +-
compiler/GHC/HsToCore/Expr.hs | 59 +++++----
compiler/GHC/HsToCore/Quote.hs | 31 +++--
compiler/GHC/HsToCore/Ticks.hs | 3 +-
compiler/GHC/Iface/Ext/Ast.hs | 82 ++++++-------
compiler/GHC/Parser/PostProcess.hs | 6 +-
compiler/GHC/Rename/Bind.hs | 2 +-
compiler/GHC/Rename/Env.hs | 8 +-
compiler/GHC/Rename/Expr.hs | 27 ++---
compiler/GHC/Rename/Fixity.hs | 2 +-
compiler/GHC/Rename/HsType.hs | 11 +-
compiler/GHC/Rename/Pat.hs | 33 +++--
compiler/GHC/Tc/Gen/Expr.hs | 19 ++-
compiler/GHC/Tc/Gen/Head.hs | 15 ++-
compiler/GHC/Tc/Gen/Pat.hs | 10 +-
compiler/GHC/Tc/TyCl/Utils.hs | 3 +-
compiler/GHC/Tc/Types/Origin.hs | 2 +-
compiler/GHC/Tc/Zonk/Type.hs | 11 +-
compiler/GHC/ThToHs.hs | 4 +-
compiler/Language/Haskell/Syntax/Expr.hs | 6 +-
compiler/Language/Haskell/Syntax/Extension.hs | 7 --
compiler/Language/Haskell/Syntax/Pat.hs | 14 +--
compiler/Language/Haskell/Syntax/Type.hs | 31 ++---
.../tests/parser/should_compile/T14189.stderr | 6 +-
utils/check-exact/ExactPrint.hs | 24 ----
.../src/Haddock/Backends/Hoogle.hs | 2 +-
.../haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +-
.../src/Haddock/Backends/Xhtml/Decl.hs | 6 +-
.../haddock-api/src/Haddock/Convert.hs | 2 +-
.../haddock-api/src/Haddock/GhcUtils.hs | 4 +-
.../src/Haddock/Interface/Create.hs | 4 +-
.../src/Haddock/Interface/Rename.hs | 4 +-
.../haddock/haddock-api/src/Haddock/Types.hs | 4 +-
41 files changed, 293 insertions(+), 341 deletions(-)
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 72b3cb81110..6f00f0ef852 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -48,7 +48,6 @@ import GHC.Types.SourceText
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var
import GHC.Data.BooleanFormula (LBooleanFormula)
-import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Utils.Outputable
@@ -664,7 +663,7 @@ pprTicks pp_no_debug pp_when_debug
then pp_when_debug
else pp_no_debug
-instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where
+instance Outputable (XRec pass (IdP pass)) => Outputable (RecordPatSynField pass) where
ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index b2cfd2706af..08abb0b9bd2 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -554,6 +554,10 @@ data XXExprGhcRn
-- Does not presist post renaming phase
-- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
-- in `GHC.Tc.Gen.Do`
+ | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector
+ -- See Note [Non-overloaded record field selectors] and
+ -- Note [Record selectors in the AST]
+
-- | Wrap a located expression with a `PopErrCtxt`
@@ -635,6 +639,11 @@ data XXExprGhcTc
Int -- module-local tick number for False
(LHsExpr GhcTc) -- sub-expression
+ | HsRecSelTc (FieldOcc GhcTc) -- ^ Variable pointing to record selector
+ -- See Note [Non-overloaded record field selectors] and
+ -- Note [Record selectors in the AST]
+
+
-- | Build a 'XXExprGhcRn' out of an extension constructor,
-- and the two components of the expansion: original and
-- expanded typechecked expressions.
@@ -695,7 +704,6 @@ ppr_expr :: forall p. (OutputableBndrId p)
=> HsExpr (GhcPass p) -> SDoc
ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
-ppr_expr (HsRecSel _ f) = pprPrefixOcc f
ppr_expr (HsIPVar _ v) = ppr v
ppr_expr (HsOverLabel s l) = case ghcPass @p of
GhcPs -> helper s
@@ -914,11 +922,13 @@ instance Outputable HsThingRn where
OrigExpr x -> ppr_builder "<OrigExpr>:" x
OrigStmt x -> ppr_builder "<OrigStmt>:" x
OrigPat x -> ppr_builder "<OrigPat>:" x
+
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
+ ppr (HsRecSelRn f) = pprPrefixOcc f
instance Outputable XXExprGhcTc where
ppr (WrapExpr co_fn e)
@@ -947,10 +957,11 @@ instance Outputable XXExprGhcTc where
ppr tickIdFalse,
text ">(",
ppr exp, text ")"]
+ ppr (HsRecSelTc f) = pprPrefixOcc f
+
ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
-ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f)
ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
ppr_infix_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr_infix_expr_rn x
@@ -959,7 +970,8 @@ ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
-ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
+ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f)
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e
@@ -967,6 +979,8 @@ ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
ppr_infix_expr_tc (ConLikeTc {}) = Nothing
ppr_infix_expr_tc (HsTick {}) = Nothing
ppr_infix_expr_tc (HsBinTick {}) = Nothing
+ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f)
+
ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc
ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e
@@ -1053,7 +1067,6 @@ hsExprNeedsParens prec = go
go (HsProc{}) = prec > topPrec
go (HsStatic{}) = prec >= appPrec
go (RecordCon{}) = False
- go (HsRecSel{}) = False
go (HsProjection{}) = True
go (HsGetField{}) = False
go (HsEmbTy{}) = prec > topPrec
@@ -1070,10 +1083,12 @@ hsExprNeedsParens prec = go
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
+ go_x_tc (HsRecSelTc{}) = False
go_x_rn :: XXExprGhcRn -> Bool
go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing
go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
+ go_x_rn (HsRecSelRn{}) = False
hsExpandedNeedsParens :: HsThingRn -> Bool
hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e
@@ -1111,21 +1126,22 @@ isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsRecSel{}) = True
isAtomicHsExpr (XExpr x)
| GhcTc <- ghcPass @p = go_x_tc x
| GhcRn <- ghcPass @p = go_x_rn x
where
go_x_tc :: XXExprGhcTc -> Bool
- go_x_tc (WrapExpr _ e) = isAtomicHsExpr e
- go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
- go_x_tc (ConLikeTc {}) = True
- go_x_tc (HsTick {}) = False
- go_x_tc (HsBinTick {}) = False
+ go_x_tc (WrapExpr _ e) = isAtomicHsExpr e
+ go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
+ go_x_tc (ConLikeTc {}) = True
+ go_x_tc (HsTick {}) = False
+ go_x_tc (HsBinTick {}) = False
+ go_x_tc (HsRecSelTc{}) = True
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
- go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
+ go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
+ go_x_rn (HsRecSelRn{}) = True
isAtomicExpandedThingRn :: HsThingRn -> Bool
isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index bf2e67731d9..a921f4cf9a2 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -244,4 +244,4 @@ instance Outputable NoExtField where
ppr _ = text "NoExtField"
instance Outputable DataConCantHappen where
- ppr = dataConCantHappen
\ No newline at end of file
+ ppr = dataConCantHappen
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 5326ae27460..de9230eb86a 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -558,12 +558,6 @@ deriving instance Data (FieldOcc GhcPs)
deriving instance Data (FieldOcc GhcRn)
deriving instance Data (FieldOcc GhcTc)
--- deriving instance DataId p => Data (AmbiguousFieldOcc p)
-deriving instance Data (AmbiguousFieldOcc GhcPs)
-deriving instance Data (AmbiguousFieldOcc GhcRn)
-deriving instance Data (AmbiguousFieldOcc GhcTc)
-
-
-- deriving instance (DataId name) => Data (ImportDecl name)
deriving instance Data (ImportDecl GhcPs)
deriving instance Data (ImportDecl GhcRn)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 587793828eb..8b357f9b7c3 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -38,7 +38,6 @@ module GHC.Hs.Pat (
HsRecUpdField, LHsRecUpdField,
RecFieldsDotDot(..),
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
- hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
mkPrefixConPat, mkCharLitPat, mkNilPat,
@@ -341,16 +340,6 @@ data ConPatTc
hsRecFieldId :: HsRecField GhcTc arg -> Id
hsRecFieldId = hsRecFieldSel
-hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) q -> Located RdrName
-hsRecUpdFieldRdr = fmap ambiguousFieldOccRdrName . reLoc . hfbLHS
-
-hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc
-
-hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
-
-
{-
************************************************************************
* *
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 98c15767a0a..3c550deacd5 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -103,7 +103,6 @@ lhsExprType (L _ e) = hsExprType e
hsExprType :: HsExpr GhcTc -> Type
hsExprType (HsVar _ (L _ id)) = idType id
hsExprType (HsUnboundVar (HER _ ty _) _) = ty
-hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
hsExprType (HsOverLabel v _) = dataConCantHappen v
hsExprType (HsIPVar v _) = dataConCantHappen v
hsExprType (HsOverLit _ lit) = overLitType lit
@@ -154,6 +153,7 @@ hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
+hsExprType (XExpr (HsRecSelTc (FieldOcc _ id))) = idType (unLoc id)
arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
arithSeqInfoType asi = mkListTy $ case asi of
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 7a467d675a4..4ff5ed43c54 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -59,12 +59,8 @@ module GHC.Hs.Type (
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..), noTypeArgs,
-
FieldOcc(..), LFieldOcc, mkFieldOcc,
- AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,
- ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName,
- selectorAmbiguousFieldOcc,
- unambiguousFieldOcc, ambiguousFieldOcc,
+ fieldOccRdrName, fieldOccLRdrName,
OpName(..),
@@ -115,7 +111,6 @@ import GHC.Hs.Extension
import GHC.Parser.Annotation
import GHC.Types.Fixity ( LexicalFixity(..) )
-import GHC.Types.Id ( Id )
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Reader ( RdrName )
@@ -1097,59 +1092,62 @@ also forbids them in types involved with `deriving`:
FieldOcc
* *
************************************************************************
+
+Note [Ambiguous FieldOcc in record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming a "record field update" (`some_record{ field = expr }`), the field
+occurrence may be ambiguous if there are multiple record types with that same
+field label in scope. Instead of failing, we may attempt to do type-directed
+disambiguation: if we typecheck the record field update, we can disambiguate
+the `field` based on the record and field type.
+
+In practice, this means an identifier of a field occurrence
+(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field
+ambiguity makes it impossible to construct a `Name` for the field.
+
+Since type-directed disambiguation is a GHC property rather than a property of
+the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`,
+but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName
+in the name. Very bad, yes, but since type-directed disambiguation is on the way
+out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366),
+we consider this acceptable for now.
+
+see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation]
+
+NB: FieldOcc preserves the RdrName throughout its lifecycle for
+exact printing purposes.
-}
-type instance XCFieldOcc GhcPs = NoExtField
-type instance XCFieldOcc GhcRn = Name
-type instance XCFieldOcc GhcTc = Id
+type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field
+type instance XCFieldOcc GhcRn = RdrName
+type instance XCFieldOcc GhcTc = RdrName
-type instance XXFieldOcc (GhcPass _) = DataConCantHappen
+type instance XXFieldOcc GhcPs = DataConCantHappen
+type instance XXFieldOcc GhcRn = DataConCantHappen
+type instance XXFieldOcc GhcTc = DataConCantHappen
+
+--------------------------------------------------------------------------------
mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc rdr = FieldOcc noExtField rdr
+fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName
+fieldOccRdrName fo = case ghcPass @p of
+ GhcPs -> unLoc $ foLabel fo
+ GhcRn -> foExt fo
+ GhcTc -> foExt fo
-type instance XUnambiguous GhcPs = NoExtField
-type instance XUnambiguous GhcRn = Name
-type instance XUnambiguous GhcTc = Id
-
-type instance XAmbiguous GhcPs = NoExtField
-type instance XAmbiguous GhcRn = NoExtField
-type instance XAmbiguous GhcTc = Id
-
-type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen
-
-instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
- ppr = ppr . ambiguousFieldOccRdrName
-
-instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
- pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName
- pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName
-
-instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where
- pprInfixOcc = pprInfixOcc . unLoc
- pprPrefixOcc = pprPrefixOcc . unLoc
-
-mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr
-
-ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName
-ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName
+fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName
+fieldOccLRdrName fo = case ghcPass @p of
+ GhcPs -> foLabel fo
+ GhcRn -> case fo of
+ FieldOcc rdr sel ->
+ let (L l _) = sel
+ in L l rdr
+ GhcTc ->
+ let (L l _) = foLabel fo
+ in L l (foExt fo)
-ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName
-ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr
-ambiguousFieldOccLRdrName (Ambiguous _ rdr) = rdr
-
-selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
-selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
-
-unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
-unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
-
-ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
{-
************************************************************************
@@ -1279,18 +1277,19 @@ instance (Outputable tyarg, Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where
+instance Outputable (XRec pass (IdP pass)) => Outputable (FieldOcc pass) where
ppr = ppr . foLabel
-instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where
- pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel
- pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel
+instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where
+ pprInfixOcc = pprInfixOcc . unXRec @(GhcPass pass) . foLabel
+ pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel
-instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where
+instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+
ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc
ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)
ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))
@@ -1351,7 +1350,7 @@ pprLHsContextAlways (L _ ctxt)
[L _ ty] -> ppr_mono_ty ty <+> darrow
_ -> parens (interpp'SP ctxt) <+> darrow
-pprConDeclFields :: OutputableBndrId p
+pprConDeclFields :: forall p. OutputableBndrId p
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
@@ -1359,7 +1358,7 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
cd_fld_doc = doc }))
= pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)
- ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
+ ppr_names :: forall p. OutputableBndrId p => [LFieldOcc (GhcPass p)] -> SDoc
ppr_names [n] = pprPrefixOcc n
ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
@@ -1587,4 +1586,3 @@ type instance Anno HsIPName = EpAnnCO
type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 40bc935195c..4c5477ef568 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1442,7 +1442,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
(foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls))
where
getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]
- getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs
+ getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs
-------------------
@@ -1684,7 +1684,7 @@ emptyFieldIndices =
, fieldIndices = Map.empty
, newInt = 0 }
-insertField :: LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p)
+insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p)
insertField new_fld fi@(FieldIndices flds idxs new_idx)
| Just i <- Map.lookup rdr idxs
= (L loc i, fi)
@@ -1695,7 +1695,7 @@ insertField new_fld fi@(FieldIndices flds idxs new_idx)
(new_idx + 1))
where
loc = getLocA new_fld
- rdr = unLoc . foLabel . unLoc $ new_fld
+ rdr = fieldOccRdrName . unLoc $ new_fld
{-
@@ -1871,5 +1871,5 @@ rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })
where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds
implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))
= ImplicitFieldBinders
- { implFlBndr_field = foExt fld
+ { implFlBndr_field = unLoc $ foLabel fld
, implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index da73bfd1ebc..acf0053cc6a 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -394,7 +394,7 @@ subordinates env instMap decl = case decl of
, maybeToList $ fmap unLoc $ con_doc c
, conArgDocs c)
| c <- toList cons, cname <- getConNames c ]
- fields = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)
+ fields = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty)
| Just flds <- toList $ fmap getRecConArgs_maybe cons
, (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
, (L _ n) <- ns ]
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 5bf8bb10f0d..eff00f86786 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -261,36 +261,6 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsVar _ (L _ id)) = dsHsVar id
-{- Record selectors are warned about if they are not
-present in all of the parent data type's constructor,
-or always in case of pattern synonym record selectors
-(regulated by a flag). However, this only produces
-a warning if it's not a part of a record selector
-application. For example:
-
- data T = T1 | T2 {s :: Bool}
- f x = s x -- the warning from this case will be supressed
-
-See the `HsApp` case for where it is filtered out
--}
-dsExpr (HsRecSel _ (FieldOcc id _))
- = do { let name = getName id
- RecSelId {sel_cons = (_, cons_wo_field)}
- = idDetails id
- ; cons_trimmed <- trim_cons cons_wo_field
- ; unless (null cons_wo_field) $ diagnosticDs
- $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
- -- This only produces a warning if it's not a part of a
- -- record selector application (e.g. `s a` where `s` is a selector)
- -- See the `HsApp` case for where it is filtered out
- ; dsHsVar id }
- where
- trim_cons :: [ConLike] -> DsM [ConLike]
- trim_cons cons_wo_field = do
- dflags <- getDynFlags
- let maxConstructors = maxUncoveredPatterns dflags
- return $ take maxConstructors cons_wo_field
-
dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
-- See Note [Holes] in GHC.Tc.Types.Constraint
@@ -336,6 +306,35 @@ dsExpr e@(XExpr ext_expr_tc)
do { assert (exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
+ {- Record selectors are warned about if they are not
+ present in all of the parent data type's constructor,
+ or always in case of pattern synonym record selectors
+ (regulated by a flag). However, this only produces
+ a warning if it's not a part of a record selector
+ application. For example:
+
+ data T = T1 | T2 {s :: Bool}
+ f x = s x -- the warning from this case will be supressed
+
+ See the `HsApp` case for where it is filtered out
+ -}
+ (HsRecSelTc (FieldOcc _ (L _ id))) ->
+ do { let name = getName id
+ RecSelId {sel_cons = (_, cons_wo_field)} = idDetails id
+ ; cons_trimmed <- trim_cons cons_wo_field
+ ; unless (null cons_wo_field) $ diagnosticDs
+ $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
+ -- This only produces a warning if it's not a part of a
+ -- record selector application (e.g. `s a` where `s` is a selector)
+ -- See the `HsApp` case for where it is filtered out
+ ; dsHsVar id }
+ where
+ trim_cons :: [ConLike] -> DsM [ConLike]
+ trim_cons cons_wo_field = do
+ dflags <- getDynFlags
+ let maxConstructors = maxUncoveredPatterns dflags
+ return $ take maxConstructors cons_wo_field
+
-- Strip ticks due to #21701, need to be invariant about warnings we produce whether
-- this is enabled or not.
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 4681c6b6be6..85c56b3a310 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -284,7 +284,7 @@ repTopDs group@(HsGroup { hs_valds = valds
, hs_docs = docs })
= do { let { bndrs = hsScopedTvBinders valds
++ hsGroupBinders group
- ++ map foExt (hsPatSynSelectors valds)
+ ++ map (unLoc . foLabel) (hsPatSynSelectors valds)
; instds = tyclds >>= group_instds } ;
ss <- mkGenSyms bndrs ;
@@ -1544,7 +1544,6 @@ repE (HsVar _ (L _ x)) =
repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ s) = repOverLabel s
-repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
@@ -1686,7 +1685,7 @@ repE (HsUnboundVar _ uv) = do
repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
e1 <- repLE e
repGetField e1 f
-repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
+repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel) xs)
repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
@@ -1719,6 +1718,8 @@ repE e@(XExpr (ExpandedThingRn o x))
= notHandled (ThExpressionForm e)
repE (XExpr (PopErrCtxt (L _ e))) = repE e
+repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (HsVar noExtField (noLocA x))
+
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
@@ -1821,11 +1822,19 @@ repUpdFields :: [LHsRecUpdField GhcRn GhcRn] -> MetaM (Core [M TH.FieldExp])
repUpdFields = repListM fieldExpTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp))
- rep_fld (L l fld) = case unLoc (hfbLHS fld) of
- Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
- ; e <- repLE (hfbRHS fld)
- ; repFieldExp fn e }
- Ambiguous{} -> notHandled (ThAmbiguousRecordUpdates fld)
+ rep_fld (L l fld) =
+ let (FieldOcc _ (L _ sel_name)) = unLoc (hfbLHS fld)
+ -- If we have an unbountName in the sel_name, that means we failed to
+ -- disambiguate during the Rename stage of Ghc. Now if we continued
+ -- onwards to type checking that might be fine, as explained in
+ -- Note [Ambiguous FieldOcc in record updates], but if instead we
+ -- are within the context of Template Haskell, we just fail immediately.
+ in if isUnboundName sel_name
+ then notHandled (ThAmbiguousRecordUpdates fld)
+ else do { fn <- lookupLOcc (L l sel_name)
+ ; e <- repLE (hfbRHS fld)
+ ; repFieldExp fn e
+ }
@@ -2028,7 +2037,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecCon fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
- sels = map (foExt . recordPatSynField) fields
+ sels = map (unLoc . foLabel . recordPatSynField) fields
; ss <- mkGenSyms sels
; return $ replaceNames (zip sels pats) ss }
@@ -2060,7 +2069,7 @@ repPatSynArgs (InfixCon arg1 arg2)
; arg2' <- lookupLOcc arg2
; repInfixPatSynArgs arg1' arg2' }
repPatSynArgs (RecCon fields)
- = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels
+ = do { sels' <- repList nameTyConName (lookupOcc . unLoc . foLabel) sels
; repRecordPatSynArgs sels' }
where sels = map recordPatSynField fields
@@ -2883,7 +2892,7 @@ repRecConArgs ips = do
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
- rep_one_ip t n = do { MkC v <- lookupOcc (foExt $ unLoc n)
+ rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index 4c743ff9c16..594d308192a 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -476,7 +476,6 @@ addBinTickLHsExpr boxLabel e@(L pos e0)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr e@(HsUnboundVar {}) = return e
-addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e
addTickHsExpr e@(HsIPVar {}) = return e
addTickHsExpr e@(HsOverLit {}) = return e
@@ -604,6 +603,8 @@ addTickHsExpr (XExpr (HsTick t e)) =
addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id))) = do freeVar (unLoc id); return e
+
addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo srcloc cxt (L l stmts')) }
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 8b88fa7914f..f9ebdfa01b5 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -828,7 +828,6 @@ class ( HiePass (NoGhcTcPass p)
, Data (Stmt (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
, Data (HsExpr (GhcPass p))
, Data (HsCmd (GhcPass p))
- , Data (AmbiguousFieldOcc (GhcPass p))
, Data (HsCmdTop (GhcPass p))
, Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
, Data (HsUntypedSplice (GhcPass p))
@@ -1205,9 +1204,6 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
-- Patch up var location since typechecker removes it
]
HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble
- HsRecSel _ fld ->
- [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
- ]
HsOverLabel {} -> []
HsIPVar _ _ -> []
HsOverLit _ o ->
@@ -1285,7 +1281,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
RecordUpd { rupd_expr = expr
, rupd_flds = RegularRecUpdFields { recUpdFields = upds } }->
[ toHie expr
- , toHie $ map (RC RecFieldAssign) upds
+ , case hiePass @p of
+ HieRn -> toHie $ map (RC RecFieldAssign) upds
+ HieTc -> toHie $ map (RC RecFieldAssign) upds
]
RecordUpd { rupd_expr = expr
, rupd_flds = OverloadedRecUpdFields {} }->
@@ -1353,23 +1351,29 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsGetField {} -> []
HsProjection {} -> []
- XExpr x
- | HieTc <- hiePass @p
- -> case x of
- WrapExpr w a
- -> [ toHie $ L mspan a
- , toHie (L mspan w) ]
- ExpandedThingTc _ e
- -> [ toHie (L mspan e) ]
- ConLikeTc con _ _
- -> [ toHie $ C Use $ L mspan $ conLikeName con ]
- HsTick _ expr
- -> [ toHie expr
- ]
- HsBinTick _ _ expr
- -> [ toHie expr
- ]
- | otherwise -> []
+ XExpr x -> case hiePass @p of
+ HieTc -> case x of
+ WrapExpr w a
+ -> [ toHie $ L mspan a
+ , toHie (L mspan w) ]
+ ExpandedThingTc _ e
+ -> [ toHie (L mspan e) ]
+ ConLikeTc con _ _
+ -> [ toHie $ C Use $ L mspan $ conLikeName con ]
+ HsTick _ expr
+ -> [ toHie expr
+ ]
+ HsBinTick _ _ expr
+ -> [ toHie expr
+ ]
+ HsRecSelTc fld
+ -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
+ ]
+ HieRn -> case x of
+ HsRecSelRn fld
+ -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
+ ]
+ _ -> []
-- NOTE: no longer have the location
instance HiePass p => ToHie (HsTupArg (GhcPass p)) where
@@ -1505,23 +1509,17 @@ instance ( ToHie (RFContext label)
]
instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where
- toHie (RFC c rhs (L nspan f)) = concatM $ case f of
- FieldOcc fld _ ->
- case hiePass @p of
- HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
- HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
-
-instance HiePass p => ToHie (RFContext (LocatedA (AmbiguousFieldOcc (GhcPass p)))) where
-
- toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
- Unambiguous fld _ ->
- case hiePass @p of
- HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
- HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
- Ambiguous fld _ ->
- case hiePass @p of
- HieRn -> []
- HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]
+ toHie (RFC c rhs (L nspan f)) = concatM $
+ case hiePass @p of
+ HieRn ->
+ case f of
+ FieldOcc _ fld ->
+ [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)]
+ HieTc ->
+ case f of
+ FieldOcc _ fld ->
+ [toHie $ C (RecField c rhs) (L (locA nspan) $ unLoc fld)]
+
instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
@@ -2107,10 +2105,10 @@ instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where
instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
- toHie (C c (FieldOcc n (L l _))) = case hiePass @p of
- HieTc -> toHie (C c (L l n))
- HieRn -> toHie (C c (L l n))
+ toHie (C c (FieldOcc _ l)) = toHie (C c l)
+ toHie (C _ (XFieldOcc _)) = concatM []
instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where
toHie (PSC sp (RecordPatSynField a b)) = concatM $
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 854e113d32e..ec035542168 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2913,7 +2913,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
True -> do
let qualifiedFields =
[ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'
- , isQual . ambiguousFieldOccRdrName $ lbl
+ , isQual . fieldOccRdrName $ lbl
]
case qualifiedFields of
qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $
@@ -2959,7 +2959,7 @@ mk_rec_fields fs (Just s) = HsRecFields { rec_ext = noExtField, rec_flds = fs
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs
mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)
- = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun
+ = HsFieldBind noAnn (L loc (FieldOcc noExtField rdr)) arg pun
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
@@ -3558,7 +3558,7 @@ mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProje
mkRdrProjection flds anns =
HsProjection {
proj_ext = anns
- , proj_flds = flds
+ , proj_flds = fmap unLoc flds
}
mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 85984a58607..3fef3acac9d 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -824,7 +824,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
, psb_ext = fvs' }
selector_names = case details' of
RecCon names ->
- map (foExt . recordPatSynField) names
+ map (unLoc . foLabel . recordPatSynField) names
_ -> []
; fvs' `seq` -- See Note [Free-variable space leak]
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index d7473d8386c..73ddb9242a4 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1525,8 +1525,8 @@ lookupGlobalOccRn_overloaded rdr_name =
addNameClashErrRn rdr_name gres
return (Just gre) }
-getFieldUpdLbl :: LHsRecUpdField (GhcPass p) q -> LocatedN RdrName
-getFieldUpdLbl = ambiguousFieldOccLRdrName . unLoc . hfbLHS . unLoc
+getFieldUpdLbl :: IsPass p => LHsRecUpdField (GhcPass p) q -> LocatedN RdrName
+getFieldUpdLbl = fieldOccLRdrName . unLoc . hfbLHS . unLoc
-- | Returns all possible collections of field labels for the given
-- record update.
@@ -1620,10 +1620,10 @@ lookupRecUpdFields flds
* *
**********************************************************************-}
-getUpdFieldLbls :: forall p q. UnXRec (GhcPass p)
+getUpdFieldLbls :: forall p q. IsPass p
=> [LHsRecUpdField (GhcPass p) q] -> [RdrName]
getUpdFieldLbls
- = map $ ambiguousFieldOccRdrName
+ = map $ fieldOccRdrName
. unXRec @(GhcPass p)
. hfbLHS
. unXRec @(GhcPass p)
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 41c6a7ccbf6..aa0ea197c38 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -339,7 +339,7 @@ rnExpr (HsVar _ (L l v))
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod sel_name) $
checkThLocalName sel_name
- ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
+ ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
}
| nm == nilDataConName
-- Treat [] as an ExplicitList, so that
@@ -416,8 +416,8 @@ rnExpr (OpApp _ e1 op e2)
-- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate
-- should prevent bad things happening.
; fixity <- case op' of
- L _ (HsVar _ (L _ n)) -> lookupFixityRn n
- L _ (HsRecSel _ f) -> lookupFieldFixityRn f
+ L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+ L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f
_ -> return (Fixity minPrecedence InfixL)
-- c.f. lookupFixity for unbound
@@ -439,7 +439,7 @@ rnExpr (NegApp _ e _)
rnExpr (HsGetField _ e f)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; (e, fv_e) <- rnLExpr e
- ; let f' = rnDotFieldOcc f
+ ; let f' = rnDotFieldOcc <$> f
; return ( mkExpandedExpr
(HsGetField noExtField e f')
(mkGetField getField e (fmap (unLoc . dfoLabel) f'))
@@ -448,10 +448,10 @@ rnExpr (HsGetField _ e f)
rnExpr (HsProjection _ fs)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; circ <- lookupOccRn compose_RDR
- ; let fs' = fmap rnDotFieldOcc fs
+ ; let fs' = NE.map rnDotFieldOcc fs
; return ( mkExpandedExpr
(HsProjection noExtField fs')
- (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))
+ (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs')
, unitFV circ `plusFV` fv_getField) }
------------------------------------------
@@ -588,7 +588,6 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds })
(mkRecordDotUpd getField setField (L l e) us)
, plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) }
-rnExpr (HsRecSel x _) = dataConCantHappen x
rnExpr (ExprWithTySig _ expr pty)
= do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
@@ -890,11 +889,11 @@ However we can still defer this error completely, and we do defer it if
************************************************************************
-}
-rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
-rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
+rnDotFieldOcc :: DotFieldOcc GhcPs -> DotFieldOcc GhcRn
+rnDotFieldOcc (DotFieldOcc x label) = DotFieldOcc x label
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map (fmap rnDotFieldOcc) fls)
{-
************************************************************************
@@ -2864,14 +2863,14 @@ mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
-- mkProjection fields calculates a projection.
-- e.g. .x = mkProjection [x] = getField @"x"
-- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
-mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn
+mkProjection :: Name -> Name -> NonEmpty FieldLabelString -> HsExpr GhcRn
mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields
where
- f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
+ f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn
f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
- proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
- proj (L _ (FieldLabelString f)) = genHsVar getFieldName `genAppType` genHsTyLit f
+ proj :: FieldLabelString -> HsExpr GhcRn
+ proj (FieldLabelString f) = genHsVar getFieldName `genAppType` genHsTyLit f
-- mkProjUpdateSetField calculates functions representing dot notation record updates.
-- e.g. Suppose an update like foo.bar = 1.
diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs
index 7ddf9fe6fb8..ce0ee3b3173 100644
--- a/compiler/GHC/Rename/Fixity.hs
+++ b/compiler/GHC/Rename/Fixity.hs
@@ -202,4 +202,4 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity
lookupTyFixityRn = lookupFixityRn . unLoc
lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n
+lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n)
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 7d1fa013b28..d1b5fcb88eb 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -1341,7 +1341,7 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
lookupField fl_env (FieldOcc _ (L lr rdr)) =
- FieldOcc sel (L lr $ mkRdrUnqual $ occName sel)
+ FieldOcc (mkRdrUnqual $ occName sel) (L lr sel)
where
lbl = occNameFS $ rdrNameOcc rdr
sel = flSelector
@@ -1467,10 +1467,10 @@ data NegationHandling = ReassociateNegation | KeepNegationIntact
get_op :: LHsExpr GhcRn -> OpName
-- An unbound name could be either HsVar or HsUnboundVar
-- See GHC.Rename.Expr.rnUnboundVar
-get_op (L _ (HsVar _ n)) = NormalOp (unLoc n)
-get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
-get_op (L _ (HsRecSel _ fld)) = RecFldOp fld
-get_op other = pprPanic "get_op" (ppr other)
+get_op (L _ (HsVar _ n)) = NormalOp (unLoc n)
+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (L _ (XExpr (HsRecSelRn fld))) = RecFldOp fld
+get_op other = pprPanic "get_op" (ppr other)
-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
@@ -1610,7 +1610,6 @@ lookupFixityOp NegateOp = lookupFixityRn negateName
lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u))
lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
-
-- Precedence-related error messages
precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 170d1004178..162dc4e0d16 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -10,6 +10,8 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -880,7 +882,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return $ L l $
HsFieldBind
{ hfbAnn = noAnn
- , hfbLHS = L loc (FieldOcc sel (L ll arg_rdr))
+ , hfbLHS = L loc (FieldOcc arg_rdr (L ll sel))
, hfbRHS = arg'
, hfbPun = pun } }
@@ -888,7 +890,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-> Maybe Name -- The constructor (Nothing for an
-- out of scope constructor)
-> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields
- -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in
+ -> RnM [LHsRecField GhcRn (LocatedA arg)] -- Field Labels we need to fill in
rn_dotdot (Just (L loc_e (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match
| not (isUnboundName con) -- This test is because if the constructor
-- isn't in scope the constructor lookup will add
@@ -900,7 +902,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; (rdr_env, lcl_env) <- getRdrEnvs
; conInfo <- lookupConstructorInfo con
; when (conFieldInfo conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con))
- ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
+ ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldRdrs flds)
-- For constructor uses (but not patterns)
-- the arg should be in scope locally;
@@ -926,7 +928,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
- = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
+ = L (noAnnSrcSpan loc) (FieldOcc arg_rdr (L (noAnnSrcSpan loc) sel))
, hfbRHS = L locn (mk_arg loc arg_rdr)
, hfbPun = False })
| fl <- dot_dot_fields
@@ -1016,10 +1018,10 @@ rnHsRecUpdFields flds
-> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars)
rn_flds _ _ [] = return ([], emptyFVs)
rn_flds pun_ok mb_unambig_lbls
- ((L l (HsFieldBind { hfbLHS = L loc f
+ ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f)
, hfbRHS = arg
, hfbPun = pun })):flds)
- = do { let lbl = ambiguousFieldOccRdrName f
+ = do { let lbl = unLoc f
; (arg' :: LHsExpr GhcPs) <- if pun
then do { setSrcSpanA loc $
checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
@@ -1028,15 +1030,18 @@ rnHsRecUpdFields flds
; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
- ; let lbl' :: AmbiguousFieldOcc GhcRn
+ ; let lbl' :: FieldOcc GhcRn
lbl' = case mb_unambig_lbls of
{ Just (fl:_) ->
let sel_name = flSelector fl
- in Unambiguous sel_name (L (l2l loc) lbl)
- ; _ -> Ambiguous noExtField (L (l2l loc) lbl) }
+ in FieldOcc lbl (L (l2l loc) sel_name)
+ -- We have one last chance to be disambiguated during type checking.
+ -- At least, until type-directed disambiguation stops being supported.
+ -- see note [Ambiguous FieldOcc in record updates] for more info.
+ ; _ -> FieldOcc lbl (L (l2l loc) (mkUnboundName $ rdrNameOcc lbl)) }
fld' :: LHsRecUpdField GhcRn GhcRn
fld' = L l (HsFieldBind { hfbAnn = noAnn
- , hfbLHS = L loc lbl'
+ , hfbLHS = L (l2l loc) lbl'
, hfbRHS = arg''
, hfbPun = pun })
; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds
@@ -1045,9 +1050,11 @@ rnHsRecUpdFields flds
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds flds = map (hsRecFieldSel . unLoc) flds
-getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
-getFieldLbls flds
- = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds
+getFieldRdrs :: [LHsRecField GhcRn arg] -> [RdrName]
+getFieldRdrs flds = map (foExt . unXRec @GhcRn . hfbLHS . unLoc) flds
+
+getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [IdP p]
+getFieldLbls = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p)
needFlagDotDot :: HsRecFieldContext -> TcRnMessage
needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 4054269348a..59ee46889f9 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -293,7 +293,6 @@ tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
-tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
tcExpr (XExpr e) res_ty = tcXExpr e res_ty
@@ -738,7 +737,6 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
| OrigStmt ls@(L loc _) <- o
= setSrcSpanA loc $
mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
-
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
{-
@@ -1300,11 +1298,10 @@ expandRecordUpd record_expr possible_parents rbnds res_ty
-- See Note [Disambiguating record updates] in GHC.Rename.Pat.
; (cons, rbinds)
<- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
- ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
- sel_ids = map selectorAmbiguousFieldOcc upd_flds
+ ; let sel_ids = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) rbinds
upd_fld_names = map idName sel_ids
relevant_cons = nonDetEltsUniqSet cons
- relevant_con = head relevant_cons
+ relevant_con = head relevant_cons
-- STEP 2: expand the record update.
--
@@ -1584,7 +1581,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
-> TcM (LHsRecUpdField GhcTc GhcRn)
lookupField fld_gre (L l upd)
= do { let L loc af = hfbLHS upd
- lbl = ambiguousFieldOccRdrName af
+ lbl = fieldOccRdrName af
mb_gre = pickGREs lbl [fld_gre]
-- NB: this GRE can be 'Nothing' when in GHCi.
-- See test T10439.
@@ -1596,7 +1593,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
; sel <- tcLookupId (greName fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
- , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl)
+ , hfbLHS = L (l2l loc) (FieldOcc lbl (L (l2l loc) sel))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
} }
@@ -1669,11 +1666,11 @@ fieldCtxt field_name
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
+tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs
| Just field_ty <- assocMaybe flds_w_tys sel_name
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcCheckPolyExprNC rhs field_ty
- ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs'))
+ ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))
field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
@@ -1682,12 +1679,12 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
-- (so the expansion knows the type of local binder to make)
- ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
+ ; return (Just (L loc (FieldOcc rdr (L l field_id)), rhs')) }
| otherwise
= do { addErrTc (badFieldConErr (getName con_like) field_lbl)
; return Nothing }
where
- field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl)
+ field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc rdr
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 882661c969c..c10a326d2e0 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -567,7 +567,7 @@ tcInferAppHead_maybe :: HsExpr GhcRn
tcInferAppHead_maybe fun
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
- HsRecSel _ f -> Just <$> tcInferRecSelId f
+ XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
@@ -596,16 +596,15 @@ addHeadCtxt fun_ctxt thing_inside
********************************************************************* -}
tcInferRecSelId :: FieldOcc GhcRn
- -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferRecSelId (FieldOcc sel_name lbl)
- = do { sel_id <- tc_rec_sel_id
- ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)
- ; return (expr, idType sel_id)
+ -> TcM ( (HsExpr GhcTc, TcSigmaType))
+tcInferRecSelId (FieldOcc lbl (L l sel_name))
+ = do { sel_id <- tc_rec_sel_id
+ ; let expr = XExpr (HsRecSelTc (FieldOcc lbl (L l sel_id)))
+ ; return $ (expr, idType sel_id)
}
where
occ :: OccName
- occ = rdrNameOcc (unLoc lbl)
-
+ occ = nameOccName sel_name
tc_rec_sel_id :: TcM TcId
-- Like tc_infer_id, but returns an Id not a HsExpr,
-- so we can wrap it back up into a HsRecSel
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 8cd2a2b2732..aaf478d9a94 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1648,14 +1648,14 @@ tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of
where
tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
(LHsRecField GhcTc (LPat GhcTc))
- tc_field penv
- (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))
- thing_inside
+ tc_field penv
+ (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel))) pat pun))
+ thing_inside
= do { sel' <- tcLookupId sel
; pat_ty <- setSrcSpanA loc $ find_field_ty sel
(occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
- ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'
+ ; return (L l (HsFieldBind ann (L loc (FieldOcc rdr (L lr sel'))) pat'
pun), res) }
-- See Note [Omitted record fields and linearity]
check_omitted_fields_multiplicity :: TcM MultiplicityCheckCoercions
@@ -1685,7 +1685,7 @@ tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of
(bound_field_tys, omitted_field_tys) = partition is_bound all_field_tys
is_bound :: (Maybe FieldLabel, Scaled TcType) -> Bool
- is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc sel _ )) _ _)) -> sel) rpats)
+ is_bound (Just fl, _) = elem (flSelector fl) (map (\(L _ (HsFieldBind _ (L _ (FieldOcc _ sel )) _ _)) -> unLoc sel) rpats)
is_bound _ = False
all_field_tys :: [(Maybe FieldLabel, Scaled TcType)]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 4433839b437..a679e063c96 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -942,8 +942,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
rec_field = noLocA (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
- = L locc (FieldOcc sel_name
- (L locn $ mkRdrUnqual (nameOccName sel_name)))
+ = L locc (FieldOcc (mkRdrUnqual $ nameOccName sel_name) (L locn sel_name))
, hfbRHS
= L loc' (VarPat noExtField (L locn field_var))
, hfbPun = False })
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index cae7d9f22ab..22062f47e46 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -718,7 +718,6 @@ exprCtOrigin :: HsExpr GhcRn -> CtOrigin
exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f)
exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable"
-exprCtOrigin (HsRecSel _ f) = OccurrenceOfRecSel (unLoc $ foLabel f)
exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l
exprCtOrigin (ExplicitList {}) = ListOrigin
exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
@@ -759,6 +758,7 @@ exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOri
| OrigStmt _ <- thing = DoOrigin
| OrigPat p <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
+exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f)
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index 5611a9de50f..27c92628f7c 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -608,8 +608,8 @@ zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = initZonkEnv DefaultFlexi $ zonkIdBndrs ids
zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc)
-zonkFieldOcc (FieldOcc sel lbl)
- = fmap ((flip FieldOcc) lbl) $ zonkIdBndr sel
+zonkFieldOcc (FieldOcc lbl (L l sel))
+ = FieldOcc lbl . L l <$> zonkIdBndr sel
zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar]
zonkEvBndrsX = traverse zonkEvBndrX
@@ -935,9 +935,6 @@ zonkExpr (HsUnboundVar her occ)
ty' <- zonkTcTypeToTypeX ty
return (HER ref ty' u)
-zonkExpr (HsRecSel _ (FieldOcc v occ))
- = do { v' <- zonkIdOcc v
- ; return (HsRecSel noExtField (FieldOcc v' occ)) }
zonkExpr (HsIPVar x _) = dataConCantHappen x
@@ -1098,6 +1095,10 @@ zonkExpr (XExpr (ConLikeTc con tvs tys))
-- The tvs come straight from the data-con, and so are strictly redundant
-- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head
+zonkExpr (XExpr (HsRecSelTc (FieldOcc occ (L l v))))
+ = do { v' <- zonkIdOcc v
+ ; return (XExpr (HsRecSelTc (FieldOcc occ (L l v')))) }
+
zonkExpr (RecordUpd x _ _) = dataConCantHappen x
zonkExpr (HsGetField x _ _) = dataConCantHappen x
zonkExpr (HsProjection x _) = dataConCantHappen x
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 248e9b002d1..499a90f2958 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1159,7 +1159,7 @@ cvtl e = wrapLA (cvt e)
; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'
- <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))
+ <- mapM (cvtFld (wrapParLA mkFieldOcc))
flds
; return $ RecordUpd noAnn e' $
RegularRecUpdFields
@@ -1177,7 +1177,7 @@ cvtl e = wrapLA (cvt e)
; return $ HsGetField noExtField e'
(L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
- (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs
+ (DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs
cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e
; return $ HsTypedSplice noAnn e' }
cvt (TypedBracketE e) = do { e' <- cvtl e
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index ea958085bbe..e7fcaa62dc1 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -351,10 +351,6 @@ data HsExpr p
-- solving. See Note [Holes] in GHC.Tc.Types.Constraint.
- | HsRecSel (XRecSel p)
- (FieldOcc p) -- ^ Variable pointing to record selector
- -- See Note [Non-overloaded record field selectors] and
- -- Note [Record selectors in the AST]
| HsOverLabel (XOverLabel p) FastString
-- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
@@ -573,7 +569,7 @@ data HsExpr p
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
| HsProjection {
proj_ext :: XProjection p
- , proj_flds :: NonEmpty (XRec p (DotFieldOcc p))
+ , proj_flds :: NonEmpty (DotFieldOcc p)
}
-- | Expression with an explicit type signature. @e :: type@
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index e7f583c71e2..67e1d50db0c 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -467,13 +467,6 @@ type family XXDotFieldOcc x
type family XSCC x
type family XXPragE x
-
--- -------------------------------------
--- AmbiguousFieldOcc type families
-type family XUnambiguous x
-type family XAmbiguous x
-type family XXAmbiguousFieldOcc x
-
-- -------------------------------------
-- HsTupArg type families
type family XPresent x
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index 4c04e70d2eb..20d2f659ae1 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -319,14 +319,14 @@ type LHsFieldBind p id arg = XRec p (HsFieldBind id arg)
-- | Located Haskell Record Field
type LHsRecField p arg = XRec p (HsRecField p arg)
--- | Located Haskell Record Update Field
-type LHsRecUpdField p q = XRec p (HsRecUpdField p q)
-
-- | Haskell Record Field
type HsRecField p arg = HsFieldBind (LFieldOcc p) arg
+-- | Located Haskell Record Update Field
+type LHsRecUpdField p q = XRec p (HsRecUpdField p q)
+
-- | Haskell Record Update Field
-type HsRecUpdField p q = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr q)
+type HsRecUpdField p q = HsFieldBind (LFieldOcc p) (LHsExpr q)
-- | Haskell Field Binding
--
@@ -395,11 +395,11 @@ data HsFieldBind lhs rhs = HsFieldBind {
--
-- See also Note [Disambiguating record updates] in GHC.Rename.Pat.
-hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
+hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [IdP p]
hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds)
hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]
hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds)
-hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p
-hsRecFieldSel = foExt . unXRec @p . hfbLHS
+hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> IdP p
+hsRecFieldSel = unXRec @p . foLabel . unXRec @p . hfbLHS
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index bff2909bf5b..d283b8dc34f 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -55,7 +55,6 @@ module Language.Haskell.Syntax.Type (
HsConDetails(..), noTypeArgs,
FieldOcc(..), LFieldOcc,
- AmbiguousFieldOcc(..), LAmbiguousFieldOcc,
mapHsOuterImplicit,
hsQTvExplicit,
@@ -69,7 +68,6 @@ import Language.Haskell.Syntax.Basic ( HsBang(..) )
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Specificity
-import GHC.Types.Name.Reader ( RdrName )
import GHC.Hs.Doc (LHsDoc)
import GHC.Data.FastString (FastString)
@@ -1367,38 +1365,23 @@ type LFieldOcc pass = XRec pass (FieldOcc pass)
-- We store both the 'RdrName' the user originally wrote, and after
-- the renamer we use the extension field to store the selector
-- function.
+--
+-- There is a wrinkle in that update field occurances are sometimes
+-- ambiguous during the rename stage. See note
+-- [Ambiguous FieldOcc in record updates] to see how we currently
+-- handle this.
data FieldOcc pass
= FieldOcc {
foExt :: XCFieldOcc pass
- , foLabel :: XRec pass RdrName -- See Note [Located RdrNames] in Language.Haskell.Syntax.Expr
+ , foLabel :: LIdP pass
}
| XFieldOcc !(XXFieldOcc pass)
deriving instance (
- Eq (XRec pass RdrName)
+ Eq (LIdP pass)
, Eq (XCFieldOcc pass)
, Eq (XXFieldOcc pass)
) => Eq (FieldOcc pass)
--- | Located Ambiguous Field Occurrence
-type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass)
-
--- | Ambiguous Field Occurrence
---
--- Represents an *occurrence* of a field that is potentially
--- ambiguous after the renamer, with the ambiguity resolved by the
--- typechecker. We always store the 'RdrName' that the user
--- originally wrote, and store the selector function after the renamer
--- (for unambiguous occurrences) or the typechecker (for ambiguous
--- occurrences).
---
--- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat".
--- See Note [Located RdrNames] in "GHC.Hs.Expr".
-data AmbiguousFieldOcc pass
- = Unambiguous (XUnambiguous pass) (XRec pass RdrName)
- | Ambiguous (XAmbiguous pass) (XRec pass RdrName)
- | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass)
-
-
{-
************************************************************************
* *
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 331baa49889..7a61b2d3ad0 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -177,7 +177,8 @@
(EpaComments
[]))
(FieldOcc
- {Name: T14189.f}
+ (Unqual
+ {OccName: f})
(L
(EpAnn
(EpaSpan { T14189.hs:6:33 })
@@ -185,8 +186,7 @@
[])
(EpaComments
[]))
- (Unqual
- {OccName: f}))))]
+ {Name: T14189.f})))]
(L
(EpAnn
(EpaSpan { T14189.hs:6:38-40 })
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 20901946346..0b42bae688c 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -3437,22 +3437,6 @@ instance (ExactPrint body)
-- ---------------------------------------------------------------------
-instance (ExactPrint (LocatedA body))
- => ExactPrint (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
- getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ _ = a
-
- exact (HsFieldBind an f arg isPun) = do
- debugM $ "HsRecUpdField"
- f' <- markAnnotated f
- an0 <- if isPun then return an
- else markEpAnnL an lidl AnnEqual
- arg' <- if isPun
- then return arg
- else markAnnotated arg
- return (HsFieldBind an0 f' arg' isPun)
-
--- ---------------------------------------------------------------------
instance ExactPrint (LHsRecUpdFields GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
@@ -4523,14 +4507,6 @@ instance ExactPrint (FieldOcc GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint (AmbiguousFieldOcc GhcPs) where
- getAnnotationEntry = const NoEntryVal
- setAnnotationAnchor a _ _ _ = a
- exact f@(Unambiguous _ n) = markAnnotated n >> return f
- exact f@(Ambiguous _ n) = markAnnotated n >> return f
-
--- ---------------------------------------------------------------------
-
instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
index a9eb97da186..9fdb57cb02b 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -300,7 +300,7 @@ ppCtor sDocContext dat subdocs con@ConDeclH98{con_args = con_args'} =
f (RecCon (L _ recs)) =
f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs)
++ concat
- [ (concatMap (lookupCon sDocContext subdocs . noLocA . foExt . unLoc) (cd_fld_names r))
+ [ (concatMap (lookupCon sDocContext subdocs . noLocA . unLoc . foLabel . unLoc) (cd_fld_names r))
++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs
]
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs b/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
index e2262e584f0..431ba46aa61 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1027,7 +1027,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt
- ( cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names))
+ ( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
<+> dcolon unicode
<+> ppLType unicode ltype
)
@@ -1035,7 +1035,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc name) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (unLoc . foLabel . unLoc $ name) subdocs >>= fmap _doc . combineDocumentation . fst
name =
case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8de1b082485..802cbb49c06 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1536,7 +1536,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
comma
[ ppBinder False (rdrNameOcc field)
| L _ name <- names
- , let field = (unLoc . foLabel) name
+ , let field = (foExt) name
]
)
<+> dcolon unicode
@@ -1547,14 +1547,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (foExt $ unLoc declName) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (unLoc . foLabel $ unLoc declName) subdocs >>= combineDocumentation . fst
declName = case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _) =
- hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names))
+ hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . foExt . unLoc) names))
<+> dcolon unicode
<+> ppLType unicode qual HideEmptyContexts ltype
diff --git a/utils/haddock/haddock-api/src/Haddock/Convert.hs b/utils/haddock/haddock-api/src/Haddock/Convert.hs
index cc9aea2fd76..4034d49af45 100644
--- a/utils/haddock/haddock-api/src/Haddock/Convert.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Convert.hs
@@ -506,7 +506,7 @@ synifyDataCon use_gadt_syntax dc =
noLocA $
ConDeclField
noAnn
- [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)]
+ [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
synTy
Nothing
diff --git a/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs b/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
index 7644a1fa237..0d92c3a0f3c 100644
--- a/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
+++ b/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
@@ -360,7 +360,7 @@ restrictCons names decls = [L p d | L p (Just d) <- fmap keep <$> decls]
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField _ fs _ _)) =
- all (\f -> foExt (unLoc f) `elem` names) fs
+ all (\f -> (unLoc . foLabel . unLoc $ f) `elem` names) fs
field_types flds = [hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds]
keep _ = Nothing
@@ -553,7 +553,7 @@ instance Parent (ConDecl GhcRn) where
children con =
case getRecConArgs_maybe con of
Nothing -> []
- Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
+ Just flds -> map (unLoc . foLabel . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
index bf384e1b44c..f17f0ad58d8 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
@@ -935,7 +935,7 @@ extractDecl prr dflags sDocContext name decl
Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d)
, ConDeclField{cd_fld_names = ns} <- map unLoc (unLoc rec)
, L _ n <- ns
- , foExt n == name
+ , unLoc (foLabel n) == name
]
in case matches of
[d0] -> extractDecl prr dflags sDocContext name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
@@ -1004,7 +1004,7 @@ extractRecSel nm t tvs (L _ con : rest) =
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds =
- [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, foExt n == nm
+ [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
index 732de63e980..da50807b235 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
@@ -748,9 +748,9 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
return $ L (locA l) (ConDeclField noExtField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
-renameLFieldOcc (L l (FieldOcc sel lbl)) = do
+renameLFieldOcc (L l (FieldOcc rdr (L n sel))) = do
sel' <- renameName sel
- return $ L l (FieldOcc sel' lbl)
+ return $ L l (FieldOcc rdr (L n sel'))
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs
index 73934fc0939..f71a3f04aee 100644
--- a/utils/haddock/haddock-api/src/Haddock/Types.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs
@@ -886,8 +886,8 @@ type instance XBndrKind DocNameI = NoExtField
type instance XBndrNoKind DocNameI = NoExtField
type instance XXBndrKind DocNameI = DataConCantHappen
-type instance XCFieldOcc DocNameI = DocName
-type instance XXFieldOcc DocNameI = NoExtField
+type instance XCFieldOcc DocNameI = RdrName
+type instance XXFieldOcc DocNameI = DataConCantHappen
type instance XFixitySig DocNameI = NoExtField
type instance XFixSig DocNameI = NoExtField
--
GitLab