From df706de378e3415a3972ddd14863f54fc7162dc7 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Wed, 14 Jun 2023 18:57:28 +0200
Subject: [PATCH] Re-instate -Wincomplete-record-updates
Commit e74fc066 refactored the handling of record updates to use
the HsExpanded mechanism. This meant that the pattern matching inherent
to a record update was considered to be "generated code", and thus we
stopped emitting "incomplete record update" warnings entirely.
This commit changes the "data Origin = Source | Generated" datatype,
adding a field to the Generated constructor to indicate whether we
still want to perform pattern-match checking. We also have to do a bit
of plumbing with HsCase, to record that the HsCase arose from an
HsExpansion of a RecUpd, so that the error message continues to mention
record updates as opposed to a generic "incomplete pattern matches in case"
error.
Finally, this patch also changes the way we handle inaccessible code
warnings. Commit e74fc066 was also a regression in this regard, as we
were emitting "inaccessible code" warnings for case statements spuriously
generated when desugaring a record update (remember: the desugaring mechanism
happens before typechecking; it thus can't take into account e.g. GADT information
in order to decide which constructors to include in the RHS of the desugaring
of the record update).
We fix this by changing the mechanism through which we disable inaccessible
code warnings: we now check whether we are in generated code in
GHC.Tc.Utils.TcMType.newImplication in order to determine whether to
emit inaccessible code warnings.
Fixes #23520
Updates haddock submodule, to avoid incomplete record update warnings
---
compiler/GHC/Hs/Expr.hs | 13 ++---
compiler/GHC/Hs/Utils.hs | 11 ++--
compiler/GHC/HsToCore/Arrows.hs | 6 +-
compiler/GHC/HsToCore/Errors/Ppr.hs | 4 +-
compiler/GHC/HsToCore/Errors/Types.hs | 8 +--
compiler/GHC/HsToCore/Expr.hs | 7 ++-
compiler/GHC/HsToCore/GuardedRHSs.hs | 6 +-
compiler/GHC/HsToCore/Match.hs | 22 +++----
compiler/GHC/HsToCore/Match.hs-boot | 8 +--
compiler/GHC/HsToCore/Match/Constructor.hs | 4 +-
compiler/GHC/HsToCore/Monad.hs | 2 +-
compiler/GHC/HsToCore/Pmc.hs | 2 +-
compiler/GHC/HsToCore/Pmc/Utils.hs | 27 +++++----
compiler/GHC/HsToCore/Utils.hs | 2 +-
compiler/GHC/Iface/Ext/Ast.hs | 2 +-
compiler/GHC/Rename/Expr.hs | 2 +-
compiler/GHC/Rename/Utils.hs | 4 +-
compiler/GHC/Tc/Deriv/Generate.hs | 6 +-
compiler/GHC/Tc/Gen/Expr.hs | 5 +-
compiler/GHC/Tc/Gen/Splice.hs | 2 +-
compiler/GHC/Tc/TyCl/Instance.hs | 12 ++--
compiler/GHC/Tc/TyCl/PatSyn.hs | 11 ++--
compiler/GHC/Tc/TyCl/Utils.hs | 2 +-
compiler/GHC/Tc/Types/Constraint.hs | 3 +-
compiler/GHC/Tc/Utils/Monad.hs | 20 +++++--
compiler/GHC/Tc/Utils/TcMType.hs | 5 +-
compiler/GHC/Types/Basic.hs | 57 +++++++++++++++++--
testsuite/tests/ghc-api/T18522-dbg-ppr.hs | 2 +-
.../pmcheck/should_compile/T12957a.stderr | 18 ++----
.../tests/pmcheck/should_compile/T17783.hs | 8 ++-
.../tests/pmcheck/should_compile/T21360.hs | 2 -
.../tests/pmcheck/should_compile/T23520.hs | 5 ++
.../pmcheck/should_compile/T23520.stderr | 4 ++
testsuite/tests/pmcheck/should_compile/all.T | 9 +--
.../tests/typecheck/should_fail/T3323.stderr | 6 +-
.../typecheck/should_run/Typeable1.stderr | 6 ++
utils/haddock | 2 +-
37 files changed, 192 insertions(+), 123 deletions(-)
create mode 100644 testsuite/tests/pmcheck/should_compile/T23520.hs
create mode 100644 testsuite/tests/pmcheck/should_compile/T23520.stderr
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index da7b2b23983f..3fcb4ef1a15e 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -286,8 +286,8 @@ type instance XExplicitSum GhcRn = NoExtField
type instance XExplicitSum GhcTc = [Type]
type instance XCase GhcPs = EpAnn EpAnnHsCase
-type instance XCase GhcRn = NoExtField
-type instance XCase GhcTc = NoExtField
+type instance XCase GhcRn = HsMatchContext GhcTc
+type instance XCase GhcTc = HsMatchContext GhcTc
type instance XIf GhcPs = EpAnn AnnsIf
type instance XIf GhcRn = NoExtField
@@ -1973,7 +1973,7 @@ matchContextErrString LambdaExpr = text "lambda"
matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
+matchContextErrString PatSyn = text "pattern synonym"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
@@ -2030,11 +2030,10 @@ matchSeparator ArrowMatchCtxt{} = text "->"
matchSeparator PatBindRhs = text "="
matchSeparator PatBindGuards = text "="
matchSeparator StmtCtxt{} = text "<-"
-matchSeparator RecUpd = text "=" -- This can be printed by the pattern
- -- match checker trace
+matchSeparator RecUpd = text "=" -- This can be printed by the pattern
+matchSeparator PatSyn = text "<-" -- match checker trace
matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
-matchSeparator PatSyn = panic "unused"
pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
@@ -2055,7 +2054,7 @@ pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
<+> text "alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative"
-pprMatchContextNoun RecUpd = text "record-update construct"
+pprMatchContextNoun RecUpd = text "record update"
pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"
pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"
pprMatchContextNoun PatBindRhs = text "pattern binding"
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 809278d47431..afa782103176 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -271,7 +271,7 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
where
- matches = mkMatchGroup Generated
+ matches = mkMatchGroup (Generated SkipPmc)
(noLocA [mkSimpleMatch LambdaExpr pats' body])
pats' = map (parenthesizePat appPrec) pats
@@ -599,7 +599,8 @@ nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-- AZ:Is this used?
-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))
+nlHsLam match = noLocA $ HsLam noExtField
+ $ mkMatchGroup (Generated SkipPmc) (noLocA [match])
nlHsPar e = noLocA (gHsPar e)
-- nlHsIf should generate if-expressions which are NOT subject to
@@ -608,7 +609,7 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
nlHsCase expr matches
- = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))
+ = noLocA (HsCase noAnn expr (mkMatchGroup (Generated SkipPmc) (noLocA matches)))
nlList exprs = noLocA (ExplicitList noAnn exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
@@ -865,9 +866,9 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
-- | Convenience function using 'mkFunBind'.
-- This is for generated bindings only, do not use for user-written code.
mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
- -> LHsExpr GhcPs -> LHsBind GhcPs
+ -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
- = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
+ = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)
[mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
emptyLocalBinds]
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index cc757a94e3c3..734ad2589e91 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -510,7 +510,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do
let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
in_ty = envStackType env_ids stack_ty
- core_body <- dsExpr (HsCase noExtField exp match')
+ core_body <- dsExpr (HsCase (ArrowMatchCtxt ArrowCaseAlt) exp match')
core_matches <- matchEnvStack env_ids stack_id core_body
return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
@@ -811,7 +811,7 @@ dsCases ids local_vars stack_id stack_ty res_ty
Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
dsExpr (HsLamCase EpAnnNotUsed LamCase
(MG { mg_alts = noLocA []
- , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated
+ , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated SkipPmc)
}))
-- Replace the commands in the case with these tagged tuples,
@@ -1191,7 +1191,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-- Match a list of expressions against a list of patterns, left-to-right.
matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext GhcRn -- Match kind
+ -> HsMatchContext GhcTc -- Match kind
-> [LPat GhcTc] -- Patterns they should match
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 4fdc6c120fd7..cc7222f447c5 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -298,11 +298,11 @@ badMonadBind elt_ty
2 (quotes (ppr elt_ty))
-- Print a single clause (for redundant/with-inaccessible-rhs)
-pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc
+pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->
f (q <+> matchSeparator ctx <+> text "...")
-pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext singular kind msg rest_of_msg_fun
= vcat [text txt <+> msg,
sep [ text "In" <+> ppr_match <> char ':'
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 8f118abb1376..608bfa285447 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -85,18 +85,18 @@ data DsMessage
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc
+ | DsRedundantBangPatterns !(HsMatchContext GhcTc) !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc
+ | DsOverlappingPatterns !(HsMatchContext GhcTc) !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc'
- | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc
+ | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc
| DsMaxPmCheckModelsReached !MaxPmCheckModels
- | DsNonExhaustivePatterns !(HsMatchContext GhcRn)
+ | DsNonExhaustivePatterns !(HsMatchContext GhcTc)
!ExhaustivityCheckType
!MaxUncoveredPatterns
[Id]
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index fde37370acc2..be9347e0e2c8 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -373,9 +373,9 @@ dsExpr (ExplicitSum types alt arity expr)
dsExpr (HsPragE _ prag expr) =
ds_prag_expr prag expr
-dsExpr (HsCase _ discrim matches)
+dsExpr (HsCase ctxt discrim matches)
= do { core_discrim <- dsLExpr discrim
- ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches
+ ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
@@ -755,11 +755,12 @@ dsDo ctx stmts
later_pats = rec_tup_pats
rets = map noLocA rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
+ match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated SkipPmc)
mfix_arg = noLocA $ HsLam noExtField
(MG { mg_alts = noLocA [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
- , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated
+ , mg_ext = match_group
})
mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
body = noLocA $ HsDo body_ty
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 6ae671668528..8a24b00a590d 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -55,7 +55,7 @@ dsGuarded grhss rhs_ty rhss_nablas = do
-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
-dsGRHSs :: HsMatchContext GhcRn
+dsGRHSs :: HsMatchContext GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-> Type -- ^ Type of RHS
-> NonEmpty Nablas -- ^ Refined pattern match checking
@@ -76,7 +76,7 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
-- NB: nested dsLet inside matchResult
; return match_result2 }
-dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
+dsGRHS :: HsMatchContext GhcTc -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty
@@ -90,7 +90,7 @@ dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
-}
matchGuards :: [GuardStmt GhcTc] -- Guard
- -> HsStmtContext GhcRn -- Context
+ -> HsStmtContext GhcTc -- Context
-> Nablas -- The RHS's covered set for PmCheck
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index d6986de6fa40..6be944d1242e 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -28,7 +28,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), isGenerated )
+import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC )
import GHC.Types.SourceText
import GHC.Driver.DynFlags
import GHC.Hs
@@ -736,7 +736,7 @@ Call @match@ with all of this information!
-- p2 q2 -> ...
matchWrapper
- :: HsMatchContext GhcRn -- ^ For shadowing warning messages
+ :: HsMatchContext GhcTc -- ^ For shadowing warning messages
-> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
-- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
@@ -798,7 +798,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
- ; result_expr <- discard_warnings_if_generated origin $
+ ; result_expr <- discard_warnings_if_skip_pmc origin $
matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
@@ -818,10 +818,10 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
, eqn_orig = FromSource
, eqn_rhs = match_result } }
- discard_warnings_if_generated orig =
- if isGenerated orig
- then discardWarningsDs
- else id
+ discard_warnings_if_skip_pmc orig =
+ if requiresPMC orig
+ then id
+ else discardWarningsDs
initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
initNablasMatches ldi_nablas ms
@@ -880,7 +880,7 @@ the expression (in this case, it will end up recursively calling 'matchWrapper'
on the user-written case statement).
-}
-matchEquations :: HsMatchContext GhcRn
+matchEquations :: HsMatchContext GhcTc
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
@@ -894,7 +894,7 @@ matchEquations ctxt vars eqns_info rhs_ty
-- situation where we want to match a single expression against a single
-- pattern. It returns an expression.
matchSimply :: CoreExpr -- ^ Scrutinee
- -> HsMatchContext GhcRn -- ^ Match kind
+ -> HsMatchContext GhcTc -- ^ Match kind
-> LPat GhcTc -- ^ Pattern it should match
-> CoreExpr -- ^ Return this if it matches
-> CoreExpr -- ^ Return this if it doesn't
@@ -916,7 +916,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
+matchSinglePat :: CoreExpr -> HsMatchContext GhcTc -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
@@ -942,7 +942,7 @@ matchSinglePat scrut hs_ctx pat ty match_result
matchSinglePatVar :: Id -- See Note [Match Ids]
-> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
- -> HsMatchContext GhcRn -> LPat GhcTc
+ -> HsMatchContext GhcTc -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var mb_scrut ctx pat ty match_result
= assertPpr (isInternalName (idName var)) (ppr var) $
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
index 3e969e922dd9..5a55463d4c6f 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -6,7 +6,7 @@ import GHC.Tc.Utils.TcType ( Type )
import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )
import GHC.Core ( CoreExpr )
import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
-import GHC.Hs.Extension ( GhcTc, GhcRn )
+import GHC.Hs.Extension ( GhcTc )
match :: [Id]
-> Type
@@ -14,14 +14,14 @@ match :: [Id]
-> DsM (MatchResult CoreExpr)
matchWrapper
- :: HsMatchContext GhcRn
+ :: HsMatchContext GhcTc
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchSimply
:: CoreExpr
- -> HsMatchContext GhcRn
+ -> HsMatchContext GhcTc
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
@@ -30,7 +30,7 @@ matchSimply
matchSinglePatVar
:: Id
-> Maybe CoreExpr
- -> HsMatchContext GhcRn
+ -> HsMatchContext GhcTc
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 03b212d0eef9..264f49e0ebca 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -21,7 +21,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import GHC.Hs
import GHC.HsToCore.Binds
import GHC.Core.ConLike
-import GHC.Types.Basic ( Origin(..) )
+import GHC.Types.Basic
import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.HsToCore.Monad
@@ -168,7 +168,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_orig = Generated
+ , eqn { eqn_orig = Generated SkipPmc
, eqn_pats = conArgPats val_arg_tys args ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 2740e5dbec47..6ba19bb95892 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -124,7 +124,7 @@ import qualified Data.Set as S
-}
data DsMatchContext
- = DsMatchContext (HsMatchContext GhcRn) SrcSpan
+ = DsMatchContext (HsMatchContext GhcTc) SrcSpan
deriving ()
instance Outputable DsMatchContext where
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index cd5bf9ddcd5a..aa72db0aed57 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -112,7 +112,7 @@ pmcPatBind _ _ _ = pure ()
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
pmcGRHSs
- :: HsMatchContext GhcRn -- ^ Match context, for warning messages
+ :: HsMatchContext GhcTc -- ^ Match context, for warning messages
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check
-> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long
-- distance info
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index 40ac5907f434..b39862821a50 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -14,7 +14,7 @@ module GHC.HsToCore.Pmc.Utils (
import GHC.Prelude
-import GHC.Types.Basic (Origin(..), isGenerated)
+import GHC.Types.Basic (Origin(..), requiresPMC)
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Core.Type
@@ -109,23 +109,20 @@ arrowMatchContextExhaustiveWarningFlag = \ case
-- exhaustiveness check).
isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
isMatchContextPmChecked dflags origin kind
- | isGenerated origin
- = False
- | otherwise
- = overlapping dflags kind || exhaustive dflags kind
+ = requiresPMC origin
+ && (overlapping dflags kind || exhaustive dflags kind)
-- | Return True when any of the pattern match warnings ('allPmCheckWarnings')
-- are enabled, in which case we need to run the pattern match checker.
needToRunPmCheck :: DynFlags -> Origin -> Bool
needToRunPmCheck dflags origin
- | isGenerated origin
- = False
- | otherwise
- = notNull (filter (`wopt` dflags) allPmCheckWarnings)
+ = requiresPMC origin
+ && notNull (filter (`wopt` dflags) allPmCheckWarnings)
{- Note [Inaccessible warnings for record updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12957)
+Consider (#12957):
+
data T a where
T1 :: { x :: Int } -> T Bool
T2 :: { x :: Int } -> T a
@@ -134,8 +131,9 @@ Consider (#12957)
f :: T Char -> T a
f r = r { x = 3 }
-The desugarer will conservatively generate a case for T1 even though
-it's impossible:
+In GHC.Tc.Gen.Expr.desugarRecordUpd, we will conservatively generate a case
+for T1 even though it's impossible:
+
f r = case r of
T1 x -> T1 3 -- Inaccessible branch
T2 x -> T2 3
@@ -143,13 +141,14 @@ it's impossible:
We don't want to warn about the inaccessible branch because the programmer
didn't put it there! So we filter out the warning here.
+The test case T12957a checks this.
The same can happen for long distance term constraints instead of type
constraints (#17783):
- data T = A { x :: Int } | B { x :: Int }
+ data T = A { x :: Int } | B
f r@A{} = r { x = 3 }
- f _ = B 0
+ f _ = B
Here, the long distance info from the FunRhs match (@r ~ A x@) will make the
clause matching on @B@ of the desugaring to @case@ redundant. It's generated
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 85484cbb4e54..0f696d6b28d2 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -453,7 +453,7 @@ For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes
is disabled.
-}
-mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
+mkFailExpr :: HsMatchContext GhcTc -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
= mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 3a7b8452aa53..a2578641ca90 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -890,7 +890,7 @@ instance ( HiePass p
setOrigin :: Origin -> NodeOrigin -> NodeOrigin
setOrigin FromSource _ = SourceInfo
-setOrigin Generated _ = GeneratedInfo
+setOrigin (Generated {}) _ = GeneratedInfo
instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
toHie (L sp psb) = concatM $ case psb of
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 68b73d2b4830..2965d290126e 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -428,7 +428,7 @@ rnExpr (HsLamCase x lc_variant matches)
rnExpr (HsCase _ expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+ ; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnExpr (HsLet _ tkLet binds tkIn expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 81fb803e51fc..1b5049737296 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -56,7 +56,7 @@ import GHC.Types.SourceFile
import GHC.Types.SourceText ( SourceText(..), IntegralLit )
import GHC.Utils.Outputable
import GHC.Utils.Misc
-import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated), TypeOrKind )
+import GHC.Types.Basic
import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Data.Maybe ( whenIsJust )
import GHC.Driver.DynFlags
@@ -628,7 +628,7 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
genFunBind fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)
+ , fun_matches = mkMatchGroup (Generated SkipPmc) (wrapGenSpan ms)
, fun_ext = emptyNameSet
}
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 62cb85dee294..c3b74ee67100 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2302,7 +2302,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches)
+ = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2330,7 +2330,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches')
+ = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2354,7 +2354,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches')
+ = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 2953f1281f1b..faba45ca67e5 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -393,7 +393,7 @@ tcExpr (HsCase x scrut matches) res_ty
; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
; return (HsCase x scrut' matches') }
where
- match_ctxt = MC { mc_what = CaseAlt,
+ match_ctxt = MC { mc_what = x,
mc_body = tcBody }
tcExpr (HsIf x pred b1 b2) res_ty
@@ -1259,7 +1259,8 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
case_expr :: HsExpr GhcRn
- case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))
+ case_expr = HsCase RecUpd record_expr
+ $ mkMatchGroup (Generated DoPmc) (wrapGenSpan matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat relevant_cons
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 853b983e82ed..6a5132138930 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1971,7 +1971,7 @@ lookupName is_type_name s
getThSpliceOrigin :: TcM Origin
getThSpliceOrigin = do
warn <- goptM Opt_EnableThSpliceWarnings
- if warn then return FromSource else return Generated
+ if warn then return FromSource else return (Generated SkipPmc)
getThing :: TH.Name -> TcM TcTyThing
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f0eddac776f1..308dececf1cd 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1955,17 +1955,15 @@ through typing information everywhere in the algorithm that generates Ord
instances in order to determine which cases were unreachable. This seems like
a lot of work for minimal gain, so we have opted not to go for this approach.
-Instead, we take the much simpler approach of always disabling
--Winaccessible-code for derived code. To accomplish this, we do the following:
+Instead, we take the following approach:
-1. In tcMethods (which typechecks method bindings), disable
- -Winaccessible-code.
+1. In tcMethods (which typechecks method bindings), use 'setInGeneratedCode'.
2. When creating Implications during typechecking, record this flag
(in ic_warn_inaccessible) at the time of creation.
3. After typechecking comes error reporting, where GHC must decide how to
report inaccessible code to the user, on an Implication-by-Implication
- basis. If an Implication's DynFlags indicate that -Winaccessible-code was
- disabled, then don't bother reporting it. That's it!
+ basis. If the ic_warn_inaccessible field of the Implication is False, then
+ we don't bother reporting it. That's it!
-}
------------------------
@@ -2214,7 +2212,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
, tyConBinderForAllTyFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
bind = L (noAnnSrcSpan loc)
- $ mkTopFunBind Generated fn
+ $ mkTopFunBind (Generated SkipPmc) fn
[mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 25e9ebd8ca59..c34e9159cb58 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -812,17 +812,18 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
then [mkHsCaseAlt lpat cont']
else [mkHsCaseAlt lpat cont',
mkHsCaseAlt lwpat fail']
+ gen = Generated SkipPmc
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
- HsCase noExtField (nlHsVar scrutinee) $
+ HsCase PatSyn (nlHsVar scrutinee) $
MG{ mg_alts = L (l2l $ getLoc lpat) cases
- , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated
+ , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen
}
body' = noLocA $
HsLam noExtField $
MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr
args body]
- , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
+ , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty gen
}
match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
@@ -830,7 +831,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
(EmptyLocalBinds noExtField)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
- , mg_ext = MatchGroupTc [] res_ty Generated
+ , mg_ext = MatchGroupTc [] res_ty gen
}
matcher_arity = length req_theta + 3
-- See Note [Pragmas for pattern synonyms]
@@ -963,7 +964,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup Generated (noLocA [builder_match])
+ mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
where
builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
| L loc n <- args]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 9c9d356a22d2..767db8a7f704 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -931,7 +931,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
- sel_bind = mkTopFunBind Generated sel_lname alts
+ sel_bind = mkTopFunBind (Generated SkipPmc) sel_lname alts
where
alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
[] unit_rhs]
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 837dff6bb90f..807348170c48 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -1456,8 +1456,7 @@ data Implication
ic_given_eqs :: HasGivenEqs, -- Are there Given equalities here?
ic_warn_inaccessible :: Bool,
- -- True <=> -Winaccessible-code is enabled
- -- at construction. See
+ -- True <=> we should report inaccessible code
-- Note [Avoid -Winaccessible-code when deriving]
-- in GHC.Tc.TyCl.Instance
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index ecc8bca4a3a3..a9bcbbe8edb2 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -61,7 +61,8 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA,
+ inGeneratedCode, setInGeneratedCode,
wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
@@ -979,11 +980,18 @@ setSrcSpan (RealSrcSpan loc _) thing_inside
setSrcSpan loc@(UnhelpfulSpan _) thing_inside
| isGeneratedSrcSpan loc
- = updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside
+ = setInGeneratedCode thing_inside
| otherwise
= thing_inside
+-- | Mark the inner computation as being done inside generated code.
+--
+-- See Note [Error contexts in generated code]
+setInGeneratedCode :: TcRn a -> TcRn a
+setInGeneratedCode thing_inside =
+ updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside
+
setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
@@ -1204,15 +1212,17 @@ problem.
Note [Error contexts in generated code]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
+* setSrcSpan sets tcl_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
and back to False when we get a useful SrcSpan
-* When tc_in_gen_code is True, addErrCtxt becomes a no-op.
+* When tcl_in_gen_code is True, addErrCtxt becomes a no-op.
So typically it's better to do setSrcSpan /before/ addErrCtxt.
See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
-more discussion of this fancy footwork.
+more discussion of this fancy footwork, as well as
+Note [Generated code and pattern-match checking] in GHC.Types.Basic for the
+relation with pattern-match checks.
-}
getErrCtxt :: TcM [ErrCtxt]
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 239b293a9150..4eba350def76 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -342,7 +342,10 @@ newImplication :: TcM Implication
newImplication
= do env <- getLclEnv
warn_inaccessible <- woptM Opt_WarnInaccessibleCode
- return (implicationPrototype (mkCtLocEnv env)) { ic_warn_inaccessible = warn_inaccessible }
+ let in_gen_code = lclEnvInGeneratedCode env
+ return $
+ (implicationPrototype (mkCtLocEnv env))
+ { ic_warn_inaccessible = warn_inaccessible && not in_gen_code }
{-
************************************************************************
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 6fd1d1d6cef3..e743276e0ee8 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -36,7 +36,7 @@ module GHC.Types.Basic (
FunctionOrData(..),
RecFlag(..), isRec, isNonRec, boolToRecFlag,
- Origin(..), isGenerated,
+ Origin(..), isGenerated, DoPmc(..), requiresPMC,
RuleName, pprRuleName,
@@ -583,17 +583,62 @@ instance Binary RecFlag where
************************************************************************
-}
+-- | Was this piece of code user-written or generated by the compiler?
+--
+-- See Note [Generated code and pattern-match checking].
data Origin = FromSource
- | Generated
+ | Generated DoPmc
deriving( Eq, Data )
isGenerated :: Origin -> Bool
-isGenerated Generated = True
-isGenerated FromSource = False
+isGenerated Generated {} = True
+isGenerated FromSource = False
instance Outputable Origin where
- ppr FromSource = text "FromSource"
- ppr Generated = text "Generated"
+ ppr FromSource = text "FromSource"
+ ppr (Generated pmc) = text "Generated" <+> ppr pmc
+
+-- | Whether to run pattern-match checks in generated code.
+--
+-- See Note [Generated code and pattern-match checking].
+data DoPmc = SkipPmc
+ | DoPmc
+ deriving( Eq, Data )
+
+instance Outputable DoPmc where
+ ppr SkipPmc = text "SkipPmc"
+ ppr DoPmc = text "DoPmc"
+
+-- | Does this 'Origin' require us to run pattern-match checking,
+-- or should we skip these checks?
+--
+-- See Note [Generated code and pattern-match checking].
+requiresPMC :: Origin -> Bool
+requiresPMC (Generated SkipPmc) = False
+requiresPMC _ = True
+
+{- Note [Generated code and pattern-match checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some parts of the compiler generate code that is then typechecked. For example:
+
+ - the HsExpansion mechanism described in Note [Rebindable syntax and HsExpansion]
+ in GHC.Hs.Expr,
+ - the deriving mechanism.
+
+It is usually the case that we want to avoid generating error messages that
+refer to generated code. The way this is handled is that we mark certain
+parts of the AST as being generated (using the Origin datatype); this is then
+used to set the tcl_in_gen_code flag in TcLclEnv, as explained in
+Note [Error contexts in generated code] in GHC.Tc.Utils.Monad.
+
+Being in generated code is usually taken to mean we should also skip doing
+pattern-match checking, but not always. For example, when desugaring a record
+update (as described in Note [Record Updates] in GHC.Tc.Gen.Expr), we still want
+to do pattern-match checking, in order to report incomplete record updates
+(failing to do so lead to #23250). So, for a 'Generated' 'Origin', we keep track
+of whether we should do pattern-match checks; see the calls of the requiresPMC
+function (e.g. isMatchContextPmChecked and needToRunPmCheck in GHC.HsToCore.Pmc.Utils).
+-}
{-
************************************************************************
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 60eae1442595..918b39eb90b6 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -44,7 +44,7 @@ main = do
forall (a :: k) (b :: j) ->
() |]
let hs_t = fromRight (error "convertToHsType") $
- convertToHsType Generated noSrcSpan th_t
+ convertToHsType (Generated SkipPmc) noSrcSpan th_t
(messages, mres) <-
tcRnType hsc_env SkolemiseFlexi True hs_t
let (warnings, errors) = partitionMessages messages
diff --git a/testsuite/tests/pmcheck/should_compile/T12957a.stderr b/testsuite/tests/pmcheck/should_compile/T12957a.stderr
index ba301f227e0b..883277d7ad22 100644
--- a/testsuite/tests/pmcheck/should_compile/T12957a.stderr
+++ b/testsuite/tests/pmcheck/should_compile/T12957a.stderr
@@ -1,13 +1,7 @@
-T12957a.hs:25:35: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)]
- • Inaccessible code in
- a pattern with constructor: BFields :: [()] -> Fields B,
- in a case alternative
- Couldn't match type ‘A’ with ‘B’
- • In a record update at field ‘list’,
- with type constructor ‘Fields’
- and data constructor ‘BFields’.
- In the expression: emptyA {list = [a]}
- In a record update at field ‘sFields’,
- with type constructor ‘S’
- and data constructor ‘S’.
+T12957a.hs:25:35: warning: [GHC-62161] [-Wincomplete-record-updates (in -Wall)]
+ Pattern match(es) are non-exhaustive
+ In a record update:
+ Patterns of type ‘Fields A’ not matched:
+ AFields
+ EmptyFields
diff --git a/testsuite/tests/pmcheck/should_compile/T17783.hs b/testsuite/tests/pmcheck/should_compile/T17783.hs
index 8ac92460007e..1b67ec1d9d54 100644
--- a/testsuite/tests/pmcheck/should_compile/T17783.hs
+++ b/testsuite/tests/pmcheck/should_compile/T17783.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wincomplete-record-updates #-}
-
module Bug where
data PartialRec = No
@@ -7,3 +5,9 @@ data PartialRec = No
update No = No
update r@(Yes {}) = r { b = False }
+
+
+data T = A { x :: Int } | B
+
+f r@A{} = r { x = 3 }
+f _ = B
diff --git a/testsuite/tests/pmcheck/should_compile/T21360.hs b/testsuite/tests/pmcheck/should_compile/T21360.hs
index db517a35a96a..80a8afebde05 100644
--- a/testsuite/tests/pmcheck/should_compile/T21360.hs
+++ b/testsuite/tests/pmcheck/should_compile/T21360.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wincomplete-record-updates #-}
-
module T21360 where
data Foo = A {a :: Int} | B deriving Show
diff --git a/testsuite/tests/pmcheck/should_compile/T23520.hs b/testsuite/tests/pmcheck/should_compile/T23520.hs
new file mode 100644
index 000000000000..768cec3b4a53
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T23520.hs
@@ -0,0 +1,5 @@
+module T23520 where
+
+data T = T1 { x :: Bool } | T2
+
+f a = a { x = False }
diff --git a/testsuite/tests/pmcheck/should_compile/T23520.stderr b/testsuite/tests/pmcheck/should_compile/T23520.stderr
new file mode 100644
index 000000000000..c7de2a511f8c
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T23520.stderr
@@ -0,0 +1,4 @@
+
+T23520.hs:5:7: warning: [GHC-62161] [-Wincomplete-record-updates (in -Wall)]
+ Pattern match(es) are non-exhaustive
+ In a record update: Patterns of type ‘T’ not matched: T2
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 810c8acbd78c..f9470110a647 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -64,7 +64,7 @@ test('T17646', normal, compile, [overlapping_incomplete])
test('T17703', normal, compile, [overlapping_incomplete])
test('T17725', normal, compile, [overlapping_incomplete])
test('T17729', normal, compile, [overlapping_incomplete])
-test('T17783', normal, compile, [overlapping_incomplete])
+test('T17783', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T17836', collect_compiler_stats('bytes allocated',10), compile, [overlapping_incomplete])
test('T17836b', collect_compiler_stats('bytes allocated',10), compile, [overlapping_incomplete])
test('T17977', collect_compiler_stats('bytes allocated',10), compile, [overlapping_incomplete])
@@ -89,7 +89,8 @@ test('T19384', expect_broken(19384), compile, [overlapping_incomplete])
test('T19622', normal, compile, [overlapping_incomplete])
test('T20631', normal, compile, [overlapping_incomplete])
test('T20642', normal, compile, [overlapping_incomplete])
-test('T21360', normal, compile, [overlapping_incomplete])
+test('T21360', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
+test('T23520', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
# Other tests
test('pmc001', [], compile, [overlapping_incomplete])
@@ -104,8 +105,8 @@ test('pmc009', [], compile, [overlapping_incomplete+'-package ghc'])
test('T11245', [], compile, [overlapping_incomplete])
test('T11336b', [], compile, [overlapping_incomplete])
test('T12949', [], compile, [overlapping_incomplete])
-test('T12957', [], compile, [overlapping_incomplete])
-test('T12957a', [], compile, [overlapping_incomplete+'-fdefer-type-errors'])
+test('T12957', [], compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
+test('T12957a', [], compile, [overlapping_incomplete+'-fdefer-type-errors -Wincomplete-record-updates'])
test('PmExprVars', [], compile, [overlapping_incomplete])
test('CyclicSubst', [], compile, [overlapping_incomplete])
test('CaseOfKnownCon', [], compile, [overlapping_incomplete])
diff --git a/testsuite/tests/typecheck/should_fail/T3323.stderr b/testsuite/tests/typecheck/should_fail/T3323.stderr
index cb2d52f21df0..ec0a41b97300 100644
--- a/testsuite/tests/typecheck/should_fail/T3323.stderr
+++ b/testsuite/tests/typecheck/should_fail/T3323.stderr
@@ -3,12 +3,12 @@ T3323.hs:18:7: error: [GHC-39999]
• Could not deduce ‘GHC.IO.Device.RawIO dev0’
from the context: (GHC.IO.Device.RawIO dev,
GHC.IO.Device.IODevice dev, GHC.IO.BufferedIO.BufferedIO dev,
- base-4.17.0.0:Data.Typeable.Internal.Typeable dev)
+ base-4.18.0.0:Data.Typeable.Internal.Typeable dev)
bound by a pattern with constructor:
Handle__ :: forall dev enc_state dec_state.
(GHC.IO.Device.RawIO dev, GHC.IO.Device.IODevice dev,
GHC.IO.BufferedIO.BufferedIO dev,
- base-4.17.0.0:Data.Typeable.Internal.Typeable dev) =>
+ base-4.18.0.0:Data.Typeable.Internal.Typeable dev) =>
dev
-> HandleType
-> GHC.IORef.IORef (GHC.IO.Buffer.Buffer GHC.Word.Word8)
@@ -23,7 +23,7 @@ T3323.hs:18:7: error: [GHC-39999]
-> Newline
-> Maybe (GHC.MVar.MVar Handle__)
-> Handle__,
- in a case alternative
+ in a record update
at T3323.hs:18:7-28
The type variable ‘dev0’ is ambiguous
• In a record update at field ‘haDevice’,
diff --git a/testsuite/tests/typecheck/should_run/Typeable1.stderr b/testsuite/tests/typecheck/should_run/Typeable1.stderr
index 17817ade2617..95adaf7b46ea 100644
--- a/testsuite/tests/typecheck/should_run/Typeable1.stderr
+++ b/testsuite/tests/typecheck/should_run/Typeable1.stderr
@@ -23,3 +23,9 @@ Typeable1.hs:22:5: error: [GHC-40564] [-Winaccessible-code (in -Wdefault), Werro
• Relevant bindings include
y :: TypeRep b2 (bound at Typeable1.hs:19:11)
x :: TypeRep a2 (bound at Typeable1.hs:19:9)
+
+Typeable1.hs:22:5: error: [GHC-94210] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns]
+ Pattern match has inaccessible right hand side
+ In a pattern binding in
+ a 'do' block:
+ App x y <- ...
diff --git a/utils/haddock b/utils/haddock
index 495c0655dcb9..b96241bad1cd 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 495c0655dcb9a9482054c5e48c0106f57f5ddb06
+Subproject commit b96241bad1cd59c65a89dab74e6cba114129e521
--
GitLab