diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 72b3cb811100ae10068547d3b5294181e8435ea1..6f00f0ef852d349a773b9f7664aaaaebd8a79653 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 b2cfd2706af65d9ac75ff92c886f9359a3d07ef4..08abb0b9bd2731f14b5033928e1ec1296f762055 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 bf2e67731d92183f24cad5089f373509dad15dc8..a921f4cf9a26e7ff533f4068e49dc4e5db771503 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 5326ae27460bcc3ccb8e95ab58cb39cc5e1b7581..de9230eb86a05da8865ed8d9166b11481c0d57e8 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 587793828eb3ad51da5d178ad60a92fb2610309a..8b357f9b7c373b520cd0553c36b5e21063745523 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 98c15767a0a0458aabf65d2eb196c46082369758..3c550deacd5502725f8af08732903a045b5ad823 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 7a467d675a4815cd3d74a9b3b9f04b752b1dfbdb..4ff5ed43c54ca63d3cccd3ae948028fa59a67477 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 40bc935195c8f8061fc98696bf7994ff98047c71..4c5477ef568990941c7462a039b7456d4a1e6549 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 da73bfd1ebc7341455dcbc369cd7555951f6dff2..acf0053cc6a7e9b5ecf8cc68d84b0e8711109508 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 5bf8bb10f0d6d22407848409f3b3957407f5312c..eff00f867863ef116daeb76f49bc9d23b6440410 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 4681c6b6be69c8add14d1b3d1304ef29cc60fc4e..85c56b3a3104aba6286d88a5ad4b6326df545cd9 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 4c743ff9c169bc15f69c4e4724edf57316fd4eda..594d308192aaf4267ba30ec35de29e34b09b4b27 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 8b88fa7914faff59d7b13fbc278f6c647d4bce40..f9ebdfa01b58b60caef9e5d26e119fb9c11b6a5f 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 854e113d32eb9685004f5564a33251229f69bec9..ec035542168aaaeade4170f7ddb3666466f1a24e 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 85984a58607e6b920751db265aacfee7b3e7b05b..3fef3acac9d22cd88508b73b2d150570e506a66c 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 d7473d8386ceca2cf57297ac733dc6e64beb69e1..73ddb9242a4dc34bc7df7e007ff232b1203a8bcd 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 41c6a7ccbf6369d3ef4070bd2df2e90d74681c40..aa0ea197c381b48dd270adde49367d4efd33c201 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 7ddf9fe6fb8690cb642d692e83c51813a990ca2c..ce0ee3b31731bfa24fb89b7cbc4fd748a5451cad 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 7d1fa013b28a07809ebd75c989b964a59ba8172f..d1b5fcb88eb2c18d4b58e314a3b9d91ae2f78cbb 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 170d10041786593f418bea23bdb5a9ff91f141c9..162dc4e0d1697372b62f0220c5615bdd51379375 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 4054269348a15dc0e629841ee93f3ab9d129d149..59ee46889f9b059c23975b666a76b04244035b05 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 882661c969c1ea356ded8bca3904ed946ed0d558..c10a326d2e0e1480db86980d351ae2a7c082405c 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 8cd2a2b27323fb7e2272bb668dd63d9a1415567f..aaf478d9a94fd79af374d52ba6c9890a04f794cb 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 4433839b437a5abfae839be773d3f37d43510b17..a679e063c96df605169191c7572cf6feb207ebba 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 cae7d9f22ab2ad61c7e2373f8a709d0b01adde65..22062f47e462a4b8ff9332dab443f47995efa282 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 5611a9de50fc6c0706f7ecfcc54fafea66e963f2..27c92628f7cee9a2b59d0f2b28d349708666af6e 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 248e9b002d120e32fbe3801e38b6de23f0af3d9b..499a90f2958e224455a82a5fc7ddbb89b7ef18b8 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 ea958085bbeddb6b379d77fbae36e181e82e24dc..e7fcaa62dc16792dcbd1da6f76b99c3582212be0 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 e7f583c71e252ff1449f3d8e0815eefd3ec8d59b..67e1d50db0c6ed31b4fee41442ab4d474b123645 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 4c04e70d2eb6031299a8ddafe0568261ac9d3389..20d2f659ae19a968aab8acb7dd1753400d3649cf 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 bff2909bf5ba25fa704201a139c6a11ae40e2e1d..d283b8dc34fb9e7c7504496184f9b9cbc5fbbea3 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 331baa498893d4efeaab71532d30973d3cb0c16f..7a61b2d3ad04514b419ce91b7e3c1f495806729e 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 20901946346b7550faf428d1854a0bb0261394c2..0b42bae688c2f28b264707aa01bf88d2a49e35b4 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 a9eb97da186b196087a8f338a64ed26c9a9a859f..9fdb57cb02b498ad8323517995f1153976ee0650 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 e2262e584f08acb27820e19f37009c7c1f5af2cd..431ba46aa61192e70e001e01de72685efd528318 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 8de1b082485a2f2fab7a9b702122dae9f177a279..802cbb49c0672f83647efd696ae400335159f09b 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 cc9aea2fd761bf017f873f33dfdf5650d1ac8818..4034d49af45c08129864f287f4b3326b5070be8c 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 7644a1fa237983de769bd5297b6b3a35f825c409..0d92c3a0f3c5689a5832fe6df8be895c51f7bebd 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 bf384e1b44c73aea36013d9be3f6e38f6192b096..f17f0ad58d80e29f0872d32500ede9216b55e1e3 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 732de63e98065cc388ba850220df68d8a9c030f0..da50807b235725e3a4a2fe80c11c46e9f8472584 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 73934fc0939a2da7b7703f4ae57098801b4180ee..f71a3f04aeea0bfdf7071f01f8428a319ccf9ac7 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