Commit 227a5668 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

We were wrongly simply dropping the bang, in tidy_bang_pat.
parent 7dd4c12c
......@@ -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:}
......
......@@ -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
......
......@@ -26,7 +26,7 @@ module HsPat (
isStrictLPat, hsPatNeedsParens,
isIrrefutableHsPat,
pprParendLPat
pprParendLPat, pprConArgs
) where
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
......
{-# 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))
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment