unikernel/duniverse/base/test/map_full_interface/base_test_map_full_interface.ml

@@ -0,0 +1 @@
+(*_ This library deliberately exports nothing. *)

unikernel/duniverse/base/test/map_full_interface/dune

@@ -0,0 +1,6 @@
+(library
+ (name base_test_map_full_interface)
+ (libraries base base_quickcheck
+   expect_test_helpers_core.expect_test_helpers_base sexp_grammar)
+ (preprocess
+  (pps ppx_jane)))

unikernel/duniverse/base/test/map_full_interface/functor.mli

@@ -0,0 +1 @@
+include Functor_intf.Functor

unikernel/duniverse/base/test/map_full_interface/functor_intf.ml

@@ -0,0 +1,130 @@
+open! Base
+
+module Definitions = struct
+  (** The types that distinguish instances of [Map.Creators_and_accessors_generic]. *)
+  module type Types = sig
+    type 'k key
+    type 'c cmp
+    type ('k, 'v, 'c) t
+    type ('k, 'v, 'c) tree
+    type ('k, 'c, 'a) create_options
+    type ('k, 'c, 'a) access_options
+  end
+
+  (** Like [Map.Creators_and_accessors_generic], but based on [Types] for easier
+      instantiation. *)
+  module type S = sig
+    module Types : Types
+
+    include
+      Map.Creators_and_accessors_generic
+        with type ('a, 'b, 'c) t := ('a, 'b, 'c) Types.t
+        with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Types.tree
+        with type 'a key := 'a Types.key
+        with type 'a cmp := 'a Types.cmp
+        with type ('a, 'b, 'c) create_options := ('a, 'b, 'c) Types.create_options
+        with type ('a, 'b, 'c) access_options := ('a, 'b, 'c) Types.access_options
+  end
+
+  (** Helpers for testing a tree or map type that is an instance of [S]. *)
+  module type Instance = sig
+    module Types : Types
+
+    module Key : sig
+      type t = int Types.key [@@deriving compare, equal, quickcheck, sexp_of]
+
+      include Comparable.Infix with type t := t
+    end
+
+    type 'a t = (int, 'a, Int.comparator_witness) Types.t
+    [@@deriving equal, quickcheck, sexp_of]
+
+    (** Construct a [Key.t]. *)
+    val key : int -> Key.t
+
+    (** Extract an int from a [Key.t]. *)
+    val int : Key.t -> int
+
+    (** Extract a tree (without a comparator) from [t]. *)
+    val tree
+      :  (Key.t, 'a, Int.comparator_witness) Types.tree
+      -> (Key.t, 'a, Int.comparator_witness Types.cmp) Map.Using_comparator.Tree.t
+
+    (** Pass a comparator to a creator function, if necessary. *)
+    val create : (int, Int.comparator_witness, 'a) Types.create_options -> 'a
+
+    (** Pass a comparator to an accessor function, if necessary *)
+    val access : (int, Int.comparator_witness, 'a) Types.access_options -> 'a
+  end
+end
+
+module type Functor = sig
+  include module type of struct
+    include Definitions
+  end
+
+  (** Expect tests for everything exported from [Map.Creators_and_accessors_generic]. *)
+  module Test_creators_and_accessors
+    (Types : Types)
+    (Impl : S with module Types := Types)
+    (Instance : Instance with module Types := Types) : S with module Types := Types
+
+  (** A functor to generate all of [Instance] but [create] and [access] for a map type. *)
+  module Instance (Cmp : sig
+    type comparator_witness
+
+    val comparator : (int, comparator_witness) Comparator.t
+  end) : sig
+    module Key : sig
+      type t = int [@@deriving compare, equal, quickcheck, sexp_of]
+
+      include
+        Comparator.S with type t := t and type comparator_witness = Cmp.comparator_witness
+
+      include Comparable.Infix with type t := t
+    end
+
+    type 'a t = 'a Map.M(Key).t [@@deriving equal, quickcheck, sexp_of]
+
+    val key : 'a -> 'a
+    val int : 'a -> 'a
+    val tree : 'a -> 'a
+  end
+
+  (** A functor like [Instance], but for tree types. *)
+  module Instance_tree (Cmp : sig
+    type comparator_witness
+
+    val comparator : (int, comparator_witness) Comparator.t
+  end) : sig
+    module Key : sig
+      type t = int [@@deriving compare, equal, quickcheck, sexp_of]
+
+      include
+        Comparator.S
+          with type t := int
+           and type comparator_witness = Cmp.comparator_witness
+
+      include Comparable.Infix with type t := t
+    end
+
+    type 'a t = (int, 'a, Cmp.comparator_witness) Map.Using_comparator.Tree.t
+    [@@deriving equal, quickcheck, sexp_of]
+
+    val key : 'a -> 'a
+    val int : 'a -> 'a
+    val tree : 'a -> 'a
+  end
+
+  module Ok (T : sig
+    type t [@@deriving equal, sexp_of]
+  end) : sig
+    type t = T.t Or_error.t [@@deriving equal, sexp_of]
+  end
+
+  module Pair (T : sig
+    type t [@@deriving equal, quickcheck, sexp_of]
+  end) : sig
+    type t = T.t * T.t [@@deriving equal, quickcheck, sexp_of]
+  end
+end

unikernel/duniverse/base/test/map_full_interface/test_all.ml

@@ -0,0 +1,315 @@
+open! Base
+open Base_quickcheck
+open Expect_test_helpers_base
+open Functor
+open Map
+
+open struct
+  (** Instantiating key and data both as [int]. *)
+  module Instance_int = struct
+    module I = Instance (Int)
+
+    type t = int I.t [@@deriving equal, quickcheck, sexp_of]
+  end
+end
+
+(** module types *)
+
+module type Accessors_generic = Accessors_generic
+module type Creators_and_accessors_generic = Creators_and_accessors_generic
+module type Creators_generic = Creators_generic
+module type For_deriving = For_deriving
+module type S_poly = S_poly
+
+(** type-only modules for module type instantiation - untested *)
+
+module With_comparator = With_comparator
+module With_first_class_module = With_first_class_module
+module Without_comparator = Without_comparator
+
+(** supporting datatypes - untested *)
+
+module Continue_or_stop = Continue_or_stop
+module Finished_or_unfinished = Finished_or_unfinished
+module Merge_element = Merge_element
+module Or_duplicate = Or_duplicate
+module Symmetric_diff_element = Symmetric_diff_element
+
+(** types *)
+
+type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t
+
+(** module types for ppx deriving *)
+
+module type Compare_m = Compare_m
+module type Equal_m = Equal_m
+module type Hash_fold_m = Hash_fold_m
+module type M_sexp_grammar = M_sexp_grammar
+module type M_of_sexp = M_of_sexp
+module type Sexp_of_m = Sexp_of_m
+
+(** functor for ppx deriving - tested below *)
+
+module M = M
+
+(** sexp conversions and grammar *)
+
+let sexp_of_m__t = sexp_of_m__t
+let m__t_of_sexp = m__t_of_sexp
+
+let%expect_test _ =
+  quickcheck_m
+    [%here]
+    (module Instance_int)
+    ~f:(fun t ->
+      let sexp = [%sexp_of: int M(Int).t] t in
+      require_equal [%here] (module Sexp) sexp [%sexp (to_alist t : (int * int) list)];
+      let round_trip = [%of_sexp: int M(Int).t] sexp in
+      require_equal [%here] (module Instance_int) round_trip t);
+  [%expect {| |}]
+;;
+
+let m__t_sexp_grammar = m__t_sexp_grammar
+
+let%expect_test _ =
+  print_s [%sexp ([%sexp_grammar: int M(Int).t] : _ Sexp_grammar.t)];
+  [%expect
+    {|
+    (Tagged (
+      (key sexp_grammar.assoc)
+      (value ())
+      (grammar (
+        List (
+          Many (
+            List (
+              Cons
+              (Tagged ((key sexp_grammar.assoc.key) (value ()) (grammar Integer)))
+              (Cons
+                (Tagged (
+                  (key sexp_grammar.assoc.value) (value ()) (grammar Integer)))
+                Empty))))))))
+    |}]
+;;
+
+(** comparisons *)
+
+let compare_m__t = compare_m__t
+let equal_m__t = equal_m__t
+
+let%expect_test _ =
+  quickcheck_m
+    [%here]
+    (module Pair (Instance_int))
+    ~f:(fun (a, b) ->
+      require_equal
+        [%here]
+        (module Ordering)
+        (Ordering.of_int ([%compare: int M(Int).t] a b))
+        (Ordering.of_int ([%compare: (int * int) list] (to_alist a) (to_alist b)));
+      require_equal
+        [%here]
+        (module Bool)
+        ([%equal: int M(Int).t] a b)
+        ([%equal: (int * int) list] (to_alist a) (to_alist b)));
+  [%expect {| |}]
+;;
+
+(** hash functions *)
+
+let hash_fold_m__t = hash_fold_m__t
+let hash_fold_direct = hash_fold_direct
+
+let%expect_test _ =
+  quickcheck_m
+    [%here]
+    (module Instance_int)
+    ~f:(fun t ->
+      let actual_m = Hash.run [%hash_fold: int M(Int).t] t in
+      let actual_direct = Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t in
+      let expect = Hash.run [%hash_fold: (int * int) list] (to_alist t) in
+      require_equal [%here] (module Int) actual_m expect;
+      require_equal [%here] (module Int) actual_direct expect);
+  [%expect {| |}]
+;;
+
+(** comparator accessors - untested *)
+
+let comparator_s = comparator_s
+let comparator = comparator
+
+(** creators and accessors *)
+
+include (Test_toplevel : Test_toplevel.S)
+
+(** polymorphic comparison interface *)
+module Poly = struct
+  open Poly
+
+  type nonrec ('k, 'v) t = ('k, 'v) t
+  type nonrec ('k, 'v) tree = ('k, 'v) tree
+  type nonrec comparator_witness = comparator_witness
+
+  include (Test_poly : Test_poly.S)
+end
+
+(** comparator interface *)
+
+module Using_comparator = struct
+  open Using_comparator
+
+  (** type *)
+
+  type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t
+
+  (** comparator accessor - untested *)
+
+  let comparator = comparator
+
+  (** sexp conversions *)
+
+  let sexp_of_t = sexp_of_t
+  let t_of_sexp_direct = t_of_sexp_direct
+
+  let%expect_test _ =
+    quickcheck_m
+      [%here]
+      (module Instance_int)
+      ~f:(fun t ->
+        let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] t in
+        require_equal [%here] (module Sexp) sexp ([%sexp_of: int Map.M(Int).t] t);
+        let round_trip =
+          t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp
+        in
+        require_equal [%here] (module Instance_int) round_trip t);
+    [%expect {| |}]
+  ;;
+
+  (** hash function *)
+
+  let hash_fold_direct = hash_fold_direct
+
+  let%expect_test _ =
+    quickcheck_m
+      [%here]
+      (module Instance_int)
+      ~f:(fun t ->
+        require_equal
+          [%here]
+          (module Int)
+          (Hash.run (hash_fold_direct Int.hash_fold_t Int.hash_fold_t) t)
+          (Hash.run [%hash_fold: int Map.M(Int).t] t));
+    [%expect {| |}]
+  ;;
+
+  (** functor for polymorphic definition - untested *)
+
+  module Empty_without_value_restriction (Cmp : Comparator.S1) = struct
+    open Empty_without_value_restriction (Cmp)
+
+    let empty = empty
+  end
+
+  (** creators and accessors *)
+
+  include (Test_using_comparator : Test_using_comparator.S)
+
+  (** tree interface *)
+
+  module Tree = struct
+    open Tree
+
+    (** type *)
+
+    type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t
+
+    (** sexp conversions *)
+
+    let sexp_of_t = sexp_of_t
+    let t_of_sexp_direct = t_of_sexp_direct
+
+    let%expect_test _ =
+      let module Tree_int = struct
+        module I = Instance_tree (Int)
+
+        type t = int I.t [@@deriving equal, quickcheck, sexp_of]
+      end
+      in
+      quickcheck_m
+        [%here]
+        (module Tree_int)
+        ~f:(fun tree ->
+          let sexp = sexp_of_t Int.sexp_of_t Int.sexp_of_t [%sexp_of: _] tree in
+          require_equal
+            [%here]
+            (module Sexp)
+            sexp
+            ([%sexp_of: int Map.M(Int).t]
+               (Using_comparator.of_tree tree ~comparator:Int.comparator));
+          let round_trip =
+            t_of_sexp_direct ~comparator:Int.comparator Int.t_of_sexp Int.t_of_sexp sexp
+          in
+          require_equal [%here] (module Tree_int) round_trip tree);
+      [%expect {| |}]
+    ;;
+
+    (** polymorphic constructor - untested *)
+
+    let empty_without_value_restriction = empty_without_value_restriction
+
+    (** builders *)
+
+    module Build_increasing = struct
+      open Build_increasing
+
+      type nonrec ('k, 'v, 'c) t = ('k, 'v, 'c) t
+
+      (** tree builder functions *)
+
+      let empty = empty
+      let add_exn = add_exn
+      let to_tree = to_tree
+
+      let%expect_test _ =
+        let module Tree_int = struct
+          module I = Instance_tree (Int)
+
+          type t = int I.t [@@deriving equal, quickcheck, sexp_of]
+        end
+        in
+        quickcheck_m
+          [%here]
+          (module struct
+            type t =
+              ((int[@generator Base_quickcheck.Generator.small_strictly_positive_int])
+              * int)
+              list
+            [@@deriving quickcheck, sexp_of]
+          end)
+          ~f:(fun alist ->
+            let actual =
+              List.fold_result alist ~init:empty ~f:(fun builder (key, data) ->
+                Or_error.try_with (fun () ->
+                  add_exn builder ~comparator:Int.comparator ~key ~data))
+              |> Or_error.map ~f:to_tree
+            in
+            Or_error.iter actual ~f:(fun map ->
+              require [%here] (Tree.invariants map ~comparator:Int.comparator));
+            let expect =
+              match List.is_sorted_strictly alist ~compare:[%compare: int * _] with
+              | false -> Error (Error.of_string "not sorted")
+              | true ->
+                Ok
+                  (Map.Using_comparator.Tree.of_sequence_exn
+                     ~comparator:Int.comparator
+                     (Sequence.of_list alist))
+            in
+            require_equal [%here] (module Ok (Tree_int)) actual expect);
+        [%expect {| |}]
+      ;;
+    end
+
+    (** creators and accessors *)
+
+    include (Test_tree : Test_tree.S)
+  end
+end

unikernel/duniverse/base/test/map_full_interface/test_all.mli

@@ -0,0 +1,5 @@
+open! Base
+
+include module type of struct
+  include Map
+end [@remove_aliases]

unikernel/duniverse/base/test/map_full_interface/test_poly.ml

@@ -0,0 +1,15 @@
+open! Base
+include Test_poly_intf.Definitions
+include (Base.Map.Poly : S)
+
+let%expect_test "[Base.Map.Poly] creators/accessors" =
+  let open
+    Functor.Test_creators_and_accessors (Types) (Base.Map.Poly)
+      (struct
+        include Functor.Instance (Comparator.Poly)
+
+        let create x = x
+        let access x = x
+      end) in
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/map_full_interface/test_poly.mli

@@ -0,0 +1 @@
+include Test_poly_intf.Test_poly

unikernel/duniverse/base/test/map_full_interface/test_poly_intf.ml

@@ -0,0 +1,22 @@
+open! Base
+
+module Definitions = struct
+  module Types = struct
+    type 'key key = 'key
+    type 'cmp cmp = Comparator.Poly.comparator_witness
+    type ('key, 'data, 'cmp) t = ('key, 'data) Map.Poly.t
+    type ('key, 'data, 'cmp) tree = ('key, 'data) Map.Poly.tree
+    type ('key, 'cmp, 'fn) create_options = 'fn
+    type ('key, 'cmp, 'fn) access_options = 'fn
+  end
+
+  module type S = Functor.S with module Types := Types
+end
+
+module type Test_poly = sig
+  include module type of struct
+    include Definitions
+  end
+
+  include S
+end

unikernel/duniverse/base/test/map_full_interface/test_toplevel.ml

@@ -0,0 +1,15 @@
+open! Base
+include Test_toplevel_intf.Definitions
+include (Base.Map : S)
+
+let%expect_test "[Base.Map] creators/accessors" =
+  let open
+    Functor.Test_creators_and_accessors (Types) (Base.Map)
+      (struct
+        include Functor.Instance (Int)
+
+        let create f = f ((module Int) : _ Comparator.Module.t)
+        let access x = x
+      end) in
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/map_full_interface/test_toplevel.mli

@@ -0,0 +1 @@
+include Test_toplevel_intf.Test_toplevel

unikernel/duniverse/base/test/map_full_interface/test_toplevel_intf.ml

@@ -0,0 +1,22 @@
+open! Base
+
+module Definitions = struct
+  module Types = struct
+    type 'key key = 'key
+    type 'cmp cmp = 'cmp
+    type ('key, 'data, 'cmp) t = ('key, 'data, 'cmp) Map.t
+    type ('key, 'data, 'cmp) tree = ('key, 'data, 'cmp) Map.Using_comparator.Tree.t
+    type ('key, 'cmp, 'fn) create_options = ('key, 'cmp) Comparator.Module.t -> 'fn
+    type ('key, 'cmp, 'fn) access_options = 'fn
+  end
+
+  module type S = Functor.S with module Types := Types
+end
+
+module type Test_toplevel = sig
+  include module type of struct
+    include Definitions
+  end
+
+  include S
+end

unikernel/duniverse/base/test/map_full_interface/test_tree.ml

@@ -0,0 +1,15 @@
+open! Base
+include Test_tree_intf.Definitions
+include (Base.Map.Using_comparator.Tree : S)
+
+let%expect_test "[Base.Map.Using_comparator.Tree] creators/accessors" =
+  let open
+    Functor.Test_creators_and_accessors (Types) (Base.Map.Using_comparator.Tree)
+      (struct
+        include Functor.Instance_tree (Int)
+
+        let create f = f ~comparator:Int.comparator
+        let access f = f ~comparator:Int.comparator
+      end) in
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/map_full_interface/test_tree.mli

@@ -0,0 +1 @@
+include Test_tree_intf.Test_tree

unikernel/duniverse/base/test/map_full_interface/test_tree_intf.ml

@@ -0,0 +1,22 @@
+open! Base
+
+module Definitions = struct
+  module Types = struct
+    type 'key key = 'key
+    type 'cmp cmp = 'cmp
+    type ('key, 'data, 'cmp) t = ('key, 'data, 'cmp) Map.Using_comparator.Tree.t
+    type ('key, 'data, 'cmp) tree = ('key, 'data, 'cmp) Map.Using_comparator.Tree.t
+    type ('key, 'cmp, 'fn) create_options = comparator:('key, 'cmp) Comparator.t -> 'fn
+    type ('key, 'cmp, 'fn) access_options = comparator:('key, 'cmp) Comparator.t -> 'fn
+  end
+
+  module type S = Functor.S with module Types := Types
+end
+
+module type Test_tree = sig
+  include module type of struct
+    include Definitions
+  end
+
+  include S
+end

unikernel/duniverse/base/test/map_full_interface/test_using_comparator.ml

@@ -0,0 +1,15 @@
+open! Base
+include Test_using_comparator_intf.Definitions
+include (Base.Map.Using_comparator : S)
+
+let%expect_test "[Base.Map.Using_comparator] creators/accessors" =
+  let open
+    Functor.Test_creators_and_accessors (Types) (Base.Map.Using_comparator)
+      (struct
+        include Functor.Instance (Int)
+
+        let create f = f ~comparator:Int.comparator
+        let access x = x
+      end) in
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/map_full_interface/test_using_comparator.mli

@@ -0,0 +1 @@
+include Test_using_comparator_intf.Test_using_comparator

unikernel/duniverse/base/test/map_full_interface/test_using_comparator_intf.ml

@@ -0,0 +1,22 @@
+open! Base
+
+module Definitions = struct
+  module Types = struct
+    type 'key key = 'key
+    type 'cmp cmp = 'cmp
+    type ('key, 'data, 'cmp) t = ('key, 'data, 'cmp) Map.Using_comparator.t
+    type ('key, 'data, 'cmp) tree = ('key, 'data, 'cmp) Map.Using_comparator.Tree.t
+    type ('key, 'cmp, 'fn) create_options = comparator:('key, 'cmp) Comparator.t -> 'fn
+    type ('key, 'cmp, 'fn) access_options = 'fn
+  end
+
+  module type S = Functor.S with module Types := Types
+end
+
+module type Test_using_comparator = sig
+  include module type of struct
+    include Definitions
+  end
+
+  include S
+end