From 45ab7560bf233ddc7679d9a97381ee5d4cb80db6 Mon Sep 17 00:00:00 2001 From: sheaf <sam.derbyshire@gmail.com> Date: Mon, 3 Jul 2023 17:15:49 +0200 Subject: [PATCH] Introduce greInfo, greParent These are simple helper functions that wrap the internal field names gre_info, gre_par. (cherry picked from commit 6fd8f566c691b936b0b65e21700b224312611f4d) --- compiler/GHC/Rename/Doc.hs | 5 ++--- compiler/GHC/Rename/Env.hs | 16 +++++----------- compiler/GHC/Rename/Expr.hs | 2 +- compiler/GHC/Rename/Module.hs | 2 +- compiler/GHC/Rename/Names.hs | 2 +- compiler/GHC/Rename/Unbound.hs | 2 +- compiler/GHC/Rename/Utils.hs | 2 +- compiler/GHC/Tc/Errors/Ppr.hs | 12 ++++++------ compiler/GHC/Types/Name/Reader.hs | 18 ++++++++++++++---- 9 files changed, 32 insertions(+), 29 deletions(-) diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs index 3fc4dd6fed1..f8499cf8c8b 100644 --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -39,9 +39,8 @@ rnHsDocIdentifiers :: GlobalRdrEnv -> [Located RdrName] -> [Located Name] rnHsDocIdentifiers gre_env ns = - [ L l nm + [ L l $ greName gre | L l rdr_name <- ns , gre <- lookupGRE_RdrName AllNameSpaces gre_env rdr_name - , let nm = greName gre - , rdrRelevantNameSpace rdr_name (nameNameSpace nm) + , rdrRelevantNameSpace rdr_name $ greNameSpace gre ] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 976df20bdf2..ce4a4f458fe 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -755,12 +755,12 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name ns_prio case original_gres of [] -> return NameNotFound [g] -> return $ IncorrectParent parent g - [p | Just p <- [getParent g]] + [p | ParentIs p <- [greParent g]] gss@(g:gss'@(_:_)) -> if all isRecFldGRE gss && dup_fields_ok then return $ IncorrectParent parent g - [p | x <- gss, Just p <- [getParent x]] + [p | x <- gss, ParentIs p <- [greParent x]] else mkNameClashErr $ g NE.:| gss' mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult @@ -768,12 +768,6 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name ns_prio addNameClashErrRn rdr_name gres return (FoundChild (NE.head gres)) - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - NoParent -> Nothing - picked_gres :: [GlobalRdrElt] -> DisambigInfo -- For Unqual, find GREs that are in scope qualified or unqualified -- For Qual, find GREs that are in scope with that qualification @@ -888,7 +882,7 @@ data ChildLookupResult instance Outputable ChildLookupResult where ppr NameNotFound = text "NameNotFound" - ppr (FoundChild n) = text "Found:" <+> ppr (gre_par n) <+> ppr n + ppr (FoundChild n) = text "Found:" <+> ppr (greParent n) <+> ppr n ppr (IncorrectParent p g ns) = text "IncorrectParent" <+> hsep [ppr p, ppr $ greName g, ppr ns] @@ -1894,7 +1888,7 @@ lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeclDeprec iface gre -- Bleat if the thing, or its parent, is warn'd = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` - case gre_par gre of + case greParent gre of ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p) NoParent -> Nothing @@ -2236,7 +2230,7 @@ lookupBindGroupOcc ctxt what rdr_name ok_ns lookup_top keep_me = do { env <- getGlobalRdrEnv - ; let all_gres = filter (ok_ns . nameNameSpace . greName) + ; let all_gres = filter (ok_ns . greNameSpace) $ lookupGRE_OccName AllNameSpaces env (rdrNameOcc rdr_name) names_in_scope = -- If rdr_name lacks a binding, only -- recommend alternatives from relevant diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index b9c7c048805..68b73d2b483 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -261,7 +261,7 @@ rnExpr (HsVar _ (L l v)) Nothing -> rnUnboundVar v ; Just gre -> do { let nm = greName gre - info = gre_info gre + info = greInfo gre ; if | IAmRecField fld_info <- info -- Since GHC 9.4, such occurrences of record fields must be -- unambiguous. For ambiguous occurrences, we arbitrarily pick one diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 1f890e35bb5..4f298e9d12c 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1555,7 +1555,7 @@ toParents rdr_env ns getParent :: GlobalRdrEnv -> Name -> Name getParent rdr_env n = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of + Just gre -> case greParent gre of ParentIs { par_is = p } -> p _ -> n Nothing -> n diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 0b650fd55e4..2baddb0646d 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1530,7 +1530,7 @@ to a list of items, rather than a single item. mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] mkChildEnv gres = foldr add emptyNameEnv gres where - add gre env = case gre_par gre of + add gre env = case greParent gre of ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre NoParent -> env diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 6fa7e6aeac3..0f8c8393092 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -213,7 +213,7 @@ fieldSelectorSuggestions global_env tried_rdr_name where gres = filter isNoFieldSelectorGRE $ lookupGRE_RdrName (IncludeFields WantField False) global_env tried_rdr_name - parents = [ parent | ParentIs parent <- map gre_par gres ] + parents = [ parent | ParentIs parent <- map greParent gres ] similarNameSuggestions :: LookingFor -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3f15986c7ce..f9856522e84 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -349,7 +349,7 @@ warnUnusedTopBinds gres = whenWOptM Opt_WarnUnusedTopBinds $ do env <- getGblEnv let isBoot = isHsBootFile $ tcg_src env - let noParent gre = case gre_par gre of + let noParent gre = case greParent gre of NoParent -> True _ -> False -- Don't warn about unused bindings with parents in diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 2f89b1c14ae..1407639cd7b 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -654,9 +654,9 @@ instance Diagnostic TcRnMessage where fld = quotes $ ppr (occNameFS $ greOccName gre1) pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma , nest 2 (pprNameProvenance gre) ] - pprGRE gre = case gre_info gre of + pprGRE gre = case greInfo gre of IAmRecField {} - -> let parent = par_is $ gre_par gre + -> let parent = par_is $ greParent gre in text "record field" <+> fld <+> text "of" <+> quotes (ppr parent) _ -> text "variable" <+> fld TcRnAmbiguousRecordUpdate _rupd tc @@ -3289,7 +3289,7 @@ dodgy_msg kind tc ie where rest :: [SDoc] rest = - case gre_info tc of + case greInfo tc of IAmTyCon ClassFlavour -> [ text "(in-scope) class methods or associated types" <> comma , text "but it has none" ] @@ -5462,7 +5462,7 @@ pprUnusedName name reason = -- See #15487 pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc pprAmbiguousGreName gre_env gre - | IAmRecField fld_info <- gre_info gre + | IAmRecField fld_info <- greInfo gre = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma , pprNameProvenance gre ] | otherwise @@ -5475,13 +5475,13 @@ pprAmbiguousGreName gre_env gre case first_con of PatSynName ps -> text "of pattern synonym" <+> quotes (ppr ps) DataConName {} -> - case gre_par gre of + case greParent gre of ParentIs par -- For a data family, only reporting the family TyCon can be -- unhelpful (see T23301). So we give a bit of additional -- info in that case. | Just par_gre <- lookupGRE_Name gre_env par - , IAmTyCon tc_flav <- gre_info par_gre + , IAmTyCon tc_flav <- greInfo par_gre , OpenFamilyFlavour IAmData _ <- tc_flav -> vcat [ ppr_cons , text "in a data family instance of" <+> quotes (ppr par) ] diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index c1d519fca3e..e2ef8f18a21 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -67,7 +67,8 @@ module GHC.Types.Name.Reader ( -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt, - greName, forceGlobalRdrEnv, hydrateGlobalRdrEnv, + greName, greNameSpace, greParent, greInfo, + forceGlobalRdrEnv, hydrateGlobalRdrEnv, isLocalGRE, isImportedGRE, isRecFldGRE, fieldGREInfo, isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, @@ -596,6 +597,15 @@ type FieldGlobalRdrElt = GlobalRdrElt greName :: GlobalRdrEltX info -> Name greName = gre_name +greNameSpace :: GlobalRdrEltX info -> NameSpace +greNameSpace = nameNameSpace . greName + +greParent :: GlobalRdrEltX info -> Parent +greParent = gre_par + +greInfo :: GlobalRdrElt -> GREInfo +greInfo = gre_info + instance NFData IfGlobalRdrElt where rnf !_ = () @@ -1023,7 +1033,7 @@ fieldGRELabel = recFieldLabel . fieldGREInfo fieldGREInfo :: HasDebugCallStack => FieldGlobalRdrElt -> RecFieldInfo fieldGREInfo gre = assertPpr (isRecFldGRE gre) (ppr gre) $ - case gre_info gre of + case greInfo gre of IAmRecField info -> info info -> pprPanic "fieldGREInfo" $ vcat [ text "gre_name:" <+> ppr (greName gre) @@ -1031,13 +1041,13 @@ fieldGREInfo gre recFieldConLike_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe ConInfo recFieldConLike_maybe gre = - case gre_info gre of + case greInfo gre of IAmConLike info -> Just info _ -> Nothing recFieldInfo_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe RecFieldInfo recFieldInfo_maybe gre = - case gre_info gre of + case greInfo gre of IAmRecField info -> assertPpr (isRecFldGRE gre) (ppr gre) $ Just info _ -> Nothing -- GitLab