+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives. For example
+
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+ arr (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts)) >>>
+ (c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+ into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+ input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+ bodies with |||.
+
+\begin{code}
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty))
+ = dsLExpr exp `thenDs` \ core_exp ->
+ mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+
+ -- Extract and desugar the leaf commands in the case, building tuple
+ -- expressions that will (after tagging) replace these leaves
+
+ let
+ leaves = concatMap leavesMatch matches
+ make_branch (leaf, bound_vars)
+ = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+ `thenDs` \ (core_leaf, fvs, leaf_ids) ->
+ returnDs (fvs `minusVarSet` bound_vars,
+ [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
+ envStackType leaf_ids stack,
+ core_leaf)
+ in
+ mappM make_branch leaves `thenDs` \ branches ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_id = nlHsVar (dataConWrapId left_con)
+ right_id = nlHsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) 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)