summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Rename/Env.hs38
-rw-r--r--compiler/GHC/Rename/Names.hs17
-rw-r--r--compiler/GHC/Rename/Utils.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs9
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs2
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/T17469.hs6
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/T17469.stderr5
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/T17469A.hs9
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/all.T2
-rw-r--r--testsuite/tests/rename/should_fail/T8448.stderr6
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’
View Lorry Controller Status