X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=66472b77a14c1e873a01dd7d4bd07090ea4ee35a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=528607cf8191d35efc49f473b26315962cd00f2e;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 528607c..66472b7 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -13,7 +13,7 @@ module DsUtils (
 
 	combineGRHSMatchResults,
 	combineMatchResults,
-	dsExprToAtom,
+	dsExprToAtom, SYN_IE(DsCoreArg),
 	mkCoAlgCaseMatchResult,
 	mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
 	mkCoLetsMatchResult,
@@ -31,8 +31,8 @@ IMP_Ubiq()
 IMPORT_DELOOPER(DsLoop)		( match, matchSimply )
 
 import HsSyn		( HsExpr(..), OutPat(..), HsLit(..),
-			  Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
-import TcHsSyn		( TypecheckedPat(..) )
+			  Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+import TcHsSyn		( SYN_IE(TypecheckedPat) )
 import DsHsSyn		( outPatType )
 import CoreSyn
 
@@ -43,22 +43,22 @@ import PprStyle		( PprStyle(..) )
 import PrelVals		( iRREFUT_PAT_ERROR_ID, voidId )
 import Pretty		( ppShow )
 import Id		( idType, dataConArgTys, mkTupleCon,
-			  pprId{-ToDo:rm-},
-			  DataCon(..), DictVar(..), Id(..), GenId )
+--			  pprId{-ToDo:rm-},
+			  SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
 import Literal		( Literal(..) )
 import TyCon		( mkTupleTyCon, isNewTyCon, tyConDataCons )
-import Type		( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
+import Type		( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
 			  mkTheta, isUnboxedType, applyTyCon, getAppTyCon
 			)
-import TysWiredIn	( voidTy )
-import UniqSet		( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
-import Util		( panic, assertPanic, pprTrace{-ToDo:rm-} )
-import PprCore{-ToDo:rm-}
+import TysPrim		( voidTy )
+import UniqSet		( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
+import Util		( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Usage		( SYN_IE(UVar) )
+--import PprCore{-ToDo:rm-}
 --import PprType--ToDo:rm
-import Pretty--ToDo:rm
-import TyVar--ToDo:rm
-import Unique--ToDo:rm
-import Usage--ToDo:rm
+--import Pretty--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm
 \end{code}
 
 %************************************************************************
@@ -240,15 +240,19 @@ combineGRHSMatchResults match_result1 match_result2
 %************************************************************************
 
 \begin{code}
-dsExprToAtom :: CoreExpr		    -- The argument expression
+dsExprToAtom :: DsCoreArg		    -- The argument expression
 	     -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
 					    -- and delivering an expression E
 	     -> DsM CoreExpr		    -- Either E or let x=arg-expr in E
 
-dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
-dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
+dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
+dsExprToAtom (TyArg    t) continue_with = continue_with (TyArg    t)
+dsExprToAtom (LitArg   l) continue_with = continue_with (LitArg   l)
 
-dsExprToAtom arg_expr continue_with
+dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
+dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
+
+dsExprToAtom (VarArg arg_expr) continue_with
   = let
 	ty = coreExprType arg_expr
     in
@@ -260,12 +264,11 @@ dsExprToAtom arg_expr continue_with
 	else Let (NonRec arg_id arg_expr) body
     )
 
-dsExprsToAtoms :: [CoreExpr]
+dsExprsToAtoms :: [DsCoreArg]
 	       -> ([CoreArg] -> DsM CoreExpr)
 	       -> DsM CoreExpr
 
-dsExprsToAtoms [] continue_with
-  = continue_with []
+dsExprsToAtoms [] continue_with = continue_with []
 
 dsExprsToAtoms (arg:args) continue_with
   = dsExprToAtom   arg 	$ \ arg_atom  ->
@@ -280,21 +283,23 @@ dsExprsToAtoms (arg:args) continue_with
 %************************************************************************
 
 \begin{code}
-mkAppDs  :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkConDs  :: Id       -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkPrimDs :: PrimOp   -> [Type] -> [CoreExpr] -> DsM CoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
+
+mkAppDs  :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
+mkConDs  :: Id       -> [DsCoreArg] -> DsM CoreExpr
+mkPrimDs :: PrimOp   -> [DsCoreArg] -> DsM CoreExpr
 
-mkAppDs fun tys arg_exprs 
-  = dsExprsToAtoms arg_exprs $ \ vals ->
-    returnDs (mkApp fun [] tys vals)
+mkAppDs fun args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (mkGenApp fun atoms)
 
-mkConDs con tys arg_exprs
-  = dsExprsToAtoms arg_exprs $ \ vals ->
-    returnDs (mkCon con [] tys vals)
+mkConDs con args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (Con  con atoms)
 
-mkPrimDs op tys arg_exprs
-  = dsExprsToAtoms arg_exprs $ \ vals ->
-    returnDs (mkPrim op [] tys vals)
+mkPrimDs op args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (Prim op  atoms)
 \end{code}
 
 \begin{code}
@@ -573,7 +578,7 @@ mkFailurePair :: Type		-- Result type of the whole case expression
 				-- applied to unit tuple
 mkFailurePair ty
   | isUnboxedType ty
-  = newFailLocalDs (mkFunTys [voidTy] ty)	`thenDs` \ fail_fun_var ->
+  = newFailLocalDs (voidTy `mkFunTy` ty)	`thenDs` \ fail_fun_var ->
     newSysLocalDs voidTy			`thenDs` \ fail_fun_arg ->
     returnDs (\ body ->
 		NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),