Import komo changes bd16w6 (#56)

* kxclib - fix Direct_io.bind regarding exception handling
* kxclib - fix Int53p FloatImpl.{succ,pred}
* kxclib - add MonadOps.{mlift,mwrap,do_cond,do_if}

classic/kxclib.ml

@@ -348,6 +348,11 @@ module type MonadOpsS = sig
   (** monadic version of {!constant} *)
   val returning : 'a -> 'b -> 'a t
 
+  val mlift : ('a -> 'b) -> ('a -> 'b t)
+  val mwrap : ('a -> 'b) -> ('a t -> 'b t)
+  val do_cond : bool -> ('a -> 'b t) -> ('a -> 'b t) -> 'a -> 'b t
+  val do_if : bool -> ('a -> unit t) -> 'a -> unit t
+
   val sequence_list : 'a t list -> 'a list t
 
   (** monadic binding version of {!sequence_list} *)
@@ -432,6 +437,14 @@ module MonadOps(M : sig
 
   let returning x = fun _ -> return x
 
+  let mlift = fun f x -> f x |> return
+
+  let mwrap = fun f m -> m >>= mlift f
+
+  let do_cond = fun c f1 f2 -> (if c then f1 else f2)
+
+  let do_if = fun c f -> do_cond c f (returning ())
+
   let sequence_list ms =
     List.fold_left (fun acc m ->
         acc >>= fun acc ->
@@ -1680,8 +1693,8 @@ module Int53p = struct
         let zero = Float.zero
         let one = Float.one
         let minus_one = Float.minus_one
-        let succ = Float.succ
-        let pred = Float.pred
+        let succ n = n +. 1.
+        let pred n = n -. 1.
         let neg = Float.neg
         let add = Float.add
         let sub = Float.sub
@@ -2420,7 +2433,6 @@ module Direct_io = struct
   type 'x t = ('x, exn * Backtrace_info.t) result [@@deriving show]
 
   let return : 'x -> 'x t = fun x -> Result.ok x
-  let bind : 'x t -> ('x -> 'y t) -> 'y t = fun x f -> Result.bind x f
 
   [%%if mel]
   let inject_error' : exn * backtrace_info option -> 'x t =
@@ -2453,6 +2465,10 @@ module Direct_io = struct
       Log0.log ~label:"trace" ~header_style:(Some `Thin) ~header_color:`Yellow
         "%s" s;
       Ok ()
+
+  let bind : 'x t -> ('x -> 'y t) -> 'y t = fun x f ->
+    try Result.bind x f
+    with e -> inject_error e
 end
 module CheckDirectIo : Io_style = Direct_io
 

intf/kxclib.mli

@@ -223,6 +223,21 @@ module type MonadOpsS = sig
   (** monadic version of {!constant} *)
   val returning : 'a -> 'b -> 'a t
 
+  val mlift : ('a -> 'b) -> ('a -> 'b t)
+
+  val mwrap : ('a -> 'b) -> ('a t -> 'b t)
+
+  (** [m >>= do_cond cond f_true f_false] performs [f_true] or [f_false]
+      on value enclosed in [m],
+      respectively when [cond] is [true] or [false];
+
+      functionally equiv. to [fun c f1 f2 -> if c then f1 else f2] but
+      return type of [f1] and [f2] is restricted to [_ t] *)
+  val do_cond : bool -> ('a -> 'b t) -> ('a -> 'b t) -> 'a -> 'b t
+
+  (** [m >>= do_if cond f] is equiv. to [m >>= do_cond cond f (returning ())] *)
+  val do_if : bool -> ('a -> unit t) -> 'a -> unit t
+
   val sequence_list : 'a t list -> 'a list t
 
   (** monadic binding version of {!sequence_list} *)