X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=8d059a2671c87c7bbca9ec405ba40c48e4f0b942;hb=dabfa71f33eabc5a2d10959728f772aa016f1c84;hp=db63f509582b650678c865e08e99029e162dd527;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index db63f50..8d059a2 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -14,7 +14,7 @@ import DsLoop		-- partly to get dsBinds, partly to chk dsExpr
 import HsSyn		( HsExpr(..), HsLit(..), ArithSeqInfo(..),
 			  Match, Qual, HsBinds, Stmt, PolyType )
 import TcHsSyn		( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
-			  TypecheckedRecordBinds(..)
+			  TypecheckedRecordBinds(..), TypecheckedPat(..)
 			)
 import CoreSyn
 
@@ -22,7 +22,8 @@ import DsMonad
 import DsCCall		( dsCCall )
 import DsListComp	( dsListComp )
 import DsUtils		( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
-			  mkErrorAppDs, showForErr
+			  mkErrorAppDs, showForErr, EquationInfo,
+			  MatchResult
 			)
 import Match		( matchWrapper )
 
@@ -38,23 +39,23 @@ import Id		( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
 			)
 import Literal		( mkMachInt, Literal(..) )
 import MagicUFs		( MagicUnfoldingFun )
+import Name		( Name{--O only-} )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType )
-import PrelInfo		( mkTupleTy, unitTy, nilDataCon, consDataCon,
-			  charDataCon, charTy, rEC_CON_ERROR_ID,
-			  rEC_UPD_ERROR_ID
-			)
+import PrelVals		( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID )
 import Pretty		( ppShow, ppBesides, ppPStr, ppStr )
 import TyCon		( isDataTyCon, isNewTyCon )
 import Type		( splitSigmaTy, splitFunTy, typePrimRep,
-			  getAppDataTyCon, getAppTyCon, applyTy
+			  getAppDataTyConExpandingDicts, getAppTyCon, applyTy
+			)
+import TysWiredIn	( mkTupleTy, unitTy, nilDataCon, consDataCon,
+			  charDataCon, charTy
 			)
 import TyVar		( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
 import Usage		( UVar(..) )
 import Util		( zipEqual, pprError, panic, assertPanic )
 
 maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
-splitTyArgs = panic "DsExpr.splitTyArgs"
 
 mk_nil_con ty = mkCon nilDataCon [] [ty] []  -- micro utility...
 \end{code}
@@ -219,10 +220,9 @@ dsExpr (SectionL expr op)
     -- for the type of x, we need the type of op's 2nd argument
     let
 	x_ty  =	case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
-		case (splitTyArgs tau_ty)		  of {
+		case (splitFunTy tau_ty)		   of {
 		  ((_:arg2_ty:_), _) -> arg2_ty;
-		  _ -> panic "dsExpr:SectionL:arg 2 ty"
-		}}
+		  _ -> panic "dsExpr:SectionL:arg 2 ty" }}
     in
     newSysLocalDs x_ty		`thenDs` \ x_id ->
     returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id)) 
@@ -236,10 +236,9 @@ dsExpr (SectionR op expr)
     -- for the type of x, we need the type of op's 1st argument
     let
 	x_ty  =	case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
-		case (splitTyArgs tau_ty)		  of {
+		case (splitFunTy tau_ty)		   of {
 		  ((arg1_ty:_), _) -> arg1_ty;
-		  _ -> panic "dsExpr:SectionR:arg 1 ty"
-		}}
+		  _ -> panic "dsExpr:SectionR:arg 1 ty" }}
     in
     newSysLocalDs x_ty		`thenDs` \ x_id ->
     returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
@@ -384,7 +383,7 @@ dsExpr (RecordCon con_expr rbinds)
 		 	    dsExpr rhs
 	      []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
     in
-    mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args ->
+    mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args ->
     mkAppDs con_expr' [] con_args
   where
 	-- "con_expr'" is simply an application of the constructor Id
@@ -423,7 +422,8 @@ dsExpr (RecordUpdOut record_expr dicts rbinds)
     dsRbinds rbinds		$ \ rbinds' ->
     let
 	record_ty		= coreExprType record_expr'
-	(tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty
+	(tycon, inst_tys, cons) = _trace "DsExpr.getAppDataTyConExpandingDicts" $
+				  getAppDataTyConExpandingDicts record_ty
 	cons_to_upd  	 	= filter has_all_fields cons
 
 	-- initial_args are passed to every constructor
@@ -439,7 +439,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds)
 	mk_alt con
 	  = newSysLocalsDs (dataConArgTys con inst_tys)	`thenDs` \ arg_ids ->
 	    let 
-		val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids)
+		val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids)
 	    in
 	    returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)