- (fvs2, builds2, in_ty2, core_exp2)
- = (fvs1 `unionVarSet` fvs2,
- map (left_expr in_ty1 in_ty2) builds1 ++
- map (right_expr in_ty1 in_ty2) builds2,
- mkTyConApp either_con [in_ty1, in_ty2],
- do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (fvs_alts, leaves', sum_ty, core_choices)
- = foldb merge_branches branches
-
- -- Replace the commands in the case with these tagged tuples,
- -- yielding a HsExpr Id we can feed to dsExpr.
-
- (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
- in_ty = envStackType env_ids stack
- fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
-
- pat_ty = funArgTy match_ty
- match_ty' = mkFunTy pat_ty sum_ty
- -- Note that we replace the HsCase result type by sum_ty,
- -- which is the type of matches'
- in
- dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body ->
- matchEnvStack env_ids stack_ids core_body
- `thenDs` \ core_matches ->
- returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
- fvs_exp `unionVarSet` fvs_alts)
+ (fvs2, builds2, in_ty2, core_exp2)
+ = (fvs1 `unionVarSet` fvs2,
+ map (left_expr in_ty1 in_ty2) builds1 ++
+ map (right_expr in_ty1 in_ty2) builds2,
+ mkTyConApp either_con [in_ty1, in_ty2],
+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+ (fvs_alts, leaves', sum_ty, core_choices)
+ = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a HsExpr Id we can feed to dsExpr.
+
+ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+ in_ty = envStackType env_ids stack
+ fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+
+ pat_ty = funArgTy match_ty
+ match_ty' = mkFunTy pat_ty sum_ty
+ -- Note that we replace the HsCase result type by sum_ty,
+ -- which is the type of matches'
+
+ core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
+ core_matches <- matchEnvStack env_ids stack_ids core_body
+ return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+ fvs_exp `unionVarSet` fvs_alts)