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