- left_id = HsVar (dataConWrapId left_con)
- right_id = HsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-
- -- Prefix each tuple with a distinct series of Left's and Right's,
- -- in a balanced way, keeping track of the types.
-
- merge_branches (fvs1, builds1, in_ty1, core_exp1)
- (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)
+ left_id = HsVar (dataConWrapId left_con)
+ right_id = HsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches (builds1, in_ty1, core_exp1)
+ (builds2, in_ty2, core_exp2)
+ = (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)
+ (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
+
+ 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,
+ exprFreeVars core_body `intersectVarSet` local_vars)