X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=11fddf57af96ab769a95d37faad8e6243e42f94b;hp=6d7d7622d3232e59e10127df7bbe8c853ac32770;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hpb=11f6e48e0d9a03b40b2e8a0b2fc1332f12552677

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6d7d762..11fddf5 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -51,6 +51,7 @@ import StaticFlags
 import CostCentre
 import Id
 import Var
+import VarSet
 import PrelInfo
 import DataCon
 import TysWiredIn
@@ -210,7 +211,9 @@ dsExpr (HsVar var)     	      = return (Var var)
 dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsCoercion co_fn
+                                   ; e' <- dsExpr e
+                                   ; return (co_fn' e') }
 
 dsExpr (NegApp expr neg_expr) 
   = App <$> dsExpr neg_expr <*> dsLExpr expr
@@ -645,7 +648,6 @@ makes all list literals be generated via the simple route.
 
 
 \begin{code}
-
 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 -- See Note [Desugaring explicit lists]
 dsExplicitList elt_ty xs
@@ -747,8 +749,7 @@ dsDo stmts body result_ty
         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 	body_ty    = mkAppTy m_ty tup_ty
-        tup_ty     = mkCoreTupTy (map idType tup_ids)
-                  -- mkCoreTupTy deals with singleton case
+        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
@@ -846,8 +847,7 @@ dsMDo tbl stmts body result_ty
 	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 	body_ty = mkAppTy m_ty tup_ty
-	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-		  -- mkCoreTupTy deals with singleton case
+	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 
 	return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
 			      (mkLHsTupleExpr rets)