Better renaming for record fields

Based on work by Alex D @nineonine

10 files changed, 58 insertions, 29 deletions

diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index a3c126222f..4ec2c6acb6 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -495,7 +495,8 @@ lookupRecFieldOcc mb_con rdr_name
   , isUnboundName con  -- Avoid error cascade
   = return (mkUnboundNameRdr rdr_name)
   | Just con <- mb_con
-  = do { flds <- lookupConstructorFields con
+  = lookupExactOrOrig rdr_name id $  -- See Note [Record field names and Template Haskell]
+    do { flds <- lookupConstructorFields con
        ; env <- getGlobalRdrEnv
        ; let lbl      = occNameFS (rdrNameOcc rdr_name)
              mb_field = do fl <- find ((== lbl) . flLabel) flds
@@ -511,12 +512,14 @@ lookupRecFieldOcc mb_con rdr_name
        ; case mb_field of
            Just (fl, gre) -> do { addUsedGRE True gre
                                 ; return (flSelector fl) }
-           Nothing        -> lookupGlobalOccRn' WantBoth rdr_name }
-             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+           Nothing        -> do { addErr (badFieldConErr con lbl)
+                                ; return (mkUnboundNameRdr rdr_name) } }
+
   | otherwise
-  -- This use of Global is right as we are looking up a selector which
-  -- can only be defined at the top level.
+  -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
   = lookupGlobalOccRn' WantBoth rdr_name
+    -- This use of Global is right as we are looking up a selector which
+    -- can only be defined at the top level.
 
 -- | Look up an occurrence of a field in a record update, returning the selector
 -- name.
@@ -636,7 +639,7 @@ determine it.
 Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Whenever we fail to find the field or it is not in scope, mb_field
-will be False, and we fall back on looking it up normally using
+will be Nothing, and we fall back on looking it up normally using
 lookupGlobalOccRn.  We don't report an error immediately because the
 actual problem might be located elsewhere.  For example (#9975):
 
@@ -650,7 +653,9 @@ pattern synonym RHS.  However, if the pattern synonym gets added to
 the environment first, we will try and fail to find `x` amongst the
 (nonexistent) fields of the pattern synonym.
 
-Alternatively, the scope check can fail due to Template Haskell.
+
+Note [Record field names and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider (#12130):
 
    module Foo where
@@ -834,7 +839,7 @@ lookupSubBndrOcc :: Bool
                  -> RdrName
                  -> RnM (Either NotInScopeError Name)
 -- Find all the things the rdr-name maps to
--- and pick the one with the right parent namep
+-- and pick the one with the right parent name
 lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
   res <-
     lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 0c2d426450..a30fdf83d0 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -18,7 +18,7 @@ module GHC.Rename.Utils (
         warnForallIdentifier,
         checkUnusedRecordWildcard,
         mkFieldEnv,
-        badQualBndrErr, typeAppErr,
+        badQualBndrErr, typeAppErr, badFieldConErr,
         wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
         genHsIntegralLit, genHsTyLit,
         HsDocContext(..), pprHsDocContext,
@@ -93,15 +93,14 @@ newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
 newLocalBndrsRn = mapM newLocalBndrRn
 
 bindLocalNames :: [Name] -> RnM a -> RnM a
-bindLocalNames names enclosed_scope
-  = do { lcl_env <- getLclEnv
-       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)
-             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
+bindLocalNames names
+  = updLclEnv $ \ lcl_env ->
+    let th_level  = thLevel (tcl_th_ctxt lcl_env)
+        th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
                            [ (n, (NotTopLevel, th_level)) | n <- names ]
-             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names
-       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
-                            , tcl_rdr      = rdr_env' })
-                    enclosed_scope }
+        rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names
+    in lcl_env { tcl_th_bndrs = th_bndrs'
+               , tcl_rdr      = rdr_env' }
 
 bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 bindLocalNamesFV names enclosed_scope
@@ -617,6 +616,12 @@ typeAppErr what (L _ k)
             <+> quotes (char '@' <> ppr k))
        2 (text "Perhaps you intended to use TypeApplications")
 
+badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
+badFieldConErr con field
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    hsep [text "Constructor" <+> quotes (ppr con),
+          text "does not have field", quotes (ppr field)]
+
 -- | Ensure that a boxed or unboxed tuple has arity no larger than
 -- 'mAX_TUPLE_SIZE'.
 checkTupSize :: Int -> TcM ()
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 8bff4b7e53..6cec172b73 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -52,7 +52,6 @@ import GHC.Tc.Utils.Env
 import GHC.Tc.Gen.Arrow
 import GHC.Tc.Gen.Match
 import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Pat
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Types.Origin
 import GHC.Tc.Utils.TcType as TcType
@@ -1399,7 +1398,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
                 --          (so the desugarer knows the type of local binder to make)
            ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
       | otherwise
-      = do { addErrTc (badFieldCon con_like field_lbl)
+      = do { addErrTc (badFieldConErr (getName con_like) field_lbl)
            ; return Nothing }
   where
         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 2fbd7dcf8c..1a38d91593 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -21,7 +21,6 @@ module GHC.Tc.Gen.Pat
    , tcCheckPat, tcCheckPat_O, tcInferPat
    , tcPats
    , addDataConStupidTheta
-   , badFieldCon
    , polyPatSig
    )
 where
@@ -1281,7 +1280,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
                 --      f (R { foo = (a,b) }) = a+b
                 -- If foo isn't one of R's fields, we don't want to crash when
                 -- typechecking the "a+b".
-           [] -> failWith (badFieldCon con_like lbl)
+           [] -> failWith (badFieldConErr (getName con_like) lbl)
 
                 -- The normal case, when the field comes from the right constructor
            (pat_ty : extras) -> do
@@ -1488,12 +1487,6 @@ checkGADT conlike ex_tvs arg_tys = \case
     has_existentials :: Bool
     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
 
-badFieldCon :: ConLike -> FieldLabelString -> TcRnMessage
-badFieldCon con field
-  = TcRnUnknownMessage $ mkPlainError noHints $
-    hsep [text "Constructor" <+> quotes (ppr con),
-          text "does not have field", quotes (ppr field)]
-
 polyPatSig :: TcType -> SDoc
 polyPatSig sig_ty
   = hang (text "Illegal polymorphic type signature in pattern:")
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 66f7406745..44818e05e1 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -452,7 +452,7 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> TcM TcGblEnv
 tcRnSrcDecls explicit_mod_hdr export_ies decls
  = do { -- Do all the declarations
-      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
+      ; (tcg_env, tcl_env, lie) <- checkNoErrs $ tc_rn_src_decls decls
 
       ------ Simplify constraints ---------
       --
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 5cf866072e..7165c4765c 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1092,7 +1092,7 @@ reportDiagnostic msg
 -----------------------
 checkNoErrs :: TcM r -> TcM r
 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
--- If m fails then (checkNoErrsTc m) fails.
+-- If m fails then (checkNoErrs m) fails.
 -- If m succeeds, it checks whether m generated any errors messages
 --      (it might have recovered internally)
 --      If so, it fails too.
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T17469.hs b/testsuite/tests/overloadedrecflds/should_fail/T17469.hs
new file mode 100644
index 0000000000..319f4d873d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T17469.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+import T17469A
+
+main :: IO ()
+main = print MkFoo { foo = "", bar = True }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T17469.stderr b/testsuite/tests/overloadedrecflds/should_fail/T17469.stderr
new file mode 100644
index 0000000000..16bffe0164
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T17469.stderr
@@ -0,0 +1,10 @@
+[1 of 2] Compiling T17469A          ( T17469A.hs, T17469A.o )
+[2 of 2] Compiling Main             ( T17469.hs, T17469.o )
+
+T17469.hs:6:14: error:
+    • Constructor ‘MkFoo’ does not have field ‘bar’
+    • In the first argument of ‘print’, namely
+        ‘MkFoo {foo = "", bar = True}’
+      In the expression: print MkFoo {foo = "", bar = True}
+      In an equation for ‘main’:
+          main = print MkFoo {foo = "", bar = True}
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T17469A.hs b/testsuite/tests/overloadedrecflds/should_fail/T17469A.hs
new file mode 100644
index 0000000000..da0d8eb827
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T17469A.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module T17469A where
+
+data Foo = MkFoo { foo :: String } deriving Show
+
+data FooWithBar = MkFooWithBar { foo :: String, bar :: Bool } deriving Show
+
+data FooWithBarAndBaz = MkFooWithBarAndBaz { foo :: String, bar :: Bool, baz :: Int } deriving Show
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 396ea516e8..b6729376cb 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -32,6 +32,8 @@ test('hasfieldfail03', normal, compile_fail, [''])
 test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
      multimod_compile_fail, ['T14953', ''])
 test('DuplicateExports', normal, compile_fail, [''])
+test('T17469', [extra_files(['T17469A.hs'])], multimod_compile_fail,
+     ['T17469', ''])
 test('T17965', normal, compile_fail, [''])
 test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', ''])
 test('DRFPartialFields', normal, compile_fail, [''])