Source file node.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
(*
 * Copyright (c) 2018-2022 Tarides <contact@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

let check _pos typ ~expected actual =
  let typ =
    Alcotest.testable Irmin.Type.(pp_dump typ) Irmin.Type.(unstage (equal typ))
  in
  Alcotest.check typ "" expected actual

module type Map = sig
  type t [@@deriving irmin]
  type data [@@deriving irmin]
  type key := string

  val empty : unit -> t
  val is_empty : t -> bool
  val length : t -> int
  val list : ?offset:int -> ?length:int -> ?cache:bool -> t -> (key * data) list
  val find : ?cache:bool -> t -> key -> data option
  val add : t -> key -> data -> t
  val remove : t -> key -> t

  (* Generators for use by the tests: *)
  val random_data : unit -> data
end

module Suite (Map : Map) = struct
  type key = string [@@deriving irmin]

  let random_bindings n =
    List.init n (fun i -> (string_of_int i, Map.random_data ()))

  let map_of_bindings kvs =
    List.fold_left (fun t (k, v) -> Map.add t k v) (Map.empty ()) kvs

  let test_empty () =
    check __POS__ [%typ: bool] ~expected:true Map.(is_empty (empty ()));
    check __POS__ [%typ: int] ~expected:0 Map.(length (empty ()));
    check __POS__ [%typ: (key * Map.data) list] ~expected:[]
      Map.(list (empty ()))

  let test_add () =
    let with_binding k v t = Map.add t k v in
    let d1 = Map.random_data () and d2 = Map.random_data () in
    let a = Map.empty () |> with_binding "1" d1 |> with_binding "2" d2 in
    check __POS__ [%typ: int] ~expected:2 (Map.length a)

  let test_remove () =
    (* Remove is a no-op on an empty node *)
    check __POS__ [%typ: Map.t] ~expected:(Map.empty ())
      Map.(remove (empty ()) "foo")

  let test_find () =
    let bindings = random_bindings 256 in
    let node = map_of_bindings bindings in
    bindings
    |> List.iter (fun (k, v) ->
           check __POS__ [%typ: Map.data option] ~expected:(Some v)
             (Map.find node k))

  let test_equal () =
    let module Map = struct
      include Map

      type nonrec t = t [@@deriving irmin ~equal ~to_bin_string ~of_bin_string]
    end in
    let bindings = random_bindings 256 in
    let m = map_of_bindings bindings in

    let m_rev = map_of_bindings (List.rev bindings) in
    check __POS__ [%typ: bool] ~expected:true (Map.equal m m_rev);

    let m_subset = map_of_bindings (List.tl bindings) in
    check __POS__ [%typ: bool] ~expected:false (Map.equal m m_subset);

    let m_serialised =
      m |> Map.to_bin_string |> Map.of_bin_string |> Result.get_ok
    in
    check __POS__ [%typ: bool] ~expected:true (Map.equal m m_serialised)

  let suite =
    [
      ("empty", test_empty);
      ("add", test_add);
      ("remove", test_remove);
      ("find", test_find);
      ("equal", test_equal);
    ]
end

module Make (Make_node : Irmin.Node.Generic_key.Maker) : sig
  val suite : unit Alcotest.test_case list
end = struct
  (* For each [Node] maker, we can instantiate the test suite above twice: once
     for regular nodes, and once for portable nodes. *)

  module Schema = Irmin.Schema.KV (Irmin.Contents.String)
  module Hash = Schema.Hash
  module Key = Irmin.Key.Of_hash (Hash)
  module Node = Make_node (Hash) (Schema.Path) (Schema.Metadata) (Key) (Key)

  type key = Key.t [@@deriving irmin]

  module Extras = struct
    type data = [ `Node of Key.t | `Contents of Key.t * unit ]
    [@@deriving irmin]

    let random_data =
      let hash_of_string = Irmin.Type.(unstage (of_bin_string Hash.t)) in
      let random_string =
        Irmin.Type.(unstage (random (string_of (`Fixed Hash.hash_size))))
      in
      fun () ->
        match hash_of_string (random_string ()) with
        | Error _ -> assert false
        | Ok x -> (
            match Random.int 2 with
            | 0 -> `Node x
            | 1 -> `Contents (x, ())
            | _ -> assert false)
  end

  let suite =
    let tc (name, f) = Alcotest.test_case name `Quick f in
    let module Suite_node = Suite (struct
      include Node
      include Extras
    end) in
    let module Suite_node_portable = Suite (struct
      include Node.Portable
      include Extras
    end) in
    List.map tc Suite_node.suite
    @ List.map
        (fun (name, f) -> tc ("Portable." ^ name, f))
        Suite_node_portable.suite
end