X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=bbc37b33b8012cdea7f06cc32e463c95f68e1569;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=bd1a5c6057abc7f077b33db0274ecd2ba538887a;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index bd1a5c6..bbc37b3 100644
--- 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