# HG changeset patch
# User Rok Strnisa <rok.strnisa@xxxxxxxxxx>
# Date 1277983550 -3600
# Node ID 147342132dafff1104ae3cefe5e7d98992ee56f9
# Parent  7cb2814de8a60e1b713cfbea5ae8e0d1a72e321c
Minor improvements to Stdext (Listext, Either, Fun, and Opt).

REQUIRED FOR:
This patch is required for the 'encrypt-vm-migrate' patch in xen-api.hg.

Signed-off-by: Rok Strnisa <rok.strnisa@xxxxxxxxxx>

diff --git a/stdext/Makefile b/stdext/Makefile
--- a/stdext/Makefile
+++ b/stdext/Makefile
@@ -20,8 +20,8 @@ FEPP = camlp4o -I ../rpc-light -I $(shel
 OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
 OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
 
-STDEXT_OBJS = fun listext filenameext stringext arrayext hashtblext pervasiveext threadext ring \
-	qring fring opt bigbuffer unixext range vIO trie config date encodings fe fecomms \
+STDEXT_OBJS = fun opt listext filenameext stringext arrayext hashtblext pervasiveext threadext ring \
+	qring fring bigbuffer unixext range vIO trie config date encodings fe fecomms \
 	forkhelpers gzip sha1sum zerocheck base64 backtrace tar mapext os either
 
 INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
diff --git a/stdext/either.ml b/stdext/either.ml
--- a/stdext/either.ml
+++ b/stdext/either.ml
@@ -1,4 +1,5 @@
 open Pervasiveext
+open Listext
 
 type ('a,'b) t = Left of 'a | Right of 'b
 
@@ -12,7 +13,7 @@ let to_option = function
 	| Right x -> Some x
 	| Left _ -> None
 
-let cat_right l = Opt.cat_some ++ List.map to_option $ l
+let cat_right l = List.unbox_list ++ List.map to_option $ l
 
 let join = function
 	| Right (Right x) -> Right x
diff --git a/stdext/fun.ml b/stdext/fun.ml
--- a/stdext/fun.ml
+++ b/stdext/fun.ml
@@ -14,7 +14,7 @@ let on op f x y = op (f x) (f y)
 let comp f g x = f (g x)
 let (++) f g x = comp f g x
 
-let comp2  f g a b = ((++) ++ (++)) f g a b
+let comp2 f g a b = f (g a b)
 let (+++) f g a b = comp2 f g a b
 
 let ($) f a = f a
diff --git a/stdext/fun.mli b/stdext/fun.mli
--- a/stdext/fun.mli
+++ b/stdext/fun.mli
@@ -4,6 +4,7 @@ val id : 'a -> 'a
 val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c)
 val on : ('b -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'a -> 'c
 val comp : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)
+val comp2 : ('b -> 'c) -> ('a1 -> 'a2 -> 'b) -> ('a1 -> 'a2 -> 'c)
 val (+++) : ('c -> 'd) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'd
 val (++) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
-val ($) : ('a -> 'b) -> 'a -> 'b
\ No newline at end of file
+val ($) : ('a -> 'b) -> 'a -> 'b
diff --git a/stdext/listext.ml b/stdext/listext.ml
--- a/stdext/listext.ml
+++ b/stdext/listext.ml
@@ -147,18 +147,9 @@ let unrle l =
 let inner fold_left2 base f l1 l2 g =
 	fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2
 
-let filter_map f list =
-	List.fold_right
-		begin
-			fun element list -> match (f element) with
-				| Some x -> x :: list
-				| None -> list
-		end
-		list []
-
-let rec is_sorted compare list = 
+let rec is_sorted compare list =
 	match list with
-		| x :: y :: list -> 
+		| x :: y :: list ->
 			if compare x y <= 0
 				then is_sorted compare (y :: list)
 				else false
@@ -172,6 +163,9 @@ let set_difference a b = List.filter (fu
 let assoc_default k l d =
   if List.mem_assoc k l then List.assoc k l else d
 
+let map_assoc_with_key op al =
+	List.map (fun (k, v1) -> (k, op k v1)) al
+
 (* Like the Lisp cons *)
 let cons a b = a :: b
 
@@ -197,8 +191,6 @@ let safe_hd = function
 	| a::_ -> Some a
 	| [] -> None
 
-let make_assoc op l = map (fun item -> item, op item) l
-
 let rec replace_assoc key new_value = function
 	| [] -> []
 	| (k, _) as p :: tl ->
@@ -207,6 +199,14 @@ let rec replace_assoc key new_value = fu
 		else
 			p :: replace_assoc key new_value tl
 
-let make_assoc op l = map (fun item -> item, op item) l
+let make_assoc op l = map (fun key -> key, op key) l
+
+let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a)
+
+let filter_map f list =
+	(unbox_list +++ map) f list
+
+let restrict_with_default default keys al =
+	make_assoc (fun k -> assoc_default k al default) keys
 
 end
diff --git a/stdext/listext.mli b/stdext/listext.mli
--- a/stdext/listext.mli
+++ b/stdext/listext.mli
@@ -72,7 +72,7 @@ sig
 	val position : ('a -> bool) -> 'a list -> int list
 
 	(** Map the given function over a list, supplying the integer
-	 * index as well as the element value. *)
+	    index as well as the element value. *)
 	val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
 
 	val iteri : (int -> 'a -> unit) -> 'a list -> unit
@@ -89,7 +89,7 @@ sig
 	val chop : int -> 'a list -> 'a list * 'a list
 
 	(** Split a list at the given index to give a pair of lists, the first in
-		reverse order. *)
+		  reverse order. *)
 	val rev_chop : int -> 'a list -> 'a list * 'a list
 
 	(** Tail-recursive [chop]. *)
@@ -118,7 +118,7 @@ sig
 	val morph : int -> ('a -> 'a) -> 'a list -> 'a list
 
 	(** Insert the element [e] between every pair of adjacent elements in the
-		given list. *)
+	    given list. *)
 	val between : 'a -> 'a list -> 'a list
 
 	(** Tail-recursive [between]. *)
@@ -128,7 +128,7 @@ sig
 	val randomize : 'a list -> 'a list
 
 	(** Distribute the given element over the given list, returning a list of
-		lists with the new element in each position. *)
+	    lists with the new element in each position. *)
 	val distribute : 'a -> 'a list -> 'a list list
 
 	(** Generate all permutations of the given list. *)
@@ -149,14 +149,14 @@ sig
 		'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h
 
 	(** Applies a function f that generates optional values, to each
-	 * of the items in a list A [a1; ...; am], generating a new list of
-	 * non-optional values B [b1; ...; bn], with m >= n. For each value
-	 * a in list A, list B contains a corresponding value b if and only
-	 * if the application of (f a) results in Some b.  *)
+	    of the items in a list A [a1; ...; am], generating a new list of
+	    non-optional values B [b1; ...; bn], with m >= n. For each value
+	    a in list A, list B contains a corresponding value b if and only
+	    if the application of (f a) results in Some b.  *)
 	val filter_map : ('a -> 'b option) -> 'a list -> 'b list
 
 	(** Returns true if and only if the given list is in sorted order
-	 * according to the given comparison function.  *)
+	    according to the given comparison function.  *)
 	val is_sorted : ('a -> 'a -> int) -> 'a list -> bool
 
 	(** Returns the intersection of two lists. *)
@@ -166,13 +166,18 @@ sig
 	val set_difference : 'a list -> 'a list -> 'a list
 
 	(** Act as List.assoc, but return the given default value if the
-	 * key is not in the list. *)
+	    key is not in the list. *)
 	val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b
 
+	(** [map_assoc_with_key op al] transforms every value in [al] based on the
+	    key and the value using [op]. *)
+	val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list
+
 	(* Like Lisp cons*)
 	val cons : 'a -> 'a list -> 'a list
 
-	(* take n list: Return the first n elements of list (or less if list is shorter).*)
+	(** [take n list] returns the first [n] elements of [list] (or less if list
+	    is shorter).*)
 	val take : int -> 'a list -> 'a list
 
 	val tails : 'a list -> ('a list) list
@@ -182,4 +187,12 @@ sig
 	val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list
 
 	val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list
+
+	(** Unbox all values from the option list. *)
+	val unbox_list : 'a option list -> 'a list
+
+	(** [restrict_with_default default keys al] makes a new association map
+	    from [keys] to previous values for [keys] in [al]. If a key is not found
+	    in [al], the [default] is used. *)
+	val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list
 end
diff --git a/stdext/opt.ml b/stdext/opt.ml
--- a/stdext/opt.ml
+++ b/stdext/opt.ml
@@ -53,8 +53,6 @@ let fold_right f opt accu =
 	| Some x -> f x accu
 	| None -> accu
 
-let cat_some a = List.map unbox (List.filter is_boxed a)
-
 let join = function
     | Some (Some a) -> Some a
     | _ -> None
diff --git a/stdext/opt.mli b/stdext/opt.mli
--- a/stdext/opt.mli
+++ b/stdext/opt.mli
@@ -19,5 +19,4 @@ val is_boxed : 'a option -> bool
 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 cat_some : 'a option list -> 'a list
 val join : ('a option) option -> 'a option