Improve errors for non-existent labels

This patch fixes #17469, by improving matters when you use
non-existent field names in a record construction:
   data T = MkT { x :: Int }
   f v = MkT { y = 3 }

The check is now made in the renamer, in GHC.Rename.Env.lookupRecFieldOcc.

That in turn led to a spurious error in T9975a, which is fixed by
making GHC.Rename.Names.extendGlobalRdrEnvRn fail fast if it finds
duplicate bindings.  See Note [Fail fast on duplicate definitions]
in that module for more details.

This patch was originated and worked on by Alex D (@nineonine)

11 files changed, 59 insertions, 46 deletions

diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index e19697bb40..cd40ab100a 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,13 @@ 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]
-  | otherwise
-  -- This use of Global is right as we are looking up a selector which
-  -- can only be defined at the top level.
+           Nothing        -> do { addErr (badFieldConErr con lbl)
+                                ; return (mkUnboundNameRdr rdr_name) } }
+
+  | otherwise  -- Can't use the data constructor to disambiguate
   = 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.
@@ -632,25 +634,8 @@ Unlike with constructors or pattern-matching, we do not allow the module
 qualifier to be omitted, because we do not have a data constructor from which to
 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
-lookupGlobalOccRn.  We don't report an error immediately because the
-actual problem might be located elsewhere.  For example (#9975):
-
-   data Test = Test { x :: Int }
-   pattern Test wat = Test { x = wat }
-
-Here there are multiple declarations of Test (as a data constructor
-and as a pattern synonym), which will be reported as an error.  We
-shouldn't also report an error about the occurrence of `x` in the
-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
@@ -669,7 +654,6 @@ lookupGlobalOccRn will find it.
 -}
 
 
-
 -- | Used in export lists to lookup the children.
 lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName
                         -> RnM ChildLookupResult
@@ -834,7 +818,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/Names.hs b/compiler/GHC/Rename/Names.hs
index dbf1f88cba..b3360ad73b 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -690,7 +690,8 @@ extendGlobalRdrEnvRn :: [AvailInfo]
 -- see Note [Top-level Names in Template Haskell decl quotes]
 
 extendGlobalRdrEnvRn avails new_fixities
-  = do  { (gbl_env, lcl_env) <- getEnvs
+  = checkNoErrs $  -- See Note [Fail fast on duplicate definitions]
+    do  { (gbl_env, lcl_env) <- getEnvs
         ; stage <- getStage
         ; isGHCi <- getIsGHCi
         ; let rdr_env  = tcg_rdr_env gbl_env
@@ -767,7 +768,19 @@ extendGlobalRdrEnvRn avails new_fixities
               (False, True)  -> isNoFieldSelectorGRE gre'
               (False, False) -> False
 
-{-
+{- Note [Fail fast on duplicate definitions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there are duplicate bindings for the same thing, we want to fail
+fast. Having two bindings for the same thing can cause follow-on errors.
+Example (test T9975a):
+   data Test = Test { x :: Int }
+   pattern Test wat = Test { x = wat }
+This defines 'Test' twice.  The second defn has no field-names; and then
+we get an error from Test { x=wat }, saying "Test has no field 'x'".
+
+Easiest thing is to bale out fast on duplicate definitions, which
+we do via `checkNoErrs` on `extendGlobalRdrEnvRn`.
+
 Note [Reporting duplicate local declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general, a single module may not define the same OccName multiple times. This
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 6497a51c02..1647c19e32 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,
@@ -616,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 230acdc3f5..46775235df 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 6034d05720..132f58b7b4 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
@@ -1282,7 +1281,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
@@ -1489,12 +1488,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/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index ea3b50fa3c..ca2915e8fa 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1142,7 +1142,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..5d93f46489
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T17469.stderr
@@ -0,0 +1,5 @@
+[1 of 3] Compiling T17469A          ( T17469A.hs, T17469A.o )
+[2 of 3] Compiling Main             ( T17469.hs, T17469.o )
+
+T17469.hs:6:32: error:
+    Constructor ‘MkFoo’ does not have field ‘bar’
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, [''])
diff --git a/testsuite/tests/rename/should_fail/T8448.stderr b/testsuite/tests/rename/should_fail/T8448.stderr
index 4b84290863..1b3ee56f47 100644
--- a/testsuite/tests/rename/should_fail/T8448.stderr
+++ b/testsuite/tests/rename/should_fail/T8448.stderr
@@ -1,6 +1,2 @@
 
-T8448.hs:5:17: error:
-    • Constructor ‘[]’ does not have field ‘r’
-    • In the first argument of ‘undefined’, namely ‘[] {r = x}’
-      In the expression: undefined [] {r = x}
-      In an equation for ‘f’: f x = undefined [] {r = x}
+T8448.hs:5:21: error: Constructor ‘[]’ does not have field ‘r’