diff options
| author | Adam Gundry <adam@well-typed.com> | 2020-10-02 20:23:27 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-12-24 16:34:49 -0500 |
| commit | 6f8bafb4fbddd2c8a113f5ddb04636a3a1be9355 (patch) | |
| tree | 7169b8ce5f972892c498c30ee48db2028e76edac | |
| parent | 9809474462527d36b9e237ee7012b08e0845b714 (diff) | |
| download | haskell-6f8bafb4fbddd2c8a113f5ddb04636a3a1be9355.tar.gz | |
Refactor renamer datastructures
This patch significantly refactors key renamer datastructures (primarily Avail
and GlobalRdrElt) in order to treat DuplicateRecordFields in a more robust way.
In particular it allows the extension to be used with pattern synonyms (fixes
where mangled record selector names could be printed instead of field labels
(e.g. with -Wpartial-fields or hole fits, see new tests).
The key idea is the introduction of a new type GreName for names that may
represent either normal entities or field labels. This is then used in
GlobalRdrElt and AvailInfo, in place of the old way of representing fields
using FldParent (yuck) and an extra list in AvailTC.
Updates the haddock submodule.
73 files changed, 1207 insertions, 743 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 65c1f4130b..60b7a3e639 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1399,7 +1399,7 @@ modInfoTyThings minf = typeEnvElts (minf_type_env minf) modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf - = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf) modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index 1d69b47f37..948752d55d 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -265,7 +265,7 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports = map (avail . idName) ghcPrimIds ++ map (avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] [] + [ availTC n [n] [] | tc <- exposedPrimTyCons, let n = tyConName tc ] ghcPrimDeclDocs :: DeclDocMap diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index ee8448cc8b..3239c80b2e 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -21,7 +21,7 @@ module GHC.Core.DataCon ( substEqSpec, filterEqSpec, -- ** Field labels - FieldLbl(..), FieldLabel, FieldLabelString, + FieldLabel(..), FieldLabelString, -- ** Type construction mkDataCon, fIRST_TAG, diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 270dc97364..201eb06255 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -1230,57 +1230,48 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) -} -- | Haskell Pattern Synonym Details -type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField (LIdP pass)] --- The Void argument to HsConDetails here is a reflection of the fact that --- type applications are not allowed in declarations of pattern synonyms at present. +type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass] -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field -data RecordPatSynField fld - = RecordPatSynField { - recordPatSynSelectorId :: fld -- Selector name visible in rest of the file - , recordPatSynPatVar :: fld - -- Filled in by renamer, the name used internally - -- by the pattern - } deriving (Data, Functor) - +data RecordPatSynField pass + = RecordPatSynField + { recordPatSynField :: FieldOcc pass + -- ^ Field label visible in rest of the file + , recordPatSynPatVar :: LIdP pass + -- ^ Filled in by renamer, the name used internally by the pattern + } {- Note [Record PatSyn Fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following two pattern synonyms. -pattern P x y = ([x,True], [y,'v']) -pattern Q{ x, y } =([x,True], [y,'v']) + pattern P x y = ([x,True], [y,'v']) + pattern Q{ x, y } =([x,True], [y,'v']) In P, we just have two local binders, x and y. In Q, we have local binders but also top-level record selectors -x :: ([Bool], [Char]) -> Bool and similarly for y. + x :: ([Bool], [Char]) -> Bool + y :: ([Bool], [Char]) -> Char + +Both are recorded in the `RecordPatSynField`s for `x` and `y`: +* recordPatSynField: the top-level record selector +* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym. It would make sense to support record-like syntax -pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) -when we have a different name for the local and top-level binder -the distinction between the two names clear +when we have a different name for the local and top-level binder, +making the distinction between the two names clear. -} -instance Outputable a => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v - -instance Foldable RecordPatSynField where - foldMap f (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = f visible `mappend` f hidden - -instance Traversable RecordPatSynField where - traverse f (RecordPatSynField { recordPatSynSelectorId =visible - , recordPatSynPatVar = hidden }) - = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id - , recordPatSynPatVar = pat_var }) - <$> f visible <*> f hidden +instance Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v -- | Haskell Pattern Synonym Direction diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 0aec281312..33c32aa7f7 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module GHC.Hs.Extension @@ -20,7 +22,7 @@ import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc ( HsDocString ) import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) import GHC.Types.SourceText ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import GHC.Types.FieldLabel ( FieldLbl(..) ) +import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -229,7 +231,6 @@ data IE pass (LIEWrappedName (IdP pass)) IEWildcard [LIEWrappedName (IdP pass)] - [XRec pass (FieldLbl (IdP pass))] -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are @@ -256,46 +257,61 @@ data IE pass type instance XIEVar (GhcPass _) = NoExtField type instance XIEThingAbs (GhcPass _) = NoExtField type instance XIEThingAll (GhcPass _) = NoExtField -type instance XIEThingWith (GhcPass _) = NoExtField type instance XIEModuleContents (GhcPass _) = NoExtField type instance XIEGroup (GhcPass _) = NoExtField type instance XIEDoc (GhcPass _) = NoExtField type instance XIEDocNamed (GhcPass _) = NoExtField type instance XXIE (GhcPass _) = NoExtCon +-- See Note [IEThingWith] +type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] +type instance XIEThingWith (GhcPass 'Parsed) = NoExtField +type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField + + -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~ - A definition like + {-# LANGUAGE DuplicateRecordFields #-} module M ( T(MkT, x) ) where data T = MkT { x :: Int } -gives rise to +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 - IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) - IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) +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 -ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n -ieName (IEThingAll _ (L _ n)) = ieWrappedName n +ieName (IEVar _ (L _ n)) = ieWrappedName n +ieName (IEThingAbs _ (L _ n)) = ieWrappedName n +ieName (IEThingWith _ (L _ n) _ _) = ieWrappedName n +ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] -ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n - : map (ieWrappedName . unLoc) ns +ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n + : map (ieWrappedName . unLoc) ns +-- NB the above case does not include names of field selectors ieNames (IEModuleContents {}) = [] ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] @@ -321,10 +337,9 @@ 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 _ thing wc withs flds) + ppr (IEThingWith flds thing wc withs) = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ - map (ppr . flLabel . unLoc) flds))) + (ppWiths ++ ppFields) )) where ppWiths = case wc of @@ -333,6 +348,10 @@ 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 7515c37fb5..3098f3a935 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -69,6 +69,11 @@ deriving instance Data (ABExport GhcPs) deriving instance Data (ABExport GhcRn) deriving instance Data (ABExport GhcTc) +-- deriving instance DataId p => Data (RecordPatSynField p) +deriving instance Data (RecordPatSynField GhcPs) +deriving instance Data (RecordPatSynField GhcRn) +deriving instance Data (RecordPatSynField GhcTc) + -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 1b1e56b314..2c64d7a491 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1898,9 +1898,13 @@ type LFieldOcc pass = XRec pass (FieldOcc pass) -- | Field Occurrence -- --- Represents an *occurrence* of an unambiguous field. We store --- both the 'RdrName' the user originally wrote, and after the --- renamer, the selector function. +-- Represents an *occurrence* of an unambiguous field. This may or may not be a +-- binding occurrence (e.g. this type is used in 'ConDeclField' and +-- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for +-- record construction and patterns, which do not). +-- +-- We store both the 'RdrName' the user originally wrote, and after the renamer, +-- the selector function. data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr" diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 0051eaa2c9..e414269413 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1192,17 +1192,17 @@ hsForeignDeclsBinders foreign_decls ------------------- -hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [IdP (GhcPass p)] +hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldr addPatSynSelector [] . unionManyBags $ map snd binds -addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [IdP p] -> [IdP p] +addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind - = map (unXRec @p . recordPatSynSelectorId) as ++ sels + = map recordPatSynField as ++ sels | otherwise = sels getPatSynBinds :: forall id. UnXRec id diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 7f675e8253..d39a6d716a 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -283,7 +283,7 @@ repTopDs group@(HsGroup { hs_valds = valds , hs_docs = docs }) = do { let { bndrs = hsScopedTvBinders valds ++ hsGroupBinders group - ++ hsPatSynSelectors valds + ++ map extFieldOcc (hsPatSynSelectors valds) ; instds = tyclds >>= group_instds } ; ss <- mkGenSyms bndrs ; @@ -1888,7 +1888,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] mkGenArgSyms (RecCon fields) = do { let pats = map (unLoc . recordPatSynPatVar) fields - sels = map (unLoc . recordPatSynSelectorId) fields + sels = map (extFieldOcc . recordPatSynField) fields ; ss <- mkGenSyms sels ; return $ replaceNames (zip sels pats) ss } @@ -1918,9 +1918,9 @@ repPatSynArgs (InfixCon arg1 arg2) ; arg2' <- lookupLOcc arg2 ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields) - = do { sels' <- repList nameTyConName lookupLOcc sels + = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels ; repRecordPatSynArgs sels' } - where sels = map recordPatSynSelectorId fields + where sels = map recordPatSynField fields repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 3917998c3e..3a511e0d77 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -877,7 +877,7 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) (RecCon r) -> foldr go NoScope r go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope a) (mkLScope b) + $ combineScopes (mkLScope (rdrNameFieldOcc a)) (mkLScope b) detSpan = case detScope of LocalScope a -> Just a _ -> Nothing @@ -1889,8 +1889,12 @@ instance ToHie (Located (DataFamInstDecl GhcRn)) where instance ToHie (Located (TyFamInstDecl GhcRn)) where toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d -instance ToHie (Context a) - => ToHie (PatSynFieldContext (RecordPatSynField a)) where +instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where + toHie (C c (FieldOcc n (L l _))) = case hiePass @p of + HieTc -> toHie (C c (L l n)) + HieRn -> toHie (C c (L l n)) + +instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where toHie (PSC sp (RecordPatSynField a b)) = concatM $ [ toHie $ C (RecField RecFieldDecl sp) a , toHie $ C Use b @@ -2022,7 +2026,7 @@ instance ToHie (IEContext (Located (IE GhcRn))) where IEThingAll _ n -> [ toHie $ IEC c n ] - IEThingWith _ n _ ns flds -> + IEThingWith flds n _ ns -> [ toHie $ IEC c n , toHie $ map (IEC c) ns , toHie $ map (IEC c) flds @@ -2046,7 +2050,7 @@ instance ToHie (IEContext (LIEWrappedName Name)) where [ toHie $ C (IEThing c) n ] -instance ToHie (IEContext (Located (FieldLbl Name))) where +instance ToHie (IEContext (Located FieldLabel)) where toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of FieldLabel _ _ n -> [ toHie $ C (IEThing c) $ L span n diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index e7833d8145..8e5bcf9f4b 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -92,7 +92,6 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc -import GHC.Types.FieldLabel import GHC.Types.TyThing import GHC.Unit.External @@ -1134,15 +1133,16 @@ When printing export lists, we print like this: -} pprExport :: IfaceExport -> SDoc -pprExport (Avail n) = ppr n -pprExport (AvailTC _ [] []) = Outputable.empty -pprExport (AvailTC n ns0 fs) - = case ns0 of - (n':ns) | n==n' -> ppr n <> pp_export ns fs - _ -> ppr n <> vbar <> pp_export ns0 fs +pprExport (Avail n) = ppr n +pprExport (AvailTC _ []) = Outputable.empty +pprExport avail@(AvailTC n _) = + ppr n <> mark <> pp_export (availSubordinateGreNames avail) where - pp_export [] [] = Outputable.empty - pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) + mark | availExportsDecl avail = Outputable.empty + | otherwise = vbar + + pp_export [] = Outputable.empty + pp_export names = braces (hsep (map ppr names)) pprUsage :: Usage -> SDoc pprUsage usage@UsagePackageModule{} diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index a37ce7516a..ddeb811564 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -372,14 +372,12 @@ mkIfaceExports exports where sort_subs :: AvailInfo -> AvailInfo sort_subs (Avail n) = Avail n - sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs) - sort_subs (AvailTC n (m:ms) fs) - | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs) - | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs) + sort_subs (AvailTC n []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | NormalGreName n==m = AvailTC n (m:sortBy stableGreNameCmp ms) + | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms)) -- Maintain the AvailTC Invariant - sort_flds = sortBy (stableNameCmp `on` flSelector) - {- Note [Original module] ~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 66a8b477f1..aba0c006ca 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -240,20 +240,25 @@ rnModule mod = do return (renameHoleModule unit_state hmap mod) rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n -rnAvailInfo (AvailTC n ns fs) = do +rnAvailInfo (Avail c) = Avail <$> rnGreName c +rnAvailInfo (AvailTC n ns) = do -- Why don't we rnIfaceGlobal the availName itself? It may not -- actually be exported by the module it putatively is from, in -- which case we won't be able to tell what the name actually -- is. But for the availNames they MUST be exported, so they -- will rename fine. - ns' <- mapM rnIfaceGlobal ns - fs' <- mapM rnFieldLabel fs - case ns' ++ map flSelector fs' of + ns' <- mapM rnGreName ns + case ns' 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') + (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do + n' <- setNameModule (Just (childModule rep)) n + return (AvailTC n' ns') + where + childModule = nameModule . greNameMangledName + +rnGreName :: Rename GreName +rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n +rnGreName (FieldGreName fl) = FieldGreName <$> rnFieldLabel fl rnFieldLabel :: Rename FieldLabel rnFieldLabel (FieldLabel l b sel) = do diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 50ebb93ebd..61d52bc47d 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1590,10 +1590,10 @@ vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } -cvars1 :: { [RecordPatSynField (Located RdrName)] } - : var { [RecordPatSynField $1 $1] } +cvars1 :: { [RecordPatSynField GhcPs] } + : var { [RecordPatSynField (mkFieldOcc $1) $1] } | var ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> - return ((RecordPatSynField $1 $1) : $3 )} + return ((RecordPatSynField (mkFieldOcc $1) $1) : $3 )} where_decls :: { Located ([AddAnn] , Located (OrdList (LHsDecl GhcPs))) } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 6071956e1b..59280962d3 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2335,7 +2335,7 @@ mkModuleImpExp (L l specname) subs = ImpExpAll -> IEThingAll noExtField . L l <$> nameT ImpExpList xs -> (\newName -> IEThingWith noExtField (L l newName) - NoIEWildcard (wrapped xs) []) <$> nameT + NoIEWildcard (wrapped xs)) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit if allowed @@ -2345,7 +2345,7 @@ mkModuleImpExp (L l specname) subs = (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExtField (L l newName) pos ies []) + -> IEThingWith noExtField (L l newName) pos ies) <$> nameT else addFatalError $ PsError PsErrIllegalPatSynExport [] l where @@ -2374,7 +2374,7 @@ mkTypeImpExp name = checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of + case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 30fef1b980..ea76feea82 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -47,6 +47,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module +import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -692,13 +693,15 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name ; return ( (pat', InfixCon name1 name2) , mkFVs (map unLoc [name1, name2])) } RecCon vars -> - do { checkDupRdrNames (map recordPatSynSelectorId vars) + do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars) + ; fls <- lookupConstructorFields name + ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] ; let rnRecordPatSynField - (RecordPatSynField { recordPatSynSelectorId = visible + (RecordPatSynField { recordPatSynField = visible , recordPatSynPatVar = hidden }) - = do { visible' <- lookupLocatedTopBndrRn visible + = do { let visible' = lookupField fld_env visible ; hidden' <- lookupPatSynBndr hidden - ; return $ RecordPatSynField { recordPatSynSelectorId = visible' + ; return $ RecordPatSynField { recordPatSynField = visible' , recordPatSynPatVar = hidden' } } ; names <- mapM rnRecordPatSynField vars ; return ( (pat', RecCon names) @@ -726,7 +729,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name , psb_ext = fvs' } selector_names = case details' of RecCon names -> - map (unLoc . recordPatSynSelectorId) names + map (extFieldOcc . recordPatSynField) names _ -> [] ; fvs' `seq` -- See Note [Free-variable space leak] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 621a01cb6c..435c20c16e 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -267,7 +267,7 @@ lookupTopBndrRn rdr_name = ; env <- getGlobalRdrEnv ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (gre_name gre) + [gre] -> return (greMangledName gre) _ -> do -- Ambiguous (can't happen) or unbound traceRn "lookupTopBndrRN fail" (ppr rdr_name) unboundName WL_LocalTop rdr_name @@ -307,9 +307,9 @@ lookupExactOcc_either name Nothing -> [] gres = [ gre | occ <- main_occ : demoted_occs , gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] + , greMangledName gre == name ] ; case gres of - [gre] -> return (Right (gre_name gre)) + [gre] -> return (Right (greMangledName gre)) [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv @@ -332,7 +332,7 @@ sameNameErr gres@(_ : _) = hang (text "Same exact name in multiple name-spaces:") 2 (vcat (map pp_one sorted_names) $$ th_hint) where - sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres) + sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) pp_one name = hang (pprNameSpace (occNameSpace (getOccName name)) <+> quotes (ppr name) <> comma) @@ -598,7 +598,7 @@ lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name | isUnboundName parent -- Avoid an error cascade - = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) + = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name))) | otherwise = do gre_env <- getGlobalRdrEnv @@ -624,20 +624,9 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name where -- Convert into FieldLabel if necessary checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name, gre_par} = do + checkFld g@GRE{gre_name,gre_par} = do addUsedGRE warn_if_deprec g - return $ case gre_par of - FldParent _ mfs -> - FoundFL (fldParentToFieldLabel gre_name mfs) - _ -> FoundName gre_par gre_name - - fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel - fldParentToFieldLabel name mfs = - case mfs of - Nothing -> - let fs = occNameFS (nameOccName name) - in FieldLabel fs False name - Just fs -> FieldLabel fs True name + return $ FoundChild gre_par gre_name -- Called when we find no matching GREs after disambiguation but -- there are three situations where this happens. @@ -655,27 +644,25 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name case original_gres of [] -> return NameNotFound [g] -> return $ IncorrectParent parent - (gre_name g) (ppr $ gre_name g) + (gre_name g) [p | Just p <- [getParent g]] gss@(g:_:_) -> if all isRecFldGRE gss && overload_ok then return $ IncorrectParent parent (gre_name g) - (ppr $ expectJust "noMatchingParentErr" (greLabel g)) [p | x <- gss, Just p <- [getParent x]] else mkNameClashErr gss mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult mkNameClashErr gres = do addNameClashErrRn rdr_name gres - return (FoundName (gre_par (head gres)) (gre_name (head gres))) + return (FoundChild (gre_par (head gres)) (gre_name (head gres))) getParent :: GlobalRdrElt -> Maybe Name getParent (GRE { gre_par = p } ) = case p of ParentIs cur_parent -> Just cur_parent - FldParent { par_is = cur_parent } -> Just cur_parent NoParent -> Nothing picked_gres :: [GlobalRdrElt] -> DisambigInfo @@ -743,11 +730,9 @@ instance Monoid DisambigInfo where data ChildLookupResult = NameNotFound -- We couldn't find a suitable name | IncorrectParent Name -- Parent - Name -- Name of thing we were looking for - SDoc -- How to print the name + GreName -- Child we were looking for [Name] -- List of possible parents - | FoundName Parent Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL + | FoundChild Parent GreName -- We resolved to a child -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult @@ -760,10 +745,9 @@ combineChildLookupResult (x:xs) = do instance Outputable ChildLookupResult where ppr NameNotFound = text "NameNotFound" - ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n - ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls - ppr (IncorrectParent p n td ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, td, ppr ns] + ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n + ppr (IncorrectParent p n ns) = text "IncorrectParent" + <+> hsep [ppr p, ppr n, ppr ns] lookupSubBndrOcc :: Bool -> Name -- Parent @@ -774,13 +758,12 @@ lookupSubBndrOcc :: Bool -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do res <- - lookupExactOrOrig rdr_name (FoundName NoParent) $ + lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $ -- This happens for built-in classes, see mod052 for example lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name case res of NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) - FoundName _p n -> return (Right n) - FoundFL fl -> return (Right (flSelector fl)) + FoundChild _p child -> return (Right (greNameMangledName child)) IncorrectParent {} -- See [Mismatched class methods and associated type families] -- in TcInstDecls. @@ -1137,7 +1120,7 @@ lookupGlobalOccRn rdr_name = lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name) lookupGlobalOccRn_base rdr_name = runMaybeT . msum . map MaybeT $ - [ fmap gre_name <$> lookupGreRn_maybe rdr_name + [ fmap greMangledName <$> lookupGreRn_maybe rdr_name , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] -- This test is not expensive, -- and only happens for failed lookups @@ -1153,7 +1136,7 @@ lookupInfoOccRn :: RdrName -> RnM [Name] lookupInfoOccRn rdr_name = lookupExactOrOrig rdr_name (:[]) $ do { rdr_env <- getGlobalRdrEnv - ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) + ; let ns = map greMangledName (lookupGRE_RdrName rdr_name rdr_env) ; qual_ns <- lookupQualifiedNameGHCi rdr_name ; return (ns ++ (qual_ns `minusList` ns)) } @@ -1176,14 +1159,14 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name = GreNotFound -> return Nothing OneNameMatch gre -> do let wrapper = if isRecFldGRE gre then Right . (:[]) else Left - return $ Just (wrapper (gre_name gre)) + return $ Just (wrapper (greMangledName gre)) MultipleNames gres | all isRecFldGRE gres && overload_ok -> -- Don't record usage for ambiguous selectors -- until we know which is meant - return $ Just (Right (map gre_name gres)) + return $ Just (Right (map greMangledName gres)) MultipleNames gres -> do addNameClashErrRn rdr_name gres - return (Just (Left (gre_name (head gres)))) } + return (Just (Left (greMangledName (head gres)))) } -------------------------------------------------- @@ -1270,7 +1253,7 @@ lookupGreAvailRn rdr_name -- Returning an unbound name here prevents an error -- cascade OneNameMatch gre -> - return (gre_name gre, availFromGRE gre) + return (greMangledName gre, availFromGRE gre) {- @@ -1327,7 +1310,7 @@ addUsedGREs gres imp_gres = filterOut isLocalGRE gres warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) +warnIfDeprecated gre@(GRE { gre_imp = iss }) | (imp_spec : _) <- iss = do { dflags <- getDynFlags ; this_mod <- getModule @@ -1343,6 +1326,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) = return () where occ = greOccName gre + name = greMangledName gre name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") @@ -1363,7 +1347,6 @@ lookupImpDeprec iface gre = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) NoParent -> Nothing {- @@ -1575,14 +1558,14 @@ lookupBindGroupOcc ctxt what rdr_name filter (\n -> nameSpacesRelated (rdrNameSpace rdr_name) (nameNameSpace n)) - $ map gre_name + $ map greMangledName $ filter isLocalGRE $ globalRdrEnvElts env candidates_msg = candidates names_in_scope - ; case filter (keep_me . gre_name) all_gres of + ; case filter (keep_me . greMangledName) all_gres of [] | null all_gres -> bale_out_with candidates_msg | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (gre_name gre)) } + (gre:_) -> return (Right (greMangledName gre)) } lookup_group bound_names -- Look in the local envt (not top level) = do { mname <- lookupLocalOccRn_maybe rdr_name diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index a66d9de5bf..9529e2b68e 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -211,7 +211,7 @@ lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) >> return (Fixity NoSourceText minPrecedence InfixL) - lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) + lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre) ambiguous_fixity_err rn ambigs = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 34f2cf1ca2..b4498c80ee 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -17,6 +17,7 @@ module GHC.Rename.HsType ( HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, newTyVarNameRn, rnConDeclFields, + lookupField, rnLTyVar, rnScaledLHsType, @@ -1247,17 +1248,17 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> 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 + = do { let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; return (L l (ConDeclField noExtField new_names new_ty haddock_doc) , fvs) } + +lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn +lookupField fl_env (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) where - lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) - where - lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + lbl = occNameFS $ rdrNameOcc rdr + fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl {- ************************************************************************ diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index d47d652358..e098156d1d 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1613,7 +1613,6 @@ getParent rdr_env n = case lookupGRE_Name rdr_env n of Just gre -> case gre_par gre of ParentIs { par_is = p } -> p - FldParent { par_is = p } -> p _ -> n Nothing -> n @@ -2389,7 +2388,8 @@ extendPatSynEnv val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls ; let pat_syn_bndrs = concat [ name: map flSelector fields | (name, fields) <- names_with_fls ] - ; let avails = map avail pat_syn_bndrs + ; let avails = map avail (map fst names_with_fls) + ++ map availField (concatMap snd names_with_fls) ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls @@ -2408,11 +2408,9 @@ extendPatSynEnv val_decls local_fix_env thing = do { , psb_args = RecCon as }))) <- bind = do bnd_name <- newTopSrcBinder (L bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) - field_occs = map mkFieldOcc rnames - flds <- mapM (newRecordSelector False [bnd_name]) field_occs + let field_occs = map ((\ f -> L (getLoc (rdrNameFieldOcc f)) f) . recordPatSynField) as + overload_ok <- xoptM LangExt.DuplicateRecordFields + flds <- mapM (newRecordSelector overload_ok [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 45b8bcd313..a52f7bca3c 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -84,7 +84,7 @@ import GHC.Data.FastString import GHC.Data.FastString.Env import Control.Monad -import Data.Either ( partitionEithers, isRight, rights ) +import Data.Either ( partitionEithers ) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing ) @@ -645,7 +645,7 @@ extendGlobalRdrEnvRn avails new_fixities | otherwise = fix_env where - name = gre_name gre + name = greMangledName gre occ = greOccName gre new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails @@ -663,12 +663,70 @@ extendGlobalRdrEnvRn avails new_fixities | otherwise = return (extendGlobalRdrEnv env gre) where - occ = greOccName gre - dups = filter isDupGRE (lookupGlobalRdrEnv env occ) - -- Duplicate GREs are those defined locally with the same OccName, - -- except cases where *both* GREs are DuplicateRecordFields (#17965). + -- See Note [Reporting duplicate local declarations] + dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) isDupGRE gre' = isLocalGRE gre' - && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') + && (not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') + || (gre_name gre == gre_name gre')) + +{- +Note [Reporting duplicate local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a single module may not define the same OccName multiple times. This +is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the +GlobalRdrEnv we report an error if there are already duplicates in the +environment. This establishes INVARIANT 1 of the GlobalRdrEnv, which says that +for a given OccName, all the GlobalRdrElts to which it maps must have distinct +'gre_name's. + +For example, the following will be rejected: + + f x = x + g x = x + f x = x -- Duplicate! + +Under what conditions will a GRE that exists already count as a duplicate of the +LocalDef GRE being added? + +* It must also be a LocalDef: the programmer is allowed to make a new local + definition that clashes with an imported one (although attempting to refer to + either may lead to ambiguity errors at use sites). For example, the following + definition is allowed: + + import M (f) + f x = x + +* When DuplicateRecordFields is enabled, the same field label may be defined in + multiple records. For example, this is allowed: + + {-# LANGUAGE DuplicateRecordFields #-} + data S1 = MkS1 { f :: Int } + data S2 = MkS2 { f :: Int } + + Even though both fields have the same OccName, this does not violate INVARIANT + 1, because the fields have distinct selector names, which form part of the + gre_name (see Note [GreNames] in GHC.Types.Name.Reader). + +* However, we must be careful to reject the following (#9156): + + {-# LANGUAGE DuplicateRecordFields #-} + data T = MkT { f :: Int, f :: Int } -- Duplicate! + + In this case, both 'gre_name's are the same (because the fields belong to the + same type), and adding them both to the environment would be a violation of + INVARIANT 1. Thus isDupGRE checks whether both GREs have the same gre_name. + +* We also reject attempts to define a field and a non-field with the same + OccName (#17965): + + {-# LANGUAGE DuplicateRecordFields #-} + f x = x + data T = MkT { f :: Int} + + In principle this could be supported, but the current "specification" of + DuplicateRecordFields does not allow it. Thus isDupGRE checks that *both* GREs + being compared are record fields. +-} {- ********************************************************************* @@ -760,7 +818,7 @@ 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 flds', fld_env) } + ; return (availTC main_name names flds', fld_env) } -- Calculate the mapping from constructor names to fields, which @@ -835,7 +893,7 @@ getLocalNonValBinders fixity_env ; let (bndrs, flds) = hsDataFamInstBinders dfid ; sub_names <- mapM newTopSrcBinder bndrs ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let avail = AvailTC (unLoc main_name) sub_names flds' + ; let avail = availTC (unLoc main_name) sub_names flds' -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } @@ -848,10 +906,12 @@ 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 - ; return $ qualFieldLbl { flSelector = selName } } + ; return $ FieldLabel { flLabel = fieldLabelString + , flIsOverloaded = overload_ok + , flSelector = selName } } where - fieldOccName = occNameFS $ rdrNameOcc fld - qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok + fieldLabelString = occNameFS $ rdrNameOcc fld + selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) overload_ok field | isExact fld = fld -- use an Exact RdrName as is to preserve the bindings -- of an already renamer-resolved field and its use @@ -859,7 +919,7 @@ newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) -- selectors in Template Haskell. See Note [Binders in -- Template Haskell] in "GHC.ThToHs" and Note [Looking up -- Exact RdrNames] in "GHC.Rename.Env". - | otherwise = mkRdrUnqual (flSelector qualFieldLbl) + | otherwise = mkRdrUnqual selOccName {- Note [Looking up family names in family instances] @@ -892,9 +952,12 @@ available, and filters it through the import spec (if any). Note [Dealing with imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) -One entry for each Name that M exports; the AvailInfo is the -AvailInfo exported from M that exports that Name. + imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name)) +One entry for each OccName that M exports, mapping each corresponding Name to +its GreName, the AvailInfo exported from M that exports that Name, and +optionally a Name for an associated type's parent class. (Typically there will +be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields] +for why we may need more than one.) The situation is made more complicated by associated types. E.g. module M where @@ -906,7 +969,7 @@ Then M's export_avails are (recall the AvailTC invariant from Avails.hs) Notice that T appears *twice*, once as a child and once as a parent. From this list we construct a raw list including T -> (T, T( T1, T2, T3 ), Nothing) - T -> (C, C( C, T ), Nothing) + T -> (T, C( C, T ), Nothing) and we combine these (in function 'combine' in 'imp_occ_env' in 'filterImports') to get T -> (T, T(T,T1,T2,T3), Just C) @@ -922,6 +985,57 @@ then we get *two* Avails: C(T), T(T1,T2) Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors. + +Note [Importing PatternSynonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Dealing with imports], associated types can lead to the +same Name appearing twice, both as a child and once as a parent, when +constructing the imp_occ_env. The same thing can happen with pattern synonyms +if they are exported bundled with a type. + +A simplified example, based on #11959: + + {-# LANGUAGE PatternSynonyms #-} + module M (T(P), pattern P) where -- Duplicate export warning, but allowed + data T = MkT + pattern P = MkT + +Here we have T(P) and P in export_avails, and construct both + P -> (P, P, Nothing) + P -> (P, T(P), Nothing) +which are 'combine'd to leave + P -> (P, T(P), Nothing) +i.e. we simply discard the non-bundled Avail. + +Note [Importing DuplicateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In filterImports, another complicating factor is DuplicateRecordFields. +Suppose we have: + + {-# LANGUAGE DuplicateRecordFields #-} + module M (S(foo), T(foo)) where + data S = MkS { foo :: Int } + data T = mkT { foo :: Int } + + module N where + import M (foo) -- this is an ambiguity error (A) + import M (S(foo)) -- this is allowed (B) + +Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo' +maps to a NameEnv containing an entry for each of the two mangled field selector +names (see Note [FieldLabel] in GHC.Types.FieldLabel). + + foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing) + , $sel:foo:MKT -> (foo, T(foo), Nothing) + ] + +Then when we look up 'foo' in lookup_name for case (A) we get both entries and +hence report an ambiguity error. Whereas in case (B) we reach the lookup_ie +case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst +its children. + +See T16745 for a test of this. + -} filterImports @@ -958,30 +1072,46 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) all_avails = mi_exports iface -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing)) + imp_occ_env :: OccEnv (NameEnv (GreName, -- the name or field + AvailInfo, -- the export item providing it + Maybe Name)) -- the parent of associated types + imp_occ_env = mkOccEnv_C (plusNameEnv_C combine) + [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))]) | a <- all_avails - , (n, occ) <- availNamesWithOccs a] - where - -- See Note [Dealing with imports] - -- 'combine' is only called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine (name1, a1@(AvailTC p1 _ _), mp1) - (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 - , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) - if p1 == name1 then (name1, a1, Just p2) - else (name1, a2, Just p1) - combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + , c <- availGreNames a] + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data types which appear + -- twice in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine :: (GreName, AvailInfo, Maybe Name) + -> (GreName, AvailInfo, Maybe Name) + -> (GreName, AvailInfo, Maybe Name) + combine (NormalGreName name1, a1@(AvailTC p1 _), mb1) + (NormalGreName name2, a2@(AvailTC p2 _), mb2) + = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2 + , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 ) + if p1 == name1 then (NormalGreName name1, a1, Just p2) + else (NormalGreName name1, a2, Just p1) + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine (c1, a1, mb1) (c2, a2, mb2) + = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2 + && (isAvailTC a1 || isAvailTC a2) + , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 ) + if isAvailTC a1 then (c1, a1, Nothing) + else (c1, a2, Nothing) + + isAvailTC AvailTC{} = True + isAvailTC _ = False lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) lookup_name ie rdr | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return succ + | Just succ <- mb_success = case nameEnvElts succ of + -- See Note [Importing DuplicateRecordFields] + [(c,a,x)] -> return (greNameMangledName c, a, x) + xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) | otherwise = failLookupWith (BadImport ie) where mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) @@ -1011,6 +1141,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) BadImport ie -> badImportItemErr iface decl_spec ie all_avails IllegalImport -> illegalImportItemErr QualImportError rdr -> qualImportItemErr rdr + AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs -- For each import item, we convert its RdrNames to Names, -- and at the same time construct an AvailInfo corresponding @@ -1037,8 +1168,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) Avail {} -- e.g. f(..) -> [DodgyImport $ ieWrappedName tc] - AvailTC _ subs fs - | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym + AvailTC _ subs + | null (drop 1 subs) -- e.g. T(..) where T is a synonym -> [DodgyImport $ ieWrappedName tc] | not (is_qual decl_spec) -- e.g. import M( T(..) ) @@ -1049,12 +1180,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] + Avail {} -> [] + AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] case mb_parent of Nothing -> return ([(renamed_ie, avail)], warns) -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) + Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns) -- associated type IEThingAbs _ (L l tc') @@ -1073,25 +1204,16 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) return ([mkIEThingAbs tc' l nameAvail] , []) - IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> - ASSERT2(null rdr_fs, ppr rdr_fs) do + IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do (name, avail, mb_parent) <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) - let (ns,subflds) = case avail of - AvailTC _ ns' subflds' -> (ns',subflds') - Avail _ -> panic "filterImports" - -- Look up the children in the sub-names of the parent - let subnames = case ns of -- The tc is first in ns, - [] -> [] -- if it is there at all - -- See the AvailTC Invariant in - -- GHC.Types.Avail - (n1:ns1) | n1 == name -> ns1 - | otherwise -> ns - case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of - - Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs [])) + -- See Note [Importing DuplicateRecordFields] + let subnames = availSubordinateGreNames avail + case lookupChildren subnames rdr_ns of + + Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs)) -- We are trying to import T( a,b,c,d ), and failed -- to find 'b' and 'd'. So we make up an import item -- to report as failing, namely T( b, d ). @@ -1101,21 +1223,18 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) case mb_parent of -- non-associated ty/cls Nothing - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (name:map unLoc childnames) (map unLoc childflds))], + -> return ([(IEThingWith childflds (L l name') wc childnames', + availTC name (name:map unLoc childnames) (map unLoc childflds))], []) where name' = replaceWrappedName rdr_tc name childnames' = map to_ie_post_rn childnames -- childnames' = postrn_ies childnames -- associated ty Just parent - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC parent [name] [])], + -> return ([(IEThingWith childflds (L l name') wc childnames', + availTC name (map unLoc childnames) (map unLoc childflds)), + (IEThingWith childflds (L l name') wc childnames', + availTC parent [name] [])], []) where name' = replaceWrappedName rdr_tc name childnames' = map to_ie_post_rn childnames @@ -1129,7 +1248,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) mkIEThingAbs tc l (n, _, Just parent) = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) - , AvailTC parent [n] []) + , availTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of BadImport ie | want_hiding -> return ([], [BadImportW ie]) @@ -1147,6 +1266,7 @@ data IELookupError = QualImportError RdrName | BadImport (IE GhcPs) | IllegalImport + | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err @@ -1201,14 +1321,13 @@ mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] mkChildEnv gres = foldr add emptyNameEnv gres where add gre env = case gre_par gre of - FldParent p _ -> extendNameEnv_Acc (:) Utils.singleton env p gre ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre NoParent -> env findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName] +lookupChildren :: [GreName] -> [LIEWrappedName RdrName] -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed ([Located Name], [Located FieldLabel]) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its @@ -1233,13 +1352,13 @@ lookupChildren all_kids rdr_items doOne item@(L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [Left n] -> Succeeded (Left (L l n)) - Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs))) - _ -> Failed item + Just [NormalGreName n] -> Succeeded (Left (L l n)) + Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L l) fs)) + _ -> Failed item -- See Note [Children for duplicate record fields] kid_env = extendFsEnvList_C (++) emptyFsEnv - [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] + [(occNameFS (occName x), [x]) | x <- all_kids] @@ -1274,11 +1393,13 @@ reportUnusedNames gbl_env hsc_src -- This is done in mkExports too; duplicated work gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names (GRE {gre_name = name}) + gre_is_used used_names gre0 = name `elemNameSet` used_names - || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) + || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name) -- A use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) + where + name = greMangledName gre0 -- Filter out the ones that are -- (a) defined in this module, and @@ -1295,7 +1416,7 @@ reportUnusedNames gbl_env hsc_src in filter is_unused_local defined_but_not_used is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre) {- ********************************************************************* * * @@ -1422,7 +1543,7 @@ findImportUsage imports used_gres -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map gre_name used_gres) + used_names = mkNameSet (map greMangledName used_gres) used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) unused_imps -- Not trivial; see eg #7454 @@ -1435,7 +1556,7 @@ findImportUsage imports used_gres add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc - add_unused (IEThingWith _ p wc ns fs) acc = + add_unused (IEThingWith fs p wc ns) acc = add_wc_all (add_unused_with pn xs acc) where pn = lieWrappedName p xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs @@ -1501,7 +1622,7 @@ mkImportMap gres best_imp_spec = bestImport imp_specs add _ gres = gre : gres -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) -> ImportDeclUsage -> RnM () warnUnusedImport flag fld_env (L loc decl, used, unused) @@ -1553,8 +1674,9 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- to improve the consistent for ambiguous/unambiguous identifiers. -- See trac#14881. ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) - Nothing -> pprNameUnqualified n + Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld) + Just (fld, NoParent) -> ppr fld + Nothing -> pprNameUnqualified n -- Print unused names in a deterministic (lexicographic) order sort_unused :: SDoc @@ -1606,35 +1728,30 @@ getMinimalImports = fmap combine . mapM mk_minimal -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail n) - = [IEVar noExtField (to_ie_post_rn $ noLoc n)] - to_ie _ (AvailTC n [m] []) - | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] - to_ie iface (AvailTC n ns fs) - = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface + to_ie _ (Avail c) -- Note [Overloaded field import] + = [IEVar noExtField (to_ie_post_rn $ noLoc (greNamePrintableName c))] + to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else + | availExportsDecl avail = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] + to_ie iface (AvailTC n cs) + = case [xs | avail@(AvailTC x xs) <- mi_exports iface , x == n - , x `elem` xs -- Note [Partial export] + , availExportsDecl avail -- Note [Partial export] ] of [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] -- Note [Overloaded field import] _other | all_non_overloaded fs -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns ++ map flSelector fs | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] where + (ns, fs) = partitionGreNames cs - fld_lbls = map flLabel fs - - all_used (avail_occs, avail_flds) - = all (`elem` ns) avail_occs - && all (`elem` fld_lbls) (map flLabel avail_flds) + all_used avail_cs = all (`elem` cs) avail_cs all_non_overloaded = all (not . flIsOverloaded) @@ -1713,7 +1830,7 @@ Then the minimal import for module B is not import A( C( op ) ) which we would usually generate if C was exported from B. Hence -the (x `elem` xs) test when deciding what to generate. +the availExportsDecl test when deciding what to generate. Note [Overloaded field import] @@ -1733,6 +1850,23 @@ then the minimal import for module B must be because when DuplicateRecordFields is enabled, field selectors are not in scope without their enclosing datatype. +On the third hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + pattern MkT { foo } = Just foo + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( foo ) +because foo doesn't have a parent. This might actually be ambiguous if A +exports another field called foo, but there is no good answer to return and this +is a very obscure corner, so it seems to be the best we can do. See +DRFPatSynExport for a test of this. + ************************************************************************ * * @@ -1746,6 +1880,14 @@ qualImportItemErr rdr = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) +ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc +ambiguousImportItemErr rdr avails + = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") + 2 (vcat (map ppr_avail avails)) + where + ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr) + ppr_avail (Avail name) = ppr name + pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec = quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of @@ -1787,13 +1929,12 @@ badImportItemErr iface decl_spec ie avails Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie Nothing -> badImportItemErrStd iface decl_spec ie where - checkIfDataCon (AvailTC _ ns _) = - case find (\n -> importedFS == nameOccNameFS n) ns of - Just n -> isDataConName n + checkIfDataCon (AvailTC _ ns) = + case find (\n -> importedFS == occNameFS (occName n)) ns of + Just n -> isDataConName (greNameMangledName n) Nothing -> False checkIfDataCon _ = False - availOccName = nameOccName . availName - nameOccNameFS = occNameFS . nameOccName + availOccName = occName . availGreName importedFS = occNameFS . rdrNameOcc $ ieName ie illegalImportItemErr :: SDoc @@ -1834,7 +1975,7 @@ addDupDeclErr gres@(gre : _) where sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (map gre_name gres) + (map greMangledName gres) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 48378ba670..19d9d333ec 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -433,7 +433,7 @@ rnSpliceExpr splice traceRn "rnSpliceExpr: typed expression splice" empty ; lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 4147b9517f..4422732363 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -180,8 +180,7 @@ similarNameSuggestions where_look dflags global_env | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name + , let occ = greOccName gre , correct_name_space occ , (mod, how) <- qualsInScope gre , let rdr_qual = mkRdrQual mod occ ] @@ -189,8 +188,7 @@ similarNameSuggestions where_look dflags global_env | otherwise = [ (rdr_unqual, pair) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name + , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ , correct_name_space occ , pair <- case (unquals_in_scope gre, quals_only gre) of @@ -210,8 +208,8 @@ similarNameSuggestions where_look dflags global_env -------------------- unquals_in_scope :: GlobalRdrElt -> [HowInScope] - unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (nameSrcSpan n) ] + unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = [ Left (greDefinitionSrcSpan gre) ] | otherwise = [ Right ispec | i <- is, let ispec = is_decl i , not (is_qual ispec) ] @@ -220,8 +218,8 @@ similarNameSuggestions where_look dflags global_env -------------------- quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] -- Ones for which *only* the qualified version is in scope - quals_only (GRE { gre_name = n, gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) + quals_only (gre@GRE { gre_imp = is }) + = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) | i <- is, let ispec = is_decl i, is_qual ispec ] -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. @@ -366,10 +364,10 @@ extensionSuggestions rdrName qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope -qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is } - | lcl = case nameModule_maybe n of +qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } + | lcl = case greDefinitionModule gre of Nothing -> [] - Just m -> [(moduleName m, Left (nameSrcSpan n))] + Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] | otherwise = [ (is_as ispec, Right ispec) | i <- is, let ispec = is_decl i ] diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3acf9d83d2..3a9fd56833 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -423,30 +423,26 @@ check_unused flag bound_names used_names warnUnusedGREs :: [GlobalRdrElt] -> RnM () warnUnusedGREs gres = mapM_ warnUnusedGRE gres +-- NB the Names must not be the names of record fields! warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names +warnUnused flag names = + mapM_ (warnUnused1 flag . NormalGreName) names -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ +warnUnused1 :: WarningFlag -> GreName -> RnM () +warnUnused1 flag child + = when (reportable child) $ addUnusedWarning flag - occ (nameSrcSpan name) + (occName child) (greNameSrcSpan child) (text $ "Defined but not used" ++ opt_str) where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name opt_str = case flag of Opt_WarnUnusedTypePatterns -> " on the right hand side" _ -> "" warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) +warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre) + | otherwise = when (reportable (gre_name gre)) (mapM_ warn is) where occ = greOccName gre warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg @@ -457,22 +453,23 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) +mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) +mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre)) | gres <- occEnvElts rdr_env , gre <- gres - , Just lbl <- [greLabel gre] + , Just fl <- [greFieldLabel gre] ] -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names +reportable :: GreName -> Bool +reportable child + | NormalGreName name <- child + , isWiredInName name = False -- Don't report unused wired-in names -- Otherwise we get a zillion warnings -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) + | otherwise = not (startsWithUnderscore (occName child)) addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg @@ -508,7 +505,7 @@ addNameClashErrRn rdr_name gres (np1:nps) = gres msg1 = text "either" <+> ppr_gre np1 msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_gre_name gre <> comma + ppr_gre gre = sep [ pp_greMangledName gre <> comma , pprNameProvenance gre] -- When printing the name, take care to qualify it in the same @@ -519,14 +516,14 @@ addNameClashErrRn rdr_name gres -- imported from ‘Prelude’ at T15487.hs:1:8-13 -- or ... -- See #15487 - pp_gre_name gre@(GRE { gre_name = name, gre_par = parent - , gre_lcl = lcl, gre_imp = iss }) - | FldParent { par_lbl = Just lbl } <- parent - = text "the field" <+> quotes (ppr lbl) - | otherwise - = quotes (pp_qual <> dot <> ppr (nameOccName name)) + pp_greMangledName gre@(GRE { gre_name = child + , gre_lcl = lcl, gre_imp = iss }) = + case child of + FieldGreName fl -> text "the field" <+> quotes (ppr fl) + NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) where - pp_qual | lcl + pp_qual name + | lcl = ppr (nameModule name) | imp : _ <- iss -- This 'imp' is the one that -- pprNameProvenance chooses diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 0048256f0e..24aed42125 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -852,7 +852,7 @@ getInfo allInfo name -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + return (map greMangledName (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated. diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 57671e4d16..244f18e355 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -48,7 +48,7 @@ import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) + , greMangledName, mkRdrQual ) import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Unit.Module ( Module, ModuleName ) @@ -268,7 +268,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do imp_spec = ImpSpec decl_spec ImpAll env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre, iface)) + [gre] -> return (Just (greMangledName gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 32091e7836..6514968b39 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -22,7 +22,8 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.DataCon import GHC.Types.Name -import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) +import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..) + , globalRdrEnvElts, greMangledName, grePrintableName ) import GHC.Builtin.Names ( gHC_ERR ) import GHC.Types.Id import GHC.Types.Var.Set @@ -441,8 +442,7 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc pprHoleFit _ (RawHoleFit sd) = sd pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = hang display 2 provenance - where name = getName hfCand - tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap + where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap where pprArg b arg = case binderArgFlag b of -- See Note [Explicit Case Statement for Specificity] (Invisible spec) -> case spec of @@ -471,7 +471,10 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" - occDisp = pprPrefixOcc name + occDisp = case hfCand of + GreHFCand gre -> pprPrefixOcc (grePrintableName gre) + NameHFCand name -> pprPrefixOcc name + IdHFCand id_ -> pprPrefixOcc id_ tyDisp = ppWhen sTy $ dcolon <+> ppr hfType has = not . null wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) @@ -490,7 +493,8 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = provenance = ppWhen sProv $ parens $ case hfCand of GreHFCand gre -> pprNameProvenance gre - _ -> text "bound at" <+> ppr (getSrcLoc name) + NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name) + IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_) getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] getLocalBindings tidy_orig ct_loc @@ -784,7 +788,7 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = #if __GLASGOW_HASKELL__ <= 810 IdHFCand id -> idName id #endif - GreHFCand gre -> gre_name gre + GreHFCand gre -> greMangledName gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 23943a8617..9c00c23cd1 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -56,11 +56,11 @@ instance NamedThing HoleFitCandidate where getName hfc = case hfc of IdHFCand cid -> idName cid NameHFCand cname -> cname - GreHFCand cgre -> gre_name cgre + GreHFCand cgre -> greMangledName cgre getOccName hfc = case hfc of IdHFCand cid -> occName cid NameHFCand cname -> occName cname - GreHFCand cgre -> occName (gre_name cgre) + GreHFCand cgre -> occName (greMangledName cgre) instance HasOccName HoleFitCandidate where occName = getOccName diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 0e730a0b84..4d0c8da8e3 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -147,7 +147,7 @@ accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum Just (Just (acc', y)) -> (acc', Just y) _ -> (acc, Nothing) -type ExportOccMap = OccEnv (Name, IE GhcPs) +type ExportOccMap = OccEnv (GreName, IE GhcPs) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things @@ -248,13 +248,9 @@ exports_from_avail Nothing rdr_env _imports _this_mod -- Even though we don't check whether this is actually a data family -- only data families can locally define subordinate things (`ns` here) -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) = - let new_ns = - case ns of - [] -> [n] - (p:_) -> if p == n then ns else n:ns - in AvailTC n new_ns flds - + fix_faminst avail@(AvailTC n ns) + | availExportsDecl avail = avail + | otherwise = AvailTC n (NormalGreName n:ns) fix_faminst avail = avail @@ -273,8 +269,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod -- See Note [Avails of associated data families] expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] - expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) - | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre (gre@GRE { gre_par = ParentIs p }) + | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }] expand_tyty_gre gre = [gre] imported_modules = [ imv_name imv @@ -355,10 +351,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod (n, avail, flds) <- lookup_ie_all ie n' let name = unLoc n return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) - , AvailTC name (name:avail) flds) + , availTC name (name:avail) flds) - lookup_ie ie@(IEThingWith _ l wc sub_rdrs _) + lookup_ie ie@(IEThingWith _ l wc sub_rdrs) = do (lname, subs, avails, flds) <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs @@ -367,9 +363,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod NoIEWildcard -> return (lname, [], []) IEWildcard _ -> lookup_ie_all ie l let name = unLoc lname - return (IEThingWith noExtField (replaceLWrappedName l name) wc subs - (flds ++ (map noLoc all_flds)), - AvailTC name (name : avails ++ all_avail) + let flds' = flds ++ (map noLoc all_flds) + return (IEThingWith flds' (replaceLWrappedName l name) wc subs, + availTC name (name : avails ++ all_avail) (map unLoc flds ++ all_flds)) @@ -420,15 +416,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionEithers . map classifyGRE - -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre +classifyGREs = partitionGreNames . map gre_name -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -529,11 +517,12 @@ lookupChildrenExport spec_parent rdr_items = NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n ; return (Left (L l (IEName (L l ub))))} - FoundFL fls -> return $ Right (L (getLoc n) fls) - FoundName par name -> do { checkPatSynParent spec_parent par name - ; return - $ Left (replaceLWrappedName n name) } - IncorrectParent p g td gs -> failWithDcErr p g td gs + FoundChild par child -> do { checkPatSynParent spec_parent par child + ; return $ case child of + FieldGreName fl -> Right (L (getLoc n) fl) + NormalGreName name -> Left (replaceLWrappedName n name) + } + IncorrectParent p c gs -> failWithDcErr p c gs -- Note: [Typing Pattern Synonym Exports] @@ -595,33 +584,30 @@ lookupChildrenExport spec_parent rdr_items = checkPatSynParent :: Name -- ^ Alleged parent type constructor -- User wrote T( P, Q ) -> Parent -- The parent of P we discovered - -> Name -- ^ Either a + -> GreName -- ^ Either a -- a) Pattern Synonym Constructor -- b) A pattern synonym selector -> TcM () -- Fails if wrong parent checkPatSynParent _ (ParentIs {}) _ = return () -checkPatSynParent _ (FldParent {}) _ - = return () - -checkPatSynParent parent NoParent mpat_syn +checkPatSynParent parent NoParent gname | isUnboundName parent -- Avoid an error cascade = return () | otherwise = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal mpat_syn + ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname) -- 1. Check that the Id was actually from a thing associated with patsyns ; case mpat_syn_thing of AnId i | isId i , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr i) parent_ty_con p + -> handle_pat_syn (selErr gname) parent_ty_con p AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } + _ -> failWithDcErr parent gname [] } where psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" @@ -669,40 +655,47 @@ checkPatSynParent parent NoParent mpat_syn check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] -> RnM ExportOccMap check_occs ie occs avails - -- 'names' and 'fls' are the entities specified by 'ie' - = foldlM check occs names_with_occs + -- 'avails' are the entities specified by 'ie' + = foldlM check occs children where - -- Each Name specified by 'ie', paired with the OccName used to - -- refer to it in the GlobalRdrEnv - -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). - -- - -- We check for export clashes using the selector Name, but need - -- the field label OccName for presenting error messages. - names_with_occs = availsNamesWithOccs avails - - check occs (name, occ) - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) + children = concatMap availGreNames avails + + -- Check for distinct children exported with the same OccName (an error) or + -- for duplicate exports of the same child (a warning). + check :: ExportOccMap -> GreName -> RnM ExportOccMap + check occs child + = case try_insert occs child of + Right occs' -> return occs' - Just (name', ie') - | name == name' -- Duplicate export + Left (child', ie') + | greNameMangledName child == greNameMangledName child' -- Duplicate export -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok name ie ie')) - (dupExportWarn occ ie ie') + (not (dupExport_ok child ie ie')) + (dupExportWarn child ie ie') ; return occs } | otherwise -- Same occ name but different names: an error -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env occ name' name ie' ie) ; + addErr (exportClashErr global_env child' child ie' ie) ; return occs } + + -- Try to insert a child into the map, returning Left if there is something + -- already exported with the same OccName + try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap + try_insert occs child + = case lookupOccEnv occs name_occ of + Nothing -> Right (extendOccEnv occs name_occ (child, ie)) + Just x -> Left x where - name_occ = nameOccName name + -- For fields, we check for export clashes using the (OccName of the) + -- selector Name + name_occ = nameOccName (greNameMangledName child) -dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool --- The Name is exported by both IEs. Is that ok? +dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool +-- The GreName is exported by both IEs. Is that ok? -- "No" iff the name is mentioned explicitly in both IEs -- or one of the IEs mentions the name *alone* -- "Yes" otherwise @@ -728,13 +721,13 @@ dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool -- import Foo -- data instance T Int = TInt -dupExport_ok n ie1 ie2 +dupExport_ok child ie1 ie2 = not ( single ie1 || single ie2 || (explicit_in ie1 && explicit_in ie2) ) where explicit_in (IEModuleContents {}) = False -- module M explicit_in (IEThingAll _ r) - = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) + = occName child == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) explicit_in _ = True single IEVar {} = True @@ -788,9 +781,9 @@ exportItemErr export_item text "attempts to export constructors or class methods that are not visible here" ] -dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), +dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc +dupExportWarn child ie1 ie2 + = hsep [quotes (ppr child), text "is exported by", quotes (ppr ie1), text "and", quotes (ppr ie2)] @@ -806,11 +799,11 @@ dcErrMsg ty_con what_is thing parents = [_] -> text "Parent:" _ -> text "Parents:") <+> fsep (punctuate comma parents) -failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a -failWithDcErr parent thing thing_doc parents = do - ty_thing <- tcLookupGlobal thing +failWithDcErr :: Name -> GreName -> [Name] -> TcM a +failWithDcErr parent child parents = do + ty_thing <- tcLookupGlobal (greNameMangledName child) failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing) - thing_doc (map ppr parents) + (ppr child) (map ppr parents) where tyThingCategory' :: TyThing -> String tyThingCategory' (AnId i) @@ -818,32 +811,37 @@ failWithDcErr parent thing thing_doc parents = do tyThingCategory' i = tyThingCategory i -exportClashErr :: GlobalRdrEnv -> OccName - -> Name -> Name +exportClashErr :: GlobalRdrEnv + -> GreName -> GreName -> IE GhcPs -> IE GhcPs -> MsgDoc -exportClashErr global_env occ name1 name2 ie1 ie2 +exportClashErr global_env child1 child2 ie1 ie2 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] + , ppr_export child1' gre1' ie1' + , ppr_export child2' gre2' ie2' + ] where - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name name)) - 2 (pprNameProvenance (get_gre name))) + occ = occName child1 + + ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr_name child)) + 2 (pprNameProvenance gre)) -- DuplicateRecordFields means that nameOccName might be a mangled -- $sel-prefixed thing, in which case show the correct OccName alone - ppr_name name - | nameOccName name == occ = ppr name - | otherwise = ppr occ + -- (but otherwise show the Name so it will have a module qualifier) + ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl + | otherwise = ppr (flSelector fl) + ppr_name (NormalGreName name) = ppr name -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = fromMaybe (pprPanic "exportClashErr" (ppr name)) - (lookupGRE_Name_OccName global_env name occ) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = - case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of - LT -> (name1, ie1, name2, ie2) - GT -> (name2, ie2, name1, ie1) + gre1 = get_gre child1 + gre2 = get_gre child2 + get_gre child + = fromMaybe (pprPanic "exportClashErr" (ppr child)) + (lookupGRE_GreName global_env child) + (child1', gre1', ie1', child2', gre2', ie2') = + case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of + LT -> (child1, gre1, ie1, child2, gre2, ie2) + GT -> (child2, gre2, ie2, child1, gre1, ie1) EQ -> panic "exportClashErr: clashing exports have idential location" diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 15ca20b738..14c55d1627 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1356,12 +1356,12 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty Just gre -> do { unless (null (tail xs)) $ do let L loc _ = hsRecFieldLbl (unLoc upd) setSrcSpan loc $ addUsedGRE True gre - ; lookupSelector (upd, gre_name gre) } + ; lookupSelector (upd, greMangledName gre) } -- The field doesn't belong to this parent, so report -- an error but keep going through all the fields Nothing -> do { addErrTc (fieldNotInType p (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, gre_name (snd (head xs))) } + ; lookupSelector (upd, greMangledName (snd (head xs))) } -- Given a (field update, selector name) pair, look up the -- selector to give a field update with an unambiguous Id diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 524d97077d..e5806637b0 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -493,11 +493,12 @@ tc_rec_sel_id lbl sel_name = do { thing <- tcLookup sel_name ; case thing of ATcId { tct_id = id } - -> do { check_local_id occ id + -> do { check_naughty occ id + ; check_local_id id ; return id } AGlobal (AnId id) - -> do { check_global_id occ id + -> do { check_naughty occ id ; return id } -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment @@ -545,7 +546,7 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } } } } } + ; return (greMangledName gre) } } } } } -- This field name really is ambiguous, so add a suitable "ambiguous -- occurrence" error, then give up. @@ -596,10 +597,10 @@ lookupParents rdr ; mapM lookupParent gres } where lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) + lookupParent gre = do { id <- tcLookupId (greMangledName gre) ; case recordSelectorTyCon_maybe id of Just rstc -> return (rstc, gre) - Nothing -> failWithTc (notSelector (gre_name gre)) } + Nothing -> failWithTc (notSelector (greMangledName gre)) } fieldNotInType :: RecSelParent -> RdrName -> SDoc @@ -758,12 +759,14 @@ tc_infer_id id_name ; global_env <- getGlobalRdrEnv ; case thing of ATcId { tct_id = id } - -> do { check_local_id occ id + -> do { check_local_id id ; return_id id } AGlobal (AnId id) - -> do { check_global_id occ id - ; return_id id } + -> return_id id + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- Hence no checkTh stuff here AGlobal (AConLike cl) -> case cl of RealDataCon con -> return_data_con con @@ -798,8 +801,6 @@ tc_infer_id id_name = text "Illegal term-level use of the type constructor" <+> quotes (ppr (tyConName ty_con)) - occ = nameOccName id_name - return_id id = return (HsVar noExtField (noLoc id), idType id) return_data_con con @@ -845,19 +846,11 @@ tc_infer_id id_name , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res) } -check_local_id :: OccName -> Id -> TcM () -check_local_id occ id - = do { check_naughty occ id -- See Note [HsVar: naughty record selectors] - ; checkThLocalId id +check_local_id :: Id -> TcM () +check_local_id id + = do { checkThLocalId id ; tcEmitBindingUsage $ unitUE (idName id) One } -check_global_id :: OccName -> Id -> TcM () -check_global_id occ id - = check_naughty occ id -- See Note [HsVar: naughty record selectors] - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- Hence no checkTh stuff here - check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) @@ -868,15 +861,7 @@ nonBidirectionalErr name = failWithTc $ text "non-bidirectional pattern synonym" <+> quotes (ppr name) <+> text "used in an expression" -{- Note [HsVar: naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All record selectors should really be HsRecFld (ambiguous or -unambiguous), but currently not all of them are: see #18452. So we -need to check for naughty record selectors in tc_infer_id, as well as -in tc_rec_sel_id. - -Remove this code when fixing #18452. - +{- Note [Linear fields generalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As per Note [Polymorphisation of linear fields], linear field of data diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 8da6031597..8f3cec19d0 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -1491,7 +1491,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, foe_binds ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre) + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) emptyFVs fo_gres ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) @@ -1556,11 +1556,11 @@ tcPreludeClashWarn warnFlag name = do where isLocalDef = gre_lcl x == True -- Names are identical ... - nameClashes = nameOccName (gre_name x) == nameOccName name + nameClashes = nameOccName (greMangledName x) == nameOccName name -- ... but not the actual definitions, because we don't want to -- warn about a bad definition of e.g. <> in Data.Semigroup, which -- is the (only) proper place where this should be defined - isNotInProperModule = gre_name x /= name + isNotInProperModule = greMangledName x /= name -- List of all offending definitions clashingElts :: [GlobalRdrElt] @@ -1569,9 +1569,9 @@ tcPreludeClashWarn warnFlag name = do ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep + ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep [ text "Local definition of" - , (quotes . ppr . nameOccName . gre_name) x + , (quotes . ppr . nameOccName . greMangledName) x , text "clashes with a future Prelude name." ] $$ text "This will become an error in a future release." ) @@ -2489,7 +2489,7 @@ isGHCiMonad hsc_env ty let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) case occIO of Just [n] -> do - let name = gre_name n + let name = greMangledName n ghciClass <- tcLookupClass ghciIoClassName userTyCon <- tcLookupTyCon name let userTy = mkTyConApp userTyCon [] @@ -2857,7 +2857,7 @@ loadUnqualIfaces hsc_env ictxt unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) - , let name = gre_name gre + , let name = greMangledName gre , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index d01f8992b5..1a5aacdbe1 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -1465,7 +1465,7 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2 ; addUsedGREs gre_list -- If a newtype constructor was imported, don't warn about not -- importing it... - ; traverse_ keepAlive $ map gre_name gre_list + ; traverse_ keepAlive $ map greMangledName gre_list -- ...and similarly, if a newtype constructor was defined in the same -- module, don't warn about it being unused. -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 50d4f72610..b912baa04d 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -4152,9 +4152,8 @@ checkPartialRecordField all_cons fld (sep [text "Use of partial record field selector" <> colon, nest 2 $ quotes (ppr occ_name)]) where - sel_name = flSelector fld - loc = getSrcSpan sel_name - occ_name = getOccName sel_name + loc = getSrcSpan (flSelector fld) + occ_name = occName fld (cons_with_field, cons_without_field) = partition has_field all_cons has_field con = fld `elem` (dataConFieldLabels con) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 13b5da759f..ae9dd613d3 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -57,6 +57,7 @@ import GHC.Types.Id.Make import GHC.Tc.TyCl.Utils import GHC.Core.ConLike import GHC.Types.FieldLabel +import GHC.Rename.Env import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Error @@ -95,7 +96,7 @@ recoverPSB (PSB { psb_id = L _ name ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv ; return (emptyBag, gbl_env) } where - (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details + (_arg_names, is_infix) = collectPatSynArgInfo details mk_placeholder matcher_name = mkPatSyn name is_infix ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) @@ -144,7 +145,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name - ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + ; let (arg_names, is_infix) = collectPatSynArgInfo details ; (tclvl, wanted, ((lpat', args), pat_ty)) <- pushLevelAndCaptureConstraints $ tcInferPat PatSyn lpat $ @@ -184,6 +185,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details ; mapM_ dependentArgErr bad_args ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) + ; rec_fields <- lookupConstructorFields name ; tc_patsyn_finish lname dir is_infix lpat' (mkTyVarBinders InferredSpec univ_tvs , req_theta, ev_binds, req_dicts) @@ -355,7 +357,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] ; let decl_arity = length arg_names - (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + (arg_names, is_infix) = collectPatSynArgInfo details ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of Right stuff -> return stuff @@ -440,6 +442,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; traceTc "tcCheckPatSynDecl }" $ ppr name + ; rec_fields <- lookupConstructorFields name ; tc_patsyn_finish lname dir is_infix lpat' (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts) (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts) @@ -623,21 +626,12 @@ a pattern synonym. What about the /building/ side? -} collectPatSynArgInfo :: HsPatSynDetails GhcRn - -> ([Name], [Name], Bool) + -> ([Name], Bool) collectPatSynArgInfo details = case details of - PrefixCon _ names -> (map unLoc names, [], False) - InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) - RecCon names -> (vars, sels, False) - where - (vars, sels) = unzip (map splitRecordPatSyn names) - where - splitRecordPatSyn :: RecordPatSynField (Located Name) - -> (Name, Name) - splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) - = (patVar, selId) + PrefixCon _ names -> (map unLoc names, False) + InfixCon name1 name2 -> (map unLoc [name1, name2], True) + RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) addPatSynCtxt :: Located Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside @@ -663,7 +657,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) -> ([LHsExpr GhcTc], [TcType]) -- ^ Pattern arguments and types -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names + -> [FieldLabel] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn -> TcM (LHsBinds GhcTc, TcGblEnv) tc_patsyn_finish lname dir is_infix lpat' @@ -709,13 +703,6 @@ tc_patsyn_finish lname dir is_infix lpat' ex_tvs prov_theta arg_tys pat_ty - -- TODO: Make this have the proper information - ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) - , flIsOverloaded = False - , flSelector = name } - field_labels' = map mkFieldLabel field_labels - - -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix (univ_tvs, req_theta) @@ -723,7 +710,7 @@ tc_patsyn_finish lname dir is_infix lpat' arg_tys pat_ty matcher_id builder_id - field_labels' + field_labels -- Selectors ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 7fff1a9e35..c1888c7f36 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -174,7 +174,8 @@ checkHsigIface tcg_env gr sig_iface -- The hsig did NOT define this function; that means it must -- be a reexport. In this case, make sure the 'Name' of the -- reexport matches the 'Name exported here. - | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = + | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do + let name' = greMangledName gre when (name /= name') $ do -- See Note [Error reporting bad reexport] -- TODO: Actually this error swizzle doesn't work @@ -751,7 +752,7 @@ mergeSignatures let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) | (occ, f) <- concatMap mi_fixities ifaces , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] @@ -951,7 +952,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do let avails = calculateAvails home_unit impl_iface False{- safe -} NotBoot ImportedBySystem - fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) + fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] updGblEnv (\tcg_env -> tcg_env { diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index a1ca04b487..93a43795dc 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -625,7 +625,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_dir = dir })) = do { id' <- zonkIdBndr env id ; (env1, lpat') <- zonkPat env lpat - ; let details' = zonkPatSynDetails env1 details + ; details' <- zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $ bind { psb_id = L loc id' @@ -635,13 +635,17 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails GhcTc - -> HsPatSynDetails GhcTc + -> TcM (HsPatSynDetails GhcTc) zonkPatSynDetails env (PrefixCon _ as) - = PrefixCon noTypeArgs (map (zonkLIdOcc env) as) + = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as) zonkPatSynDetails env (InfixCon a1 a2) - = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) + = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) zonkPatSynDetails env (RecCon flds) - = RecCon (map (fmap (zonkLIdOcc env)) flds) + = RecCon <$> mapM (zonkPatSynField env) flds + +zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc) +zonkPatSynField env (RecordPatSynField x y) = + RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y) zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc -> TcM (ZonkEnv, HsPatSynDir GhcTc) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 5bde24bb12..cad86d1445 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -412,7 +412,7 @@ cvtDec (TH.PatSynD nm args dir pat) cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM vNameL sels + = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameL) sels ; vars' <- mapM (vNameL . mkNameS . nameBase) sels ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs index adc3ffa391..61d9d91b0a 100644 --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -10,22 +10,32 @@ module GHC.Types.Avail ( Avails, AvailInfo(..), avail, + availField, + availTC, availsToNameSet, availsToNameSetWithSelectors, availsToNameEnv, - availName, availNames, availNonFldNames, + availExportsDecl, + availName, availGreName, + availNames, availNonFldNames, availNamesWithSelectors, availFlds, - availsNamesWithOccs, - availNamesWithOccs, + availGreNames, + availSubordinateGreNames, stableAvailCmp, plusAvail, trimAvail, filterAvail, filterAvails, - nubAvails - - + nubAvails, + + GreName(..), + greNameMangledName, + greNamePrintableName, + greNameSrcSpan, + greNameFieldLabel, + partitionGreNames, + stableGreNameCmp, ) where import GHC.Prelude @@ -33,6 +43,7 @@ import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set +import GHC.Types.SrcLoc import GHC.Types.FieldLabel import GHC.Utils.Binary @@ -42,8 +53,9 @@ import GHC.Utils.Panic import GHC.Utils.Misc import Data.Data ( Data ) +import Data.Either ( partitionEithers ) import Data.List ( find ) -import Data.Function +import Data.Maybe -- ----------------------------------------------------------------------------- -- The AvailInfo type @@ -51,20 +63,19 @@ import Data.Function -- | Records what things are \"available\", i.e. in scope data AvailInfo - -- | An ordinary identifier in scope - = Avail Name + -- | An ordinary identifier in scope, or a field label without a parent type + -- (see Note [Representing pattern synonym fields in AvailInfo]). + = Avail GreName -- | A type or class in scope -- -- The __AvailTC Invariant__: If the type or class is itself to be in scope, -- it must be /first/ in this list. Thus, typically: -- - -- > AvailTC Eq [Eq, ==, \/=] [] + -- > AvailTC Eq [Eq, ==, \/=] | AvailTC 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 + [GreName] -- ^ The available pieces of type or class -- (see Note [Representing fields in AvailInfo]). deriving ( Eq -- ^ Used when deciding if the interface has changed @@ -76,6 +87,8 @@ type Avails = [AvailInfo] {- Note [Representing fields in AvailInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [FieldLabel] in GHC.Types.FieldLabel. + When -XDuplicateRecordFields is disabled (the normal case), a datatype like @@ -83,11 +96,11 @@ datatype like gives rise to the AvailInfo - AvailTC T [T, MkT] [FieldLabel "foo" False foo] + AvailTC T [T, MkT, FieldLabel "foo" False foo] whereas if -XDuplicateRecordFields is enabled it gives - AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] + AvailTC T [T, MkT, FieldLabel "foo" True $sel:foo:MkT] since the label does not match the selector name. @@ -101,8 +114,8 @@ multiple distinct fields with the same label. For example, gives rise to - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt + AvailTC F [ F, MkFInt, MkFBool + , FieldLabel "foo" True $sel:foo:MkFInt , FieldLabel "foo" True $sel:foo:MkFBool ] Moreover, note that the flIsOverloaded flag need not be the same for @@ -111,8 +124,8 @@ the two data instances are defined in different modules, one with `-XDuplicateRecordFields` enabled and one with it disabled. Thus it is possible to have - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt + AvailTC F [ F, MkFInt, MkFBool + , FieldLabel "foo" True $sel:foo:MkFInt , FieldLabel "foo" False foo ] If the two data instances are defined in different modules, both @@ -121,20 +134,58 @@ them from the same module (even with `-XDuplicateRecordfields` enabled), because they would be represented identically. The workaround here is to enable `-XDuplicateRecordFields` on the defining modules. + + +Note [Representing pattern synonym fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record pattern synonym fields cannot be represented using AvailTC like fields of +normal record types (see Note [Representing fields in AvailInfo]), because they +do not always have a parent type constructor. So we represent them using the +Avail constructor, with a NormalGreName that carries the underlying FieldLabel. + +Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration + + pattern MkFoo{f} = Bar f + +gives rise to the AvailInfo + + Avail (NormalGreName MkFoo) + Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo)) + +However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in +an export list, then whenever `f` is imported the parent will be `T`, +represented as + + AvailTC T [ NormalGreName T + , NormalGreName MkFoo + , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ] + +See also Note [GreNames] in GHC.Types.Name.Reader. -} -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 -stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = - (n `stableNameCmp` m) `thenCmp` - (cmpList stableNameCmp ns ms) `thenCmp` - (cmpList (stableNameCmp `on` flSelector) nfs mfs) -stableAvailCmp (AvailTC {}) (Avail {}) = GT +stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` + (cmpList stableGreNameCmp ns ms) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +stableGreNameCmp :: GreName -> GreName -> Ordering +stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2 +stableGreNameCmp (NormalGreName {}) (FieldGreName {}) = LT +stableGreNameCmp (FieldGreName f1) (FieldGreName f2) = flSelector f1 `stableNameCmp` flSelector f2 +stableGreNameCmp (FieldGreName {}) (NormalGreName {}) = GT avail :: Name -> AvailInfo -avail n = Avail n +avail n = Avail (NormalGreName n) + +availField :: FieldLabel -> AvailInfo +availField fl = Avail (FieldGreName fl) + +availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo +availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls) + -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -152,48 +203,106 @@ availsToNameEnv avails = foldr add emptyNameEnv avails where add avail env = extendNameEnvList env (zip (availNames avail) (repeat avail)) +-- | Does this 'AvailInfo' export the parent decl? This depends on the +-- invariant that the parent is first if it appears at all. +availExportsDecl :: AvailInfo -> Bool +availExportsDecl (AvailTC ty_name names) + | n : _ <- names = NormalGreName ty_name == n + | otherwise = False +availExportsDecl _ = True + -- | Just the main name made available, i.e. not the available pieces --- of type or class brought into scope by the 'GenAvailInfo' +-- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _ _) = n +availName (Avail n) = greNameMangledName n +availName (AvailTC n _) = n + +availGreName :: AvailInfo -> GreName +availGreName (Avail c) = c +availGreName (AvailTC n _) = NormalGreName n -- | All names made available by the availability information (excluding overloaded selectors) availNames :: AvailInfo -> [Name] -availNames (Avail n) = [n] -availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] +availNames (Avail c) = childNonOverloadedNames c +availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs + +childNonOverloadedNames :: GreName -> [Name] +childNonOverloadedNames (NormalGreName n) = [n] +childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ] -- | All names made available by the availability information (including overloaded selectors) availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail n) = [n] -availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs +availNamesWithSelectors (Avail c) = [greNameMangledName c] +availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs -- | Names for non-fields made available by the availability information availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail n) = [n] -availNonFldNames (AvailTC _ ns _) = ns +availNonFldNames (Avail (NormalGreName n)) = [n] +availNonFldNames (Avail (FieldGreName {})) = [] +availNonFldNames (AvailTC _ ns) = mapMaybe f ns + where + f (NormalGreName n) = Just n + f (FieldGreName {}) = Nothing -- | Fields made available by the availability information availFlds :: AvailInfo -> [FieldLabel] -availFlds (AvailTC _ _ fs) = fs -availFlds _ = [] +availFlds (Avail c) = maybeToList (greNameFieldLabel c) +availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs + +-- | Names and fields made available by the availability information. +availGreNames :: AvailInfo -> [GreName] +availGreNames (Avail c) = [c] +availGreNames (AvailTC _ cs) = cs + +-- | Names and fields made available by the availability information, other than +-- the main decl itself. +availSubordinateGreNames :: AvailInfo -> [GreName] +availSubordinateGreNames (Avail {}) = [] +availSubordinateGreNames avail@(AvailTC _ ns) + | availExportsDecl avail = tail ns + | otherwise = ns + + +-- | Used where we may have an ordinary name or a record field label. +-- See Note [GreNames] in GHC.Types.Name.Reader. +data GreName = NormalGreName Name + | FieldGreName FieldLabel + deriving (Data, Eq) + +instance Outputable GreName where + ppr (NormalGreName n) = ppr n + ppr (FieldGreName fl) = ppr fl + +instance HasOccName GreName where + occName (NormalGreName n) = occName n + occName (FieldGreName fl) = occName fl + +-- | A 'Name' for internal use, but not for output to the user. For fields, the +-- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader. +greNameMangledName :: GreName -> Name +greNameMangledName (NormalGreName n) = n +greNameMangledName (FieldGreName fl) = flSelector fl + +-- | A 'Name' suitable for output to the user. For fields, the 'OccName' will +-- be the field label. See Note [GreNames] in GHC.Types.Name.Reader. +greNamePrintableName :: GreName -> Name +greNamePrintableName (NormalGreName n) = n +greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl + +greNameSrcSpan :: GreName -> SrcSpan +greNameSrcSpan (NormalGreName n) = nameSrcSpan n +greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl) + +greNameFieldLabel :: GreName -> Maybe FieldLabel +greNameFieldLabel (NormalGreName {}) = Nothing +greNameFieldLabel (FieldGreName fl) = Just fl + +partitionGreNames :: [GreName] -> ([Name], [FieldLabel]) +partitionGreNames = partitionEithers . map to_either + where + to_either (NormalGreName n) = Left n + to_either (FieldGreName fl) = Right fl -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] -availsNamesWithOccs = concatMap availNamesWithOccs - --- | 'Name's made available by the availability information, paired with --- the 'OccName' used to refer to each one. --- --- When @DuplicateRecordFields@ is in use, the 'Name' may be the --- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the --- 'OccName' will be the label of the field (e.g. @foo@). --- --- See Note [Representing fields in AvailInfo]. -availNamesWithOccs :: AvailInfo -> [(Name, OccName)] -availNamesWithOccs (Avail n) = [(n, nameOccName n)] -availNamesWithOccs (AvailTC _ ns fs) - = [ (n, nameOccName n) | n <- ns ] ++ - [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] -- ----------------------------------------------------------------------------- -- Utility @@ -203,30 +312,22 @@ plusAvail a1 a2 | debugIsOn && availName a1 /= availName a2 = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) plusAvail a1@(Avail {}) (Avail {}) = a1 -plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 -plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 -plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) - = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first +plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 +plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) + = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (fs1 `unionLists` fs2) (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (fs1 `unionLists` fs2) (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (fs1 `unionLists` fs2) (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) - (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) - = AvailTC n1 ss1 (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) - = AvailTC n1 ss2 (fs1 `unionLists` fs2) plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail n) _ = Avail n -trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of - Just x -> AvailTC n [] [x] - Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] +trimAvail avail@(Avail {}) _ = avail +trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of + Just c -> AvailTC n [c] + Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) -- | filters 'AvailInfo's by the given predicate filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] @@ -236,12 +337,11 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest = case ie of - Avail n | keep n -> ie : rest + Avail c | keep (greNameMangledName c) -> ie : rest | otherwise -> rest - AvailTC tc ns fs -> - let ns' = filter keep ns - fs' = filter (keep . flSelector) fs in - if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest + AvailTC tc cs -> + let cs' = filter (keep . greNameMangledName) cs + in if null cs' then rest else AvailTC tc cs' : rest -- | Combines 'AvailInfo's from the same family @@ -263,19 +363,17 @@ instance Outputable AvailInfo where pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n -pprAvail (AvailTC n ns fs) - = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi - , fsep (punctuate comma (map (ppr . flLabel) fs))]) +pprAvail (AvailTC n ns) + = ppr n <> braces (fsep (punctuate comma (map ppr ns))) instance Binary AvailInfo where put_ bh (Avail aa) = do putByte bh 0 put_ bh aa - put_ bh (AvailTC ab ac ad) = do + put_ bh (AvailTC ab ac) = do putByte bh 1 put_ bh ab put_ bh ac - put_ bh ad get bh = do h <- getByte bh case h of @@ -283,5 +381,19 @@ instance Binary AvailInfo where return (Avail aa) _ -> do ab <- get bh ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) + return (AvailTC ab ac) + +instance Binary GreName where + put_ bh (NormalGreName aa) = do + putByte bh 0 + put_ bh aa + put_ bh (FieldGreName ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (NormalGreName aa) + _ -> do ab <- get bh + return (FieldGreName ab) diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs index f3352c50a1..226a854f6f 100644 --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -1,12 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {- % % (c) Adam Gundry 2013-2015 % +Note [FieldLabel] +~~~~~~~~~~~~~~~~~ + This module defines the representation of FieldLabels as stored in TyCons. As well as a selector name, these have some extra structure to support the DuplicateRecordFields extension. @@ -63,9 +68,9 @@ Of course, datatypes with no constructors cannot have any fields. module GHC.Types.FieldLabel ( FieldLabelString , FieldLabelEnv - , FieldLbl(..) - , FieldLabel - , mkFieldLabelOccs + , FieldLabel(..) + , fieldSelectorOccName + , fieldLabelPrintableName ) where @@ -89,22 +94,26 @@ type FieldLabelString = FastString type FieldLabelEnv = DFastStringEnv FieldLabel -type FieldLabel = FieldLbl Name - --- | Fields in an algebraic record type -data FieldLbl a = FieldLabel { +-- | Fields in an algebraic record type; see Note [FieldLabel]. +data FieldLabel = FieldLabel { flLabel :: FieldLabelString, -- ^ User-visible label of the field flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on -- in the defining module for this datatype? - flSelector :: a -- ^ Record selector function + flSelector :: Name -- ^ Record selector function } - deriving (Eq, Functor, Foldable, Traversable) -deriving instance Data a => Data (FieldLbl a) + deriving (Data, Eq) -instance Outputable a => Outputable (FieldLbl a) where - ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) +instance HasOccName FieldLabel where + occName = mkVarOccFS . flLabel -instance Binary a => Binary (FieldLbl a) where +instance Outputable FieldLabel where + ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))) + +-- | We need the @Binary Name@ constraint here even though there is an instance +-- defined in "GHC.Types.Name", because the we have a SOURCE import, so the +-- instance is not in scope. And the instance cannot be added to Name.hs-boot +-- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". +instance Binary Name => Binary FieldLabel where put_ bh (FieldLabel aa ab ac) = do put_ bh aa put_ bh ab @@ -120,11 +129,18 @@ instance Binary a => Binary (FieldLbl a) where -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors]. -mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName -mkFieldLabelOccs lbl dc is_overloaded - = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = sel_occ } +fieldSelectorOccName :: FieldLabelString -> OccName -> Bool -> OccName +fieldSelectorOccName lbl dc is_overloaded + | is_overloaded = mkRecFldSelOcc str + | otherwise = mkVarOccFS lbl where str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc - sel_occ | is_overloaded = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl + +-- | Undo the name mangling described in Note [FieldLabel] to produce a Name +-- that has the user-visible OccName (but the selector's unique). This should +-- be used only when generating output, when we want to show the label, but may +-- need to qualify it with a module prefix. +fieldLabelPrintableName :: FieldLabel -> Name +fieldLabelPrintableName fl + | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl)) + | otherwise = flSelector fl diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot index 8799f6dbb3..ebc2efd34c 100644 --- a/compiler/GHC/Types/Name.hs-boot +++ b/compiler/GHC/Types/Name.hs-boot @@ -3,13 +3,16 @@ module GHC.Types.Name ( module GHC.Types.Name.Occurrence ) where -import GHC.Prelude () +import GHC.Prelude (Eq) import {-# SOURCE #-} GHC.Types.Name.Occurrence import GHC.Types.Unique import GHC.Utils.Outputable +import Data.Data (Data) data Name +instance Eq Name +instance Data Name instance Uniquable Name instance Outputable Name @@ -22,3 +25,4 @@ class NamedThing a where nameUnique :: Name -> Unique setNameUnique :: Name -> Unique -> Name nameOccName :: Name -> OccName +tidyNameOcc :: Name -> OccName -> Name diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index be9d26ac91..e48f39576e 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -120,7 +120,7 @@ mkPrintUnqualified unit_env env map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] ++ [ eqTyConName ] - right_name gre = nameModule_maybe (gre_name gre) == Just mod + right_name gre = greDefinitionModule gre == Just mod unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env qual_gres = filter right_name (lookupGlobalRdrEnv env occ) diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index 0e6c9ead94..c40a7143ff 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -46,7 +46,8 @@ module GHC.Types.Name.Reader ( GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_RdrName, lookupGRE_Name, + lookupGRE_GreName, lookupGRE_FieldLabel, lookupGRE_Name_OccName, getGRE_NameQualifier_maybes, transformGREs, pickGREs, pickGREsModExp, @@ -55,11 +56,14 @@ module GHC.Types.Name.Reader ( gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, greRdrNames, greSrcSpan, greQualModName, gresToAvailInfo, + greDefinitionModule, greDefinitionSrcSpan, + greMangledName, grePrintableName, -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel, + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greFieldLabel, unQualOK, qualSpecOK, unQualSpecOK, pprNameProvenance, + GreName(..), greNameSrcSpan, Parent(..), greParent_maybe, ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), importSpecLoc, importSpecModule, isExplicitItem, bestImport, @@ -473,42 +477,35 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt] -- greOccName gre = occ -- -- NB: greOccName gre is usually the same as --- nameOccName (gre_name gre), but not always in the --- case of record selectors; see greOccName +-- nameOccName (greMangledName gre), but not always in the +-- case of record selectors; see Note [GreNames] -- | Global Reader Element -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt - = GRE { gre_name :: Name - , gre_par :: Parent + = GRE { gre_name :: GreName -- ^ See Note [GreNames] + , gre_par :: Parent -- ^ See Note [Parents] , gre_lcl :: Bool -- ^ True <=> the thing was defined locally , gre_imp :: [ImportSpec] -- ^ In scope through these imports } deriving (Data, Eq) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. See Note [Parents] +-- | See Note [Parents] data Parent = NoParent | ParentIs { par_is :: Name } - | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } - -- ^ See Note [Parents for record fields] deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n - ppr (FldParent n f) = text "fldparent:" - <> ppr n <> colon <> ppr f plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 -plusParent _ _ = NoParent +plusParent NoParent NoParent = NoParent hasParent :: Parent -> Parent -> Parent #if defined(DEBUG) @@ -545,10 +542,15 @@ module that SOURCE-imported A. Example (#7672): In A.hs, 'T' is locally bound, *and* imported as B.T. + Note [Parents] ~~~~~~~~~~~~~~~~~ +The children of a Name are the things that are abbreviated by the ".." notation +in export lists. + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ data T Data constructors Record-field ids @@ -558,51 +560,66 @@ Note [Parents] class C Class operations Associated type constructors -~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning - ~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Can not be bundled with a type constructor. - ParentIs n Can be bundled with the type constructor corresponding to - n. - FldParent See Note [Parents for record fields] - - - - -Note [Parents for record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record fields, in addition to the Name of the type constructor -(stored in par_is), we use FldParent to store the field label. This -extra information is used for identifying overloaded record fields -during renaming. - -In a definition arising from a normal module (without --XDuplicateRecordFields), par_lbl will be Nothing, meaning that the -field's label is the same as the OccName of the selector's Name. The -GlobalRdrEnv will contain an entry like this: - - "x" |-> GRE x (FldParent T Nothing) LocalDef - -When -XDuplicateRecordFields is enabled for the module that contains -T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel). -Thus we store the actual field label in par_lbl, and the GlobalRdrEnv -entry looks like this: - - "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef - -Note that the OccName used when adding a GRE to the environment -(greOccName) now depends on the parent field: for FldParent it is the -field label, if present, rather than the selector name. - -~~ - -Record pattern synonym selectors are treated differently. Their parent -information is `NoParent` in the module in which they are defined. This is because -a pattern synonym `P` has no parent constructor either. - -However, if `f` is bundled with a type constructor `T` then whenever `f` is -imported the parent will use the `Parent` constructor so the parent of `f` is -now `T`. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Not bundled with a type constructor. + ParentIs n Bundled with the type constructor corresponding to n. + +Pattern synonym constructors (and their record fields, if any) are unusual: +their gre_par is NoParent in the module in which they are defined. However, a +pattern synonym can be bundled with a type constructor on export, in which case +whenever the pattern synonym is imported the gre_par will be ParentIs. + +Thus the gre_name and gre_par fields are independent, because a normal datatype +introduces FieldGreNames using ParentIs, but a record pattern synonym can +introduce FieldGreNames that use NoParent. (In the past we represented fields +using an additional constructor of the Parent type, which could not adequately +represent this situation.) See also +Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail. + + +Note [GreNames] +~~~~~~~~~~~~~~~ +A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely +identifies what the `GlobalRdrElt` describes. There are two sorts of +`GreName` (see the data type decl): + +* NormalGreName Name: this is used for most entities; the Name + uniquely identifies it. It is stored in the GlobalRdrEnv under + the OccName of the Name. + +* FieldGreName FieldLabel: is used only for field labels of a + record. With -XDuplicateRecordFields there may be many field + labels `x` in scope; e.g. + data T1 = MkT1 { x :: Int } + data T2 = MkT2 { x :: Bool } + Each has a different GlobalRdrElt with a distinct GreName. + The two fields are uniquely identified by their record selectors, + which are stored in the FieldLabel, and have mangled names like + `$sel:x:MkT1`. See Note [FieldLabel] in GHC.Types.FieldLabel. + + These GREs are stored in the GlobalRdrEnv under the OccName of the + field (i.e. "x" in both cases above), /not/ the OccName of the mangled + record selector function. + +A GreName, and hence a GRE, has both a "printable" and a "mangled" Name. These +are identical for normal names, but for record fields compiled with +-XDuplicateRecordFields they will differ. So we have two pairs of functions: + + * greNameMangledName :: GreName -> Name + greMangledName :: GlobalRdrElt -> Name + The "mangled" Name is the actual Name of the selector function, + e.g. $sel:x:MkT1. This should not be displayed to the user, but is used to + uniquely identify the field in the renamer, and later in the backend. + + * greNamePrintableName :: GreName -> Name + grePrintableName :: GlobalRdrElt -> Name + The "printable" Name is the "manged" Name with its OccName replaced with that + of the field label. This is how the field should be output to the user. + +Since the right Name to use is context-dependent, we do not define a NamedThing +instance for GREName (or GlobalRdrElt), but instead make the choice explicit. Note [Combining parents] @@ -652,32 +669,52 @@ gresFromAvail prov_fn avail mk_gre n = case prov_fn n of -- Nothing => bound locally -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = mkParent n avail + Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail , gre_lcl = False, gre_imp = [is] } - mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = n }) - = case prov_fn n of -- Nothing => bound locally + mk_fld_gre fl + = case prov_fn (flSelector fl) of -- Nothing => bound locally -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail , gre_lcl = False, gre_imp = [is] } - where - mb_lbl | is_overloaded = Just lbl - | otherwise = Nothing +instance HasOccName GlobalRdrElt where + occName = greOccName + +-- | See Note [GreNames] +greOccName :: GlobalRdrElt -> OccName +greOccName = occName . gre_name + +-- | A 'Name' for the GRE for internal use. Careful: the 'OccName' of this +-- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]). +greMangledName :: GlobalRdrElt -> Name +greMangledName = greNameMangledName . gre_name + +-- | A 'Name' for the GRE suitable for output to the user. Its 'OccName' will +-- be the 'greOccName' (see Note [GreNames]). +grePrintableName :: GlobalRdrElt -> Name +grePrintableName = greNamePrintableName . gre_name + +-- | The SrcSpan of the name pointed to by the GRE. +greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan +greDefinitionSrcSpan = nameSrcSpan . greMangledName + +-- | The module in which the name pointed to by the GRE is defined. +greDefinitionModule :: GlobalRdrElt -> Maybe Module +greDefinitionModule = nameModule_maybe . greMangledName greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified) --- Prerecondition: the gre_name is always External -greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- nameModule_maybe name = moduleName mod - | (is:_) <- iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) +-- Prerecondition: the greMangledName is always External +greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- greDefinitionModule gre = moduleName mod + | (is:_) <- iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } @@ -696,21 +733,25 @@ greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } -- declaration. We want to sort the export locations in -- exportClashErr by this SrcSpan, we need to extract it: greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) - | lcl = nameSrcSpan name +greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) + | lcl = greDefinitionSrcSpan gre | (is:_) <- iss = is_dloc (is_decl is) | otherwise = pprPanic "greSrcSpan" (ppr gre) mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _ _) | n == m = NoParent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _) | n == m = NoParent | otherwise = ParentIs m +availParent :: AvailInfo -> Parent +availParent (AvailTC m _) = ParentIs m +availParent (Avail {}) = NoParent + + greParent_maybe :: GlobalRdrElt -> Maybe Name greParent_maybe gre = case gre_par gre of NoParent -> Nothing ParentIs n -> Just n - FldParent n _ -> Just n -- | Takes a list of distinct GREs and folds them -- into AvailInfos. This is more efficient than mapping each individual @@ -733,46 +774,34 @@ gresToAvailInfo gres = ( extendNameEnv_Acc comb availFromGRE env key gre , done `extendNameSet` name ) where - name = gre_name gre + name = greMangledName gre key = case greParent_maybe gre of Just parent -> parent - Nothing -> gre_name gre + Nothing -> greMangledName gre -- We want to insert the child `k` into a list of children but -- need to maintain the invariant that the parent is first. -- -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName] insertChildIntoChildren _ [] k = [k] insertChildIntoChildren p (n:ns) k - | p == k = k:n:ns + | NormalGreName p == k = k:n:ns | otherwise = n:k:ns comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name, should not happen - comb gre (AvailTC m ns fls) + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns) = case gre_par gre of - NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls - FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) + NoParent -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre)) availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = me, gre_par = parent }) +availFromGRE (GRE { gre_name = child, gre_par = parent }) = case parent of - ParentIs p -> AvailTC p [me] [] - NoParent | isTyConName me -> AvailTC me [me] [] - | otherwise -> avail me - FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] - -mkFieldLabel :: Name -> Maybe FastString -> FieldLabel -mkFieldLabel me mb_lbl = - case mb_lbl of - Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) - , flIsOverloaded = False - , flSelector = me } - Just lbl -> FieldLabel { flLabel = lbl - , flIsOverloaded = True - , flSelector = me } + ParentIs p -> AvailTC p [child] + NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child] + | otherwise -> Avail child emptyGlobalRdrEnv :: GlobalRdrEnv emptyGlobalRdrEnv = emptyOccEnv @@ -781,7 +810,7 @@ globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] globalRdrEnvElts env = foldOccEnv (++) [] env instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre)) 2 (pprNameProvenance gre) pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc @@ -799,17 +828,13 @@ pprGlobalRdrEnv locals_only env <> colon) 2 (vcat (map ppr gres)) where - occ = nameOccName (gre_name (head gres)) + occ = nameOccName (greMangledName (head gres)) lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of Nothing -> [] Just gres -> gres -greOccName :: GlobalRdrElt -> OccName -greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl -greOccName gre = nameOccName (gre_name gre) - lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env = case lookupOccEnv env (rdrNameOcc rdr_name) of @@ -823,6 +848,13 @@ lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt lookupGRE_Name env name = lookupGRE_Name_OccName env name (nameOccName name) +lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'GreName' in the environment. This tests +-- whether it is in scope, ignoring anything else that might be in +-- scope with the same 'OccName'. +lookupGRE_GreName env gname + = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname) + lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> 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 @@ -836,7 +868,7 @@ lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- Note [Parents for record fields]. lookupGRE_Name_OccName env name occ = case [ gre | gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] of + , greMangledName gre == name ] of [] -> Nothing [gre] -> Just gre gres -> pprPanic "lookupGRE_Name_OccName" @@ -861,20 +893,16 @@ isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_lcl = lcl }) = lcl isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE (GRE {gre_par = FldParent{}}) = True -isRecFldGRE _ = False +isRecFldGRE = isJust . greFieldLabel isOverloadedRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields? -- (See Note [Parents for record fields]) -isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True -isOverloadedRecFldGRE _ = False +isOverloadedRecFldGRE = maybe False flIsOverloaded . greFieldLabel --- Returns the field label of this GRE, if it has one -greLabel :: GlobalRdrElt -> Maybe FieldLabelString -greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl -greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) -greLabel _ = Nothing +greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel +-- ^ Returns the field label of this GRE, if it has one +greFieldLabel = greNameFieldLabel . gre_name unQualOK :: GlobalRdrElt -> Bool -- ^ Test if an unqualified version of this thing would be in scope @@ -936,17 +964,17 @@ pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) iss' = filter unQualSpecOK iss pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) +pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl', null iss' = Nothing | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) where iss' = filter (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod n + lcl' = lcl && name_is_from mod - name_is_from :: ModuleName -> Name -> Bool - name_is_from mod name = case nameModule_maybe name of - Just n_mod -> moduleName n_mod == mod - Nothing -> False + name_is_from :: ModuleName -> Bool + name_is_from mod = case greDefinitionModule gre of + Just n_mod -> moduleName n_mod == mod + Nothing -> False pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] -- ^ Pick GREs that are in scope *both* qualified *and* unqualified @@ -965,8 +993,8 @@ pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres -- cluttered envt is no use. Really, it's only useful for -- GHC.Base and GHC.Tuple. pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre@(GRE { gre_name = n }) - | isBuiltInSyntax n = Nothing +pickBothGRE mod gre + | isBuiltInSyntax (greMangledName gre) = Nothing | Just gre1 <- pickQualGRE mod gre , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) | otherwise = Nothing @@ -1104,8 +1132,8 @@ shadowName env name shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt shadow_with new_name - old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) - = case nameModule_maybe old_name of + old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + = case greDefinitionModule old_gre of Nothing -> Just old_gre -- Old name is Internal; do not shadow Just old_mod | Just new_mod <- nameModule_maybe new_name @@ -1120,17 +1148,17 @@ shadowName env name where iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss - lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] + lcl_imp | lcl = [mk_fake_imp_spec old_gre old_mod] | otherwise = [] - mk_fake_imp_spec old_name old_mod -- Urgh! + mk_fake_imp_spec old_gre old_mod -- Urgh! = ImpSpec id_spec ImpAll where old_mod_name = moduleName old_mod id_spec = ImpDeclSpec { is_mod = old_mod_name , is_as = old_mod_name , is_qual = True - , is_dloc = nameSrcSpan old_name } + , is_dloc = greDefinitionSrcSpan old_gre } shadow_is :: Name -> ImportSpec -> Maybe ImportSpec shadow_is new_name is@(ImpSpec { is_decl = id_spec }) @@ -1297,10 +1325,11 @@ isExplicitItem (ImpSome {is_explicit = exp}) = exp pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all) -pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) +pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss }) = ifPprDebug (vcat pp_provs) (head pp_provs) where + name = greMangledName gre pp_provs = pp_lcl ++ map pp_is iss pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index 9228a15fa8..304f341b53 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -183,12 +183,17 @@ substName env n | Just n' <- lookupNameEnv env n = n' -- for type constructors, where it is sufficient to substitute the 'availName' -- to induce a substitution on 'availNames'. substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail n) = return (Avail (substName env n)) -substNameAvailInfo hsc_env env (AvailTC n ns fs) = +substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n))) +substNameAvailInfo _ env (Avail (FieldGreName fl)) = + return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) })) +substNameAvailInfo hsc_env env (AvailTC n ns) = 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 + in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns + +setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName +setNameGreName hsc_env mb_mod gname = case gname of + NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n) + FieldGreName fl -> FieldGreName <$> setNameFieldSelector hsc_env mb_mod fl -- | Set the 'Module' of a 'FieldSelector' setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel @@ -235,8 +240,8 @@ uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo -> Either SDoc ShNameSubst -uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2 +uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2 uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" <+> ppr a1 <+> text "with" <+> ppr a2 <+> parens (text "one is a type, the other is a plain identifier") diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs index d9c1bad013..1eb08b4549 100644 --- a/compiler/GHC/Types/TyThing.hs +++ b/compiler/GHC/Types/TyThing.hs @@ -253,11 +253,10 @@ tyThingsTyCoVars tts = tyThingAvailInfo :: TyThing -> [AvailInfo] tyThingAvailInfo (ATyCon t) = case tyConClass_maybe t of - Just c -> [AvailTC n (n : map getName (classMethods c) - ++ map getName (classATs c)) - [] ] + Just c -> [availTC n ((n : map getName (classMethods c) + ++ map getName (classATs c))) [] ] where n = getName c - Nothing -> [AvailTC n (n : map getName dcs) flds] + Nothing -> [availTC n (n : map getName dcs) flds] where n = getName t dcs = tyConDataCons t flds = tyConFieldLabels t diff --git a/testsuite/tests/overloadedrecflds/ghci/T13438.hs b/testsuite/tests/overloadedrecflds/ghci/T13438.hs new file mode 100644 index 0000000000..a23a16c1f3 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T13438.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T13438 where +data T = MkT { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/ghci/T13438.script b/testsuite/tests/overloadedrecflds/ghci/T13438.script new file mode 100644 index 0000000000..04bce206ca --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T13438.script @@ -0,0 +1,5 @@ +:l T13438.hs +:browse! T13438 +:browse T13438 +:ctags +:!cat tags diff --git a/testsuite/tests/overloadedrecflds/ghci/T13438.stdout b/testsuite/tests/overloadedrecflds/ghci/T13438.stdout new file mode 100644 index 0000000000..6c199b4c66 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T13438.stdout @@ -0,0 +1,10 @@ +-- defined locally +type T :: * +data T = ... +MkT :: Int -> T +foo :: T -> Int +type T :: * +data T = MkT {foo :: Int} +foo T13438.hs 3;" v file: +MkT T13438.hs 3;" d +T T13438.hs 3;" t diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T index 6a95bb2744..e8c008d1df 100644 --- a/testsuite/tests/overloadedrecflds/ghci/all.T +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -1,2 +1,3 @@ test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script']) test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script']) +test('T13438', [expect_broken(13438), combined_output], ghci_script, ['T13438.script']) diff --git a/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.hs b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.hs new file mode 100644 index 0000000000..9c8b12e752 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +module DRFPatSynExport where +import DRFPatSynExport_A +v = MkT { m = () } diff --git a/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout new file mode 100644 index 0000000000..763c80e822 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout @@ -0,0 +1 @@ +import DRFPatSynExport_A ( MkT, m ) diff --git a/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport_A.hs b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport_A.hs new file mode 100644 index 0000000000..c44a72a0fe --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PatternSynonyms #-} +module DRFPatSynExport_A where +data S = MkS { m :: Int } +pattern MkT { m } = m diff --git a/testsuite/tests/overloadedrecflds/should_compile/Makefile b/testsuite/tests/overloadedrecflds/should_compile/Makefile new file mode 100644 index 0000000000..99f0a67f30 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/Makefile @@ -0,0 +1,10 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +DRFPatSynExport: + $(RM) DRFPatSynExport.hi DRFPatSynExport.o DRFPatSynExport.imports + $(RM) DRFPatSynExport_A.hi DRFPatSynExport_A.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c DRFPatSynExport_A.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c DRFPatSynExport.hs -ddump-minimal-imports + cat DRFPatSynExport.imports diff --git a/testsuite/tests/overloadedrecflds/should_compile/T17176.hs b/testsuite/tests/overloadedrecflds/should_compile/T17176.hs new file mode 100644 index 0000000000..22e11d1d6b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T17176.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DuplicateRecordFields #-} +module T17176 (Foo(Bar,bar,Baz)) where + +data Foo = + Bar { bar :: Int } + | BadBaz { baz :: Int } + +pattern Baz :: Int -> Foo +pattern Baz{baz} = BadBaz baz + +pattern Woz :: Int -> Foo +pattern Woz{baz} = Baz{baz=baz} + +foo = Baz { baz = 42 } +woo (Woz{baz=z}) = z diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T index d375d468f2..515b19635f 100644 --- a/testsuite/tests/overloadedrecflds/should_compile/all.T +++ b/testsuite/tests/overloadedrecflds/should_compile/all.T @@ -1,3 +1,5 @@ test('T11173', [], multimod_compile, ['T11173', '-v0']) test('T12609', normal, compile, ['']) test('T16597', [], multimod_compile, ['T16597', '-v0']) +test('T17176', normal, compile, ['']) +test('DRFPatSynExport', [], makefile_test, ['DRFPatSynExport']) diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRF9156.hs b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.hs new file mode 100644 index 0000000000..107b8047ec --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module DRF9156 where +data D = D1 { f1 :: Int } + | D2 { f1, f1 :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr new file mode 100644 index 0000000000..ea1d10dc10 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr @@ -0,0 +1,5 @@ + +DRF9156.hs:4:19: error: + Multiple declarations of ‘f1’ + Declared at: DRF9156.hs:3:15 + DRF9156.hs:4:19 diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.hs b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.hs new file mode 100644 index 0000000000..bc7248f642 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module DRFHoleFits where +import qualified DRFHoleFits_A as A + +data T = MkT { foo :: Int } + +bar = _ :: T -> Int +baz = _ :: A.S -> Int diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr new file mode 100644 index 0000000000..a5b406567f --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr @@ -0,0 +1,24 @@ +[1 of 2] Compiling DRFHoleFits_A ( DRFHoleFits_A.hs, DRFHoleFits_A.o ) +[2 of 2] Compiling DRFHoleFits ( DRFHoleFits.hs, DRFHoleFits.o ) + +DRFHoleFits.hs:7:7: error: + • Found hole: _ :: T -> Int + • In the expression: _ :: T -> Int + In an equation for ‘bar’: bar = _ :: T -> Int + • Relevant bindings include + bar :: T -> Int (bound at DRFHoleFits.hs:7:1) + Valid hole fits include + foo :: T -> Int (defined at DRFHoleFits.hs:5:16) + bar :: T -> Int (defined at DRFHoleFits.hs:7:1) + +DRFHoleFits.hs:8:7: error: + • Found hole: _ :: A.S -> Int + • In the expression: _ :: A.S -> Int + In an equation for ‘baz’: baz = _ :: A.S -> Int + • Relevant bindings include + baz :: A.S -> Int (bound at DRFHoleFits.hs:8:1) + Valid hole fits include + baz :: A.S -> Int (defined at DRFHoleFits.hs:8:1) + DRFHoleFits_A.foo :: A.S -> Int + (imported qualified from ‘DRFHoleFits_A’ at DRFHoleFits.hs:3:1-35 + (and originally defined at DRFHoleFits_A.hs:5:16-18)) diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits_A.hs b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits_A.hs new file mode 100644 index 0000000000..02d9bddb99 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits_A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module DRFHoleFits_A where + +data S = MkS { foo :: Int } +data U = MkU { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.hs b/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.hs new file mode 100644 index 0000000000..5c5ec744bb --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror=partial-fields #-} +module DRFPartialFields where +data T = MkT1 { foo :: Int } | MkT2 diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.stderr new file mode 100644 index 0000000000..1f9034e7b2 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.stderr @@ -0,0 +1,3 @@ + +DRFPartialFields.hs:4:17: error: [-Wpartial-fields, -Werror=partial-fields] + Use of partial record field selector: ‘foo’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr b/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr new file mode 100644 index 0000000000..6e1cac2fbe --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr @@ -0,0 +1,14 @@ +[1 of 4] Compiling T16745C ( T16745C.hs, T16745C.o ) +[2 of 4] Compiling T16745B ( T16745B.hs, T16745B.o ) +[3 of 4] Compiling T16745D ( T16745D.hs, T16745D.o ) +[4 of 4] Compiling T16745A ( T16745A.hs, T16745A.o ) + +T16745A.hs:3:24: error: + Ambiguous name ‘field’ in import item. It could refer to: + T16745C.field + T16745B.R(field) + +T16745A.hs:4:24: error: + Ambiguous name ‘foo’ in import item. It could refer to: + T16745D.T(foo) + T16745D.S(foo) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745A.hs b/testsuite/tests/overloadedrecflds/should_fail/T16745A.hs new file mode 100644 index 0000000000..49dbeb3fac --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745A.hs @@ -0,0 +1,6 @@ +module T16745A where + +import T16745B hiding (field) +import T16745D hiding (foo) + +wrong = foo -- should not be in scope diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745B.hs b/testsuite/tests/overloadedrecflds/should_fail/T16745B.hs new file mode 100644 index 0000000000..1e549ba05d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745B.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +-- This module tries to export a record field 'field' (defined below) and a +-- function 'field' (defined in another module), which shouldn't be allowed. +module T16745B + ( R(field) + , module T16745C + ) where + +import T16745C + +data R = R { field :: Int} diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745C.hs b/testsuite/tests/overloadedrecflds/should_fail/T16745C.hs new file mode 100644 index 0000000000..ddafe2db95 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745C.hs @@ -0,0 +1,2 @@ +module T16745C where +field = () diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745D.hs b/testsuite/tests/overloadedrecflds/should_fail/T16745D.hs new file mode 100644 index 0000000000..ee98217d4c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745D.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T16745D where +data S = MkS { foo :: Char } +data T = MkT { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T index bc3c0650d2..09bee3ba06 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/all.T +++ b/testsuite/tests/overloadedrecflds/should_fail/all.T @@ -33,3 +33,7 @@ test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])], multimod_compile_fail, ['T14953', '']) test('DuplicateExports', normal, compile_fail, ['']) test('T17965', normal, compile_fail, ['']) +test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', '']) +test('DRFPartialFields', normal, compile_fail, ['']) +test('T16745', extra_files(['T16745C.hs', 'T16745B.hs']), multimod_compile_fail, ['T16745A', '']) +test('DRF9156', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 52f2099d6e..8e79b4bc9f 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -123,7 +123,11 @@ [((,) ({ T14189.hs:3:3-15 } (IEThingWith - (NoExtField) + [({ T14189.hs:3:11 } + (FieldLabel + {FastString: "f"} + (False) + {Name: T14189.f}))] ({ T14189.hs:3:3-8 } (IEName ({ T14189.hs:3:3-8 } @@ -132,20 +136,18 @@ [({ T14189.hs:3:13-14 } (IEName ({ T14189.hs:3:13-14 } - {Name: T14189.NT})))] - [({ T14189.hs:3:11 } + {Name: T14189.NT})))])) + [(AvailTC + {Name: T14189.MyType} + [(NormalGreName + {Name: T14189.MyType}) + ,(NormalGreName + {Name: T14189.NT}) + ,(FieldGreName (FieldLabel {FastString: "f"} (False) - {Name: T14189.f}))])) - [(AvailTC - {Name: T14189.MyType} - [{Name: T14189.MyType} - ,{Name: T14189.NT}] - [(FieldLabel - {FastString: "f"} - (False) - {Name: T14189.f})])])]) + {Name: T14189.f}))])])]) (Nothing))) diff --git a/testsuite/tests/patsyn/should_compile/T11959.stderr b/testsuite/tests/patsyn/should_compile/T11959.stderr new file mode 100644 index 0000000000..4645f33641 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/T11959.stderr @@ -0,0 +1,3 @@ + +T11959Lib.hs:2:35: warning: [-Wduplicate-exports (in -Wdefault)] + ‘:>’ is exported by ‘pattern (:>)’ and ‘Vec2(Nil, (:>))’ diff --git a/testsuite/tests/patsyn/should_compile/T14630.hs b/testsuite/tests/patsyn/should_compile/T14630.hs new file mode 100644 index 0000000000..04aee67038 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/T14630.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module T14630 where + +pattern Tuple :: a -> b -> (a, b) +pattern Tuple{x, y} = (x, y) + +{-# COMPLETE Tuple #-} + +f :: (a, b) -> a +f Tuple{x} = x + +g :: (Int, Int) -> Int +g Tuple{..} = x + y diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index 75be0c68b2..defb2ac52b 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -53,7 +53,7 @@ test('T11367', normal, compile, ['']) test('T11351', normal, compile, ['']) test('T11633', normal, compile, ['']) test('T11727', normal, compile, ['']) -test('T11959', expect_broken(11959), multimod_compile, ['T11959', '-v0']) +test('T11959', normal, multimod_compile, ['T11959', '-v0']) test('T12094', normal, compile, ['']) test('T11977', normal, compile, ['']) test('T12108', normal, compile, ['']) @@ -79,3 +79,4 @@ test('T14498', normal, compile, ['']) test('T16682', [extra_files(['T16682.hs', 'T16682a.hs'])], multimod_compile, ['T16682', '-v0 -fwarn-incomplete-patterns -fno-code']) test('T17775-singleton', normal, compile, ['']) +test('T14630', normal, compile, ['-Wname-shadowing']) diff --git a/utils/haddock b/utils/haddock -Subproject beafcacfd0fc3d447d461a2be3378e50ef77d9c +Subproject 8a5ccf93c53a40abe42134c2282ac9b9d653224 |