Add bang patterns

[ghc-hetmet.git] / ghc / compiler / deSugar / Match.lhs

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index bd1a5c6..bbc37b3 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -10,7 +10,7 @@ module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
 
 import DynFlags        ( DynFlag(..), dopt )
 import HsSyn           
-import TcHsSyn         ( hsPatType )
+import TcHsSyn         ( mkVanillaTuplePat )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils       ( bindNonRec, exprType )
@@ -24,12 +24,12 @@ import MatchCon             ( matchConFamily )
 import MatchLit                ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
 import PrelInfo                ( pAT_ERROR_ID )
 import TcType          ( Type, tcTyConAppArgs )
-import Type            ( splitFunTysN )
-import TysWiredIn      ( consDataCon, mkTupleTy, mkListTy,
+import Type            ( splitFunTysN, mkTyVarTys )
+import TysWiredIn      ( consDataCon, mkListTy, unitTy,
                          tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes      ( Boxity(..) )
 import ListSetOps      ( runs )
-import SrcLoc          ( noSrcSpan, noLoc, unLoc, Located(..) )
+import SrcLoc          ( noLoc, unLoc, Located(..) )
 import Util             ( lengthExceeds, notNull )
 import Name            ( Name )
 import Outputable
@@ -410,6 +410,8 @@ tidy1 v wrap (VarPatOut var binds)
 tidy1 v wrap (AsPat (L _ var) pat)
   = tidy1 v (wrap . wrapBind var v) (unLoc pat)
 
+tidy1 v wrap (BangPat pat)
+  = tidy1 v (wrap . seqVar v) (unLoc pat)
 
 {- now, here we handle lazy patterns:
     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
@@ -434,7 +436,7 @@ tidy1 v wrap (LazyPat pat)
 tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
   = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
   where
-    tidy_ps = PrefixCon (tidy_con con pat_ty ps)
+    tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
 
 tidy1 v wrap (ListPat pats ty)
   = returnDs (wrap, unLoc list_ConPat)
@@ -452,18 +454,17 @@ tidy1 v wrap (PArrPat pats ty)
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 
-tidy1 v wrap (TuplePat pats boxity)
+tidy1 v wrap (TuplePat pats boxity ty)
   = returnDs (wrap, unLoc tuple_ConPat)
   where
     arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
-                                 (mkTupleTy boxity arity (map hsPatType pats))
+    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
 
 tidy1 v wrap (DictPat dicts methods)
   = case num_of_d_and_ms of
-       0 -> tidy1 v wrap (TuplePat [] Boxed) 
+       0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 
        1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
-       _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
+       _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
   where
     num_of_d_and_ms     = length dicts + length methods
     dict_and_method_pats = map nlVarPat (dicts ++ methods)
@@ -482,9 +483,9 @@ tidy1 v wrap non_interesting_pat
   = returnDs (wrap, non_interesting_pat)
 
 
-tidy_con data_con pat_ty (PrefixCon ps)   = ps
-tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con pat_ty (RecCon rpats)
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps)   = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
   | null rpats
   =    -- Special case for C {}, which can be used for 
        -- a constructor that isn't declared to have
@@ -492,14 +493,13 @@ tidy_con data_con pat_ty (RecCon rpats)
     map (noLoc . WildPat) con_arg_tys'
 
   | otherwise
-  = ASSERT( isVanillaDataCon data_con )
-       -- We're in a record case, so the data con must be vanilla
-       -- and hence no existentials to worry about
-    map mk_pat tagged_arg_tys
+  = map mk_pat tagged_arg_tys
   where
        -- Boring stuff to find the arg-tys of the constructor
        
-    inst_tys         = tcTyConAppArgs pat_ty   -- Newtypes must be opaque
+    inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty       -- Newtypes must be opaque
+            | otherwise                 = mkTyVarTys ex_tvs
+
     con_arg_tys'     = dataConInstOrigArgTys data_con inst_tys
     tagged_arg_tys   = con_arg_tys' `zip` dataConFieldLabels data_con