diff options
Diffstat (limited to 'compiler/GHC')
44 files changed, 1019 insertions, 729 deletions
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 |