From 84e6df59bcd29cfdd2879c55554931634101ae91 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Mon, 17 Jul 2023 20:35:14 +0200
Subject: [PATCH] Prioritise Parent when looking up class sub-binder
When we look up children GlobalRdrElts of a given Parent, we sometimes
would rather prioritise those GlobalRdrElts which have the right Parent,
and sometimes prioritise those that have the right NameSpace:
- in export lists, we should prioritise NameSpace
- for class/instance binders, we should prioritise Parent
See Note [childGREPriority] in GHC.Types.Name.Reader.
fixes #23664
(cherry picked from commit 3bd4d5b5482fd44914f22492877b3f3ca27299e0)
---
compiler/GHC/Rename/Env.hs | 6 +-
compiler/GHC/Tc/Gen/Export.hs | 8 +-
compiler/GHC/Types/Name/Reader.hs | 82 +++++++++++++++----
.../tests/rename/should_compile/T23664.hs | 7 ++
testsuite/tests/rename/should_compile/all.T | 1 +
5 files changed, 83 insertions(+), 21 deletions(-)
create mode 100644 testsuite/tests/rename/should_compile/T23664.hs
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index e4d8a9d5553..41515605a86 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -845,8 +845,10 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name =
-- See [Mismatched class methods and associated type families]
-- in TcInstDecls.
where
- what_lkup = LookupChild { wantedParent = the_parent
- , lookupDataConFirst = False }
+ what_lkup = LookupChild { wantedParent = the_parent
+ , lookupDataConFirst = False
+ , prioritiseParent = True -- See T23664.
+ }
{-
Note [Family instance binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 3912b95c7f8..6b03d136b01 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -690,8 +690,12 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
let bareName = (ieWrappedName . unLoc) n
what_lkup :: LookupChild
- what_lkup = LookupChild { wantedParent = spec_parent
- , lookupDataConFirst = True }
+ what_lkup =
+ LookupChild
+ { wantedParent = spec_parent
+ , lookupDataConFirst = True
+ , prioritiseParent = False -- See T11970.
+ }
-- Do not report export list declaration deprecations
name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index e2898bfdaca..c5a9c153b48 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -1186,6 +1186,13 @@ data LookupChild
, lookupDataConFirst :: Bool
-- ^ for type constructors, should we look in the data constructor
-- namespace first?
+ , prioritiseParent :: Bool
+ -- ^ should we prioritise getting the right 'Parent'?
+ --
+ -- - @True@: prioritise getting the right 'Parent'
+ -- - @False@: prioritise getting the right 'NameSpace'
+ --
+ -- See Note [childGREPriority].
}
-- | After looking up something with the given 'NameSpace', is the resulting
@@ -1221,14 +1228,52 @@ greIsRelevant which_gres ns gre
where
other_ns = greNameSpace gre
+{- Note [childGREPriority]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are currently two places in the compiler where we look up GlobalRdrElts
+which have a given Parent. These are the two calls to lookupSubBndrOcc_helper:
+
+ A. Looking up children in an export item, e.g.
+
+ module M ( T(MkT, D) ) where { data T = MkT; data D = D }
+
+ B. Looking up binders in a class or instance declaration, e.g.
+ the operator +++ in the fixity declaration:
+
+ class C a where { type (+++) :: a -> a ->; infixl 6 +++ }
+ (+++) :: Int -> Int -> Int; (+++) = (+)
+
+In these two situations, there are two competing metrics for finding the "best"
+'GlobalRdrElt' that a particular 'OccName' resolves to:
+
+ - does the resolved 'GlobalRdrElt' have the correct parent?
+ - does the resolved 'GlobalRdrElt' have the same 'NameSpace' as the 'OccName'?
+
+(A) and (B) have competing requirements.
+
+For the example of (A) above, we know that the child 'D' of 'T' must live
+in the data namespace, so we look up the OccName 'OccName DataName "D"' and
+prioritise the lookup results based on the 'NameSpace'.
+This means we get an error message of the form:
+
+ The type constructor 'T' is not the parent of the data constructor 'D'.
+
+as opposed to the rather unhelpful and confusing:
+
+ The type constructor 'T' is not the parent of the type constructor 'D'.
+
+See test case T11970.
+
+For the example of (B) above, the fixity declaration for +++ lies inside the
+class, so we should prioritise looking up 'GlobalRdrElt's whose parent is 'C'.
+Not doing so led to #23664.
+-}
+
-- | Scoring priority function for looking up children 'GlobalRdrElt'.
--
--- First we score by 'NameSpace', with higher-priority 'NameSpace's having a
--- lower number. Then we break ties by checking if the 'Parent' is correct.
---
--- This complicated scoring function is determined by the behaviour required by
--- 'lookupChildrenExport', which requires us to look in the data constructor
--- 'NameSpace' first, for things in the type constructor 'NameSpace'.
+-- We score by 'Parent' and 'NameSpace', with higher priorities having lower
+-- numbers. Which lexicographic order we use ('Parent' or 'NameSpace' first)
+-- is determined by the first argument; see Note [childGREPriority].
childGREPriority :: LookupChild -- ^ what kind of child do we want,
-- e.g. what should its parent be?
-> NameSpace -- ^ what 'NameSpace' are we originally looking in?
@@ -1237,13 +1282,18 @@ childGREPriority :: LookupChild -- ^ what kind of child do we want,
-- 'NameSpace', which is used to determine the score
-- (in the first component)
-> Maybe (Int, Int)
-childGREPriority (LookupChild { wantedParent = wanted_parent, lookupDataConFirst = try_dc_first })
+childGREPriority (LookupChild { wantedParent = wanted_parent
+ , lookupDataConFirst = try_dc_first
+ , prioritiseParent = par_first })
ns gre =
- case child_ns_prio $ greNameSpace gre of
- Nothing -> Nothing
- Just np -> Just (np, parent_prio $ greParent gre)
- -- Prioritise GREs first on NameSpace, and then on Parent.
- -- See T11970.
+ case child_ns_prio $ greNameSpace gre of
+ Nothing -> Nothing
+ Just ns_prio ->
+ let par_prio = parent_prio $ greParent gre
+ in Just $ if par_first
+ then (par_prio, ns_prio)
+ else (ns_prio, par_prio)
+ -- See Note [childGREPriority].
where
-- Pick out the possible 'NameSpace's in order of priority.
@@ -1298,11 +1348,9 @@ lookupGRE env = \case
lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ
| otherwise = fromMaybe [] $ lookupOccEnv env occ
LookupChildren occ which_child ->
- highestPriorityGREs (childGREPriority which_child ns) $
- concat $ lookupOccEnv_AllNameSpaces env occ
- where
- ns :: NameSpace
- ns = occNameSpace occ
+ let ns = occNameSpace occ
+ all_gres = concat $ lookupOccEnv_AllNameSpaces env occ
+ in highestPriorityGREs (childGREPriority which_child ns) all_gres
-- | Collect the 'GlobalRdrElt's with the highest priority according
-- to the given function (lower value <=> higher priority).
diff --git a/testsuite/tests/rename/should_compile/T23664.hs b/testsuite/tests/rename/should_compile/T23664.hs
new file mode 100644
index 00000000000..ea92b5ed44f
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T23664.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies, TypeOperators #-}
+
+module T23664 where
+
+class POrd a where
+ type a >= b
+ infix 4 >=
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 1eefe0b0806..875563f470f 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -214,6 +214,7 @@ test('T23318', normal, compile, ['-Wduplicate-exports'])
test('T23434', normal, compile, [''])
test('T23510b', normal, compile, [''])
test('T23512b', normal, compile, [''])
+test('T23664', normal, compile, [''])
test('ExportWarnings1', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings1', '-v0 -Wno-duplicate-exports -Wx-custom'])
test('ExportWarnings2', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs', 'ExportWarnings_aux2.hs']), multimod_compile, ['ExportWarnings2', '-v0 -Wno-duplicate-exports -Wx-custom'])
test('ExportWarnings3', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings3', '-v0 -Wno-duplicate-exports -Wx-custom'])
--
GitLab