[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