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.

8 files changed, 51 insertions, 40 deletions

diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 6dff5b195e..92e1309bd6 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 243624553d..6b4a4d0624 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 6eb81653a5..a4ec4bea8d 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 1eb08b4549..fb89c42ee3 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 0000000000..793841fbac
--- /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 0000000000..4e09a8a476
--- /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 f0d2544c0e..17f4f82ff5 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 ff758c18bb..c7550d36e2 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