X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=82c5a8ea8f46121c165e69112e3ea8af7dfbffca;hb=dabfa71f33eabc5a2d10959728f772aa016f1c84;hp=fd4bb5dfcef84b1d76f589a3da5435202610b554;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index fd4bb5d..82c5a8e 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -12,7 +12,7 @@ import Ubiq
 import DsLoop		-- here for paranoia-checking reasons
 			-- and to break dsExpr/dsBinds-ish loop
 
-import HsSyn
+import HsSyn		hiding ( collectBinders{-also from CoreSyn-} )
 import TcHsSyn		( TypecheckedPat(..), TypecheckedMatch(..),
 			  TypecheckedHsBinds(..), TypecheckedHsExpr(..)	)
 import DsHsSyn		( outPatType, collectTypedPatBinders )
@@ -32,19 +32,20 @@ import Id		( idType, mkTupleCon, dataConSig,
 			)
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
-			  charTy, charDataCon, intTy, intDataCon,
-			  floatTy, floatDataCon, doubleTy, doubleDataCon,
-			  integerTy, intPrimTy, charPrimTy,
-			  floatPrimTy, doublePrimTy, stringTy,
-			  addrTy, addrPrimTy, addrDataCon,
-			  wordTy, wordPrimTy, wordDataCon,
-			  pAT_ERROR_ID
-			)
-import Type		( isPrimType, eqTy, getAppDataTyCon,
+import PrelVals		( pAT_ERROR_ID )
+import Type		( isPrimType, eqTy, getAppDataTyConExpandingDicts,
 			  instantiateTauTy
 			)
 import TyVar		( GenTyVar{-instance Eq-} )
+import TysPrim		( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
+			  addrPrimTy, wordPrimTy
+			)
+import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+			  charTy, charDataCon, intTy, intDataCon,
+			  floatTy, floatDataCon, doubleTy,
+			  doubleDataCon, integerTy, stringTy, addrTy,
+			  addrDataCon, wordTy, wordDataCon
+			)
 import Unique		( Unique{-instance Eq-} )
 import Util		( panic, pprPanic, assertPanic )
 \end{code}
@@ -334,7 +335,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
     pats 	     = map mk_pat tagged_arg_tys
 
 	-- Boring stuff to find the arg-tys of the constructor
-    (_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty
+    (_, inst_tys, _) = {-_trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
     con_arg_tys'     = dataConArgTys con_id inst_tys 
     tagged_arg_tys   = con_arg_tys' `zip` allFieldLabelTags
 
@@ -513,21 +514,24 @@ matchUnmixedEqns :: [Id]
 matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
 
 matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
-  | unfailablePats column_1_pats	-- Could check just one; we know they've been tidied, unmixed;
-					-- this way is (arguably) a sanity-check
-  =	-- Real true variables, just like in matchVar, SLPJ p 94
+  | unfailablePat first_pat
+  = ASSERT( unfailablePats column_1_pats )	-- Sanity check
+  	-- Real true variables, just like in matchVar, SLPJ p 94
     match vars remaining_eqns_info remaining_shadows
 
-  | patsAreAllCons column_1_pats	-- ToDo: maybe check just one...
-  = matchConFamily all_vars eqns_info shadows
+  | isConPat first_pat
+  = ASSERT( patsAreAllCons column_1_pats )
+    matchConFamily all_vars eqns_info shadows
 
-  | patsAreAllLits column_1_pats	-- ToDo: maybe check just one...
-  =	-- see notes in MatchLiteral
+  | isLitPat first_pat
+  = ASSERT( patsAreAllLits column_1_pats )
+  	-- see notes in MatchLiteral
 	-- not worried about the same literal more than once in a column
 	-- (ToDo: sort this out later)
     matchLiterals all_vars eqns_info shadows
 
   where
+    first_pat		= head column_1_pats
     column_1_pats 	= [pat                       | EqnInfo (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
     remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,