summaryrefslogtreecommitdiff
path: root/compiler/GHC/Hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Hs')
-rw-r--r--compiler/GHC/Hs/Decls.hs5
-rw-r--r--compiler/GHC/Hs/Expr.hs36
-rw-r--r--compiler/GHC/Hs/ImpExp.hs60
-rw-r--r--compiler/GHC/Hs/Instances.hs8
-rw-r--r--compiler/GHC/Hs/Pat.hs4
-rw-r--r--compiler/GHC/Hs/Type.hs20
-rw-r--r--compiler/GHC/Hs/Utils.hs250
7 files changed, 251 insertions, 132 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index fa62c6a49c..201adc5467 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -124,7 +124,6 @@ import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Core.Type
-import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour))
import GHC.Types.ForeignCall
import GHC.Unit.Module.Warnings (WarningTxt(..))
@@ -704,7 +703,7 @@ ppDataDefnHeader pp_hdr HsDataDefn
| isTypeDataDefnCons condecls = text "type"
| otherwise = empty
pp_ct = case mb_ct of
- Nothing -> empty
+ Nothing -> empty
Just ct -> ppr ct
pp_sig = case mb_sig of
Nothing -> empty
@@ -935,7 +934,7 @@ instDeclDataFamInsts inst_decls
do_one (L _ (TyFamInstD {})) = []
-- | Convert a 'NewOrData' to a 'TyConFlavour'
-newOrDataToFlavour :: NewOrData -> TyConFlavour
+newOrDataToFlavour :: NewOrData -> TyConFlavour tc
newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 621848920d..4a8abe8404 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -44,6 +44,7 @@ import GHC.Parser.Annotation
-- others:
import GHC.Tc.Types.Evidence
+import GHC.Types.Id.Info ( RecSelParent )
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Name.Set
@@ -52,7 +53,8 @@ import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Tickish (CoreTickish)
-import GHC.Core.ConLike
+import GHC.Types.Unique.Set (UniqSet)
+import GHC.Core.ConLike ( conLikeName, ConLike )
import GHC.Unit.Module (ModuleName)
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -74,6 +76,7 @@ import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
import Data.List (uncons)
+import Data.List.NonEmpty (NonEmpty)
import Data.Bifunctor (first)
{- *********************************************************************
@@ -324,6 +327,31 @@ type instance XRecordUpd GhcTc = DataConCantHappen
-- See [Handling overloaded and rebindable constructs],
-- and [Record Updates] in GHC.Tc.Gen.Expr.
+-- | Information about the parent of a record update:
+--
+-- - the parent type constructor or pattern synonym,
+-- - the relevant con-likes,
+-- - the field labels.
+data family HsRecUpdParent x
+
+data instance HsRecUpdParent GhcPs
+data instance HsRecUpdParent GhcRn
+ = RnRecUpdParent
+ { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt
+ , rnRecUpdCons :: UniqSet ConLikeName }
+data instance HsRecUpdParent GhcTc
+ = TcRecUpdParent
+ { tcRecUpdParent :: RecSelParent
+ , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt
+ , tcRecUpdCons :: UniqSet ConLike }
+
+type instance XLHsRecUpdLabels GhcPs = NoExtField
+type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn)
+ -- Possible parents for the record update.
+type instance XLHsRecUpdLabels GhcTc = DataConCantHappen
+
+type instance XLHsOLRecUpdLabels p = NoExtField
+
type instance XGetField GhcPs = EpAnnCO
type instance XGetField GhcRn = NoExtField
type instance XGetField GhcTc = DataConCantHappen
@@ -625,8 +653,10 @@ ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })
ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })
= case flds of
- Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
- Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))
+ RegularRecUpdFields { recUpdFields= rbinds } ->
+ hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
+ OverloadedRecUpdFields { olRecUpdFields = pbinds } ->
+ hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))
ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })
= ppr fexp <> dot <> ppr field
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index c25a72c079..83f5cfbb88 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -21,25 +21,26 @@ module GHC.Hs.ImpExp
, module GHC.Hs.ImpExp
) where
+import Language.Haskell.Syntax.Extension
+import Language.Haskell.Syntax.Module.Name
+import Language.Haskell.Syntax.ImpExp
+
import GHC.Prelude
import GHC.Types.SourceText ( SourceText(..) )
-import GHC.Types.FieldLabel ( FieldLabel )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
import GHC.Types.SrcLoc
-import GHC.Parser.Annotation
-import GHC.Hs.Extension
import GHC.Types.Name
import GHC.Types.PkgQual
+import GHC.Parser.Annotation
+import GHC.Hs.Extension
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
import Data.Data
import Data.Maybe
-import Language.Haskell.Syntax.Extension
-import Language.Haskell.Syntax.Module.Name
-import Language.Haskell.Syntax.ImpExp
{-
************************************************************************
@@ -203,11 +204,7 @@ type instance XIEVar GhcTc = NoExtField
type instance XIEThingAbs (GhcPass _) = EpAnn [AddEpAnn]
type instance XIEThingAll (GhcPass _) = EpAnn [AddEpAnn]
-
--- See Note [IEThingWith]
-type instance XIEThingWith (GhcPass 'Parsed) = EpAnn [AddEpAnn]
-type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel]
-type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField
+type instance XIEThingWith (GhcPass _) = EpAnn [AddEpAnn]
type instance XIEModuleContents GhcPs = EpAnn [AddEpAnn]
type instance XIEModuleContents GhcRn = NoExtField
@@ -220,32 +217,6 @@ type instance XXIE (GhcPass _) = DataConCantHappen
type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA
-{-
-Note [IEThingWith]
-~~~~~~~~~~~~~~~~~~
-A definition like
-
- {-# LANGUAGE DuplicateRecordFields #-}
- module M ( T(MkT, x) ) where
- data T = MkT { x :: Int }
-
-gives rise to this in the output of the parser:
-
- IEThingWith NoExtField T [MkT, x] NoIEWildcard
-
-But in the renamer we need to attach the correct field label,
-because the selector Name is mangled (see Note [FieldLabel] in
-GHC.Types.FieldLabel). Hence we change this to:
-
- IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard
-
-using the TTG extension field to store the list of fields in renamed syntax
-only. (Record fields always appear in this list, regardless of whether
-DuplicateRecordFields was in use at the definition site or not.)
-
-See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details.
--}
-
ieName :: IE (GhcPass p) -> IdP (GhcPass p)
ieName (IEVar _ (L _ n)) = ieWrappedName n
ieName (IEThingAbs _ (L _ n)) = ieWrappedName n
@@ -292,9 +263,8 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
ppr (IEVar _ var) = ppr (unLoc var)
ppr (IEThingAbs _ thing) = ppr (unLoc thing)
ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
- ppr (IEThingWith flds thing wc withs)
- = ppr (unLoc thing) <> parens (fsep (punctuate comma
- (ppWiths ++ ppFields) ))
+ ppr (IEThingWith _ thing wc withs)
+ = ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))
where
ppWiths =
case wc of
@@ -303,10 +273,6 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
IEWildcard pos ->
let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
in bs ++ [text ".."] ++ as
- ppFields =
- case ghcPass @p of
- GhcRn -> map ppr flds
- _ -> []
ppr (IEModuleContents _ mod')
= text "module" <+> ppr mod'
ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">")
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 74d75fb7be..5c8e403bb3 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -287,6 +287,14 @@ deriving instance Data (FieldLabelStrings GhcPs)
deriving instance Data (FieldLabelStrings GhcRn)
deriving instance Data (FieldLabelStrings GhcTc)
+deriving instance Data (HsRecUpdParent GhcPs)
+deriving instance Data (HsRecUpdParent GhcRn)
+deriving instance Data (HsRecUpdParent GhcTc)
+
+deriving instance Data (LHsRecUpdFields GhcPs)
+deriving instance Data (LHsRecUpdFields GhcRn)
+deriving instance Data (LHsRecUpdFields GhcTc)
+
deriving instance Data (DotFieldOcc GhcPs)
deriving instance Data (DotFieldOcc GhcRn)
deriving instance Data (DotFieldOcc GhcTc)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index bc0b51457e..2591efc732 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -244,8 +244,8 @@ data ConPatTc
hsRecFieldId :: HsRecField GhcTc arg -> Id
hsRecFieldId = hsRecFieldSel
-hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) q -> Located RdrName
+hsRecUpdFieldRdr = fmap ambiguousFieldOccRdrName . reLoc . hfbLHS
hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id
hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 313b8e8fe2..968fc99b73 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -56,7 +56,8 @@ module GHC.Hs.Type (
FieldOcc(..), LFieldOcc, mkFieldOcc,
AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,
- rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
+ ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName,
+ selectorAmbiguousFieldOcc,
unambiguousFieldOcc, ambiguousFieldOcc,
mkAnonWildCardTy, pprAnonWildCard,
@@ -104,7 +105,7 @@ import GHC.Parser.Annotation
import GHC.Types.Fixity ( LexicalFixity(..) )
import GHC.Types.Id ( Id )
import GHC.Types.SourceText
-import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName )
+import GHC.Types.Name
import GHC.Types.Name.Reader ( RdrName )
import GHC.Types.Var ( VarBndr, visArgTypeLike )
import GHC.Core.TyCo.Rep ( Type(..) )
@@ -915,11 +916,11 @@ type instance XAmbiguous GhcTc = Id
type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen
instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
- ppr = ppr . rdrNameAmbiguousFieldOcc
+ ppr = ppr . ambiguousFieldOccRdrName
instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
- pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
- pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
+ pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName
+ pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName
instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where
pprInfixOcc = pprInfixOcc . unLoc
@@ -928,9 +929,12 @@ instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where
mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
-rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
+ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName
+ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName
+
+ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName
+ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr
+ambiguousFieldOccLRdrName (Ambiguous _ rdr) = rdr
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 5866243824..008469b458 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+
{-|
Module : GHC.Hs.Utils
Description : Generic helpers for the HsSyn type.
@@ -97,6 +99,7 @@ module GHC.Hs.Utils(
collectLStmtBinders, collectStmtBinders,
CollectPass(..), CollectFlag(..),
+ TyDeclBinders(..), LConsWithFields(..),
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
@@ -113,6 +116,7 @@ import GHC.Hs.Expr
import GHC.Hs.Pat
import GHC.Hs.Type
import GHC.Hs.Lit
+import Language.Haskell.Syntax.Decls
import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -146,13 +150,18 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import Data.Either
+import Control.Arrow ( first )
+import Data.Either ( partitionEithers )
import Data.Foldable ( toList )
-import Data.Function
-import Data.List ( partition, deleteBy )
+import Data.List ( partition )
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NE
+import Data.IntMap ( IntMap )
+import qualified Data.IntMap.Strict as IntMap
+import Data.Map ( Map )
+import qualified Data.Map.Strict as Map
+
{-
************************************************************************
* *
@@ -1356,17 +1365,31 @@ hsTyClForeignBinders :: [TyClGroup GhcRn]
hsTyClForeignBinders tycl_decls foreign_decls
= map unLoc (hsForeignDeclsBinders foreign_decls)
++ getSelectorNames
- (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
+ (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls
`mappend`
- foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_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
-------------------
-hsLTyClDeclBinders :: IsPass p
+
+data TyDeclBinders p
+ = TyDeclBinders
+ { tyDeclMainBinder :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ())
+ , tyDeclATs :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())]
+ , tyDeclOpSigs :: ![LocatedA (IdP (GhcPass p))]
+ , tyDeclConsWithFields :: !(LConsWithFields p) }
+
+tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
+tyDeclBinders (TyDeclBinders main ats sigs consWithFields)
+ = (fst main : (fmap fst ats ++ sigs ++ cons), flds)
+ where
+ (cons, flds) = lconsWithFieldsBinders consWithFields
+
+hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p)
=> LocatedA (TyClDecl (GhcPass p))
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
+ -> TyDeclBinders p
-- ^ Returns all the /binding/ names of the decl. The first one is
-- guaranteed to be the name of the decl. The first component
-- represents all binding names except record fields; the second
@@ -1377,27 +1400,40 @@ hsLTyClDeclBinders :: IsPass p
-- See Note [SrcSpan for binders]
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
- { fdLName = (L _ name) } }))
- = ([L loc name], [])
+ { fdLName = (L _ name)
+ , fdInfo = fd_info } }))
+ = TyDeclBinders
+ { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info)
+ , tyDeclATs = [], tyDeclOpSigs = []
+ , tyDeclConsWithFields = emptyLConsWithFields }
hsLTyClDeclBinders (L loc (SynDecl
{ tcdLName = (L _ name) }))
- = ([L loc name], [])
+ = TyDeclBinders
+ { tyDeclMainBinder = (L loc name, TypeSynonymFlavour)
+ , tyDeclATs = [], tyDeclOpSigs = []
+ , tyDeclConsWithFields = emptyLConsWithFields }
hsLTyClDeclBinders (L loc (ClassDecl
{ tcdLName = (L _ cls_name)
, tcdSigs = sigs
, tcdATs = ats }))
- = (L loc cls_name :
- [ L fam_loc fam_name | (L fam_loc (FamilyDecl
- { fdLName = L _ fam_name })) <- ats ]
- ++
- [ L mem_loc mem_name
- | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
- , (L _ mem_name) <- ns ]
- , [])
+ = TyDeclBinders
+ { tyDeclMainBinder = (L loc cls_name, ClassFlavour)
+ , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info)
+ | (L fam_loc (FamilyDecl { fdLName = L _ fam_name
+ , fdInfo = fd_info })) <- ats ]
+ , tyDeclOpSigs = [ L mem_loc mem_name
+ | (L mem_loc (ClassOpSig _ False ns _)) <- sigs
+ , (L _ mem_name) <- ns ]
+ , tyDeclConsWithFields = emptyLConsWithFields }
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
, tcdDataDefn = defn }))
- = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
-
+ = TyDeclBinders
+ { tyDeclMainBinder = (L loc name, flav )
+ , tyDeclATs = []
+ , tyDeclOpSigs = []
+ , tyDeclConsWithFields = hsDataDefnBinders defn }
+ where
+ flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn
-------------------
hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)
@@ -1430,94 +1466,170 @@ getPatSynBinds binds
, (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]
-------------------
-hsLInstDeclBinders :: IsPass p
+hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)
=> LInstDecl (GhcPass p)
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
+ -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])
hsLInstDeclBinders (L _ (ClsInstD
{ cid_inst = ClsInstDecl
{ cid_datafam_insts = dfis }}))
- = foldMap (hsDataFamInstBinders . unLoc) dfis
+ = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
- = hsDataFamInstBinders fi
+ = lconsWithFieldsBinders $ hsDataFamInstBinders fi
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
-------------------
-- | the 'SrcLoc' returned are for the whole declarations, not just the names
-hsDataFamInstBinders :: IsPass p
+hsDataFamInstBinders :: (IsPass p, OutputableBndrId p)
=> DataFamInstDecl (GhcPass p)
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
+ -> LConsWithFields p
hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
-------------------
-- | the 'SrcLoc' returned are for the whole declarations, not just the names
-hsDataDefnBinders :: IsPass p
+hsDataDefnBinders :: (IsPass p, OutputableBndrId p)
=> HsDataDefn (GhcPass p)
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
+ -> LConsWithFields p
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders (toList cons)
-- See Note [Binders in family instances]
-------------------
-type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]
- -- Filters out ones that have already been seen
-hsConDeclsBinders :: forall p. IsPass p
+{- Note [Collecting record fields in data declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming a data declaration that includes record constructors, we are, in
+the end, going to to create a mapping from constructor to its field labels,
+to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer,
+which constructor has what fields.
+
+In order to achieve this, we return the constructor and field information from
+hsConDeclsBinders in the following format:
+
+ - [(ConRdrName, [Located Int])], a list of the constructors, each associated
+ with its record fields, in the form of a list of Int indices into...
+ - IntMap FieldOcc, an IntMap of record fields.
+
+(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating
+that the constructor has unlabelled fields: see Note [Local constructor info in the renamer]
+in GHC.Types.GREInfo.)
+
+This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc):
+
+ - create 'Name's for each of the record fields, to get IntMap FieldLabel,
+ - create 'Name's for each of the constructors, to get [(ConName, [Int])],
+ - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])].
+
+NB: This can be a bit tricky to get right in the presence of data types with
+duplicate constructors or fields. Storing locations allows us to report an error
+for duplicate field declarations, see test cases T9156 T9156_DF.
+Other relevant test cases: rnfail015.
+
+-}
+
+-- | A mapping from constructors to all of their fields.
+--
+-- See Note [Collecting record fields in data declarations].
+data LConsWithFields p =
+ LConsWithFields
+ { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])]
+ , consFields :: IntMap (LFieldOcc (GhcPass p))
+ }
+
+lconsWithFieldsBinders :: LConsWithFields p
+ -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])
+lconsWithFieldsBinders (LConsWithFields cons fields)
+ = (map fst cons, IntMap.elems fields)
+
+emptyLConsWithFields :: LConsWithFields p
+emptyLConsWithFields = LConsWithFields [] IntMap.empty
+
+hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p)
=> [LConDecl (GhcPass p)]
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
- -- See hsLTyClDeclBinders for what this does
- -- The function is boringly complicated because of the records
- -- And since we only have equality, we have to be a little careful
-hsConDeclsBinders cons
- = go id cons
+ -> LConsWithFields p
+ -- The function is boringly complicated because of the records
+ -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons = go emptyFieldIndices cons
where
- go :: Seen p -> [LConDecl (GhcPass p)]
- -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
- go _ [] = ([], [])
- go remSeen (r:rs)
+ go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p
+ go seen [] = LConsWithFields [] (fields seen)
+ go seen (r:rs)
-- Don't re-mangle the location of field names, because we don't
-- have a record of the full location of the field declaration anyway
= let loc = getLoc r
in case unLoc r of
- -- remove only the first occurrence of any seen field in order to
- -- avoid circumventing detection of duplicate fields (#9156)
ConDeclGADT { con_names = names, con_g_args = args }
- -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs)
+ -> LConsWithFields (cons ++ ns) fs
where
- (remSeen', flds) = get_flds_gadt remSeen args
- (ns, fs) = go remSeen' rs
+ cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names)
+ (con_flds, seen') = get_flds_gadt seen args
+ LConsWithFields ns fs = go seen' rs
ConDeclH98 { con_name = name, con_args = args }
- -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+ -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs
where
- (remSeen', flds) = get_flds_h98 remSeen args
- (ns, fs) = go remSeen' rs
-
- get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)
- -> (Seen p, [LFieldOcc (GhcPass p)])
- get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds
- get_flds_h98 remSeen _ = (remSeen, [])
-
- get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)
- -> (Seen p, [LFieldOcc (GhcPass p)])
- get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds
- get_flds_gadt remSeen _ = (remSeen, [])
-
- get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]
- -> (Seen p, [LFieldOcc (GhcPass p)])
- get_flds remSeen flds = (remSeen', fld_names)
- where
- fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
- remSeen' = foldr (.) remSeen
- [deleteBy ((==) `on` unLoc . foLabel . unLoc) v
- | v <- fld_names]
+ (con_flds, seen') = get_flds_h98 seen args
+ LConsWithFields ns fs = go seen' rs
+
+ get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p)
+ -> (Maybe [Located Int], FieldIndices p)
+ get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds
+ get_flds_h98 seen (PrefixCon _ []) = (Just [], seen)
+ get_flds_h98 seen _ = (Nothing, seen)
+
+ get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)
+ -> (Maybe [Located Int], FieldIndices p)
+ get_flds_gadt seen (RecConGADT flds _) = first Just $ get_flds seen flds
+ get_flds_gadt seen (PrefixConGADT []) = (Just [], seen)
+ get_flds_gadt seen _ = (Nothing, seen)
+
+ get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)]
+ -> ([Located Int], FieldIndices p)
+ get_flds seen flds =
+ foldr add_fld ([], seen) fld_names
+ where
+ add_fld fld (is, ixs) =
+ let (i, ixs') = insertField fld ixs
+ in (i:is, ixs')
+ fld_names = concatMap (cd_fld_names . unLoc) (unLoc flds)
+
+-- | A bijection between record fields of a datatype and integers,
+-- used to implement Note [Collecting record fields in data declarations].
+data FieldIndices p =
+ FieldIndices
+ { fields :: IntMap (LFieldOcc (GhcPass p))
+ -- ^ Look up a field from its index.
+ , fieldIndices :: Map RdrName Int
+ -- ^ Look up the index of a field label in the previous 'IntMap'.
+ , newInt :: !Int
+ -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'.
+ }
+
+emptyFieldIndices :: FieldIndices p
+emptyFieldIndices =
+ FieldIndices { fields = IntMap.empty
+ , fieldIndices = Map.empty
+ , newInt = 0 }
+
+insertField :: 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)
+ | otherwise
+ = (L loc new_idx,
+ FieldIndices (IntMap.insert new_idx new_fld flds)
+ (Map.insert rdr new_idx idxs)
+ (new_idx + 1))
+ where
+ loc = getLocA new_fld
+ rdr = unLoc . foLabel . unLoc $ new_fld
{-
Note [SrcSpan for binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-When extracting the (Located RdrNme) for a binder, at least for the
+When extracting the (Located RdrName) for a binder, at least for the
main name (the TyCon of a type declaration etc), we want to give it
the @SrcSpan@ of the whole /declaration/, not just the name itself
(which is how it appears in the syntax tree). This SrcSpan (for the
View Lorry Controller Status