summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs33
-rw-r--r--testsuite/tests/pmcheck/should_compile/T21761.hs19
-rw-r--r--testsuite/tests/pmcheck/should_compile/T21761.stderr24
-rw-r--r--testsuite/tests/pmcheck/should_compile/all.T1
4 files changed, 75 insertions, 2 deletions
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 81d6de64a9..9b02e50c29 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -38,7 +38,7 @@ import GHC.Core.Coercion
import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
-import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar)
+import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import GHC.Core.TyCo.Rep
@@ -334,7 +334,10 @@ desugarMatches vars matches =
-- Desugar a single match
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
- pats' <- concat <$> zipWithM desugarLPat vars pats
+ dflags <- getDynFlags
+ -- decideBangHood: See Note [Desugaring -XStrict matches in Pmc]
+ let banged_pats = map (decideBangHood dflags) pats
+ pats' <- concat <$> zipWithM desugarLPat vars banged_pats
grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
-- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }
@@ -533,4 +536,30 @@ the whole point.
The place to store the 'PmLet' guards for @where@ clauses (which are per
'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of
@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.
+
+Note [Desugaring -XStrict matches in Pmc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#21761)
+
+ {-# LANGUAGE Strict #-}
+ idV :: Void -> Void
+ idV v = v
+
+Without -XStrict, we would not warn here. But with -XStrict, there is an
+implicit bang on `v` and we should give an inaccessible warning for the RHS.
+The way we account for that is by calling `decideBangHood` on patterns
+in a `Match`, which inserts the implicit bang.
+
+Making the call here actually seems redundant with the call to `decideBangHood`
+in `GHC.HsToCore.Match.matchWrapper`, which does it *after* it calls the
+pattern-match checker on the Match's patterns. It would be great if we could expect
+`matchWrapper` to pass the bang-adorned `Match` to the pattern-match checker,
+but sadly then we get worse warning messages which would print `idV` as if the
+user *had* written a bang:
+
+ Pattern match has inaccessible right hand side
+- In an equation for ‘idV’: idV v = ...
++ In an equation for ‘idV’: idV !v = ...
+
+So we live with the duplication.
-}
diff --git a/testsuite/tests/pmcheck/should_compile/T21761.hs b/testsuite/tests/pmcheck/should_compile/T21761.hs
new file mode 100644
index 0000000000..9298366f39
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T21761.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
+
+module T21761 where
+
+data Void
+
+idV :: Void -> Void
+idV v = v
+
+idV' :: Void -> Void
+idV' v = case v of w -> w
+
+bangIdV :: Void -> Void
+bangIdV !v = v
+
+bangIdV' :: Void -> Void
+bangIdV' v = case v of !w -> w
diff --git a/testsuite/tests/pmcheck/should_compile/T21761.stderr b/testsuite/tests/pmcheck/should_compile/T21761.stderr
new file mode 100644
index 0000000000..bae05e270a
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T21761.stderr
@@ -0,0 +1,24 @@
+
+T21761.hs:10:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘idV’: idV v = ...
+
+T21761.hs:13:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘idV'’: idV' v = ...
+
+T21761.hs:13:20: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In a case alternative: w -> ...
+
+T21761.hs:16:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘bangIdV’: bangIdV !v = ...
+
+T21761.hs:19:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In an equation for ‘bangIdV'’: bangIdV' v = ...
+
+T21761.hs:19:24: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+ Pattern match has inaccessible right hand side
+ In a case alternative: !w -> ...
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 6415e83dab..0980dbb157 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -157,3 +157,4 @@ test('EmptyCase008', [], compile, [overlapping_incomplete])
test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
test('T19271', [], compile, [overlapping_incomplete])
+test('T21761', [], compile, [overlapping_incomplete])