From 69fa6a67ad99d425d184262ed726bf14c330a6b1 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Thu, 3 Apr 2014 13:30:59 +0100
Subject: [PATCH] Fix desguaring of bang patterns (Trac #8952)
A palpable bug, although one that will rarely bite
(cherry picked from commit 3671d0027329804a31a628a5bee355e0640a2045)
---
compiler/deSugar/Match.lhs | 10 +++++-----
testsuite/tests/deSugar/should_run/T8952.hs | 8 ++++++++
testsuite/tests/deSugar/should_run/T8952.stdout | 1 +
testsuite/tests/deSugar/should_run/all.T | 1 +
4 files changed, 15 insertions(+), 5 deletions(-)
create mode 100644 testsuite/tests/deSugar/should_run/T8952.hs
create mode 100644 testsuite/tests/deSugar/should_run/T8952.stdout
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 0433d873d55a..e0a5d4af0cc6 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -586,8 +586,6 @@ tidy1 _ non_interesting_pat
--------------------
tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
--- BangPatterns: Pattern matching is already strict in constructors,
--- tuples etc, so the last case strips off the bang for those patterns.
-- Discard bang around strict pattern
tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p
@@ -596,8 +594,7 @@ tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p
tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p
tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
--- Discard lazy/par/sig under a bang
-tidy_bang_pat v _ (LazyPat (L l p)) = tidy_bang_pat v l p
+-- Discard par/sig under a bang
tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
@@ -607,7 +604,10 @@ tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p)))
tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
-- Default case, leave the bang there:
--- VarPat, WildPat, ViewPat, NPat, NPlusKPat
+-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat
+-- For LazyPat, remember that it's semantically like a VarPat
+-- i.e. !(~p) is not like ~p, or p! (Trac #8952)
+
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
-- NB: SigPatIn, ConPatIn should not happen
\end{code}
diff --git a/testsuite/tests/deSugar/should_run/T8952.hs b/testsuite/tests/deSugar/should_run/T8952.hs
new file mode 100644
index 000000000000..42eeb250a9ba
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T8952.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+main = print (case Nothing of
+ !(~(Just x)) -> "ok"
+ Nothing -> "bad")
+
diff --git a/testsuite/tests/deSugar/should_run/T8952.stdout b/testsuite/tests/deSugar/should_run/T8952.stdout
new file mode 100644
index 000000000000..52c33a57c76f
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T8952.stdout
@@ -0,0 +1 @@
+"ok"
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 352a65239eac..233f6485d9c9 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -40,3 +40,4 @@ test('mc08', normal, compile_and_run, [''])
test('T5742', normal, compile_and_run, [''])
test('DsLambdaCase', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, [''])
test('DsMultiWayIf', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, [''])
+test('T8952', normal, compile_and_run, [''])
--
GitLab