Fix push_bang_into_newtype when the pattern match has no arguments
authorMatthew Pickering <matthewtpickering@gmail.com>
Wed, 8 Feb 2017 02:35:32 +0000 (21:35 -0500)
committerBen Gamari <ben@smart-cactus.org>
Wed, 8 Feb 2017 03:39:14 +0000 (22:39 -0500)
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

compiler/deSugar/Match.hs
testsuite/tests/deSugar/should_compile/T13215.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_compile/all.T
testsuite/tests/deSugar/should_run/T9844.hs
testsuite/tests/deSugar/should_run/T9844.stderr
testsuite/tests/deSugar/should_run/T9844.stdout

index f5c3cf5..53b719a 100644 (file)
@@ -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 (file)
index 0000000..102bd90
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE BangPatterns #-}
+module T13215 where
+
+newtype F = F Int
+
+foo !(F {}) = ()
index d40f8eb..24b95a0 100644 (file)
@@ -95,3 +95,4 @@ test('T11414', normal, compile, [''])
 test('T12944', normal, compile, [''])
 test('T12950', normal, compile, [''])
 test('T13043', normal, compile, [''])
+test('T13215', normal, compile, [''])
index e06628e..851f628 100644 (file)
@@ -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))