Add bang patterns

[ghc-hetmet.git] / ghc / compiler / typecheck / TcPat.lhs

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 4244763..ce9e99b 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -88,7 +88,8 @@ tcPats ctxt pats tys res_ty thing_inside
   =  do        { let init_state = PS { pat_ctxt = ctxt, pat_reft = emptyTvSubst }
 
        ; (pats', ex_tvs, res) <- tc_lpats init_state pats tys $ \ pstate' ->
-                                 thing_inside (refineType (pat_reft pstate') res_ty)
+                                 refineEnvironment (pat_reft pstate') $
+                                 thing_inside (refineType (pat_reft pstate') res_ty)
 
        ; tcCheckExistentialPat ctxt pats' ex_tvs tys res_ty
 
@@ -273,6 +274,10 @@ tc_pat pstate (ParPat pat) pat_ty thing_inside
   = do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
        ; return (ParPat pat', tvs, res) }
 
+tc_pat pstate (BangPat pat) pat_ty thing_inside
+  = do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
+       ; return (BangPat pat', tvs, res) }
+
 -- There's a wrinkle with irrefuatable patterns, namely that we
 -- must not propagate type refinement from them.  For example
 --     data T a where { T1 :: Int -> T Int; ... }
@@ -336,7 +341,7 @@ tc_pat pstate (PArrPat pats _) pat_ty thing_inside
        ; ifM (null pats) (zapToMonotype pat_ty)        -- c.f. ExplicitPArr in TcExpr
        ; return (PArrPat pats' elt_ty, pats_tvs, res) }
 
-tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
+tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
   = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty
        ; (pats', pats_tvs, res) <- tc_lpats pstate pats arg_tys thing_inside
 
@@ -344,7 +349,7 @@ tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
        -- so that we can experiment with lazy tuple-matching.
        -- This is a pretty odd place to make the switch, but
        -- it was easy to do.
-       ; let unmangled_result = TuplePat pats' boxity
+       ; let unmangled_result = TuplePat pats' boxity pat_ty
              possibly_mangled_result
                | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
                | otherwise                               = unmangled_result
@@ -605,10 +610,10 @@ refineAlt pstate con pat_tvs arg_flags pat_res_tys ctxt_res_tys thing_inside
                                -- to refine the environment or pstate
          -> do  { traceTc trace_msg
                 ; thing_inside pstate pat_tvs' }
-         | otherwise           -- New bindings affect the context, so refine
-                               -- the environment and pstate
-         -> refineEnvironment (pat_reft pstate') $
-            do { traceTc trace_msg
+         | otherwise   -- New bindings affect the context, so pass down pstate'.  
+                       -- DO NOT refine the envt, because we might be inside a
+                       -- lazy pattern
+         -> do { traceTc trace_msg
                ; thing_inside pstate' pat_tvs' }
          where
             pat_tvs' = map (substTyVar new_subst) pat_tvs