diff options
| -rw-r--r-- | compiler/deSugar/Match.hs | 32 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/T13215.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T9844.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T9844.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T9844.stdout | 2 |
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 |