Don't discard a bang on a newtype pattern (Trac #9844)

We were wrongly simply dropping the bang, in tidy_bang_pat.

7 files changed, 79 insertions, 13 deletions

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 3bbb0ecd32..753c8fda52 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -35,6 +35,7 @@ import PatSyn
 import MatchCon
 import MatchLit
 import Type
+import TyCon( isNewTyCon )
 import TysWiredIn
 import ListSetOps
 import SrcLoc
@@ -292,9 +293,9 @@ match [] ty eqns
 
 match vars@(v:_) ty eqns    -- Eqns *can* be empty
   = do  { dflags <- getDynFlags
-        ;       -- Tidy the first pattern, generating
+                -- Tidy the first pattern, generating
                 -- auxiliary bindings if necessary
-          (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
 
                 -- Group the equations and match each group in turn
         ; let grouped = groupEquations dflags tidy_eqns
@@ -588,13 +589,6 @@ tidy1 _ non_interesting_pat
 --------------------
 tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
 
--- Discard bang around strict pattern
-tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
-tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
-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 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
@@ -604,15 +598,64 @@ tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
 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)
 
+-- Discard bang around strict pattern
+tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
+tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
+tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
+tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
+
+-- Data/newtype constructors
+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args })
+  | isNewTyCon (dataConTyCon dc)   -- Newtypes: push bang inwards (Trac #9844)
+  = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args })
+  | otherwise                      -- Data types: discard the bang
+  = tidy1 v p
+
+-------------------
 -- Default case, leave the bang there:
--- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat
+--    VarPat,
+--    LazyPat,
+--    WildPat,
+--    ViewPat,
+--    pattern synonyms (ConPatOut with PatSynCon)
+--    NPat,
+--    NPlusKPat
+--
 -- For LazyPat, remember that it's semantically like a VarPat
 --  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
+--
+-- NB: SigPatIn, ConPatIn should not happen
 
 tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
-  -- NB: SigPatIn, ConPatIn should not happen
+
+-------------------
+push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id
+-- See Note [Bang patterns and newtypes]
+-- We are transforming   !(N p)   into   (N !p)
+push_bang_into_newtype_arg l (PrefixCon (arg:args))
+  = ASSERT( null args) 
+    PrefixCon [L l (BangPat arg)]
+push_bang_into_newtype_arg l (RecCon rf)
+  | HsRecFields { rec_flds = L lf fld : flds } <- rf
+  , HsRecField { hsRecFieldArg = arg } <- fld
+  = ASSERT( null flds)
+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
+push_bang_into_newtype_arg _ cd
+  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 \end{code}
 
+Note [Bang patterns and newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the pattern  !(Just pat)  we can discard the bang, because
+the pattern is strict anyway. But for !(N pat), where
+  newtype NT = N Int
+we definitely can't discard the bang.  Trac #9844.
+
+So what we do is to push the bang inwards, in the hope that it will
+get discarded there.  So we transform
+   !(N pat)   into    (N !pat)
+
+
 \noindent
 {\bf Previous @matchTwiddled@ stuff:}
 
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 2cfa959925..f4e5a46bc5 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -990,7 +990,8 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
 pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
   = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
         -- In GADT syntax we don't allow infix constructors
-        -- but the renamer puts them in this form (Note [Infix GADT constructors] in RnSource)
+        -- so if we ever trip over one (albeit I can't see how that
+        -- can happen) print it like a prefix one
 
 ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
 ppr_con_names [x] = ppr x
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 32a03391db..48c707b51f 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -26,7 +26,7 @@ module HsPat (
         isStrictLPat, hsPatNeedsParens,
         isIrrefutableHsPat,
 
-        pprParendLPat
+        pprParendLPat, pprConArgs
     ) where
 
 import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
diff --git a/testsuite/tests/deSugar/should_run/T9844.hs b/testsuite/tests/deSugar/should_run/T9844.hs
new file mode 100644
index 0000000000..e06628ea90
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9844.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+import Debug.Trace
+
+newtype N = N Int
+
+f0 :: N -> Int
+f0 n = case n of
+  !(N _) -> 0
+
+f1 :: N -> Int
+f1 n = n `seq` case n of
+  N _ -> 0
+
+main = do
+  print $ f0 (trace "evaluated f0" (N 1))
+  print $ f1 (trace "evaluated f1" (N 1))
diff --git a/testsuite/tests/deSugar/should_run/T9844.stderr b/testsuite/tests/deSugar/should_run/T9844.stderr
new file mode 100644
index 0000000000..c94d12f4f5
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9844.stderr
@@ -0,0 +1,2 @@
+evaluated f0
+evaluated f1
diff --git a/testsuite/tests/deSugar/should_run/T9844.stdout b/testsuite/tests/deSugar/should_run/T9844.stdout
new file mode 100644
index 0000000000..aa47d0d46d
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9844.stdout
@@ -0,0 +1,2 @@
+0
+0
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 233f6485d9..7e1618b7e1 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -41,3 +41,4 @@ 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, [''])
+test('T9844', normal, compile_and_run, [''])