[Git][ghc/ghc][wip/amg/hasfield-2020] 3 commits: Minor fixes from code review
Adam Gundry
gitlab at gitlab.haskell.org
Sat Sep 12 20:00:24 UTC 2020
Adam Gundry pushed to branch wip/amg/hasfield-2020 at Glasgow Haskell Compiler / GHC
Commits:
b139f25f by Adam Gundry at 2020-09-12T15:55:17+01:00
Minor fixes from code review
- - - - -
5fef615b by Adam Gundry at 2020-09-12T16:01:54+01:00
Rename {FieldLabel,FieldLabelWithUpdate} -> {FieldLabelNoUpdater,FieldLabel}
- - - - -
fdff0fe1 by Adam Gundry at 2020-09-12T20:58:30+01:00
Update comments in response to review
- - - - -
28 changed files:
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Types/Avail.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/Name/Shape.hs
Changes:
=====================================
compiler/GHC/Core/ConLike.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Prelude
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Utils.Outputable
+import GHC.Types.FieldLabel
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Types.Name
@@ -103,9 +104,11 @@ conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn
-- | Names of fields used for selectors
-conLikeFieldLabels :: ConLike -> [FieldLabel]
-conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
-conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn
+conLikeFieldLabels :: ConLike -> [FieldLabelNoUpdater]
+conLikeFieldLabels (RealDataCon data_con) =
+ fieldLabelsWithoutUpdaters (dataConFieldLabels data_con)
+conLikeFieldLabels (PatSynCon pat_syn) =
+ patSynFieldLabels pat_syn
-- | Returns just the instantiated /value/ argument types of a 'ConLike',
-- (excluding dictionary args)
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -40,8 +40,7 @@ module GHC.Core.DataCon (
dataConOtherTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
- dataConFieldLabels, dataConFieldLabelsWithUpdates,
- dataConFieldType, dataConFieldType_maybe,
+ dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
dataConSrcBangs,
dataConSourceArity, dataConRepArity,
dataConIsInfix,
@@ -436,7 +435,7 @@ data DataCon
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
- dcFields :: [FieldLabelWithUpdate],
+ dcFields :: [FieldLabel],
-- Field labels for this constructor, in the
-- same order as the dcOrigArgTys;
-- length = 0 (if not a record) or dataConSourceArity.
@@ -942,8 +941,8 @@ mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> TyConRepName -- ^ TyConRepName for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
- -> [FieldLabelWithUpdate] -- ^ Field labels for the constructor,
- -- if it is a record, otherwise empty
+ -> [FieldLabel] -- ^ Field labels for the constructor,
+ -- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyCoVar] -- ^ Existentials.
-> [InvisTVBinder] -- ^ User-written 'TyVarBinder's.
@@ -1200,12 +1199,7 @@ dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
-- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels = fieldLabelsWithoutUpdates . dcFields
-
--- | The labels for the fields of this particular 'DataCon',
--- including the updater functions for each
-dataConFieldLabelsWithUpdates :: DataCon -> [FieldLabelWithUpdate]
-dataConFieldLabelsWithUpdates = dcFields
+dataConFieldLabels = dcFields
-- | Extract the type for any given labelled field of the 'DataCon'
dataConFieldType :: DataCon -> FieldLabelString -> Type
@@ -1218,7 +1212,7 @@ dataConFieldType con label = case dataConFieldType_maybe con label of
dataConFieldType_maybe :: DataCon -> FieldLabelString
-> Maybe (FieldLabel, Type)
dataConFieldType_maybe con label
- = find ((== label) . flLabel . fst) (dataConFieldLabels con `zip` (scaledThing <$> dcOrigArgTys con))
+ = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
=====================================
compiler/GHC/Core/DataCon.hs-boot
=====================================
@@ -4,7 +4,7 @@ import GHC.Prelude
import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder )
import GHC.Types.Name( Name, NamedThing )
import {-# SOURCE #-} GHC.Core.TyCon( TyCon )
-import GHC.Types.FieldLabel ( FieldLabel, FieldLabelWithUpdate )
+import GHC.Types.FieldLabel ( FieldLabel )
import GHC.Types.Unique ( Uniquable )
import GHC.Utils.Outputable ( Outputable, OutputableBndr )
import GHC.Types.Basic (Arity)
@@ -21,7 +21,6 @@ dataConUserTyVars :: DataCon -> [TyVar]
dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]
dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabelsWithUpdates :: DataCon -> [FieldLabelWithUpdate]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type]
dataConStupidTheta :: DataCon -> ThetaType
dataConFullSig :: DataCon
=====================================
compiler/GHC/Core/PatSyn.hs
=====================================
@@ -63,11 +63,10 @@ data PatSyn
psArgs :: [Type],
psArity :: Arity, -- == length psArgs
psInfix :: Bool, -- True <=> declared infix
- psFieldLabels :: [FieldLabel], -- List of fields for a
- -- record pattern synonym
- -- INVARIANT: either empty if no
- -- record pat syn or same length as
- -- psArgs
+
+ -- List of fields for a record pattern synonym
+ -- INVARIANT: either empty if no record pat syn or same length as psArgs
+ psFieldLabels :: [FieldLabelNoUpdater],
-- Universally-quantified type variables
psUnivTyVars :: [InvisTVBinder],
@@ -365,8 +364,8 @@ mkPatSyn :: Name
-> Type -- ^ Original result type
-> (Id, Bool) -- ^ Name of matcher
-> Maybe (Id, Bool) -- ^ Name of builder
- -> [FieldLabel] -- ^ Names of fields for
- -- a record pattern synonym
+ -> [FieldLabelNoUpdater] -- ^ Names of fields for
+ -- a record pattern synonym
-> PatSyn
-- NB: The univ and ex vars are both in TyBinder form and TyVar form for
-- convenience. All the TyBinders should be Named!
@@ -404,7 +403,7 @@ patSynArity = psArity
patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs
-patSynFieldLabels :: PatSyn -> [FieldLabel]
+patSynFieldLabels :: PatSyn -> [FieldLabelNoUpdater]
patSynFieldLabels = psFieldLabels
-- | Extract the type for any given labelled field of the 'DataCon'
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -27,7 +27,6 @@ module GHC.Core.TyCon(
-- ** Field labels
tyConFieldLabels, lookupTyConFieldLabel,
- tyConFieldLabelsWithUpdates,
-- ** Constructing TyCons
mkAlgTyCon,
@@ -147,7 +146,7 @@ import {-# SOURCE #-} GHC.Builtin.Types
, multiplicityTyCon
, vecCountTyCon, vecElemTyCon, liftedTypeKind )
import {-# SOURCE #-} GHC.Core.DataCon
- ( DataCon, dataConExTyCoVars, dataConFieldLabelsWithUpdates
+ ( DataCon, dataConExTyCoVars, dataConFieldLabels
, dataConTyCon, dataConFullSig
, isUnboxedSumCon )
@@ -1548,11 +1547,7 @@ primRepIsFloat _ = Just False
-- | The labels for the fields of this particular 'TyCon'
tyConFieldLabels :: TyCon -> [FieldLabel]
-tyConFieldLabels tc = fieldLabelsWithoutUpdates $ tyConFieldLabelsWithUpdates tc
-
-tyConFieldLabelsWithUpdates :: TyCon -> [FieldLabelWithUpdate]
-tyConFieldLabelsWithUpdates tc = dFsEnvElts $ tyConFieldLabelEnv tc
-
+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc
-- | The labels for the fields of this particular 'TyCon'
tyConFieldLabelEnv :: TyCon -> FieldLabelEnv
@@ -1561,7 +1556,7 @@ tyConFieldLabelEnv tc
| otherwise = emptyDFsEnv
-- | Look up a field label belonging to this 'TyCon'
-lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabelWithUpdate
+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl
-- | Make a map from strings to FieldLabels from all the data
@@ -1571,7 +1566,7 @@ fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl)
| fl <- dataConsFields (visibleDataCons rhs) ]
where
-- Duplicates in this list will be removed by 'mkFsEnv'
- dataConsFields dcs = concatMap dataConFieldLabelsWithUpdates dcs
+ dataConsFields dcs = concatMap dataConFieldLabels dcs
{-
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -178,6 +178,7 @@ import GHC.Unit
import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )
import GHC.Core.FamInstEnv
import GHC.Core ( CoreProgram, RuleBase, CoreRule )
+import GHC.Types.FieldLabel
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Var.Set
@@ -2208,7 +2209,7 @@ tyThingAvailInfo (ATyCon t)
Nothing -> [AvailTC n (n : map getName dcs) flds]
where n = getName t
dcs = tyConDataCons t
- flds = tyConFieldLabels t
+ flds = fieldLabelsWithoutUpdaters (tyConFieldLabels t)
tyThingAvailInfo (AConLike (PatSynCon p))
= map avail ((getName p) : map flSelector (patSynFieldLabels p))
tyThingAvailInfo t
=====================================
compiler/GHC/Hs/ImpExp.hs
=====================================
@@ -228,14 +228,16 @@ data IE pass
-- See Note [Located RdrNames] in GHC.Hs.Expr
| IEThingWith (XIEThingWith pass)
- (LIEWrappedName (IdP pass))
+ (LIEWrappedName (IdP pass)) -- Parent
IEWildcard
- [LIEWrappedName (IdP pass)]
- [XRec pass (FieldLbl () (IdP pass))]
- -- ^ Imported or exported Thing With given imported or exported
+ [LIEWrappedName (IdP pass)] -- Child methods/constructors, and
+ -- record fields (only in parser)
+ [XRec pass (FieldLbl () (IdP pass))] -- Child record fields (after renaming)
+ -- ^ Imported or exported Thing With given imported or exported children
--
- -- The thing is a Class/Type and the imported or exported things are
+ -- The thing is a Class/Type and the imported or exported children are
-- methods/constructors and record fields; see Note [IEThingWith]
+ --
-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',
-- 'GHC.Parser.Annotation.AnnClose',
-- 'GHC.Parser.Annotation.AnnComma',
@@ -271,18 +273,45 @@ data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
{-
Note [IEThingWith]
~~~~~~~~~~~~~~~~~~
+IEThingWith represents a parent type constructor or class together with its
+children imported or exported along with it. There are two lists of children:
+
+ * [LIEWrappedName (IdP pass)] - always contains data constructors or class
+ methods, and prior to renaming contains record fields;
+
+ * [XRec pass (FieldLbl () (IdP pass))] - empty prior to renaming, then after
+ renaming contains record fields identified by their selectors.
+
+We need to store a FieldLbl, because we need the flLabel for pretty-printing the
+right field (we don't want to show the internal selector name), and we need the
+flSelector to uniquely identify the field in the renamer. We do not need the
+updater name (see Note [Updater names] in GHC.Types.FieldLabel).
-A definition like
+For example, a definition like
module M ( T(MkT, x) ) where
data T = MkT { x :: Int }
-gives rise to
+gives rise to (in the parser):
+
+ IEThingWith noExtField T NoIEWildcard [MkT,x] []
+
+but the renamer moves record fields from the general list of children to the
+list of field labels, giving one of these instead:
+
+ (without DuplicateRecordFields):
+ IEThingWith noExtField T NoIEWildcard [MkT] [FieldLabel "x" False () x]
+
+ (with DuplicateRecordFields):
+ IEThingWith noExtField T NoIEWildcard [MkT] [FieldLabel "x" True () $sel:x:MkT]
- IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields)
- IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields)
+See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details
+about how different FieldLabels are produced depending on the state of the
+DuplicateRecordFields extension.
-See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details.
+It might be better to move the list of field labels to the extension point, so
+that it is absent in GhcPs but present from GhcRn onwards. At the moment we
+simply maintain the invariant that the parser always produces an empty list.
-}
ieName :: IE (GhcPass p) -> IdP (GhcPass p)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2027,6 +2027,6 @@ instance ToHie (IEContext (LIEWrappedName Name)) where
instance ToHie (IEContext (Located (FieldLbl () Name))) where
toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
- FieldLabel _ _ _ n ->
+ FieldLabel { flSelector = n } ->
[ toHie $ C (IEThing c) $ L span n
]
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -554,7 +554,7 @@ tyConToIfaceDecl env tycon
ifConArgTys =
map (\(Scaled w t) -> (tidyToIfaceType con_env2 w
, (tidyToIfaceType con_env2 t))) arg_tys,
- ifConFields = dataConFieldLabelsWithUpdates data_con,
+ ifConFields = dataConFieldLabels data_con,
ifConStricts = map (toIfaceBang con_env2)
(dataConImplBangs data_con),
ifConSrcStricts = map toIfaceSrcBang
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -245,25 +245,25 @@ rnAvailInfo (AvailTC n ns fs) = do
-- is. But for the availNames they MUST be exported, so they
-- will rename fine.
ns' <- mapM rnIfaceGlobal ns
- fs' <- mapM rnFieldLabel fs
+ fs' <- mapM rnFieldLabelNoUpdater fs
case ns' ++ map flSelector fs' of
[] -> panic "rnAvailInfoEmpty AvailInfo"
(rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
n' <- setNameModule (Just (nameModule rep)) n
return (AvailTC n' ns' fs')
-rnFieldLabel :: Rename FieldLabel
-rnFieldLabel (FieldLabel l b () sel) = do
+rnFieldLabelNoUpdater :: Rename FieldLabelNoUpdater
+rnFieldLabelNoUpdater fl@(FieldLabel { flSelector = sel }) = do
sel' <- rnIfaceGlobal sel
- return (FieldLabel l b () sel')
+ return (fl { flSelector = sel' })
-rnFieldLabelWithUpdate :: Rename FieldLabelWithUpdate
-rnFieldLabelWithUpdate (FieldLabel l b upd sel) = do
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel fl@(FieldLabel { flUpdate = upd, flSelector = sel }) = do
-- The selector appears in the AvailInfo, so it gets renamed normally, but
-- the updater does not so it is a "never-exported TyThing".
upd' <- rnIfaceNeverExported upd
sel' <- rnIfaceGlobal sel
- return (FieldLabel l b upd' sel')
+ return (fl { flUpdate = upd', flSelector = sel' })
@@ -574,7 +574,7 @@ rnIfaceConDecl d = do
con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
con_ctxt <- mapM rnIfaceType (ifConCtxt d)
con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d)
- con_fields <- mapM rnFieldLabelWithUpdate (ifConFields d)
+ con_fields <- mapM rnFieldLabel (ifConFields d)
let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
rnIfaceBang bang = pure bang
con_stricts <- mapM rnIfaceBang (ifConStricts d)
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -173,7 +173,7 @@ data IfaceDecl
ifPatReqCtxt :: IfaceContext,
ifPatArgs :: [IfaceType],
ifPatTy :: IfaceType,
- ifFieldLabels :: [FieldLabel] }
+ ifFieldLabels :: [FieldLabelNoUpdater] }
-- See also 'ClassBody'
data IfaceClassBody
@@ -262,7 +262,9 @@ data IfaceConDecl
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [(IfaceMult, IfaceType)],-- Arg types
- ifConFields :: [FieldLabelWithUpdate], -- ...ditto... (field labels)
+ ifConFields :: [FieldLabel], -- Field labels: we carefully serialise
+ -- the Names of the selector and updater,
+ -- so there is no doubt when deserialising
ifConStricts :: [IfaceBang],
-- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
@@ -1237,7 +1239,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
zipWith maybe_show_label fields tys_w_strs
- maybe_show_label :: FieldLabelWithUpdate -> (IfaceBang, IfaceType) -> Maybe SDoc
+ maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
maybe_show_label lbl bty
| showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ
<+> dcolon <+> pprFieldArgTy bty)
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Rename.Env (
lookupSigCtxtOccRn,
lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
- lookupConstructorFields, lookupDataConFieldsWithUpdates,
+ lookupConstructorFields, lookupDataConFields,
lookupGreAvailRn,
@@ -386,8 +386,8 @@ lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrenc
= lookupLocatedOccRn tc_rdr
-----------------------------------------------
-lookupConstructorFields :: Name -> RnM [FieldLabel]
--- Look up the fields of a given constructor
+lookupConstructorFields :: Name -> RnM [FieldLabelNoUpdater]
+-- Look up the fields of a given data constructor or pattern synonym
-- * For constructors from this module, use the record field env,
-- which is itself gathered from the (as yet un-typechecked)
-- data type decls
@@ -395,13 +395,15 @@ lookupConstructorFields :: Name -> RnM [FieldLabel]
-- * For constructors from imported modules, use the *type* environment
-- since imported modules are already compiled, the info is conveniently
-- right there
+--
+-- Returns field labels without updaters (pattern synonyms don't have them).
lookupConstructorFields con_name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod con_name then
do { field_env <- getRecFieldEnv
; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
- ; return (fieldLabelsWithoutUpdates
+ ; return (fieldLabelsWithoutUpdaters
(lookupNameEnv field_env con_name `orElse` [])) }
else
do { con <- tcLookupConLike con_name
@@ -410,8 +412,8 @@ lookupConstructorFields con_name
-- | Look up the fields of a given *data* constructor, like
-- 'lookupConstructorFields', but include the names of the update functions.
-lookupDataConFieldsWithUpdates :: Name -> RnM [FieldLabelWithUpdate]
-lookupDataConFieldsWithUpdates con_name
+lookupDataConFields :: Name -> RnM [FieldLabel]
+lookupDataConFields con_name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod con_name then
do { field_env <- getRecFieldEnv
@@ -420,7 +422,7 @@ lookupDataConFieldsWithUpdates con_name
else
do { con <- tcLookupDataCon con_name
; traceTc "lookupCF 2" (ppr con)
- ; return (dataConFieldLabelsWithUpdates con) } }
+ ; return (dataConFieldLabels con) } }
-- In CPS style as `RnM r` is monadic
@@ -644,13 +646,17 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
FoundFL (fldParentToFieldLabel gre_name mfs)
_ -> FoundName gre_par gre_name
- fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+ fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabelNoUpdater
fldParentToFieldLabel name mfs =
- case mfs of
- Nothing ->
- let fs = occNameFS (nameOccName name)
- in FieldLabel fs False () name
- Just fs -> FieldLabel fs True () name
+ FieldLabel { flLabel = fs
+ , flIsOverloaded = is_overloaded
+ , flUpdate = ()
+ , flSelector = name
+ }
+ where
+ (fs, is_overloaded) = case mfs of
+ Nothing -> (occNameFS (nameOccName name), False)
+ Just fs -> (fs, True)
-- Called when we find no matching GREs after disambiguation but
-- there are three situations where this happens.
@@ -760,7 +766,7 @@ data ChildLookupResult
SDoc -- How to print the name
[Name] -- List of possible parents
| FoundName Parent Name -- We resolved to a normal name
- | FoundFL FieldLabel -- We resolved to a FL
+ | FoundFL FieldLabelNoUpdater -- We resolved to a field
-- | Specialised version of msum for RnM ChildLookupResult
combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1136,7 +1136,9 @@ GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an
argument, build a map and look them up.
-}
-rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
+rnConDeclFields :: HsDocContext
+ -> [FieldLabelNoUpdater]
+ -> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
-- Also called from GHC.Rename.Module
-- No wildcards can appear in record fields
@@ -1146,7 +1148,9 @@ rnConDeclFields ctxt fls fields
env = mkTyKiEnv ctxt TypeLevel RnTypeBody
fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
-rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
+rnField :: FastStringEnv FieldLabelNoUpdater
+ -> RnTyKiEnv
+ -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
= do { let new_names = map (fmap lookupField) names
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2308,13 +2308,13 @@ extendPatSynEnv val_decls local_fix_env thing = do {
final_gbl_env = gbl_env { tcg_field_env = field_env' }
; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where
- new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabelWithUpdate])]
+ new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
new_ps _ = panic "new_ps"
new_ps' :: LHsBindLR GhcPs GhcPs
- -> [(Name, [FieldLabelWithUpdate])]
- -> TcM [(Name, [FieldLabelWithUpdate])]
+ -> [(Name, [FieldLabel])]
+ -> TcM [(Name, [FieldLabel])]
new_ps' bind names
| (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
, psb_args = RecCon as }))) <- bind
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -736,7 +736,7 @@ getLocalNonValBinders fixity_env
; return (avail nm) }
new_tc :: Bool -> LTyClDecl GhcPs
- -> RnM (AvailInfo, [(Name, [FieldLabelWithUpdate])])
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
new_tc overload_ok tc_decl -- NOT for type/data instances
= do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
@@ -744,14 +744,14 @@ getLocalNonValBinders fixity_env
; let fld_env = case unLoc tc_decl of
DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
_ -> []
- ; return (AvailTC main_name names (fieldLabelsWithoutUpdates flds'), fld_env) }
+ ; return (AvailTC main_name names (fieldLabelsWithoutUpdaters flds'), fld_env) }
-- Calculate the mapping from constructor names to fields, which
-- will go in tcg_field_env. It's convenient to do this here where
-- we are working with a single datatype definition.
- mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabelWithUpdate]
- -> [(Name, [FieldLabelWithUpdate])]
+ mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]
+ -> [(Name, [FieldLabel])]
mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
where
find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
@@ -778,7 +778,7 @@ getLocalNonValBinders fixity_env
where lbl = occNameFS (rdrNameOcc rdr)
new_assoc :: Bool -> LInstDecl GhcPs
- -> RnM ([AvailInfo], [(Name, [FieldLabelWithUpdate])])
+ -> RnM ([AvailInfo], [(Name, [FieldLabel])])
new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
-- type instances don't bind new names
@@ -813,7 +813,7 @@ getLocalNonValBinders fixity_env
pure (avails, concat fldss)
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
- -> RnM (AvailInfo, [(Name, [FieldLabelWithUpdate])])
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
HsIB { hsib_body = ti_decl }})
= do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
@@ -822,16 +822,16 @@ getLocalNonValBinders fixity_env
; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
; let avail = AvailTC (unLoc main_name)
sub_names
- (fieldLabelsWithoutUpdates flds')
+ (fieldLabelsWithoutUpdaters flds')
-- main_name is not bound here!
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
- -> RnM (AvailInfo, [(Name, [FieldLabelWithUpdate])])
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
-newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabelWithUpdate
+newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
= do { selName <- newTopSrcBinder $ L loc $ field
@@ -1063,6 +1063,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
, [])
IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
+ -- See Note [IEThingWith] in GHC.Hs.ImpExp for why rdr_fs is null
ASSERT2(null rdr_fs, ppr rdr_fs) do
(name, avail, mb_parent)
<- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)
@@ -1197,9 +1198,11 @@ mkChildEnv gres = foldr add emptyNameEnv gres
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
-lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]
+lookupChildren :: forall a b .
+ [Either Name (FieldLbl a b)]
+ -> [LIEWrappedName RdrName]
-> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed
- ([Located Name], [Located FieldLabel])
+ ([Located Name], [Located (FieldLbl a b)])
-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
-- corresponding Name all_kids, if the former exists
-- The matching is done by FastString, not OccName, so that
@@ -1211,14 +1214,14 @@ lookupChildren all_kids rdr_items
| null fails
= Succeeded (fmap concat (partitionEithers oks))
-- This 'fmap concat' trickily applies concat to the /second/ component
- -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])
+ -- of the pair, whose type is ([Located Name], [[Located (FieldLbl a b)]])
| otherwise
= Failed fails
where
mb_xs = map doOne rdr_items
fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
oks = [ ok | Succeeded ok <- mb_xs ]
- oks :: [Either (Located Name) [Located FieldLabel]]
+ oks :: [Either (Located Name) [Located (FieldLbl a b)]]
doOne item@(L l r)
= case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Utils.Error
+import GHC.Types.FieldLabel
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Unit.Module
@@ -32,7 +33,6 @@ import GHC.Driver.Types
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.ConLike
-import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Data.Maybe
import GHC.Types.Unique.Set
@@ -377,7 +377,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
-> RnM (Located Name, [LIEWrappedName Name], [Name],
- [Located FieldLabel])
+ [Located FieldLabelNoUpdater])
lookup_ie_with (L l rdr) sub_rdrs
= do name <- lookupGlobalOccRn $ ieWrappedName rdr
(non_flds, flds) <- lookupChildrenExport name sub_rdrs
@@ -388,7 +388,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
, flds)
lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
- -> RnM (Located Name, [Name], [FieldLabel])
+ -> RnM (Located Name, [Name], [FieldLabelNoUpdater])
lookup_ie_all ie (L l rdr) =
do name <- lookupGlobalOccRn $ ieWrappedName rdr
let gres = findChildren kids_env name
@@ -420,10 +420,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
-classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabelNoUpdater])
classifyGREs = partitionEithers . map classifyGRE
-classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabelNoUpdater
classifyGRE gre = case gre_par gre of
FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False () n)
FldParent _ (Just lbl) -> Right (FieldLabel lbl True () n)
@@ -499,7 +499,7 @@ If the module has NO main function:
lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
- -> RnM ([LIEWrappedName Name], [Located FieldLabel])
+ -> RnM ( [LIEWrappedName Name], [Located FieldLabelNoUpdater] )
lookupChildrenExport spec_parent rdr_items =
do
xs <- mapAndReportM doOne rdr_items
@@ -515,7 +515,7 @@ lookupChildrenExport spec_parent rdr_items =
| otherwise = [ns]
-- Process an individual child
doOne :: LIEWrappedName RdrName
- -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
+ -> RnM (Either (LIEWrappedName Name) (Located FieldLabelNoUpdater))
doOne n = do
let bareName = (ieWrappedName . unLoc) n
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate
+import GHC.Types.FieldLabel
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Name
@@ -1170,7 +1171,7 @@ tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of
traceTc "find_field" (ppr pat_ty <+> ppr extras)
ASSERT( null extras ) (return pat_ty)
- field_tys :: [(FieldLabel, Scaled TcType)]
+ field_tys :: [(FieldLabelNoUpdater, Scaled TcType)]
field_tys = zip (conLikeFieldLabels con_like) arg_tys
-- Don't use zipEqual! If the constructor isn't really a record, then
-- dataConFieldLabels will be empty (and each field in the pattern
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -676,7 +676,7 @@ matchHasField dflags short_cut clas tys
-- x should be a field of r
, Just fl <- lookupTyConFieldLabel x r_tc
-- the field selector should be in scope
- , Just gre <- lookupGRE_FieldLabel rdr_env (fieldLabelWithoutUpdate fl)
+ , Just gre <- lookupGRE_FieldLabel rdr_env fl
-> do { upd_id <- tcLookupId (flUpdate fl)
; (tv_prs, preds, upd_ty) <- tcInstType newMetaTyVars upd_id
@@ -704,7 +704,7 @@ matchHasField dflags short_cut clas tys
-- Do not generate an instance if the updater cannot be
-- defined for the field and hence is (). (See Note
- -- [Missing record updaters] in GHC.Tc.TyCl.Utils.)
+ -- [Naughty record updaters] in GHC.Tc.TyCl.Utils.)
; if not (upd_ty `eqType` unitTy)
then do { addUsedGRE True gre
; return OneInst { cir_new_theta = theta
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2042,7 +2042,7 @@ runTcInteractive hsc_env thing_inside
-- Putting the dfuns in the type_env
-- is just to keep Core Lint happy
- con_fields = [ (dataConName c, dataConFieldLabelsWithUpdates c)
+ con_fields = [ (dataConName c, dataConFieldLabels c)
| ATyCon t <- top_ty_things
, c <- tyConDataCons t ]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Tc.Utils.TcMType
import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon )
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
-import GHC.Rename.Env( lookupDataConFieldsWithUpdates )
+import GHC.Rename.Env( lookupDataConFields )
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
@@ -3201,7 +3201,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
do { ctxt <- tcHsMbContext hs_ctxt
; let exp_kind = getArgExpKind new_or_data res_kind
; btys <- tcConArgs exp_kind hs_args
- ; field_lbls <- lookupDataConFieldsWithUpdates (unLoc name)
+ ; field_lbls <- lookupDataConFields (unLoc name)
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, field_lbls, stricts)
}
@@ -3289,7 +3289,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
; btys <- tcConArgs exp_kind hs_args
; let (arg_tys, stricts) = unzip btys
- ; field_lbls <- lookupDataConFieldsWithUpdates name
+ ; field_lbls <- lookupDataConFields name
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
}
; imp_tvs <- zonkAndScopedSort imp_tvs
=====================================
compiler/GHC/Tc/TyCl/Build.hs
=====================================
@@ -105,7 +105,7 @@ buildDataCon :: FamInstEnvs
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make
- -> [FieldLabelWithUpdate] -- Field labels
+ -> [FieldLabel] -- Field labels
-> [TyVar] -- Universals
-> [TyCoVar] -- Existentials
-> [InvisTVBinder] -- User-written 'TyVarBinder's
@@ -176,7 +176,7 @@ buildPatSyn :: Name -> Bool
-> ([InvisTVBinder], ThetaType) -- ^ Ex and prov
-> [Type] -- ^ Argument types
-> Type -- ^ Result type
- -> [FieldLabel] -- ^ Field labels for
+ -> [FieldLabelNoUpdater] -- ^ Field labels for
-- a record pattern synonym
-> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -763,7 +763,7 @@ tcPatSynMatcher (L loc name) lpat
; return ((matcher_id, is_unlifted), matcher_bind) }
mkPatSynRecSelBinds :: PatSyn
- -> [FieldLabel] -- ^ Visible field labels
+ -> [FieldLabelNoUpdater] -- ^ Visible field labels
-> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds ps fields
= [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -851,11 +851,11 @@ mkRecSelBinds :: [TyCon] -> TcM [(Id, LHsBind GhcRn)]
mkRecSelBinds tycons
= concatMapM mkRecSelAndUpd [ (tc,fld)
| tc <- tycons
- , fld <- tyConFieldLabelsWithUpdates tc ]
+ , fld <- tyConFieldLabels tc ]
-- | Create both a record selector and a record updater binding for a field in a
-- TyCon. See Note [Record updaters]
-mkRecSelAndUpd :: (TyCon, FieldLabelWithUpdate) -> TcM [(Id, LHsBind GhcRn)]
+mkRecSelAndUpd :: (TyCon, FieldLabel) -> TcM [(Id, LHsBind GhcRn)]
mkRecSelAndUpd (tycon, fl) = do
-- Make fresh names x1..xN for binding all the fields in the TyCon
-- (including the one being updated), and a fresh name y for binding the new
@@ -871,14 +871,14 @@ mkRecSelAndUpd (tycon, fl) = do
-- | Create a record selector binding, but no updater. This is used for fields
-- in pattern synonyms. See Note [No updaters for pattern synonyms]
-mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
+mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabelNoUpdater
-> (Id, LHsBind GhcRn)
mkOneRecordSelector all_cons idDetails fl
= fst $ mkRecordSelectorAndUpdater all_cons idDetails (fl { flUpdate = oops }) oops oops
where
oops = error "mkOneRecordSelector: poked a field needed only for updaters"
-mkRecordSelectorAndUpdater :: [ConLike] -> RecSelParent -> FieldLabelWithUpdate
+mkRecordSelectorAndUpdater :: [ConLike] -> RecSelParent -> FieldLabel
-> NameEnv Name -> Name
-> ((Id, LHsBind GhcRn), (Id, LHsBind GhcRn))
mkRecordSelectorAndUpdater all_cons idDetails fl x_vars y_var =
@@ -911,7 +911,7 @@ mkRecordSelectorAndUpdater all_cons idDetails fl x_vars y_var =
conLikeUserTyVarBinders con1
data_tv_set= tyCoVarsOfTypes inst_tys
- -- See Note [Naughty record selectors] and Note [Missing record updaters]
+ -- See Note [Naughty record selectors] and Note [Naughty record updaters]
is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
no_updater = is_naughty
|| not (isTauTy field_ty)
@@ -1010,7 +1010,9 @@ mkRecordSelectorAndUpdater all_cons idDetails fl x_vars y_var =
-- Used for both pattern and record construction, to create
-- { fld1 = k fld1, .., fldN = k fldN }
-- where k gives the hsRecFieldArg for each field
- rec_fields :: ConLike -> (FieldLabel -> a) -> HsRecFields GhcRn (Located a)
+ rec_fields :: ConLike
+ -> (FieldLabelNoUpdater -> a)
+ -> HsRecFields GhcRn (Located a)
rec_fields con k = HsRecFields { rec_flds = map rec_field
(conLikeFieldLabels con)
, rec_dotdot = Nothing }
@@ -1266,38 +1268,47 @@ Note that:
scope.
* The Name of each updater is stored alongside that of the selector in the
- 'FieldLabelWithUpdate's in each 'DataCon'.
+ 'FieldLabel's in each 'DataCon'.
* Renamed-syntax bindings for both a selector and an updater for each field are
produced by mkRecordSelectorAndUpdater; these bindings are then type-checked
- together normally. We produce renamed syntax rather than attempting to
- generate Core terms directly because the corresponding Core terms are rather
- complex (e.g. because of worker-wrapper).
+ together normally.
+
+ * We produce renamed syntax rather than attempting to generate Core terms
+ directly because the corresponding Core terms are rather complex. This is
+ because they include the code necessary to evaluate strict fields, and to
+ pack/unpack UNPACKed fields, i.e. everything that is handled by the
+ constructor wrapper, and by dataConBoxer when desugaring pattern matching.
+ See Note [Generating updaters in advance].
* In some cases we may not be able to generate an updater and will bind its
name to () instead, even if we can generate the corresponding selector. See
- Note [Missing record updaters].
+ Note [Naughty record updaters].
-Note [Missing record updaters]
+Note [Naughty record updaters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are a few cases in which we cannot generate an updater for a field:
- * The field has an existential tyvar, e.g.
+1. The field has an existential tyvar, e.g.
data T = forall a . MkT { foo :: a }
This is the same as for selectors (see Note [Naughty record selectors]).
- * The field is higher-rank, e.g.
+2. The field is higher-rank, e.g.
data T = MkT { foo :: forall a . a -> a }
as this would require an impredicative instantiation of (,).
- * The field kind is not Type, e.g.
+3. The field kind is not Type, e.g.
data T = MkT { foo :: Addr# }
as this would require an ill-kinded application of (,).
-If any of these apply, we bind $upd:foo:MkT to (), just like for naughty
-record selectors. This means that when trying to generate a HasField instance,
-we need to check if the updater is () and if so give up.
+Every field with a naughty record selector also has a naughty record updater
+(because the condition 1 is the same for both). However, some types will have a
+naughty updater but a regular selector (where conditions 2 or 3 apply).
+
+If any of these apply, we bind $upd:foo:MkT to (), just as a naughty record
+selector is bound to (). This means that when trying to generate a HasField
+instance, we need to check if the updater is () and if so give up.
Note [Generating updaters in advance]
@@ -1324,6 +1335,40 @@ For record pattern synonyms, we generate a selector function, but not an
updater. The updater function is not necessary because we do not solve HasField
constraints for fields defined by pattern synonyms.
+That is, given
+
+ pattern MkPair{x,y} = (x, y)
+
+you can use `x` as a "record selector" in an expression. But the constraint
+solver will not automatically solve constraints like `HasField "x" (a, b) a`, so
+you cannot directly use expressions such as `getField @"x" (True, False)` or
+`setField @"x" p False`, and RecordDotSyntax will not natively support record
+pattern synonyms.
+
+This can be worked around by the user user manually writing an explicit
+HasField instance, such as
+
+ instance HasField "x" (a,b) a where
+ hasField (x,y) = (\x' -> (x',y), x)
+
+which will be subject to the usual rules around orphan instances and the
+restrictions on when HasField instances can be defined (as described in
+Note [Validity checking of HasField instances] in GHC.Tc.Validity).
+
+We could imagine allowing record pattern synonyms to lead to automatic HasField
+constraint solving, but this potentially introduces incoherent HasField
+instances, because multiple pattern synonyms (in different modules) might use
+the same field name in the same type, and would even lead to e.g.
+
+ pattern Id{id} = id
+
+introducing an `id` field to *every* type!
+
+Given the possibility of incoherence, and the fact that a reasonable workaround
+exists, we do not currently solve HasField constraints for fields defined by
+pattern synonyms. And since we do not need updaters for anything other than
+solving HasField constraints, we do not generate them for pattern synonyms.
+
-}
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -98,7 +98,7 @@ import GHC.Core.TyCon ( TyCon, tyConKind )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.Lint ( lintAxioms )
import GHC.Types.Id ( idType, idName )
-import GHC.Types.FieldLabel ( FieldLabelWithUpdate )
+import GHC.Types.FieldLabel ( FieldLabel )
import GHC.Core.UsageEnv
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
@@ -640,7 +640,7 @@ tcVisibleOrphanMods tcg_env
instance ContainsModule TcGblEnv where
extractModule env = tcg_semantic_mod env
-type RecFieldEnv = NameEnv [FieldLabelWithUpdate]
+type RecFieldEnv = NameEnv [FieldLabel]
-- Maps a constructor name *in this module*
-- to the fields for that constructor.
-- This is used when dealing with ".." notation in record
=====================================
compiler/GHC/Types/Avail.hs
=====================================
@@ -64,7 +64,7 @@ data AvailInfo
Name -- ^ The name of the type or class
[Name] -- ^ The available pieces of type or class,
-- excluding field selectors.
- [FieldLabel] -- ^ The record fields of the type
+ [FieldLabelNoUpdater] -- ^ The record fields of the type
-- (see Note [Representing fields in AvailInfo]).
deriving ( Eq -- ^ Used when deciding if the interface has changed
@@ -174,7 +174,7 @@ availNonFldNames (Avail n) = [n]
availNonFldNames (AvailTC _ ns _) = ns
-- | Fields made available by the availability information
-availFlds :: AvailInfo -> [FieldLabel]
+availFlds :: AvailInfo -> [FieldLabelNoUpdater]
availFlds (AvailTC _ _ fs) = fs
availFlds _ = []
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -59,25 +59,27 @@ Of course, datatypes with no constructors cannot have any fields.
Note [Updater names]
~~~~~~~~~~~~~~~~~~~~
-As well as the name of the selector for a field label, we sometimes need to
-store the name of the updater, which is a pre-generated function for updating a
-sole field of a record. See Note [Record updaters] in GHC.Tc.TyCl.Utils, which
-describes how updaters are constructed and used.
+A record "updater" is a pre-generated function for updating a single field of a
+record, just as a selector is a pre-generated function for accessing a single
+field. See Note [Record updaters] in GHC.Tc.TyCl.Utils, which describes how
+updaters are constructed and used.
-However, in some circumstance we do not need the updater name:
+Field labels usually store both the name of the selector and the name of the
+updater. However, there are two cases in which we do not need the updater name,
+so we store the selector only:
* The renamer uses the selector name to uniquely identify the field, but the
updater name is irrelevant for renaming, so field labels with only selector
- names appear in AvailInfo and IE. (Arguably it might be better for the
- renamer not to rely on the selector name like this, but changing it would be
- a major effort.)
+ names appear in AvailInfo and IEThingWith. (Arguably it might be better for
+ the renamer not to rely on the selector name like this, but changing it would
+ be a major effort.)
* Record pattern synonyms do not have updaters, but they do contain field
labels. (See Note [No updaters for pattern synonyms] in GHC.Tc.TyCl.Utils.)
The FieldLbl type is parameterised over the representations of updater names and
selector names, so we can vary whether updater names are available
-(FieldLabelWithUpdate) or not (FieldLabel).
+(FieldLabel) or not (FieldLabelNoUpdater).
-}
@@ -92,10 +94,9 @@ module GHC.Types.FieldLabel
, FieldLabelEnv
, FieldLbl(..)
, FieldLabel
- , FieldLabelWithUpdate
+ , FieldLabelNoUpdater
, mkFieldLabelOccs
- , fieldLabelWithoutUpdate
- , fieldLabelsWithoutUpdates
+ , fieldLabelsWithoutUpdaters
)
where
@@ -116,16 +117,16 @@ import Data.Data
type FieldLabelString = FastString
-- | A map from labels to all the auxiliary information
-type FieldLabelEnv = DFastStringEnv FieldLabelWithUpdate
+type FieldLabelEnv = DFastStringEnv FieldLabel
--- | Representation of a field where we know the name of the selector function,
--- but not the updater.
-type FieldLabel = FieldLbl () Name
-
-- | Representation of a field where we know the names of both the selector and
-- updater functions.
-type FieldLabelWithUpdate = FieldLbl Name Name
+type FieldLabel = FieldLbl Name Name
+
+-- | Representation of a field where we know the name of the selector function,
+-- but not the updater.
+type FieldLabelNoUpdater = FieldLbl () Name
-- | Fields in an algebraic record type
data FieldLbl update_rep selector_rep = FieldLabel {
@@ -157,12 +158,12 @@ instance (Binary a, Binary b) => Binary (FieldLbl a b) where
-- | Drop the updater names from a field label (see Note [Updater names]).
-fieldLabelWithoutUpdate :: FieldLabelWithUpdate -> FieldLabel
-fieldLabelWithoutUpdate fl = fl { flUpdate = () }
+fieldLabelWithoutUpdater :: FieldLabel -> FieldLabelNoUpdater
+fieldLabelWithoutUpdater fl = fl { flUpdate = () }
-- | Drop the updater names from a list of field labels.
-fieldLabelsWithoutUpdates :: [FieldLabelWithUpdate] -> [FieldLabel]
-fieldLabelsWithoutUpdates = map fieldLabelWithoutUpdate
+fieldLabelsWithoutUpdaters :: [FieldLabel] -> [FieldLabelNoUpdater]
+fieldLabelsWithoutUpdaters = map fieldLabelWithoutUpdater
-- | Record selector OccNames are built from the underlying field name
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -753,7 +753,7 @@ availFromGRE (GRE { gre_name = me, gre_par = parent })
| otherwise -> avail me
FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]
-mkFieldLabel :: Name -> Maybe FastString -> FieldLabel
+mkFieldLabel :: Name -> Maybe FastString -> FieldLabelNoUpdater
mkFieldLabel me mb_lbl =
case mb_lbl of
Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me)
@@ -814,7 +814,7 @@ lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name env name
= lookupGRE_Name_OccName env name (nameOccName name)
-lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
+lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLbl a Name -> Maybe GlobalRdrElt
-- ^ Look for a particular record field selector in the environment, where the
-- selector name and field label may be different: the GlobalRdrEnv is keyed on
-- the label. See Note [Parents for record fields] for why this happens.
=====================================
compiler/GHC/Types/Name/Shape.hs
=====================================
@@ -185,14 +185,15 @@ substNameAvailInfo hsc_env env (AvailTC n ns fs) =
let mb_mod = fmap nameModule (lookupNameEnv env n)
in AvailTC (substName env n)
<$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
- <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+ <*> mapM (setNameFieldLabel hsc_env mb_mod) fs
--- | Set the 'Module' of a 'FieldSelector'
-setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
-setNameFieldSelector _ Nothing f = return f
-setNameFieldSelector hsc_env mb_mod (FieldLabel l b () sel) = do
+-- | Set the 'Module' of a 'FieldLabelNoUpdater'
+setNameFieldLabel :: HscEnv -> Maybe Module -> FieldLabelNoUpdater
+ -> IO FieldLabelNoUpdater
+setNameFieldLabel _ Nothing f = return f
+setNameFieldLabel hsc_env mb_mod fl@(FieldLabel {flSelector = sel }) = do
sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
- return (FieldLabel l b () sel')
+ return (fl { flSelector = sel' })
{-
************************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca5801f1157f0732e8b5656bc4bc636b4c08e06f...fdff0fe1834729148842ac0d7b94e68a9c916466
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca5801f1157f0732e8b5656bc4bc636b4c08e06f...fdff0fe1834729148842ac0d7b94e68a9c916466
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/20200912/25f10825/attachment-0001.html>
More information about the ghc-commits
mailing list