diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-04-03 13:30:59 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-04-03 13:35:31 +0100 |
| commit | 3671d0027329804a31a628a5bee355e0640a2045 (patch) | |
| tree | 2c5f6f9e546ff77d09474b4c539aac3b92bd9f56 | |
| parent | 791f4fa24dd6929ab2e55c9f8b870d8078337427 (diff) | |
| download | haskell-3671d0027329804a31a628a5bee355e0640a2045.tar.gz | |
Fix desguaring of bang patterns (Trac #8952)
A palpable bug, although one that will rarely bite
| -rw-r--r-- | compiler/deSugar/Match.lhs | 10 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T8952.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T8952.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/all.T | 1 |
4 files changed, 15 insertions, 5 deletions
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 0433d873d5..e0a5d4af0c 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 0000000000..42eeb250a9 --- /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 0000000000..52c33a57c7 --- /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 352a65239e..233f6485d9 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, ['']) |