summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Rename/Names.hs7
-rw-r--r--compiler/GHC/Runtime/Context.hs2
-rw-r--r--compiler/GHC/Types/Name/Reader.hs25
-rw-r--r--compiler/GHC/Types/TyThing.hs2
-rw-r--r--testsuite/tests/overloadedrecflds/ghci/T19314.script12
-rw-r--r--testsuite/tests/overloadedrecflds/ghci/T19314.stdout12
-rw-r--r--testsuite/tests/overloadedrecflds/ghci/all.T1
-rw-r--r--testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout30
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
View Lorry Controller Status