xapi-stdext: remove unused functions from listext, and replace chop with split_at (#6733)

Although I doubt it, please check whether Xenserver's proprietary code
uses these functions.

I took the chance to consolidate some functions in
`ocaml/xapi/db_gc_util.ml` as well.

Author: psafont

dune-project

@@ -612,6 +612,8 @@
    (= :version))
   (xapi-stdext-pervasives
    (= :version))
+  (xapi-stdext-std
+   (= :version))
   (xapi-stdext-threads
    (= :version))
   (xapi-stdext-unix

ocaml/libs/stunnel/dune

@@ -13,6 +13,7 @@
     xapi-inventory
     xapi-log
     xapi-stdext-pervasives
+    xapi-stdext-std
     xapi-stdext-threads
     xapi-stdext-unix
   )

ocaml/libs/stunnel/stunnel_cache.ml

@@ -27,6 +27,8 @@ open Safe_resources
 
 let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute
 
+let list_drop = Xapi_stdext_std.Listext.List.drop
+
 (* Disable debug-level logging but leave higher-priority enabled.  It would be
  * better to handle this sort of configuration in the Debug module itself.
  *)
@@ -93,17 +95,6 @@ let unlocked_gc () =
            !index ""
         )
   ) ;
-  (* Split a list at the given index to give a pair of lists.
-   *  From Xapi_stdext_std.Listext *)
-  let rec chop i l =
-    match (i, l) with
-    | 0, l ->
-        ([], l)
-    | i, h :: t ->
-        (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t)
-    | _ ->
-        invalid_arg "chop"
-  in
   let all_ids = Tbl.fold !stunnels (fun k _ acc -> k :: acc) [] in
   let to_gc = ref [] in
   (* Find the ones which are too old *)
@@ -134,8 +125,8 @@ let unlocked_gc () =
       List.filter (fun (idx, _) -> not (List.mem idx !to_gc)) times'
     in
     (* Sort into descending order of donation time, ie youngest first *)
-    let times' = List.sort (fun x y -> compare (fst y) (fst x)) times' in
-    let _youngest, oldest = chop max_stunnel times' in
+    let times' = List.sort (fun (_, x) (_, y) -> Float.compare y x) times' in
+    let oldest = list_drop max_stunnel times' in
     let oldest_ids = List.map fst oldest in
     List.iter
       (fun x ->

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune

@@ -7,5 +7,5 @@
   (names xstringext_test listext_test)
   (package xapi-stdext-std)
   (modules xstringext_test listext_test)
-  (libraries xapi_stdext_std alcotest)
+  (libraries xapi_stdext_std fmt alcotest)
 )

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml

@@ -22,8 +22,7 @@ module List = struct
     | x :: xs ->
         if mem x xs then setify xs else x :: setify xs
 
-  let subset s1 s2 =
-    List.fold_left ( && ) true (List.map (fun s -> List.mem s s2) s1)
+  let subset s1 s2 = List.for_all (fun s -> List.mem s s2) s1
 
   let set_equiv s1 s2 = subset s1 s2 && subset s2 s1
 
@@ -84,61 +83,14 @@ module List = struct
     | _ :: xs ->
         last xs
 
-  let sub i j l = drop i l |> take (j - max i 0)
-
-  let rec chop i l =
-    match (i, l) with
-    | j, _ when j < 0 ->
-        invalid_arg "chop: index cannot be negative"
-    | 0, l ->
-        ([], l)
-    | _, h :: t ->
-        (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t)
-    | _, [] ->
-        invalid_arg "chop: index not in list"
-
-  let rev_chop i l =
-    let rec aux i fr ba =
-      match (i, fr, ba) with
-      | i, _, _ when i < 0 ->
-          invalid_arg "rev_chop: index cannot be negative"
-      | 0, fr, ba ->
-          (fr, ba)
-      | i, fr, h :: t ->
-          aux (i - 1) (h :: fr) t
-      | _ ->
-          invalid_arg "rev_chop"
+  let split_at n list =
+    let rec loop i acc = function
+      | x :: xs when i < n ->
+          loop (i + 1) (x :: acc) xs
+      | xs ->
+          (List.rev acc, xs)
     in
-    aux i [] l
-
-  let chop_tr i l = (fun (fr, ba) -> (rev fr, ba)) (rev_chop i l)
-
-  let rec dice m l =
-    match chop m l with l, [] -> [l] | l1, l2 -> l1 :: dice m l2
-
-  let remove i l =
-    match rev_chop i l with
-    | rfr, _ :: t ->
-        rev_append rfr t
-    | _ ->
-        invalid_arg "remove"
-
-  let insert i e l =
-    match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba)
-
-  let replace i e l =
-    match rev_chop i l with
-    | rfr, _ :: t ->
-        rev_append rfr (e :: t)
-    | _ ->
-        invalid_arg "replace"
-
-  let morph i f l =
-    match rev_chop i l with
-    | rfr, h :: t ->
-        rev_append rfr (f h :: t)
-    | _ ->
-        invalid_arg "morph"
+    loop 0 [] list
 
   let rec between e = function
     | [] ->

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli

@@ -27,6 +27,12 @@ module List : sig
   (** [drop n list] returns the list without the first [n] elements of [list]
       (or [] if list is shorter). *)
 
+  val split_at : int -> 'a list -> 'a list * 'a list
+  (** [split_at n list] returns a tuple with the first element being the first
+  [n] elements of [list] (or less if the list is shorter); and the second
+  element being the rest of elements of the list (or [] if the list is
+  shorter). The results with negative values of [n] are the same as using 0. *)
+
   val last : 'a list -> 'a
   (** [last l] returns the last element of a list or raise Invalid_argument if 
     the list is empty *)
@@ -67,42 +73,6 @@ module List : sig
       When using OCaml compilers 5.1 or later, please use the standard library
       instead. *)
 
-  (** {1 Using indices to manipulate lists} *)
-
-  val chop : int -> 'a list -> 'a list * 'a list
-  (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises
-      invalid_arg when [i] is negative or greater than the length of [l]. *)
-
-  val rev_chop : int -> 'a list -> 'a list * 'a list
-  (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the
-      first in reverse order. Raises invalid_arg when [i] is negative or
-      greater than the length of [l]. *)
-
-  val chop_tr : int -> 'a list -> 'a list * 'a list
-  (** Tail-recursive {!chop}. *)
-
-  val dice : int -> 'a list -> 'a list list
-  (** [dice k l] splits [l] into lists with [k] elements each. Raises
-      {!Invalid_arg} if [List.length l] is not divisible by [k]. *)
-
-  val sub : int -> int -> 'a list -> 'a list
-  (** [sub from to l] returns the sub-list of [l] that starts at index [from]
-      and ends at [to] or an empty list if [to] is equal or less than [from].
-      Negative indices are treated as 0 and indeces higher than [List.length l
-      - 1] are treated as [List.length l - 1]. *)
-
-  val remove : int -> 'a list -> 'a list
-  (** Remove the element at the given index. *)
-
-  val insert : int -> 'a -> 'a list -> 'a list
-  (** Insert the given element at the given index. *)
-
-  val replace : int -> 'a -> 'a list -> 'a list
-  (** Replace the element at the given index with the given value. *)
-
-  val morph : int -> ('a -> 'a) -> 'a list -> 'a list
-  (** Apply the given function to the element at the given index. *)
-
   (** {1 Association Lists} *)
 
   val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml

@@ -25,7 +25,7 @@ let test_option typ tested_f (name, case, expected) =
   let check () = Alcotest.(check @@ option typ) name expected (tested_f case) in
   (name, `Quick, check)
 
-let test_chopped_list tested_f (name, case, expected) =
+let test_split_at_list tested_f (name, case, expected) =
   let check () =
     Alcotest.(check @@ pair (list int) (list int)) name expected (tested_f case)
   in
@@ -135,7 +135,7 @@ let test_last =
   let error_tests = List.map error_test error_specs in
   ("last", tests @ error_tests)
 
-let test_chop =
+let test_split_at =
   let specs =
     [
       ([], 0, ([], []))
@@ -144,67 +144,21 @@ let test_chop =
     ; ([0; 1], 0, ([], [0; 1]))
     ; ([0; 1], 1, ([0], [1]))
     ; ([0; 1], 2, ([0; 1], []))
-    ]
-  in
-  let error_specs =
-    [
-      ([0], -1, Invalid_argument "chop: index cannot be negative")
-    ; ([0], 2, Invalid_argument "chop: index not in list")
+    (* test invalid arguments *) [@ocamlformat "disable"]
+    ; ([0], -1, ([], [0]))
+    ; ([0], 2, ([0], []))
     ]
   in
   let test (whole, number, expected) =
     let name =
-      Printf.sprintf "chop [%s] with %i"
-        (String.concat "; " (List.map string_of_int whole))
-        number
-    in
-    test_chopped_list (Listext.chop number) (name, whole, expected)
-  in
-  let tests = List.map test specs in
-  let error_test (whole, number, error) =
-    let name =
-      Printf.sprintf "chop [%s] with %i fails"
+      Printf.sprintf "split_at [%s] with %i"
         (String.concat "; " (List.map string_of_int whole))
         number
     in
-    test_error
-      (fun ls () -> ignore (Listext.chop number ls))
-      (name, whole, error)
-  in
-  let error_tests = List.map error_test error_specs in
-  ("chop", tests @ error_tests)
-
-let test_sub =
-  let specs =
-    [
-      ([], 0, 0, [])
-    ; ([], 0, 1, [])
-    ; ([0], 0, 0, [])
-    ; ([0], 0, 1, [0])
-    ; ([0], 1, 1, [])
-    ; ([0], 0, 2, [0])
-    ; ([0; 1], 0, 0, [])
-    ; ([0; 1], 0, 1, [0])
-    ; ([0; 1], 0, 2, [0; 1])
-    ; ([0; 1], 1, 1, [])
-    ; ([0; 1], 1, 2, [1])
-    ; ([0; 1], 2, 2, [])
-      (* test_cases below used to fail *) [@ocamlformat "disable"]
-    ; ([0], -1, 0, [])
-    ; ([0], 0, -1, [])
-    ; ([0; 1], 1, 0, [])
-    ]
-  in
-  let test (whole, from, until, expected) =
-    let name =
-      Printf.sprintf "sub [%s] from %i to %i"
-        (String.concat "; " (List.map string_of_int whole))
-        from until
-    in
-    test_list (Listext.sub from until) (name, whole, expected)
+    test_split_at_list (Listext.split_at number) (name, whole, expected)
   in
   let tests = List.map test specs in
-  ("sub", tests)
+  ("split_at", tests)
 
 let test_find_minimum (name, pp, typ, specs) =
   let test ((cmp, cmp_name), input, expected) =
@@ -260,8 +214,7 @@ let () =
     ; test_take
     ; test_drop
     ; test_last
-    ; test_chop
-    ; test_sub
+    ; test_split_at
     ; test_find_minimum_int
     ; test_find_minimum_tuple
     ]

ocaml/xapi/binpack.ml

@@ -98,7 +98,7 @@ let choose l n =
 (** Return all permutations of a list *)
 let rec permutations : 'a list -> 'a list list =
   let rotate n xs =
-    let a, b = Xapi_stdext_std.Listext.List.chop n xs in
+    let a, b = Xapi_stdext_std.Listext.List.split_at n xs in
     b @ a
   in
   let insert_at n x xs = rotate (List.length xs - n + 1) (x :: rotate n xs) in

ocaml/xapi/db_gc_util.ml

@@ -293,6 +293,12 @@ let gc_vtpms ~__context =
 
 let probation_pending_tasks = Hashtbl.create 53
 
+let sort_and_split compare n tasks =
+  if List.length tasks <= n then
+    (tasks, [])
+  else
+    Listext.List.split_at n (List.sort compare tasks)
+
 let timeout_tasks ~__context =
   let all_tasks =
     Db.Task.get_internal_records_where ~__context
@@ -368,32 +374,20 @@ let timeout_tasks ~__context =
   let lucky, unlucky =
     if List.length young <= Xapi_globs.max_tasks then
       (young, []) (* keep them all *)
-    else (* Compute how many we'd like to delete *)
-      let overflow = List.length young - Xapi_globs.max_tasks in
-      (* We only consider deleting completed tasks *)
+    else (* We only consider deleting completed tasks *)
       let completed, pending =
         List.partition
           (fun (_, t) -> TaskHelper.status_is_completed t.Db_actions.task_status)
           young
       in
-      (* Sort the completed tasks so we delete oldest tasks in preference *)
-      let completed =
-        List.sort
-          (fun (_, t1) (_, t2) ->
-            compare
-              (Date.to_unix_time t1.Db_actions.task_finished)
-              (Date.to_unix_time t2.Db_actions.task_finished)
-          )
-          completed
-      in
-      (* From the completes set, choose up to 'overflow' *)
-      let unlucky, lucky =
-        if List.length completed > overflow then
-          Listext.List.chop overflow completed
-        else
-          (completed, [])
+      (* pending tasks limit the amount of completed tasks to keep, negatives
+         values are equivalent to 0 *)
+      let limit = Xapi_globs.max_tasks - List.length completed in
+      (* Reverse compare order so oldest dates (earliest) are sorted last *)
+      let compare (_, t1) (_, t2) =
+        Date.compare t2.Db_actions.task_finished t1.Db_actions.task_finished
       in
-      (* not enough to delete, oh well *)
+      let lucky, unlucky = sort_and_split compare limit completed in
       (* Keep all pending and any which were not chosen from the completed set *)
       (pending @ lucky, unlucky)
   in
@@ -456,11 +450,8 @@ let timeout_sessions_common ~__context sessions limit session_group =
   in
   (* If there are too many young sessions then we need to delete the oldest *)
   let _, unlucky =
-    if List.length young <= limit then
-      (young, []) (* keep them all *)
-    else (* Need to reverse sort by last active and drop the oldest *)
-      Listext.List.chop limit
-        (List.sort (fun (_, a, _) (_, b, _) -> compare b a) young)
+    let compare (_, a, _) (_, b, _) = compare b a in
+    sort_and_split compare limit young
   in
   let cancel doc sessions =
     List.iter

opam/stunnel.opam

@@ -18,6 +18,7 @@ depends: [
   "xapi-inventory"
   "xapi-log" {= version}
   "xapi-stdext-pervasives" {= version}
+  "xapi-stdext-std" {= version}
   "xapi-stdext-threads" {= version}
   "xapi-stdext-unix" {= version}
   "odoc" {with-doc}