X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsExpr.lhs;h=45cdacdedb5244067140350393ede496cdda0a70;hb=916abd028990c7fb1588d1792f3ac799a257ba21;hp=881822930dd4d82f768222de5e10401f1205e618;hpb=278092c8eeb3835ad850b595afab0423fa890026;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 8818229..45cdacd 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -20,7 +20,7 @@ import DsMonad
 
 #ifdef GHCI
 	-- Template Haskell stuff iff bootstrapped
-import DsMeta		( dsBracket )
+import DsMeta		( dsBracket, dsReify )
 #endif
 
 import HsSyn		( failureFreePat,
@@ -88,6 +88,13 @@ dsLet (ThenBinds b1 b2) body
   = dsLet b2 body 	`thenDs` \ body' ->
     dsLet b1 body'
   
+dsLet (IPBinds binds is_with) body
+  = foldlDs dsIPBind body binds
+  where
+    dsIPBind body (n, e)
+        = dsExpr e	`thenDs` \ e' ->
+	  returnDs (Let (NonRec (ipNameName n) e') body)
+
 -- Special case for bindings which bind unlifted variables
 -- We need to do a case right away, rather than building
 -- a tuple and doing selections.
@@ -259,14 +266,6 @@ dsExpr (HsLet binds body)
   = dsExpr body		`thenDs` \ body' ->
     dsLet binds body'
 
-dsExpr (HsWith expr binds is_with)
-  = dsExpr expr		`thenDs` \ expr' ->
-    foldlDs dsIPBind expr' binds
-    where
-      dsIPBind body (n, e)
-        = dsExpr e	`thenDs` \ e' ->
-	  returnDs (Let (NonRec (ipNameName n) e') body)
-
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
@@ -550,7 +549,8 @@ Here is where we desugar the Template Haskell brackets and escapes
 
 #ifdef GHCI	/* Only if bootstrapping */
 dsExpr (HsBracketOut x ps) = dsBracket x ps
-dsExpr (HsSplice n e)      = pprPanic "dsExpr:splice" (ppr e)
+dsExpr (HsReify r)	   = dsReify r
+dsExpr (HsSplice n e _)    = pprPanic "dsExpr:splice" (ppr e)
 #endif
 
 \end{code}
@@ -636,10 +636,10 @@ dsDo do_or_lc stmts ids result_ty
 	    returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
 				            mkLams binders matching_code])
 
-	go (RecStmt rec_vars rec_stmts : stmts)
+	go (RecStmt rec_vars rec_stmts rec_rets : stmts)
 	  = go (bind_stmt : stmts)
 	  where
-	    bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
+	    bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
 	    
     in
     go stmts
@@ -658,19 +658,21 @@ We turn (RecStmt [v1,..vn] stmts) into:
 \begin{code}
 dsRecStmt :: Type		-- Monad type constructor :: * -> *
 	  -> [Id]		-- Ids for: [return,fail,>>=,>>,mfix]
-	  -> [Id] -> [TypecheckedStmt]	-- Guts of the RecStmt
+	  -> [Id] -> [TypecheckedStmt]	-> [TypecheckedHsExpr] 	-- Guts of the RecStmt
 	  -> TypecheckedStmt
-dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
-  = BindStmt tup_pat mfix_app noSrcLoc
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+  = ASSERT( length vars == length rets )
+    BindStmt tup_pat mfix_app noSrcLoc
   where 
 	(var1:rest) = vars		-- Always at least one
+	(ret1:_)    = rets
 	one_var     = null rest
 
 	mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
 	mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
 
-	tup_expr | one_var   = HsVar var1
-		 | otherwise = ExplicitTuple (map HsVar vars) Boxed
+	tup_expr | one_var   = ret1
+		 | otherwise = ExplicitTuple rets Boxed
 	tup_ty   | one_var   = idType var1
 		 | otherwise = mkTupleTy Boxed (length vars) (map idType vars)
 	tup_pat  | one_var   = VarPat var1