From 10a1a6c635dcd8b3db5ef8bb7195717a75ebb935 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sebastian.graf@kit.edu>
Date: Fri, 1 Dec 2023 11:30:55 +0100
Subject: [PATCH] Pmc: Fix SrcLoc and warning for incomplete irrefutable pats
(#24234)
Before, the source location would point at the surrounding function definition,
causing the confusion in #24234.
I also took the opportunity to introduce a new `LazyPatCtx :: HsMatchContext _`
to make the warning message say "irrefutable pattern" instead of "pattern
binding".
---
compiler/GHC/Hs/Expr.hs | 33 +++++++++++--------
compiler/GHC/HsToCore/Binds.hs | 2 +-
compiler/GHC/HsToCore/Match.hs | 6 ++--
compiler/GHC/HsToCore/Pmc.hs | 1 +
compiler/GHC/HsToCore/Pmc/Utils.hs | 1 +
compiler/GHC/HsToCore/Utils.hs | 22 ++++++++-----
compiler/Language/Haskell/Syntax/Expr.hs | 1 +
testsuite/tests/ado/T22483.stderr | 4 +--
.../tests/deSugar/should_run/dsrun008.stderr | 2 +-
.../tests/pmcheck/should_compile/T24234.hs | 7 ++++
.../pmcheck/should_compile/T24234.stderr | 8 +++++
testsuite/tests/pmcheck/should_compile/all.T | 3 +-
12 files changed, 60 insertions(+), 30 deletions(-)
create mode 100644 testsuite/tests/pmcheck/should_compile/T24234.hs
create mode 100644 testsuite/tests/pmcheck/should_compile/T24234.stderr
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index f0c07b634cf8..1ed31c848fa4 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1469,6 +1469,21 @@ pprGRHS ctxt (GRHS _ guards body)
pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
+matchSeparator :: HsMatchContext p -> SDoc
+matchSeparator FunRhs{} = text "="
+matchSeparator CaseAlt = text "->"
+matchSeparator LamAlt{} = text "->"
+matchSeparator IfAlt = text "->"
+matchSeparator ArrowMatchCtxt{} = text "->"
+matchSeparator PatBindRhs = text "="
+matchSeparator PatBindGuards = text "="
+matchSeparator StmtCtxt{} = text "<-"
+matchSeparator RecUpd = text "=" -- This can be printed by the pattern
+matchSeparator PatSyn = text "<-" -- match checker trace
+matchSeparator LazyPatCtx = panic "unused"
+matchSeparator ThPatSplice = panic "unused"
+matchSeparator ThPatQuote = panic "unused"
+
instance Outputable GrhsAnn where
ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s
@@ -1931,6 +1946,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
ppr ThPatSplice = text "ThPatSplice"
ppr ThPatQuote = text "ThPatQuote"
ppr PatSyn = text "PatSyn"
+ ppr LazyPatCtx = text "LazyPatCtx"
instance Outputable HsLamVariant where
ppr = text . \case
@@ -1981,6 +1997,7 @@ matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (Stm
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
+matchContextErrString LazyPatCtx = text "irrefutable pattern"
matchArrowContextErrString :: HsArrowMatchContext -> SDoc
matchArrowContextErrString ProcExpr = text "proc"
@@ -2022,20 +2039,6 @@ pprStmtInCtxt ctxt stmt
, trS_form = form }) = pprTransStmt by using form
ppr_stmt stmt = pprStmt stmt
-matchSeparator :: HsMatchContext p -> SDoc
-matchSeparator FunRhs{} = text "="
-matchSeparator CaseAlt = text "->"
-matchSeparator LamAlt{} = text "->"
-matchSeparator IfAlt = text "->"
-matchSeparator ArrowMatchCtxt{} = text "->"
-matchSeparator PatBindRhs = text "="
-matchSeparator PatBindGuards = text "="
-matchSeparator StmtCtxt{} = text "<-"
-matchSeparator RecUpd = text "=" -- This can be printed by the pattern
-matchSeparator PatSyn = text "<-" -- match checker trace
-matchSeparator ThPatSplice = panic "unused"
-matchSeparator ThPatQuote = panic "unused"
-
pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContext ctxt
@@ -2045,6 +2048,7 @@ pprMatchContext ctxt
want_an (FunRhs {}) = True -- Use "an" in front
want_an (ArrowMatchCtxt ProcExpr) = True
want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True
+ want_an LazyPatCtx = True
want_an _ = False
pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
@@ -2065,6 +2069,7 @@ pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c
pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
$$ pprAStmtContext ctxt
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
+pprMatchContextNoun LazyPatCtx = text "irrefutable pattern"
pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index e173360f3c8a..024f9377c7ea 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -237,7 +237,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
; body_expr <- dsGuarded grhss ty rhss_nablas
; let body' = mkOptTickBox rhs_tick body_expr
pat' = decideBangHood dflags pat
- ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
+ ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body'
-- We silently ignore inline pragmas; no makeCorePair
-- Not so cool, but really doesn't matter
; let force_var' = if isBangedLPat pat'
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 9c26bdcf3367..05e5becb53c2 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -451,13 +451,13 @@ tidy1 v _ (LazyPat _ pat)
-- This is a convenient place to check for unlifted types under a lazy pattern.
-- Doing this check during type-checking is unsatisfactory because we may
-- not fully know the zonked types yet. We sure do here.
- = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
+ = putSrcSpanDs (getLocA pat) $
+ do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
-- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType
; unless (null unlifted_bndrs) $
- putSrcSpanDs (getLocA pat) $
diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
- ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+ ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index 9dc22fee6ebb..d0a247c3791c 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -118,6 +118,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
then id
else discardWarningsDs
want_pmc PatBindRhs = True
+ want_pmc LazyPatCtx = True
want_pmc (StmtCtxt stmt_ctxt) =
case stmt_ctxt of
PatGuard {} -> False
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index 96cf9a7d6ee5..ed8d3f2a8afd 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -91,6 +91,7 @@ exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag ThPatSplice = Nothing
exhaustiveWarningFlag PatSyn = Nothing
exhaustiveWarningFlag ThPatQuote = Nothing
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 4ec5fa1838d8..248e408b7250 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -597,7 +597,12 @@ mkSelectorBinds is used to desugar a pattern binding {p = e},
in a binding group:
let { ...; p = e; ... } in body
where p binds x,y (this list of binders can be empty).
-There are two cases.
+
+mkSelectorBinds is also used to desugar irrefutable patterns, which is the
+pattern syntax equivalent of a lazy pattern binding:
+ f (~(a:as)) = rhs ==> f x = let (a:as) = x in rhs
+
+There are three cases.
------ Special case (A) -------
For a pattern that is just a variable,
@@ -634,7 +639,7 @@ There are two cases.
Note that (C) /includes/ the situation where
* The pattern binds exactly one variable
- let !(Just (Just x) = e in body
+ let !(Just (Just x)) = e in body
==>
let { t = case e of Just (Just v) -> Solo v
; v = case t of Solo v -> v }
@@ -726,15 +731,16 @@ work out well:
-}
-- Remark: pattern selectors only occur in unrestricted patterns so we are free
-- to select Many as the multiplicity of every let-expression introduced.
-mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
- -> LPat GhcTc -- ^ The pattern
- -> CoreExpr -- ^ Expression to which the pattern is bound
+mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
+ -> LPat GhcTc -- ^ The pattern
+ -> HsMatchContext GhcTc -- ^ Where the pattern occurs
+ -> CoreExpr -- ^ Expression to which the pattern is bound
-> DsM (Id,[(Id,CoreExpr)])
-- ^ Id the rhs is bound to, for desugaring strict
-- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds")
-- and all the desugared binds
-mkSelectorBinds ticks pat val_expr
+mkSelectorBinds ticks pat ctx val_expr
| L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
@@ -745,7 +751,7 @@ mkSelectorBinds ticks pat val_expr
; let mk_bind tick bndr_var
-- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
-- Remember, 'pat' binds 'bv'
- = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+ = do { rhs_expr <- matchSimply (Var val_var) ctx pat'
(Var bndr_var)
(Var bndr_var) -- Neat hack
-- Neat hack: since 'pat' can't fail, the
@@ -760,7 +766,7 @@ mkSelectorBinds ticks pat val_expr
| otherwise -- General case (C)
= do { tuple_var <- newSysLocalDs ManyTy tuple_ty
; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
- ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+ ; tuple_expr <- matchSimply val_expr ctx pat
local_tuple error_expr
; let mk_tup_bind tick binder
= (binder, mkOptTickBox tick $
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index e1f7b9f33a94..6b6a4dc348fa 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1576,6 +1576,7 @@ data HsMatchContext p
| ThPatSplice -- ^A Template Haskell pattern splice
| ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
| PatSyn -- ^A pattern synonym declaration
+ | LazyPatCtx -- ^An irrefutable pattern
{-
Note [mc_fun field of FunRhs]
diff --git a/testsuite/tests/ado/T22483.stderr b/testsuite/tests/ado/T22483.stderr
index 2428c31ea92f..8c2e8e3f8627 100644
--- a/testsuite/tests/ado/T22483.stderr
+++ b/testsuite/tests/ado/T22483.stderr
@@ -2,7 +2,7 @@
T22483.hs:1:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)]
Top-level binding with no type signature: main :: IO ()
-T22483.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
+T22483.hs:4:4: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
Pattern match(es) are non-exhaustive
- In a pattern binding:
+ In an irrefutable pattern:
Patterns of type ‘Maybe ()’ not matched: Nothing
diff --git a/testsuite/tests/deSugar/should_run/dsrun008.stderr b/testsuite/tests/deSugar/should_run/dsrun008.stderr
index cef2458b1ef2..b40f7458a8e8 100644
--- a/testsuite/tests/deSugar/should_run/dsrun008.stderr
+++ b/testsuite/tests/deSugar/should_run/dsrun008.stderr
@@ -1,2 +1,2 @@
-dsrun008: dsrun008.hs:2:15-42: Non-exhaustive patterns in (2, x)
+dsrun008: dsrun008.hs:2:32-36: Non-exhaustive patterns in (2, x)
diff --git a/testsuite/tests/pmcheck/should_compile/T24234.hs b/testsuite/tests/pmcheck/should_compile/T24234.hs
new file mode 100644
index 000000000000..03f28dcc4b46
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T24234.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -W #-}
+
+module T24234 where
+
+foo :: [()] -> ()
+foo ~(a:_) = a
+foo _ = ()
diff --git a/testsuite/tests/pmcheck/should_compile/T24234.stderr b/testsuite/tests/pmcheck/should_compile/T24234.stderr
new file mode 100644
index 000000000000..ca980c5e1f07
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T24234.stderr
@@ -0,0 +1,8 @@
+
+T24234.hs:6:6: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)]
+ Pattern match(es) are non-exhaustive
+ In an irrefutable pattern: Patterns of type ‘[()]’ not matched: []
+
+T24234.hs:7:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match is redundant
+ In an equation for ‘foo’: foo _ = ...
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 75d11e1641ac..a7c8a194ea81 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -120,6 +120,7 @@ test('T19271', [], compile, [overlapping_incomplete])
test('T21761', [], compile, [overlapping_incomplete])
test('T22964', [], compile, [overlapping_incomplete])
test('T23445', [], compile, [overlapping_incomplete])
+test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns'])
# Series (inspired) by Luke Maranget
@@ -166,4 +167,4 @@ test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
-test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
\ No newline at end of file
+test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
--
GitLab