irmin-pack: replace inode's Map by a list of pairs

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

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

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

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)

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) ]