Fix panic on module re-exports of DuplicateRcordFields

Test Plan: new test overloadedrecflds/should_fail/T14953

Reviewers: mpickering, simonpj, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14953

Differential Revision: https://phabricator.haskell.org/D4527

7 files changed, 75 insertions, 13 deletions

diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 6ff114b343..61ab1a9277 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -48,6 +48,7 @@ module RdrName (
         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
         pprGlobalRdrEnv, globalRdrEnvElts,
         lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
+        lookupGRE_Name_OccName,
         getGRE_NameQualifier_maybes,
         transformGREs, pickGREs, pickGREsModExp,
 
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index f89206503e..be2b9343ef 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -238,7 +238,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                                 || (moduleName this_mod == mod)
                    ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
                    ; new_exports = map (availFromGRE . fst) gre_prs
-                   ; names       = map (gre_name     . fst) gre_prs
+                   ; (names, fls)= classifyGREs (map fst gre_prs)
                    ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
                }
 
@@ -250,7 +250,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
              ; traceRn "efa" (ppr mod $$ ppr all_gres)
              ; addUsedGREs all_gres
 
-             ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
+             ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names fls
                       -- This check_occs not only finds conflicts
                       -- between this item and others, but also
                       -- internally within this item.  That is, if
@@ -276,7 +276,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                   then return acc    -- Avoid error cascade
                   else do
 
-                    occs' <- check_occs ie occs (availNames avail)
+                    occs' <- check_occs ie occs (availNonFldNames avail)
+                                                (availFlds avail)
 
                     return (ExportAccum ((L loc new_ie, [avail]) : lie_avails) occs')
 
@@ -582,11 +583,21 @@ checkPatSynParent parent NoParent mpat_syn
 
 
 {-===========================================================================-}
-check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> RnM ExportOccMap
-check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
-  = foldlM check occs names
+check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> [FieldLabel]
+           -> RnM ExportOccMap
+check_occs ie occs names fls
+  -- 'names' and 'fls' are the entities specified by 'ie'
+  = foldlM check occs names_with_occs
   where
-    check occs name
+    -- Each Name specified by 'ie', paired with the OccName used to
+    -- refer to it in the GlobalRdrEnv
+    -- (see Note [Parents for record fields] in RdrName).  We check for export
+    -- clashes using the selector Name, but need the field label OccName in
+    -- order to look up the right GRE later.
+    names_with_occs = map (\name -> (name, nameOccName name)) names
+                   ++ map (\fl -> (flSelector fl, mkVarOccFS (flLabel fl))) fls
+
+    check occs (name, occ)
       = case lookupOccEnv occs name_occ of
           Nothing -> return (extendOccEnv occs name_occ (name, ie))
 
@@ -601,7 +612,7 @@ check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
 
             | otherwise    -- Same occ name but different names: an error
             ->  do { global_env <- getGlobalRdrEnv ;
-                     addErr (exportClashErr global_env name' name ie' ie) ;
+                     addErr (exportClashErr global_env occ name' name ie' ie) ;
                      return occs }
       where
         name_occ = nameOccName name
@@ -723,21 +734,29 @@ failWithDcErr parent thing thing_doc parents = do
     tyThingCategory' i = tyThingCategory i
 
 
-exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE GhcPs -> IE GhcPs
+exportClashErr :: GlobalRdrEnv -> OccName
+               -> Name -> Name
+               -> IE GhcPs -> IE GhcPs
                -> MsgDoc
-exportClashErr global_env name1 name2 ie1 ie2
+exportClashErr global_env occ name1 name2 ie1 ie2
   = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
          , ppr_export ie1' name1'
          , ppr_export ie2' name2' ]
   where
-    occ = nameOccName name1
     ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
-                                       quotes (ppr name))
+                                       quotes (ppr_name name))
                                     2 (pprNameProvenance (get_gre name)))
 
+    -- DuplicateRecordFields means that nameOccName might be a mangled
+    -- $sel-prefixed thing, in which case show the correct OccName alone
+    ppr_name name
+      | nameOccName name == occ = ppr name
+      | otherwise               = ppr occ
+
     -- get_gre finds a GRE for the Name, so that we can show its provenance
     get_gre name
-        = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name)
+        = fromMaybe (pprPanic "exportClashErr" (ppr name))
+                    (lookupGRE_Name_OccName global_env name occ)
     get_loc name = greSrcSpan (get_gre name)
     (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
                                    then (name1, ie1, name2, ie2)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T14953.hs b/testsuite/tests/overloadedrecflds/should_fail/T14953.hs
new file mode 100644
index 0000000000..3a0020b561
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T14953.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T14953 (module T14953_A, module T14953_B) where
+import T14953_A
+import T14953_B
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr b/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr
new file mode 100644
index 0000000000..dc2249750e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr
@@ -0,0 +1,30 @@
+[1 of 3] Compiling T14953_A         ( T14953_A.hs, T14953_A.o )
+[2 of 3] Compiling T14953_B         ( T14953_B.hs, T14953_B.o )
+[3 of 3] Compiling T14953           ( T14953.hs, T14953.o )
+
+T14953.hs:2:33: error:
+    Conflicting exports for ‘R’:
+       ‘module T14953_A’ exports ‘T14953_A.R’
+         imported from ‘T14953_A’ at T14953.hs:3:1-15
+         (and originally defined at T14953_A.hs:3:1-23)
+       ‘module T14953_B’ exports ‘T14953_B.R’
+         imported from ‘T14953_B’ at T14953.hs:4:1-15
+         (and originally defined at T14953_B.hs:3:1-23)
+
+T14953.hs:2:33: error:
+    Conflicting exports for ‘R’:
+       ‘module T14953_A’ exports ‘T14953_A.R’
+         imported from ‘T14953_A’ at T14953.hs:3:1-15
+         (and originally defined at T14953_A.hs:3:10-23)
+       ‘module T14953_B’ exports ‘T14953_B.R’
+         imported from ‘T14953_B’ at T14953.hs:4:1-15
+         (and originally defined at T14953_B.hs:3:10-23)
+
+T14953.hs:2:33: error:
+    Conflicting exports for ‘unR’:
+       ‘module T14953_A’ exports ‘unR’
+         imported from ‘T14953_A’ at T14953.hs:3:1-15
+         (and originally defined at T14953_A.hs:3:13-15)
+       ‘module T14953_B’ exports ‘unR’
+         imported from ‘T14953_B’ at T14953.hs:4:1-15
+         (and originally defined at T14953_B.hs:3:13-15)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T14953_A.hs b/testsuite/tests/overloadedrecflds/should_fail/T14953_A.hs
new file mode 100644
index 0000000000..a3acd512ac
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T14953_A.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T14953_A where
+data R = R {unR :: Int}
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T14953_B.hs b/testsuite/tests/overloadedrecflds/should_fail/T14953_B.hs
new file mode 100644
index 0000000000..4d4696b833
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T14953_B.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T14953_B where
+data R = R {unR :: Int}
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 5463be7006..3e6c121de0 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -29,3 +29,5 @@ test('hasfieldfail01', extra_files(['HasFieldFail01_A.hs']),
      multimod_compile_fail, ['hasfieldfail01', ''])
 test('hasfieldfail02', normal, compile_fail, [''])
 test('hasfieldfail03', normal, compile_fail, [''])
+test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
+     multimod_compile_fail, ['T14953', ''])