[Git][ghc/ghc][wip/jade/ast] Refactor FieldOcc vs AmbiguousFieldOcc with TTG
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Sep 16 09:54:22 UTC 2024
Rodrigo Mesquita pushed to branch wip/jade/ast at Glasgow Haskell Compiler / GHC
Commits:
5e11f34d by Jade at 2024-09-16T10:53:51+01:00
Refactor FieldOcc vs AmbiguousFieldOcc with TTG
Improves the design of FieldOcc vs AmbiguousFieldOcc, and removes a
dependency on `RdrName` from the Language.Haskell.* namespace (#21592).
The design:
* The FieldOcc constructor of FieldOcc always refers to an unambiguous
field occurrence.
* During renaming, a FieldOcc may be ambiguous and only be resolvable
during Typechecking
* Therefore, we extend (with TTG) `FieldOcc GhcRn` with a constructor
`AmbiguousFieldOcc` that constructs a definitely ambiguous `FieldOcc`.
* During typechecking, all ambiguous field occurrences must be resolved,
so the `AmbiguousFieldOcc` constructor no longer exists
See Note [Lifecycle of a FieldOcc]
Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita at gmail.com>
- - - - -
20 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Fixity.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -49,7 +49,6 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var
import GHC.Data.Bag
import GHC.Data.BooleanFormula (LBooleanFormula)
-import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Utils.Outputable
@@ -653,7 +652,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
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -240,4 +240,4 @@ instance Outputable NoExtField where
ppr _ = text "NoExtField"
instance Outputable DataConCantHappen where
- ppr = dataConCantHappen
\ No newline at end of file
+ ppr = dataConCantHappen
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -544,12 +544,7 @@ deriving instance Data (ConDeclField GhcTc)
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 Data AmbiguousFieldOcc
-- deriving instance (DataId name) => Data (ImportDecl name)
deriving instance Data (ImportDecl GhcPs)
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -37,7 +37,6 @@ module GHC.Hs.Pat (
HsRecUpdField, LHsRecUpdField,
RecFieldsDotDot(..),
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
- hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
mkPrefixConPat, mkCharLitPat, mkNilPat,
@@ -335,16 +334,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
-
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -102,7 +102,7 @@ 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 (HsRecSel _ (FieldOcc _ id)) = idType (unLoc id)
hsExprType (HsOverLabel v _ _) = dataConCantHappen v
hsExprType (HsIPVar v _) = dataConCantHappen v
hsExprType (HsOverLit _ lit) = overLitType lit
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -58,10 +58,9 @@ module GHC.Hs.Type (
HsConDetails(..), noTypeArgs,
FieldOcc(..), LFieldOcc, mkFieldOcc,
- AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,
- ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName,
- selectorAmbiguousFieldOcc,
- unambiguousFieldOcc, ambiguousFieldOcc,
+ fieldOccRdrName, fieldOccLRdrName,
+ AmbiguousFieldOcc(..),
+ ambiguousFieldOccRdrName,
OpName(..),
@@ -108,7 +107,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 )
@@ -1040,59 +1038,94 @@ also forbids them in types involved with `deriving`:
FieldOcc
* *
************************************************************************
--}
-type instance XCFieldOcc GhcPs = NoExtField
-type instance XCFieldOcc GhcRn = Name
-type instance XCFieldOcc GhcTc = Id
+Note [Lifecycle of a FieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A field occurrence (FieldOcc) has a slightly special lifecycle because field
+occurrences may be deemed /ambiguous/ during renaming. Ambiguous field
+occurrences can only be resolved during typechecking (since we do type-directed
+disambiguation). To accommodate the fact that we may be unable to produce a
+`Name` for a `FieldOcc` during renaming, `FieldOcc` is extended with
+`AmbiguousFieldOcc` during renaming. Here's the life cycle:
-type instance XXFieldOcc (GhcPass _) = DataConCantHappen
+* The `FieldOcc` constructor of the `FieldOcc` type always refers to an
+ unambiguous field occurrence. We parse field occurrences into `FieldOcc`.
-mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc noExtField rdr
+* During renaming, a FieldOcc may be ambiguous and only be resolvable
+ during typechecking. To construct an /ambiguous/ `FieldOcc GhcRn`, we use the
+ extension point for constructors, which is instanced with `AmbiguousFieldOcc`:
+ (XFieldOcc . Ambiguous) :: FieldOcc GhcRn
-type instance XUnambiguous GhcPs = NoExtField
-type instance XUnambiguous GhcRn = Name
-type instance XUnambiguous GhcTc = Id
+* During typechecking, all ambiguous field occurrences must be resolved. We
+ statically guarantee this by making it impossible to construct a `FieldOcc
+ GhcTc` with an ambiguous name:
-type instance XAmbiguous GhcPs = NoExtField
-type instance XAmbiguous GhcRn = NoExtField
-type instance XAmbiguous GhcTc = Id
+ type instance XXFieldOcc GhcTc = DataConCantHappen
-type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen
+Note that throughout this lifecycle, we preserve the `RdrName` the user
+originally wrote in the extension point during renaming and typechecking.
+-}
-instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
- ppr = ppr . ambiguousFieldOccRdrName
+-- | Ambiguous Field Occurrence
+--
+-- Represents an *occurrence* of a field that is definiely
+-- 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 typechecker (for
+-- ambiguous occurrences).
+--
+-- Unambiguous field occurrences should be stored in the proper FieldOcc datacon of FieldOcc.
+--
+-- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat".
+-- See Note [Located RdrNames] in "GHC.Hs.Expr".
+newtype AmbiguousFieldOcc
+ = Ambiguous (LocatedN RdrName)
-instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
- pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName
- pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName
+type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field
+type instance XCFieldOcc GhcRn = RdrName
+type instance XCFieldOcc GhcTc = RdrName
-instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where
- pprInfixOcc = pprInfixOcc . unLoc
- pprPrefixOcc = pprPrefixOcc . unLoc
+type instance XXFieldOcc GhcPs = DataConCantHappen
+type instance XXFieldOcc GhcRn = AmbiguousFieldOcc
+type instance XXFieldOcc GhcTc = DataConCantHappen
-mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr
+--------------------------------------------------------------------------------
-ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName
-ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName
+mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
+mkFieldOcc rdr = FieldOcc noExtField rdr
-ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName
-ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr
-ambiguousFieldOccLRdrName (Ambiguous _ rdr) = 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
+
+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
+ XFieldOcc (Ambiguous l) -> l
+ GhcTc ->
+ let (L l _) = foLabel fo
+ in L l (foExt fo)
+
+instance Outputable AmbiguousFieldOcc where
+ ppr = ppr . ambiguousFieldOccRdrName
-selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
-selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
+instance OutputableBndr AmbiguousFieldOcc where
+ pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName
+ pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName
-unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
-unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
+instance OutputableBndr (Located AmbiguousFieldOcc) where
+ pprInfixOcc = pprInfixOcc . unLoc
+ pprPrefixOcc = pprPrefixOcc . unLoc
-ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
+ambiguousFieldOccRdrName :: AmbiguousFieldOcc -> RdrName
+ambiguousFieldOccRdrName (Ambiguous rdr) = unLoc rdr
{-
************************************************************************
@@ -1210,14 +1243,14 @@ 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
@@ -1282,7 +1315,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
@@ -1290,7 +1323,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))
@@ -1531,4 +1564,4 @@ 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
+type instance Anno AmbiguousFieldOcc = SrcSpanAnnA
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1435,7 +1435,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
-------------------
@@ -1677,7 +1677,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)
@@ -1688,7 +1688,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
{-
@@ -1864,5 +1864,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 }
=====================================
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 ]
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -477,7 +477,7 @@ 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@(HsRecSel _ (FieldOcc _ id)) = do freeVar (unLoc id); return e
addTickHsExpr e@(HsIPVar {}) = return e
addTickHsExpr e@(HsOverLit {}) = return e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -800,7 +800,7 @@ 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 AmbiguousFieldOcc
, Data (HsCmdTop (GhcPass p))
, Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
, Data (HsUntypedSplice (GhcPass p))
@@ -1461,23 +1461,19 @@ 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)]
+ XFieldOcc (Ambiguous (L nspan fld))
+ -> [ toHie $ C (RecField c rhs) (L (locA nspan) 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
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2665,7 +2665,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) $
@@ -2711,7 +2711,7 @@ mk_rec_fields fs (Just s) = HsRecFields { 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
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1508,8 +1508,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.
@@ -1603,10 +1603,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)
=====================================
compiler/GHC/Rename/Fixity.hs
=====================================
@@ -202,5 +202,6 @@ lookupFixityRn_help name
lookupTyFixityRn :: LocatedN Name -> RnM Fixity
lookupTyFixityRn = lookupFixityRn . unLoc
-lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n
+lookupFieldFixityRn :: FieldOcc GhcRn -> RnM (Maybe Fixity)
+lookupFieldFixityRn (FieldOcc _ n) = Just <$> lookupFixityRn (unLoc n)
+lookupFieldFixityRn _ = pure Nothing
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1302,7 +1302,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 rdr (L lr sel)
where
lbl = occNameFS $ rdrNameOcc rdr
sel = flSelector
@@ -1598,7 +1598,12 @@ lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp (NormalOp n) = lookupFixityRn n
lookupFixityOp NegateOp = lookupFixityRn negateName
lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u))
-lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
+lookupFixityOp (RecFldOp f) =
+ -- We could get rid of this panic by parametrising FieldOcc with (k ::
+ -- MaybeAmbiguous), say 'PossiblyAmbiguous | 'Unambiguous, and using
+ -- 'PossiblyAmbiguous only for record field updates... but seems overkill
+ fromMaybe (panic "lookupFixityOp: RecFldOp should not be ambiguous!") <$>
+ lookupFieldFixityRn f
-- Precedence-related error messages
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -717,7 +717,7 @@ 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 (HsRecSel _ f) = OccurrenceOfRecSel (foExt f)
exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l
exprCtOrigin (ExplicitList {}) = ListOrigin
exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -607,8 +607,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
@@ -934,9 +934,9 @@ zonkExpr (HsUnboundVar her occ)
ty' <- zonkTcTypeToTypeX ty
return (HER ref ty' u)
-zonkExpr (HsRecSel _ (FieldOcc v occ))
+zonkExpr (HsRecSel _ (FieldOcc occ (L l v)))
= do { v' <- zonkIdOcc v
- ; return (HsRecSel noExtField (FieldOcc v' occ)) }
+ ; return (HsRecSel noExtField (FieldOcc occ (L l v'))) }
zonkExpr (HsIPVar x _) = dataConCantHappen x
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1147,7 +1147,7 @@ cvtl e = wrapLA (cvt e)
; return $ mkRdrRecordCon c' (HsRecFields 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
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -460,13 +460,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
=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -323,7 +323,7 @@ type LHsRecUpdField p q = XRec p (HsRecUpdField p q)
type HsRecField p arg = HsFieldBind (LFieldOcc p) arg
-- | 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
--
@@ -392,11 +392,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
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -51,7 +51,6 @@ module Language.Haskell.Syntax.Type (
HsConDetails(..), noTypeArgs, conDetailsArity,
FieldOcc(..), LFieldOcc,
- AmbiguousFieldOcc(..), LAmbiguousFieldOcc,
mapHsOuterImplicit,
hsQTvExplicit,
@@ -63,7 +62,6 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice )
import Language.Haskell.Syntax.Extension
-import GHC.Types.Name.Reader ( RdrName )
import GHC.Core.DataCon( HsSrcBang(..) )
import GHC.Core.Type (Specificity)
import GHC.Types.Basic (Arity)
@@ -1286,38 +1284,20 @@ 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.
+--
+-- See Note [Lifecycle of a FieldOcc]
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)
-
-
{-
************************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e11f34d6f5a089e5c4659bdf20e715750e08120
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e11f34d6f5a089e5c4659bdf20e715750e08120
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240916/7ed71733/attachment-0001.html>
More information about the ghc-commits
mailing list