From ad273c5145f23f186850e0749d26e2c79a2415e0 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 19 Jul 2022 14:26:08 +0200 Subject: [PATCH] irmin-pack: replace inode's Map by a list of pairs --- src/irmin-pack/inode.ml | 12 ++--- src/irmin/import.ml | 103 +++++++++++++++++++++++++++++++++++++ src/irmin/mem/irmin_mem.ml | 4 +- test/irmin-mem/dune | 2 +- test/irmin-mem/test.ml | 63 ++++++++++++++++++++++- 5 files changed, 170 insertions(+), 14 deletions(-) diff --git a/src/irmin-pack/inode.ml b/src/irmin-pack/inode.ml index 4c15c6cb5f..f54ec66227 100644 --- a/src/irmin-pack/inode.ml +++ b/src/irmin-pack/inode.ml @@ -160,15 +160,9 @@ struct | `Custom f -> f end - module StepMap = struct - include Map.Make (struct - type t = T.step - - let compare = T.compare_step - end) - - let of_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l - end + module StepMap = Small_map.Make (struct + type t = T.step [@@deriving irmin] + end) module Val_ref : sig open T diff --git a/src/irmin/import.ml b/src/irmin/import.ml index db5ff6da02..a230823b5a 100644 --- a/src/irmin/import.ml +++ b/src/irmin/import.ml @@ -146,3 +146,106 @@ let shuffle state arr = let len = Array.length arr in aux (len - 1); () + +module Small_map = struct + module Make (K : sig + type t [@@deriving irmin] + end) : sig + type 'a t [@@deriving irmin] + type key = K.t + + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val of_list : (key * 'a) list -> 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val cardinal : 'a t -> int + val to_seq : 'a t -> (key * 'a) Seq.t + val of_seq : (key * 'a) Seq.t -> 'a t + val bindings : 'a t -> (key * 'a) list + val is_empty : 'a t -> bool + val find : key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option + val singleton : key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + val iter : (key -> 'a -> unit) -> 'a t -> unit + end = struct + type key = K.t [@@deriving irmin ~compare ~pp] + type 'a t = (key * 'a) list [@@deriving irmin] + + (* Use a (short) sorted list of pairs *) + let empty = [] + let is_empty = function [] -> true | _ -> false + let cardinal = List.length + + exception No_change + + let compare_pair (x, _) (y, _) = compare_key x y + + let remove k t = + (* non tail-rec as it's a short list *) + let rec aux = function + | [] -> raise No_change + | ((x, _) as e) :: rest -> ( + match compare_key x k with + | 0 -> rest + | i when i < 0 -> e :: aux rest + | _ -> raise No_change) + in + try aux t with No_change -> t + + let add k v t = + (* non tail-rec as it's a short list *) + let rec aux t = + match t with + | [] -> [ (k, v) ] + | ((x, y) as e) :: rest -> ( + match compare_key x k with + | 0 -> if y == v then raise No_change else (x, v) :: rest + | i when i < 0 -> e :: aux rest + | _ -> (k, v) :: t) + in + try aux t with No_change -> t + + let bindings t = t + let to_seq t = List.to_seq t + let singleton k v = [ (k, v) ] + let iter f t = List.iter (fun (k, v) -> f k v) t + + let find k t = + let rec aux = function + | [] -> raise Not_found + | (x, v) :: rest -> ( + match compare_key x k with + | 0 -> v + | i when i < 0 -> aux rest + | _ -> raise Not_found) + in + aux t + + let find_opt k t = try Some (find k t) with Not_found -> None + let fold f t acc = List.fold_left (fun acc (k, v) -> f k v acc) acc t + let of_list l = List.sort_uniq compare_pair l + let of_seq s = of_list (List.of_seq s) + + let update k f t = + (* non tail-rec as it's a short list *) + let rec aux t = + match t with + | [] -> ( + match f None with None -> raise No_change | Some v -> [ (k, v) ]) + | ((x, y) as e) :: rest -> ( + match compare_key x k with + | 0 -> ( + match f (Some y) with + | None -> rest + | Some v -> if v == y then raise No_change else (x, v) :: rest) + | i when i < 0 -> e :: aux rest + | _ -> ( + match f None with + | None -> raise No_change + | Some v -> (k, v) :: t)) + in + try aux t with No_change -> t + end +end diff --git a/src/irmin/mem/irmin_mem.ml b/src/irmin/mem/irmin_mem.ml index e69eefa1af..7431b12801 100644 --- a/src/irmin/mem/irmin_mem.ml +++ b/src/irmin/mem/irmin_mem.ml @@ -29,9 +29,7 @@ end module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct module KMap = Map.Make (struct - type t = K.t - - let compare = Irmin.Type.(unstage (compare K.t)) + type t = K.t [@@deriving irmin ~compare] end) type key = K.t diff --git a/test/irmin-mem/dune b/test/irmin-mem/dune index 1f548b95c1..9e0540235a 100644 --- a/test/irmin-mem/dune +++ b/test/irmin-mem/dune @@ -6,7 +6,7 @@ (executable (name test) (modules test) - (libraries alcotest lwt.unix irmin-test test_mem)) + (libraries alcotest qcheck-alcotest lwt.unix irmin-test test_mem)) (rule (alias runtest) diff --git a/test/irmin-mem/test.ml b/test/irmin-mem/test.ml index e2d99e032f..03fbe4e9e7 100644 --- a/test/irmin-mem/test.ml +++ b/test/irmin-mem/test.ml @@ -14,7 +14,68 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +module S = struct + type t = int + + let compare = ( - ) + let t = Irmin.Type.like ~compare Irmin.Type.int +end + +module M = Irmin.Export_for_backends.Small_map.Make (S) +module M' = Map.Make (S) + +type key = int +type action = Add of key * int | Remove of key | Update of key * int option + +let add k v = Add (k, v) +let remove k = Remove k +let update k v = Update (k, v) + +let gen_action = + QCheck.Gen.( + frequency + [ + (1, map2 add small_int nat); + (2, map remove small_int); + (3, map2 update small_int (option small_int)); + ]) + +let print_action = function + | Add (k, v) -> Fmt.str "Add %d %d" k v + | Remove k -> Fmt.str "Remove %d" k + | Update (k, v) -> Fmt.str "Update %d (%a)" k Fmt.(Dump.option int) v + +let apply t = function + | Add (k, v) -> M.add k v t + | Remove k -> M.remove k t + | Update (k, v) -> M.update k (fun _ -> v) t + +let apply' t = function + | Add (k, v) -> M'.add k v t + | Remove k -> M'.remove k t + | Update (k, v) -> M'.update k (fun _ -> v) t + +let run_aux apply empty t = + let rec aux acc = function [] -> acc | h :: t -> aux (apply acc h) t in + aux empty t + +let run = run_aux apply M.empty +let run' = run_aux apply' M'.empty +let eq m m' = M.bindings m = M'.bindings m' +let arbitrary_action = QCheck.make gen_action ~print:print_action + +let test = + QCheck.Test.make ~name:"Maps" ~count:10_000 + QCheck.(list arbitrary_action) + (fun t -> eq (run t) (run' t)) + +let to_lwt_alcotest test = + let map (x, y, f) = (x, y, fun () -> Lwt.return (f ())) in + map (QCheck_alcotest.to_alcotest test) + +let misc = [ ("small_map", [ to_lwt_alcotest test ]) ] + let () = Lwt_main.run - @@ Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + @@ Irmin_test.Store.run "irmin-mem" ~slow:true ~misc ~sleep:Lwt_unix.sleep [ (`Quick, Test_mem.suite) ]