[commit: ghc] master: Don't discard a bang on a newtype pattern (Trac #9844) (227a566)
git at git.haskell.org
git at git.haskell.org
Fri Nov 28 13:25:49 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/227a566851f19f5a720c4a86fdb1ff99117325c6/ghc
>---------------------------------------------------------------
commit 227a566851f19f5a720c4a86fdb1ff99117325c6
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Nov 28 11:28:15 2014 +0000
Don't discard a bang on a newtype pattern (Trac #9844)
We were wrongly simply dropping the bang, in tidy_bang_pat.
>---------------------------------------------------------------
227a566851f19f5a720c4a86fdb1ff99117325c6
compiler/deSugar/Match.lhs | 65 ++++++++++++++++++----
compiler/hsSyn/HsDecls.lhs | 3 +-
compiler/hsSyn/HsPat.lhs | 2 +-
testsuite/tests/deSugar/should_run/T9844.hs | 17 ++++++
testsuite/tests/deSugar/should_run/T9844.stderr | 2 +
.../should_run/T9844.stdout} | 0
testsuite/tests/deSugar/should_run/all.T | 1 +
7 files changed, 77 insertions(+), 13 deletions(-)
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 3bbb0ec..753c8fd 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 2cfa959..f4e5a46 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 32a0339..48c707b 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 0000000..e06628e
--- /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 0000000..c94d12f
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9844.stderr
@@ -0,0 +1,2 @@
+evaluated f0
+evaluated f1
diff --git a/testsuite/tests/simplCore/should_run/T3403.stdout b/testsuite/tests/deSugar/should_run/T9844.stdout
similarity index 100%
copy from testsuite/tests/simplCore/should_run/T3403.stdout
copy to testsuite/tests/deSugar/should_run/T9844.stdout
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 233f648..7e1618b 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, [''])
More information about the ghc-commits
mailing list