X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=c0ad86d312d32668308e54f16ed15b5caf6e2d5e;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=bd1a5c6057abc7f077b33db0274ecd2ba538887a;hpb=8761b73561019d5514194fc8b0eee2b13f0e0ec9;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index bd1a5c6..c0ad86d 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -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 Type		( splitFunTysN, mkTyVarTys )
 import TysWiredIn	( consDataCon, mkTupleTy, mkListTy,
 			  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
@@ -434,7 +434,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)
@@ -482,9 +482,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 +492,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