From 5581e7b4c3ab6aa2bb7cca6ed917ed40ad3ed423 Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Thu, 4 Feb 2021 22:13:21 +0000
Subject: [PATCH] Simplify shadowing of DuplicateRecordFields in GHCi (fixes
#19314)
Previously, defining fields with DuplicateRecordFields in GHCi lead to
strange shadowing behaviour, whereby fields would (accidentally) not
shadow other fields. This simplifies things so that fields are shadowed
in the same way whether or not DuplicateRecordFields is enabled.
---
compiler/GHC/Rename/Names.hs | 7 +++--
compiler/GHC/Runtime/Context.hs | 2 +-
compiler/GHC/Types/Name/Reader.hs | 25 ++++++++--------
compiler/GHC/Types/TyThing.hs | 2 +-
.../overloadedrecflds/ghci/T19314.script | 12 ++++++++
.../overloadedrecflds/ghci/T19314.stdout | 12 ++++++++
testsuite/tests/overloadedrecflds/ghci/all.T | 1 +
.../ghci/duplicaterecfldsghci01.stdout | 30 +++++--------------
8 files changed, 51 insertions(+), 40 deletions(-)
create mode 100644 testsuite/tests/overloadedrecflds/ghci/T19314.script
create mode 100644 testsuite/tests/overloadedrecflds/ghci/T19314.stdout
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 6dff5b195e63..92e1309bd695 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -624,7 +624,8 @@ extendGlobalRdrEnvRn avails new_fixities
| otherwise = rdr_env
lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
- [ (n, (TopLevel, th_lvl))
+ [ ( greNameMangledName n
+ , (TopLevel, th_lvl) )
| n <- new_names ] }
; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
@@ -635,8 +636,8 @@ extendGlobalRdrEnvRn avails new_fixities
; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
; return (gbl_env', lcl_env3) }
where
- new_names = concatMap availNames avails
- new_occs = map nameOccName new_names
+ new_names = concatMap availGreNames avails
+ new_occs = map occName new_names
-- If there is a fixity decl for the gre, add it to the fixity env
extend_fix_env fix_env gre
diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs
index 243624553df7..6b4a4d0624a7 100644
--- a/compiler/GHC/Runtime/Context.hs
+++ b/compiler/GHC/Runtime/Context.hs
@@ -367,7 +367,7 @@ icExtendGblRdrEnv env tythings
| otherwise
= foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
where
- env1 = shadowNames env (concatMap availNames avail)
+ env1 = shadowNames env (concatMap availGreNames avail)
avail = tyThingAvailInfo thing
-- Ugh! The new_tythings may include record selectors, since they
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 6eb81653a520..a4ec4bea8d45 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -1068,7 +1068,7 @@ extendGlobalRdrEnv env gre
= extendOccEnv_Acc insertGRE Utils.singleton env
(greOccName gre) gre
-shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
+shadowNames :: GlobalRdrEnv -> [GreName] -> GlobalRdrEnv
shadowNames = foldl' shadowName
{- Note [GlobalRdrEnv shadowing]
@@ -1144,22 +1144,21 @@ There are two reasons for shadowing:
At that stage, the class op 'f' will have an Internal name.
-}
-shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv
+shadowName :: GlobalRdrEnv -> GreName -> GlobalRdrEnv
-- Remove certain old GREs that share the same OccName as this new Name.
-- See Note [GlobalRdrEnv shadowing] for details
-shadowName env name
- = alterOccEnv (fmap alter_fn) env (nameOccName name)
+shadowName env new_name
+ = alterOccEnv (fmap (mapMaybe shadow)) env (occName new_name)
where
- alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]
- alter_fn gres = mapMaybe (shadow_with name) gres
+ maybe_new_mod = nameModule_maybe (greNameMangledName new_name)
- shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt
- shadow_with new_name
+ shadow :: GlobalRdrElt -> Maybe GlobalRdrElt
+ shadow
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
+ | Just new_mod <- maybe_new_mod
, new_mod == old_mod -- Old name same as new name; shadow completely
-> Nothing
@@ -1170,7 +1169,7 @@ shadowName env name
-> Just (old_gre { gre_lcl = False, gre_imp = iss' })
where
- iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss
+ iss' = lcl_imp ++ mapMaybe shadow_is iss
lcl_imp | lcl = [mk_fake_imp_spec old_gre old_mod]
| otherwise = []
@@ -1183,9 +1182,9 @@ shadowName env name
, is_qual = True
, is_dloc = greDefinitionSrcSpan old_gre }
- shadow_is :: Name -> ImportSpec -> Maybe ImportSpec
- shadow_is new_name is@(ImpSpec { is_decl = id_spec })
- | Just new_mod <- nameModule_maybe new_name
+ shadow_is :: ImportSpec -> Maybe ImportSpec
+ shadow_is is@(ImpSpec { is_decl = id_spec })
+ | Just new_mod <- maybe_new_mod
, is_as id_spec == moduleName new_mod
= Nothing -- Shadow both qualified and unqualified
| otherwise -- Shadow unqualified only
diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs
index 1eb08b454920..fb89c42ee301 100644
--- a/compiler/GHC/Types/TyThing.hs
+++ b/compiler/GHC/Types/TyThing.hs
@@ -261,7 +261,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo (AConLike (PatSynCon p))
- = map avail ((getName p) : map flSelector (patSynFieldLabels p))
+ = avail (getName p) : map availField (patSynFieldLabels p)
tyThingAvailInfo t
= [avail (getName t)]
diff --git a/testsuite/tests/overloadedrecflds/ghci/T19314.script b/testsuite/tests/overloadedrecflds/ghci/T19314.script
new file mode 100644
index 000000000000..793841fbac8e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/T19314.script
@@ -0,0 +1,12 @@
+:set -XPatternSynonyms
+pattern P{w} = [w]
+:t w
+:set -XDuplicateRecordFields
+pattern Q{x} = [x]
+:t x
+:set -XNoFieldSelectors
+pattern R{y} = [y]
+:t y
+:set -XNoDuplicateRecordFields
+pattern S{z} = [z]
+:t z
diff --git a/testsuite/tests/overloadedrecflds/ghci/T19314.stdout b/testsuite/tests/overloadedrecflds/ghci/T19314.stdout
new file mode 100644
index 000000000000..4e09a8a476ec
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/T19314.stdout
@@ -0,0 +1,12 @@
+w :: [a] -> a
+x :: [a] -> a
+
+<interactive>:1:1:
+ • Variable not in scope: y
+ • NB: ‘y’ is a field selector
+ that has been suppressed by NoFieldSelectors
+
+<interactive>:1:1:
+ • Variable not in scope: z
+ • NB: ‘z’ is a field selector
+ that has been suppressed by NoFieldSelectors
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index f0d2544c0e9d..17f4f82ff583 100644
--- a/testsuite/tests/overloadedrecflds/ghci/all.T
+++ b/testsuite/tests/overloadedrecflds/ghci/all.T
@@ -3,3 +3,4 @@ test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsg
test('T13438', [expect_broken(13438), combined_output], ghci_script, ['T13438.script'])
test('GHCiDRF', [extra_files(['GHCiDRF.hs']), combined_output], ghci_script, ['GHCiDRF.script'])
test('T19322', combined_output, ghci_script, ['T19322.script'])
+test('T19314', combined_output, ghci_script, ['T19314.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout
index ff758c18bb11..c7550d36e25d 100644
--- a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout
+++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout
@@ -1,29 +1,15 @@
True
-type S :: *
-data S = MkS {Ghci1.foo :: Int}
- -- Defined at <interactive>:3:16
-
type T :: * -> *
-data T a = MkT {Ghci2.foo :: Bool, ...}
+data T a = MkT {foo :: Bool, ...}
-- Defined at <interactive>:4:18
+foo :: T a -> Bool
-<interactive>:1:1: error:
- Ambiguous occurrence ‘foo’
- It could refer to
- either the field ‘foo’, defined at <interactive>:3:16
- or the field ‘foo’, defined at <interactive>:4:18
-
-<interactive>:9:1: error:
- Ambiguous occurrence ‘foo’
- It could refer to
- either the field ‘foo’, defined at <interactive>:3:16
- or the field ‘foo’, defined at <interactive>:4:18
+<interactive>:9:6: error:
+ • Couldn't match expected type ‘T a0’ with actual type ‘S’
+ • In the first argument of ‘foo’, namely ‘(MkS 42)’
+ In the expression: foo (MkS 42)
+ In an equation for ‘it’: it = foo (MkS 42)
True
-
-<interactive>:1:1: error:
- Ambiguous occurrence ‘foo’
- It could refer to
- either the field ‘foo’, defined at <interactive>:3:16
- or the field ‘foo’, defined at <interactive>:4:18
+foo :: T a -> Bool
foo :: U -> Int
42
--
GitLab