+--
+-- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
+-- It looks a mess: I wonder if it could be refactored.
+
+boxResult augment mbTopCon result_ty
+ | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+ -- isIOType_maybe handles the case where the type is a
+ -- simple wrapping of IO. E.g.
+ -- newtype Wrap a = W (IO a)
+ -- No coercion necessay because its a non-recursive newtype
+ -- (If we wanted to handle a *recursive* newtype too, we'd need
+ -- another case, and a coercion.)
+ = -- The result is IO t, so wrap the result in an IO constructor
+
+ resultWrapper io_res_ty `thenDs` \ res ->
+ let aug_res = augment res
+ extra_result_tys = case aug_res of
+ (Just ty,_)
+ | isUnboxedTupleType ty
+ -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+ _ -> []
+
+ return_result state anss
+ = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
+ (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+ ++ (state : anss))
+ in
+ mk_alt return_result aug_res `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ io_data_con = head (tyConDataCons io_tycon)
+ toIOCon = case mbTopCon of
+ Nothing -> dataConWrapId io_data_con
+ Just x -> x
+ wrap = \ the_call -> mkApps (Var toIOCon)
+ [ Type io_res_ty,
+ Lam state_id $
+ Case (App the_call (Var state_id))
+ (mkWildId ccall_res_ty)
+ (coreAltType the_alt)
+ [the_alt]
+ ]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)