Simon's hacking on monad-comp; incomplete

[ghc-hetmet.git] / compiler / deSugar / DsArrows.lhs

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 608f25e..a5bf2b6 100644 (file)
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
                         core_body,
         exprFreeVars core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _ _)
-  = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+  = dsCmdDo ids local_vars env_ids res_ty stmts 
 
 --     A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 --     A | xs |- ci :: [tsi] ti
@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv         -- arrow combinators
                                -- so don't pull on it too early
        -> Type                 -- return type of the statement
        -> [LStmt Id]           -- statements to desugar
-       -> LHsExpr Id           -- body
        -> DsM (CoreExpr,       -- desugared expression
                IdSet)          -- set of local vars that occur free
 
@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv               -- arrow combinators
 --     --------------------------
 --     A | xs |- do { c } :: [] t
 
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
   = dsLCmd ids local_vars env_ids [] res_ty body
 
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
     let
         bound_vars = mkVarSet (collectLStmtBinders stmt)
         local_vars' = local_vars `unionVarSet` bound_vars
     (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
-        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts 
         return (core_stmts, fv_stmts, varSetElems fv_stmts))
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
     return (do_compose ids