Fix push_bang_into_newtype when the pattern match has no arguments

Correct behaviour of push_bang_into_newtype when the pattern match has
no arguments. A user can write

```
newtype T = T Int

f :: T -> ()
f !(T {}) = ()
```
in which case we have to push the bang inwards through the newtype in
order to achieve the desired strictness properties. This patch fixes
this special case where the pattern match has no arguments to push the
bang onto. We now make up a wildcard pattern which is wrapped in the
bang pattern.

```
f (T !_) = ()
```

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D3057

6 files changed, 47 insertions, 9 deletions

diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index f5c3cf5066..53b719a2c0 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -518,11 +518,16 @@ tidy_bang_pat v _ p@(SumPat {})    = 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
+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+                               , pat_args = args
+                               , pat_arg_tys = arg_tys })
+  -- Newtypes: push bang inwards (Trac #9844)
+  =
+    if isNewTyCon (dataConTyCon dc)
+      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })
+      else tidy1 v p  -- Data types: discard the bang
+    where
+      (ty:_) = dataConInstArgTys dc arg_tys
 
 -------------------
 -- Default case, leave the bang there:
@@ -542,18 +547,24 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args
 tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
 
 -------------------
-push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id
+push_bang_into_newtype_arg :: SrcSpan
+                           -> Type -- The type of the argument we are pushing
+                                   -- onto
+                           -> 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))
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
   = ASSERT( null args)
     PrefixCon [L l (BangPat arg)]
-push_bang_into_newtype_arg l (RecCon rf)
+push_bang_into_newtype_arg l _ty (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
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+  | HsRecFields { rec_flds = [] } <- rf
+  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
 {-
@@ -568,6 +579,9 @@ 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)
 
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
 
 \noindent
 {\bf Previous @matchTwiddled@ stuff:}
diff --git a/testsuite/tests/deSugar/should_compile/T13215.hs b/testsuite/tests/deSugar/should_compile/T13215.hs
new file mode 100644
index 0000000000..102bd902d3
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T13215.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE BangPatterns #-}
+module T13215 where
+
+newtype F = F Int
+
+foo !(F {}) = ()
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index d40f8eb05c..24b95a0112 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -95,3 +95,4 @@ test('T11414', normal, compile, [''])
 test('T12944', normal, compile, [''])
 test('T12950', normal, compile, [''])
 test('T13043', normal, compile, [''])
+test('T13215', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_run/T9844.hs b/testsuite/tests/deSugar/should_run/T9844.hs
index e06628ea90..851f628c20 100644
--- a/testsuite/tests/deSugar/should_run/T9844.hs
+++ b/testsuite/tests/deSugar/should_run/T9844.hs
@@ -12,6 +12,19 @@ f1 :: N -> Int
 f1 n = n `seq` case n of
   N _ -> 0
 
+f2 :: N -> Int
+f2 n = case n of
+  !(N {}) -> 0
+
+f3 :: N -> Int
+f3 n = n `seq` case n of
+  N {} -> 0
+
+
+
 main = do
   print $ f0 (trace "evaluated f0" (N 1))
   print $ f1 (trace "evaluated f1" (N 1))
+
+  print $ f2 (trace "evaluated f2" (N 1))
+  print $ f3 (trace "evaluated f3" (N 1))
diff --git a/testsuite/tests/deSugar/should_run/T9844.stderr b/testsuite/tests/deSugar/should_run/T9844.stderr
index c94d12f4f5..6da33db520 100644
--- a/testsuite/tests/deSugar/should_run/T9844.stderr
+++ b/testsuite/tests/deSugar/should_run/T9844.stderr
@@ -1,2 +1,4 @@
 evaluated f0
 evaluated f1
+evaluated f2
+evaluated f3
diff --git a/testsuite/tests/deSugar/should_run/T9844.stdout b/testsuite/tests/deSugar/should_run/T9844.stdout
index aa47d0d46d..44e0be8e35 100644
--- a/testsuite/tests/deSugar/should_run/T9844.stdout
+++ b/testsuite/tests/deSugar/should_run/T9844.stdout
@@ -1,2 +1,4 @@
 0
 0
+0
+0