+ mkAppDs con_expr' [] con_args
+ where
+ -- The "con_expr'" is simply an application of the constructor Id
+ -- to types and (perhaps) dictionaries. This boring little
+ -- function gets the constructor out.
+ get_con_id (App fun _) = get_con_id fun
+ get_con_id (Var con) = con
+\end{code}
+
+Record update is a little harder. Suppose we have the decl:
+
+ data T = T1 {op1, op2, op3 :: Int}
+ | T2 {op4, op1 :: Int}
+ | T3
+
+Then we translate as follows:
+
+ r { op2 = e }
+===>
+ let op2 = e in
+ case r of
+ T1 op1 _ op3 -> T1 op1 op2 op3
+ T2 op4 _ -> T2 op4 op2
+ other -> recUpdError "M.lhs/230"
+
+It's important that we use the constructor Ids for T1, T2 etc on the
+RHSs, and do not generate a Core Con directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+\begin{code}
+dsExpr (RecordUpdOut record_expr dicts rbinds)
+ = dsExpr record_expr `thenDs` \ record_expr' ->
+
+ -- Desugar the rbinds, and generate let-bindings if
+ -- necessary so that we don't lose sharing
+-- dsRbinds rbinds $ \ rbinds' ->
+ let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
+ let
+ record_ty = coreExprType record_expr'
+ (tycon, inst_tys, cons) = getAppDataTyCon record_ty
+ cons_to_upd = filter has_all_fields cons
+
+ -- initial_args are passed to every constructor
+ initial_args = map TyArg inst_tys ++ map VarArg dicts
+
+ mk_val_arg (field, arg_id)
+ = case [arg | (f, arg) <- rbinds', f==field] of
+ (arg:args) -> ASSERT(null args)
+ arg
+ [] -> VarArg arg_id
+
+ mk_alt con
+ = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids ->
+ let
+ val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids)
+ in
+ returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
+
+ mk_default
+ | length cons_to_upd == length cons
+ = returnDs NoDefault
+ | otherwise
+ = newSysLocalDs record_ty `thenDs` \ deflt_id ->
+ mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err ->
+ returnDs (BindDefault deflt_id err)
+ in
+ mapDs mk_alt cons_to_upd `thenDs` \ alts ->
+ mk_default `thenDs` \ deflt ->
+
+ returnDs (Case record_expr' (AlgAlts alts deflt))
+
+ where
+ has_all_fields :: Id -> Bool
+ has_all_fields con_id
+ = all ok rbinds
+ where
+ con_fields = dataConFieldLabels con_id
+ ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields