diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index da7b2b23983fc673f4519f7b6d2f116dd237b81f..3fcb4ef1a15e6ee6db4496c8e73a6d8253d247b4 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 809278d4743162340b520ccb1ac22c8193f75782..afa7821031761eb942dc714f0d5440454b6a6ce1 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 cc757a94e3c3d306237480cefb844017f826c521..734ad2589e9123564b67244d9a7e924db9ddc1aa 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 4fdc6c120fd70bc462e473556e100e493eaa5795..cc7222f447c5566b9eb9264cf4d72dca3ee355e6 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 8f118abb137675422a8a765827e94b98fbcc55e5..608bfa28544780b186d2f1d1b6fbca1f40b7ba8a 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 fde37370acc2b104f9efedf9448eea1d446c1bfe..be9347e0e2c8ddb5d20a29a834e77ec2497d3828 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 6ae6716685282c8a18ddf0b768288f8ab9d986b3..8a24b00a590d3f530a303880f90fd1db163863e6 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 d6986de6fa4071f20ca048883d01ecf8622a2fdf..6be944d1242e274d141a31ed48412d82c7c109a0 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 3e969e922dd968f1347c1f73de073f57a0297e86..5a55463d4c6f9825c32df0deaa310930f39aa0a3 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 03b212d0eef929add7e1325ac3489bb488c7f514..264f49e0ebca50b2104b0fc58f24eefe8f1a0667 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 2740e5dbec473d2bd604efe8e7e3a62d64545125..6ba19bb95892004e6cd7a2363cc44f3f9019ea46 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 cd5bf9ddcd5a6cd6a87c2a82d78855a4337c5ec1..aa72db0aed57c677dd2490191be9467ddc5a3a2f 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 40ac5907f434d4c78e171adcde0a0ba2f5f22719..b39862821a5041a8d4665df023997e91b84f1f00 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 85484cbb4e5458501446e32129f5036378e7d61a..0f696d6b28d277373f91a4af7e4384c375c1e53b 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 3a7b8452aa532cddd50aad7e4ad52277ed3f159f..a2578641ca909c395eb886cc247dfe1579c68a7e 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 68b73d2b4830dea4fcd930907570c78d6751b3e9..2965d290126ea77bb15f55264a278c35cf96e97d 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 81fb803e51fc0bb7693d1b5b4c811653209650c6..1b504973729640dfb3a15e0b9d0bf4294a984e27 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 62cb85dee294fefcf9dcd150c1a85a20e587883f..c3b74ee671008d7021f2149df7491dbd92cbcf3f 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 2953f1281f1be4fd4b5084eb53966e998679c6e0..faba45ca67e52fe6bc234257e93eeef9114e8029 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 853b983e82ed4706641647052fc611511a5f0421..6a513213893064eee56ce4ba88f1142669b04603 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 f0eddac776f1e295157f8efa23b715622dbc49ef..308dececf1cd139d9f703dbeea51851457748215 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 25e9ebd8ca599efb472270a784e1de204bee389c..c34e9159cb588de80c8a765cd96546848e474bc9 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 9c9d356a22d2e059b0bd116c87ace777cd738824..767db8a7f7040dce4ce7749d8b7fd7bbd43ecfeb 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 837dff6bb90ffdb0175e39ed8997f8d95a765c68..807348170c48f5658247c4002b7a4f501568b10b 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 ecc8bca4a3a3d7b02fccff41298bc5587c889d0e..a9bcbbe8edb21112ca8b97b002d15727bca9e937 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 239b293a91502654d61f722cc8d75e45801f4e50..4eba350def76de6a62002bbed597b85d02f7379f 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 6fd1d1d6cef3702783b07f5dc68f72f6a5566950..e743276e0ee83c84d9bbc3d17ba176dee306cffe 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 60eae1442595e2736b3128d637658027f173c910..918b39eb90b636f9d198d1546b823724cfc569b3 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 ba301f227e0b10eb4a9194b3a3dc6f6e6819d073..883277d7ad22c95e598e03cfe4750b7350bd9433 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 8ac92460007e3e31e09f247d62f392b7eb415f8b..1b67ec1d9d54b73721992b7ff8dfc47c90126af9 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 db517a35a96a2ab8d0295783f5ba04da7b472d99..80a8afebde05e6ba0d851e2581c9dc3449cbb691 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 0000000000000000000000000000000000000000..768cec3b4a535a9b82828b7e99b7c28f4ef3705d
--- /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 0000000000000000000000000000000000000000..c7de2a511f8c2ece817c48191ed92bd4830d992a
--- /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 810c8acbd78c828dc7648558a65a998fbe7ac071..f9470110a6475140db573b27e9362796399f8cde 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 cb2d52f21df07bf4d512b3b7d6ec8e443d047016..ec0a41b97300aae2b7116357e3d1d1e124618fa2 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 17817ade2617224e70ecfe573b8f8e5f760c0390..95adaf7b46ea200ac45750e2f521dc68468c56dd 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 495c0655dcb9a9482054c5e48c0106f57f5ddb06..b96241bad1cd59c65a89dab74e6cba114129e521 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 495c0655dcb9a9482054c5e48c0106f57f5ddb06
+Subproject commit b96241bad1cd59c65a89dab74e6cba114129e521