X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=58bf6b88e705baa2153a07beda77c0aecede34da;hp=45fbf07682fb01a915c9b14b274cdc97be58da34;hb=ba05282d3915e7051b3f016366b971a8506b0093;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 45fbf07..58bf6b8 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -34,7 +34,6 @@ import MkCore
 import Name
 import Var
 import Id
-import PrelInfo
 import DataCon
 import TysWiredIn
 import BasicTypes
@@ -405,7 +404,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
 --			if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
 --		     c1 ||| c2
 
-dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do
+dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
     (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd
@@ -413,20 +412,26 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do
     either_con <- dsLookupTyCon eitherTyConName
     left_con   <- dsLookupDataCon leftDataConName
     right_con  <- dsLookupDataCon rightDataConName
-    let
-        left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
-        right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+    let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
 
         in_ty = envStackType env_ids stack
         then_ty = envStackType then_ids stack
         else_ty = envStackType else_ids stack
         sum_ty = mkTyConApp either_con [then_ty, else_ty]
         fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
-    
-    core_if <- matchEnvStack env_ids stack_ids
-                (mkIfThenElse core_cond
-                    (left_expr  then_ty else_ty (buildEnvStack then_ids stack_ids))
-                    (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+        
+        core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_ids)
+        core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)
+
+    core_if <- case mb_fun of 
+       Just fun -> do { core_fun <- dsExpr fun
+                      ; matchEnvStack env_ids stack_ids $
+                        mkCoreApps core_fun [core_cond, core_left, core_right] }
+       Nothing  -> matchEnvStack env_ids stack_ids $
+                   mkIfThenElse core_cond core_left core_right
+
     return (do_map_arrow ids in_ty sum_ty res_ty
                 core_if
                 (do_choice ids then_ty else_ty res_ty core_then core_else),
@@ -774,8 +779,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
 
 dsCmdStmt ids local_vars env_ids out_ids 
           (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
-                   , recS_rec_rets = rhss, recS_dicts = _binds }) = do
-    let         -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
+                   , recS_rec_rets = rhss }) = do
+    let
         env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
         env2_ids = varSetElems env2_id_set
         env2_ty = mkBigCoreVarTupTy env2_ids
@@ -1036,8 +1041,6 @@ collectl (L _ pat) bndrs
   = go pat
   where
     go (VarPat var)               = var : bndrs
-    go (VarPatOut var bs)         = var : collectEvBinders bs
-                                    ++ bndrs
     go (WildPat _)                = bndrs
     go (LazyPat pat)              = collectl pat bndrs
     go (BangPat pat)              = collectl pat bndrs