Miscellaneous improvements to stdext.

stdext/Makefile

@@ -21,6 +21,7 @@ OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
 OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
 
 STDEXT_OBJS = \
+	monad \
 	fun \
 	opt \
 	listext \

stdext/either.ml

@@ -3,6 +3,19 @@ open Listext
 
 type ('a,'b) t = Left of 'a | Right of 'b
 
+module Monad = Monad.M2.Make (struct
+
+	type ('a, 'b) m = ('b, 'a) t
+
+	let bind value f =
+		match value with
+			| Left value -> Left value
+			| Right value -> f value
+
+	let return value = Right value
+
+end)
+
 let left x = Left x
 let right x = Right x
 let is_left = function
@@ -23,3 +36,7 @@ let join = function
 let swap = function
 	| Right x -> Left x
 	| Left x -> Right x
+
+let of_exception f =
+	try Right (f ())
+	with e -> Left e

stdext/either.mli

@@ -6,6 +6,8 @@
  *)
 
 type ('a,'b) t = Left of 'a | Right of 'b
+module Monad : sig include Monad.M2.MONAD with type ('a, 'b) m = ('b, 'a) t end
+
 val left : 'a -> ('a, 'b) t
 val right: 'b -> ('a, 'b) t
 val is_left: ('a, 'b) t -> bool
@@ -16,3 +18,4 @@ val cat_right: ('a, 'b) t list -> 'b list
 val join: ('a, ('b, 'c) t) t -> (('a, 'b) t, 'c) t
 
 val swap : ('a, 'b) t -> ('b, 'a) t
+val of_exception : (unit -> 'a) -> (exn, 'a) t

stdext/listext.ml

@@ -14,6 +14,21 @@
 open Fun
 module List = struct include List
 
+module Monad = Monad.M1.Make (struct
+
+	type 'a m = 'a list
+
+	let bind list f =
+		let rec inner result = function
+			| x :: xs -> inner (List.rev_append (f x) result) xs
+			| [] -> List.rev result
+		in
+		inner [] list
+
+	let return x = [x]
+
+end)
+
 (** Turn a list into a set *)
 let rec setify = function
 	| [] -> []

stdext/listext.mli

@@ -13,6 +13,7 @@
  *)
 module List :
 sig
+	module Monad : sig include Monad.M1.MONAD with type 'a m = 'a list end
 	val setify : 'a list -> 'a list
 	val subset : 'a list -> 'a list -> bool
 	val set_equiv : 'a list -> 'a list -> bool

stdext/monad.ml

@@ -0,0 +1,70 @@
+(*
+ * Copyright (C) 2010-2011 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 1-parameter monads. *)
+module M1 = struct
+
+	module type BASE =
+	sig
+		type 'a m
+		val bind : 'a m -> ('a -> 'b m) -> 'b m
+		val return : 'a -> 'a m
+	end
+
+	module type MONAD =
+	sig
+		type 'a m
+		val (>>=) : 'a m -> ('a -> 'b m) -> 'b m
+		val bind : 'a m -> ('a -> 'b m) -> 'b m
+		val return : 'a -> 'a m
+	end
+
+	module Make (B : BASE) : MONAD with type 'a m = 'a B.m =
+	struct
+		type 'a m = 'a B.m
+		let (>>=) = B.bind
+		let bind = B.bind
+		let return = B.return
+	end
+
+end
+
+(** 2-parameter monads. *)
+module M2 = struct
+
+	module type BASE =
+	sig
+		type ('a, 'x) m
+		val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m
+		val return : 'a -> ('a, 'x) m
+	end
+
+	module type MONAD =
+	sig
+		type ('a, 'x) m
+		val (>>=) : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m
+		val bind : ('a, 'x) m -> ('a -> ('b, 'x) m) -> ('b, 'x) m
+		val return : 'a -> ('a, 'x) m
+	end
+
+	module Make (B : BASE) : MONAD with type ('a, 'x) m = ('a, 'x) B.m =
+	struct
+		type ('a, 'x) m = ('a, 'x) B.m
+		let (>>=) = B.bind
+		let bind = B.bind
+		let return = B.return
+	end
+
+end
+

stdext/monad.mli

@@ -0,0 +1,70 @@
+(*
+ * Copyright (C) 2010-2011 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 1-parameter monads. *)
+module M1 : sig
+
+	module type BASE =
+	sig
+		type 'a m
+		val bind : 'a m -> ('a -> 'b m) -> 'b m
+		val return : 'a -> 'a m
+	end
+
+	module type MONAD =
+	sig
+		type 'a m
+		val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m
+		val bind : 'a m -> ('a -> 'b m) -> 'b m
+		val return : 'a -> 'a m
+	end
+
+	module Make : functor (B : BASE) ->
+	sig
+		type 'a m = 'a B.m
+		val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m
+		val bind : 'a m -> ('a -> 'b m) -> 'b m
+		val return : 'a -> 'a m
+	end
+
+end
+
+(** 2-parameter monads. *)
+module M2 : sig
+
+	module type BASE =
+	sig
+		type ('a, 'b) m
+		val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+		val return : 'a -> ('a, 'b) m
+	end
+
+	module type MONAD =
+	sig
+		type ('a, 'b) m
+		val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+		val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+		val return : 'a -> ('a, 'b) m
+	end
+
+	module Make : functor (B : BASE) ->
+	sig
+		type ('a, 'b) m = ('a, 'b) B.m
+		val ( >>= ) : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+		val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+		val return : 'a -> ('a, 'b) m
+	end
+
+end
+

stdext/opt.ml

@@ -20,6 +20,19 @@
 
 open Pervasiveext
 
+module Monad = Monad.M1.Make (struct
+
+	type 'a m = 'a option
+
+	let bind option f =
+		match option with
+			| None -> None
+			| Some result -> f result
+
+	let return x = Some x
+
+end)
+
 let iter f = function
 	| Some x -> f x
 	| None -> ()
@@ -54,6 +67,10 @@ let fold_right f opt accu =
 	| None -> accu
 
 let join = function
-    | Some (Some a) -> Some a
-    | _ -> None
+	| Some (Some a) -> Some a
+	| _ -> None
+
+let of_exception f =
+	try Some (f ())
+	with _ -> None
 

stdext/opt.mli

@@ -11,6 +11,8 @@
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU Lesser General Public License for more details.
  *)
+
+module Monad : sig include Monad.M1.MONAD with type 'a m = 'a option end
 val iter : ('a -> unit) -> 'a option -> unit
 val map : ('a -> 'b) -> 'a option -> 'b option
 val default : 'a -> 'a option -> 'a
@@ -20,3 +22,4 @@ val to_list : 'a option -> 'a list
 val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a
 val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
 val join : ('a option) option -> 'a option
+val of_exception : (unit -> 'a) -> 'a option

xapi-libs.spec

@@ -211,6 +211,8 @@ rm -rf $RPM_BUILD_ROOT
    /usr/lib/ocaml/stdext/listext.cmx
    /usr/lib/ocaml/stdext/mapext.cmi
    /usr/lib/ocaml/stdext/mapext.cmx
+   /usr/lib/ocaml/stdext/monad.cmi
+   /usr/lib/ocaml/stdext/monad.cmx
    /usr/lib/ocaml/stdext/opt.cmi
    /usr/lib/ocaml/stdext/opt.cmx
    /usr/lib/ocaml/stdext/pervasiveext.cmi