X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=7f798f81f79c55001e6043afe74c7d745e4148bd;hp=c55d6a4828401ed55ad86d52babfe0770608d7a6;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index c55d6a4..7f798f8 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -404,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 @@ -412,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), @@ -535,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 @@ -612,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 @@ -620,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 @@ -668,7 +675,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do +dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -773,8 +780,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 @@ -1035,8 +1042,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 @@ -1057,7 +1062,6 @@ collectl (L _ pat) bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = collectl (noLoc pat) bndrs go (ViewPat _ pat _) = collectl pat bndrs go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)