REQUIRED FOR: This patch is required for the 'encrypt-vm-migrate' patch in xen-api.hg.
Signed-off-by: Rok Strnisa <[email protected]> stdext/Makefile | 4 ++-- stdext/either.ml | 3 ++- stdext/fun.ml | 2 +- stdext/fun.mli | 3 ++- stdext/listext.ml | 28 ++++++++++++++-------------- stdext/listext.mli | 35 ++++++++++++++++++++++++----------- stdext/opt.ml | 2 -- stdext/opt.mli | 1 - 8 files changed, 45 insertions(+), 33 deletions(-)
# HG changeset patch # User Rok Strnisa <[email protected]> # 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 <[email protected]> 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
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
