unikernel/duniverse/gmap/CHANGES.md

@@ -0,0 +1,32 @@
+## 0.3.0 (2019-04-20)
+
+* S.union and S.merge could invalidate the invariant:
+  foreach k \in m . m[k] = (key, value) /\ k = key
+  which could lead to assertion fail in find
+* The signatures uses semi-explicit polymorphism with a record type:
+  * S.equal : { f : 'a key -> 'a -> 'a -> bool } -> t -> t -> bool
+  * S.merge : { f : 'a key -> 'a option -> 'a option -> 'a option } -> t -> t -> t
+  * S.union : { f : 'a key -> 'a -> 'a -> 'a option } -> t -> t -> t
+  * new function S.map : { f : 'a key -> 'a -> 'a } -> t -> t
+* Interface duplication for "bindings" and "value" were removed:
+  S.findb, S.getb, S.addb, S.addb_unless_bound no longer exist,
+  use S.find, S.get, S.add, S.add_unless_bound instead.
+* The pretty-printer S.pp was removed, and K.pp is no longer required! S.pp is:
+  let pp ppf = M.iter (fun (M.B (k, v)) -> Fmt.pf ppf (K.pp k) v)
+* no more Fmt dependency
+* added some initial tests
+
+## 0.2.1 (2019-02-16)
+
+* move build system to dune
+
+## 0.2.0 (2018-06-24)
+
+* New function `update`.
+* New function `add_unless_bound` and `addb_unless_bound`.
+* Replace `type v = V : 'a key * 'a -> v` by `type b = B : 'a key * 'a -> b`.
+* Renamed functions ending with `v` to `b`
+
+## 0.1.0 (2018-06-16)
+
+* Initial release

unikernel/duniverse/gmap/LICENSE.md

@@ -0,0 +1,16 @@
+(*
+ * Copyright (c) 2017 2018 Hannes Mehnert <hannes@mehnert.org>
+ *
+ * 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.
+ *
+ *)

unikernel/duniverse/gmap/README.md

@@ -0,0 +1,65 @@
+## Gmap - heterogenous maps over a GADT
+
+0.3.0
+
+Gmap exposes the functor `Make` which takes a key type (a
+[GADT](https://en.wikipedia.org/wiki/Generalized_algebraic_data_type) 'a key)
+and outputs a type-safe Map where each 'a key is associated with a 'a value.
+This removes the need for additional packing.  It uses OCaml's stdlib
+[Map](http://caml.inria.fr/pub/docs/manual-ocaml/libref/Map.html) data
+structure.
+
+```OCaml
+type _ key =
+  | I : int key
+  | S : string key
+
+module K = struct
+  type 'a t = 'a key
+
+  let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun t t' ->
+    let open Gmap.Order in
+    match t, t' with
+    | I, I -> Eq | I, _ -> Lt | _, I -> Gt
+    | S, S -> Eq
+end
+
+module M = Gmap.Make(K)
+
+
+let () =
+  let m = M.empty in
+  ...
+  match M.find I m with
+  | Some x -> Printf.printf "got %d\n" x
+  | None -> Printf.printf "found nothing\n"
+```
+
+This is already an exhaustive pattern match: there is no need for another case
+(for the constructor `B`) since the type system knows that looking for `A` will
+result in an `int`.
+
+Motivation came from parsing of protocols which usually specify optional values
+and extensions via a tag-length-value (TLV) mechanism: for a given tag the
+structure of value is different - see for example IP options, TCP options, DNS
+resource records, TLS hello extensions, etc.
+
+Discussing this problem with Justus Matthiesen during summer 2017, we came up
+with this design. Its main difference to Daniel C. Bünzli's
+[hmap](http://erratique.ch/software/hmap) is that in gmap the key-value GADT
+type must be provided when instantiating the functor.  In hmap, keys are created
+dynamically.
+
+## Documentation
+
+[![Build Status](https://travis-ci.org/hannesm/gmap.svg?branch=master)](https://travis-ci.org/hannesm/gmap)
+
+[API documentation](https://hannesm.github.io/gmap/doc/) is available online.
+
+## Installation
+
+You need [opam](https://opam.ocaml.org) installed on your system.  The command
+
+`opam install gmap`
+
+will install this library.

unikernel/duniverse/gmap/dune

@@ -0,0 +1,9 @@
+(library
+  (name gmap)
+  (public_name gmap)
+  (modules gmap))
+
+(test
+  (name tests)
+  (modules tests)
+  (libraries alcotest fmt gmap))

unikernel/duniverse/gmap/dune-project

@@ -0,0 +1,2 @@
+(lang dune 1.0)
+(name gmap)

unikernel/duniverse/gmap/gmap.ml

@@ -0,0 +1,180 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+(* this code wouldn't exist without Justus Matthiesen, thanks for the help! *)
+
+module Order = struct
+  type (_,_) t =
+    | Lt : ('a, 'b) t
+    | Eq : ('a, 'a) t
+    | Gt : ('a, 'b) t
+end
+
+module type KEY = sig
+  type _ t
+  val compare : 'a t -> 'b t -> ('a, 'b) Order.t
+end
+
+module type S = sig
+  type 'a key
+  type t
+
+  val empty : t
+  val singleton : 'a key -> 'a -> t
+  val is_empty : t -> bool
+  val cardinal : t -> int
+  val mem : 'a key -> t -> bool
+  val find : 'a key -> t -> 'a option
+  val get : 'a key -> t -> 'a
+  val add_unless_bound : 'a key -> 'a -> t -> t option
+  val add : 'a key -> 'a -> t -> t
+  val remove : 'a key -> t -> t
+  val update : 'a key -> ('a option -> 'a option) -> t -> t
+
+  type b = B : 'a key * 'a -> b
+
+  val min_binding : t -> b option
+  val max_binding : t -> b option
+  val any_binding :  t -> b option
+  val bindings : t -> b list
+
+  type eq = { f : 'a . 'a key -> 'a -> 'a -> bool }
+  val equal : eq -> t -> t -> bool
+
+  type mapper = { f : 'a. 'a key -> 'a -> 'a }
+  val map : mapper -> t -> t
+
+  val iter : (b -> unit) -> t -> unit
+  val fold : (b -> 'a -> 'a) -> t -> 'a -> 'a
+  val for_all : (b -> bool) -> t -> bool
+  val exists : (b -> bool) -> t -> bool
+  val filter : (b -> bool) -> t -> t
+  type merger = { f : 'a. 'a key -> 'a option -> 'a option -> 'a option }
+  val merge : merger -> t -> t -> t
+  type unionee = { f : 'a. 'a key -> 'a -> 'a -> 'a option }
+  val union : unionee -> t -> t -> t
+end
+
+module Make (Key : KEY) : S with type 'a key = 'a Key.t = struct
+  type 'a key = 'a Key.t
+  type k = K : 'a key -> k
+  type b = B : 'a key * 'a -> b
+
+  module M = Map.Make(struct
+      type t = k
+      let compare (K a) (K b) = match Key.compare a b with
+        | Order.Lt -> -1 | Order.Eq -> 0 | Order.Gt -> 1
+    end)
+
+  type t = b M.t
+
+  let empty = M.empty
+  let singleton k v = M.singleton (K k) (B (k, v))
+
+  let is_empty = M.is_empty
+  let mem k m = M.mem (K k) m
+
+  let add k v m = M.add (K k) (B (k, v)) m
+
+  let add_unless_bound k v m = if mem k m then None else Some (add k v m)
+
+  let remove k m = M.remove (K k) m
+
+  let get : type a. a key -> t -> a = fun k m ->
+    match M.find (K k) m with
+    | B (k', v) ->
+      (* TODO this compare (and further below similar ones) is only needed for
+         the type checker (to get the k = k' proof), because the invariant
+         foreach k . t [K k] = B (k', v) -> k = k' is preserved by this library
+
+         it could be replaced by:
+          - Obj.magic
+          - vendor and slight modification of Stdlib.Map
+          - using integers as key -> compare can be a single instruction
+         Stay better safe than sorry (at least for now) *)
+      match Key.compare k k' with
+      | Order.Eq -> v
+      | _ -> assert false
+
+  let find : type a. a key -> t -> a option = fun k m ->
+    try Some (get k m) with Not_found -> None
+
+  let update k f m =
+    match f (find k m) with
+    | None -> remove k m
+    | Some v -> add k v m
+
+  let any_binding m = try Some (snd (M.choose m)) with Not_found -> None
+  let min_binding m = try Some (snd (M.min_binding m)) with Not_found -> None
+  let max_binding m = try Some (snd (M.max_binding m)) with Not_found -> None
+  let bindings m = snd (List.split (M.bindings m))
+
+  let cardinal m = M.cardinal m
+
+  let for_all p m = M.for_all (fun _ b -> p b) m
+  let exists p m = M.exists (fun _ b -> p b) m
+
+  let iter f m = M.iter (fun _ b -> f b) m
+  let fold f m acc = M.fold (fun _ b acc -> f b acc) m acc
+  let filter p m = M.filter (fun _ b -> p b) m
+
+  type mapper = { f : 'a. 'a key -> 'a -> 'a }
+  let map f m = M.map (fun (B (k, v)) -> B (k, f.f k v)) m
+
+  type merger = { f : 'a. 'a key -> 'a option -> 'a option -> 'a option }
+  let merge f m m' =
+    M.merge (fun (K k) b b' ->
+        match b, b' with
+        | None, None ->
+          begin match f.f k None None with
+            | None -> None
+            | Some v -> Some (B (k, v))
+          end
+        | None, Some (B (k', v)) ->
+          (* see above comment about compare *)
+          begin match Key.compare k k' with
+            | Order.Eq ->
+              (match f.f k None (Some v) with
+               | None -> None
+               | Some v -> Some (B (k, v)))
+            | _ -> assert false
+          end
+        | Some (B (k', v)), None ->
+          (* see above comment about compare *)
+          begin match Key.compare k k' with
+            | Order.Eq ->
+              (match f.f k (Some v) None with
+               | None -> None
+               | Some v -> Some (B (k, v)))
+            | _ -> assert false
+          end
+        | Some (B (k', v)), Some (B (k'', v')) ->
+          (* see above comment about compare *)
+          begin match Key.compare k k', Key.compare k k'' with
+           | Order.Eq, Order.Eq ->
+             (match f.f k (Some v) (Some v') with
+              | None -> None
+              | Some v -> Some (B (k, v)))
+           | _ -> assert false
+          end)
+      m m'
+
+  type unionee = { f : 'a. 'a key -> 'a -> 'a -> 'a option }
+  let union f m m' =
+    M.union
+      (fun (K k) (B (k', v)) (B (k'', v')) ->
+         (* see above comment about compare *)
+         match Key.compare k k', Key.compare k k'' with
+         | Order.Eq, Order.Eq ->
+           (match f.f k v v' with None -> None | Some v'' -> Some (B (k, v'')))
+         | _ -> assert false)
+      m m'
+
+  type eq = { f : 'a . 'a key -> 'a -> 'a -> bool }
+  let equal cmp m m' =
+    M.equal (fun (B (k, v)) (B (k', v')) ->
+        (* see above comment about compare *)
+        match Key.compare k k' with
+        | Order.Eq -> cmp.f k v v'
+        | _ -> assert false)
+      m m'
+end

unikernel/duniverse/gmap/gmap.mli

@@ -0,0 +1,226 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+(* this code wouldn't exist without Justus Matthiesen, thanks for the help! *)
+
+(** Heterogenous maps over a GADT.
+
+    The motivation for this library originated in the area of parsing binary
+    network protocols, which often contain options and extensions in the form of
+    tag, length, value encodings: the set of tags and corresponding values is
+    specified in some Internet standard, and later extended by using a global
+    registry.  Examples are IP options, TCP options, DNS resource records, TLS
+    hello extensions, X.509v3 extensions, ... These extension mechanisms usually
+    include the invariant that each tag may only be present once.
+
+    A more naive approach is to use a variant type of all known tag-value
+    combinations and storing these in an association list while parsing, but
+    verifying the uniqueness invariant takes quadratic ([O(n^2)]) time, and
+    retrieving a specific option is only doable in linear [O(n)] time.
+    Additionally, packing and unpacking is required with the variant type
+    solution.
+
+    In gmap, {{:https://en.wikipedia.org/wiki/Generalized_algebraic_data_type}GADTs}
+    are used to provide key-dependent value types: each GADT constructor carries
+    their value type.  The underlying storage mechanism uses OCaml's stdlib
+    {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Map.html}Map} type:
+    Lookup takes [O(log n)] time.  The above mentioned uniqueness invariant can
+    be preserved while constructing the gmap if for insertion into the map only
+    {!S.update} and {!S.add_unless_bound} are used ({!S.add} replaces the
+    existing binding if present).
+
+    A small example:
+
+{[
+type _ key =
+  | I : int key
+  | S : string key
+
+module K = struct
+  type 'a t = 'a key
+
+  let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun t t' ->
+    let open Gmap.Order in
+    match t, t' with
+    | I, I -> Eq | I, _ -> Lt | _, I -> Gt
+    | S, S -> Eq
+end
+
+module GM = Gmap.Make(K)
+]}
+
+    Using [GM] is done as follows:
+
+{[
+match GM.find I (GM.singleton I 10) with
+| Some x -> x * x
+| None -> 0
+]}
+
+    {e 0.3.0 - {{:https://github.com/hannesm/gmap }homepage}} *)
+
+(** Ordering. *)
+module Order : sig
+
+  (** The ordering type embedding type equality for [Eq]. *)
+  type (_,_) t =
+    | Lt : ('a, 'b) t
+    | Eq : ('a, 'a) t
+    | Gt : ('a, 'b) t
+end
+
+(** Key. *)
+module type KEY = sig
+
+  type _ t
+  (** The type of a key *)
+
+  val compare : 'a t -> 'b t -> ('a, 'b) Order.t
+  (** [compare k k'] is the total order of keys. *)
+end
+
+(** Output signature of the functor {!Make} *)
+module type S = sig
+
+  type 'a key
+  (** The type for map keys whose lookup value is ['a]. *)
+
+  type t
+  (** The type of maps from type ['a key] to ['a]. *)
+
+  (** {2 Constructors} *)
+
+  val empty : t
+  (** [empty] is the empty map. *)
+
+  val singleton : 'a key -> 'a -> t
+  (** [singleton key value] creates a one-element map that contains a binding
+      [value] for [key]. *)
+
+  (** {2 Basic operations} *)
+
+  val is_empty : t -> bool
+  (** [is_empty m] returns [true] if the map [m] is empty, [false] otherwise. *)
+
+  val cardinal : t -> int
+  (** [cardinal m] returns the number of bindings of the map [m]. *)
+
+  (** {2 Lookup operations} *)
+
+  val mem : 'a key -> t -> bool
+  (** [mem key m] returns [true] if the map [m] contains a binding for [key]. *)
+
+  val find : 'a key -> t -> 'a option
+  (** [find key m] returns [Some v] if the binding of [key] in [m] is [v], or
+      [None] if [key] is not bound [m]. *)
+
+  val get : 'a key -> t -> 'a
+  (** [find key m] returns [v] if the binding of [key] in [m] is [v].
+
+      @raise Not_found if [m] does not contain a binding for [key]. *)
+
+  (** {2 Insertion and removal operations} *)
+
+  val add_unless_bound : 'a key -> 'a -> t -> t option
+  (** [add_unless_bound key value m] returns [Some m'], a map containing the
+      same bindings as [m], plus a binding of [key] to [value].  Or, [None] if
+      [key] was already bound in [m]. *)
+
+  val add : 'a key -> 'a -> t -> t
+  (** [add key value m] returns a map containing the same bindings as [m], plus
+      a binding of [key] to [value].  If [key] was already bound in [m], the
+      previous binding disappears. *)
+
+  val remove : 'a key -> t -> t
+  (** [remove key m] returns a map containing the same bindings as [m], except
+      for [key] which is not bound in the returned map.  If [key] was not bound
+      in [m], [m] is returned unchanged. *)
+
+  val update : 'a key -> ('a option -> 'a option) -> t -> t
+  (** [update k f m] returns a map containing the same bindings as [m], except
+      for the binding [v] of [k].  Depending the value of [v], which is
+      [f (find k m)], the binding of [k] is added, removed, or updated. *)
+
+  (** {2 Bindings} *)
+
+  type b = B : 'a key * 'a -> b
+  (** The type for a binding: a pair containing a key and its value. *)
+
+  (** {2 Selection of bindings} *)
+
+  val min_binding : t -> b option
+  (** [min_binding m] is the minimal binding in [m], [None] if [m] is empty. *)
+
+  val max_binding : t -> b option
+  (** [max_binding m] is the maximal binding in [m], [None] if [m] is empty. *)
+
+  val any_binding :  t -> b option
+  (** [any_binding m] is any binding in [m], [None] if [m] is empty. *)
+
+  val bindings : t -> b list
+  (** [bindings m] returns the list of all bindings in the given map [m].  The
+      list is sorted with respect to the ordering over the type of the keys. *)
+
+  (** {2 Higher-order functions} *)
+
+  type eq = { f : 'a . 'a key -> 'a -> 'a -> bool }
+  (** The function type for the equal operation, using a record type for
+      "first-class" semi-explicit polymorphism. *)
+
+  val equal : eq -> t -> t -> bool
+  (** [equal p m m'] tests whether the maps [m] and [m'] are equal, that is
+      contain equal keys and associate them with equal data.  [p] is the
+      equality predicate used to compare the data associated with the keys. *)
+
+  type mapper = { f : 'a. 'a key -> 'a -> 'a }
+  (** The function type for the map operation, using a record type for
+      "first-class" semi-explicit polymorphism. *)
+
+  val map : mapper -> t -> t
+  (** [map f m] returns a map with the same domain as [m], where the associated
+      binding [b] has been replaced by the result of the application of [f] to
+      [b]. The bindings are passed to [f] in increasing order with respect to
+      the ordering over the type of the keys. *)
+
+  val iter : (b -> unit) -> t -> unit
+  (** [iter f m] applies [f] to all bindings in [m].  The bindings are passed in
+      increasing order with respect to the ordering over the type of keys. *)
+
+  val fold : (b -> 'a -> 'a) -> t -> 'a -> 'a
+  (** [fold f m acc] computes [(f bN .. (f b1 acc))], where [b1 .. bN] are the
+      bindings of [m] in increasing order with respect to the ordering over the
+      type of the keys. *)
+
+  val for_all : (b -> bool) -> t -> bool
+  (** [for_all p m] checks if all bindings of the map [m] satisfy the predicate
+      [p]. *)
+
+  val exists : (b -> bool) -> t -> bool
+  (** [exists p m] checks if at least one binding of the map [m] satisfies
+      [p]. *)
+
+  val filter : (b -> bool) -> t -> t
+  (** [filter p m] returns the map with all the bindings in [m] that satisfy
+      [p]. *)
+
+  type merger = { f : 'a. 'a key -> 'a option -> 'a option -> 'a option }
+  (** The function type for the merge operation, using a record type for
+      "first-class" semi-explicit polymorphism. *)
+
+  val merge : merger -> t -> t -> t
+  (** [merge f m m'] computes a map whose keys is a subset of keys of [m] and
+      [m'].  The presence of each such binding, and the corresponding value, is
+      determined with the function [f]. *)
+
+  type unionee = { f : 'a. 'a key -> 'a -> 'a -> 'a option }
+  (** The function type for the union operation, using a record type for
+      "first-class" semi-explicit polymorphism. *)
+
+  val union : unionee -> t -> t -> t
+  (** [union f m m'] computes a map whose keys is the union of the keys of [m]
+      and [m'].  When the same binding is defined in both maps, the function [f]
+      is used to combine them. *)
+end
+
+(** Functor for heterogenous maps whose keys are provided by [Key]. *)
+module Make (Key : KEY) : sig
+  include S with type 'a key = 'a Key.t
+end

unikernel/duniverse/gmap/gmap.opam

@@ -0,0 +1,29 @@
+version: "0.3.0"
+opam-version: "2.0"
+maintainer: "Hannes Mehnert <hannes@mehnert.org>"
+authors: "Hannes Mehnert <hannes@mehnert.org>"
+license: "ISC"
+homepage: "https://github.com/hannesm/gmap"
+doc: "https://hannesm.github.io/gmap/doc"
+bug-reports: "https://github.com/hannesm/gmap/issues"
+depends: [
+  "ocaml" {>= "4.04.2"}
+  "dune" {build}
+  "alcotest" {with-test}
+  "fmt" {with-test}
+]
+build: [
+  ["dune" "subst"] {pinned}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/hannesm/gmap.git"
+synopsis: "Heterogenous maps over a GADT"
+description: """
+Gmap exposes the functor `Make` which takes a key type (a
+[GADT](https://en.wikipedia.org/wiki/Generalized_algebraic_data_type) 'a key)
+and outputs a type-safe Map where each 'a key is associated with a 'a value.
+This removes the need for additional packing.  It uses OCaml's stdlib
+[Map](http://caml.inria.fr/pub/docs/manual-ocaml/libref/Map.html) data
+structure.
+"""

unikernel/duniverse/gmap/tests.ml

@@ -0,0 +1,160 @@
+
+type _ key =
+  | I : int key
+  | S : string key
+
+let pp_m : type a . Format.formatter -> a key -> a -> unit = fun ppf k v ->
+  match k, v with
+  | I, x -> Fmt.pf ppf "I %d" x
+  | S, s -> Fmt.pf ppf "S %s" s
+
+let eq_m : type a. a key -> a -> a -> bool = fun k v v' ->
+  match k, v, v' with
+  | I, x, y -> x = y
+  | S, s, t -> String.equal s t
+
+module K = struct
+  type 'a t = 'a key
+
+  let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun t t' ->
+    let open Gmap.Order in
+    match t, t' with
+    | I, I -> Eq | I, _ -> Lt | _, I -> Gt
+    | S, S -> Eq
+end
+
+module M = Gmap.Make(K)
+
+let m_check =
+  let module M = struct
+    type t = M.t
+    let pp ppf m = M.iter (fun (M.B (k, v)) -> pp_m ppf k v) m
+    let equal a b = M.equal { f = eq_m } a b
+  end in
+  (module M: Alcotest.TESTABLE with type t = M.t)
+
+let b_check =
+  let module M = struct
+    type t = M.b
+    let pp ppf (M.B (k, v)) = pp_m ppf k v
+    let equal (M.B (k, v)) (M.B (k', v')) = match K.compare k k' with
+      | Gmap.Order.Eq -> eq_m k v v'
+      | _ -> false
+  end in
+  (module M: Alcotest.TESTABLE with type t = M.t)
+
+let empty () =
+  Alcotest.(check bool "empty map is empty" true (M.is_empty M.empty));
+  Alcotest.(check bool "mem on empty map doesn't have A" false (M.mem I M.empty));
+  Alcotest.(check (option int) "find on empty map doesn't have A" None
+              (M.find I M.empty));
+  Alcotest.(check (option string) "find on empty map doesn't have B" None
+              (M.find S M.empty));
+  Alcotest.(check (option b_check) "min binding is none" None
+              (M.min_binding M.empty));
+  Alcotest.(check (option b_check) "max binding is none" None
+              (M.max_binding M.empty));
+  Alcotest.(check (option b_check) "any binding is none" None
+              (M.any_binding M.empty));
+  Alcotest.(check (list b_check) "bindings is empty" []
+              (M.bindings M.empty))
+
+let basic () =
+  let m = M.singleton I 5 in
+  Alcotest.(check bool "non-empty map is not empty" false (M.is_empty m));
+  Alcotest.(check int "non-empty map has cardinal 1" 1 (M.cardinal m));
+  Alcotest.(check bool "non-empty map has member I" true (M.mem I m));
+  Alcotest.(check (option int) "non-empty map finds I" (Some 5) (M.find I m));
+  Alcotest.check m_check "singleton and add are equivalent" m (M.add I 5 M.empty);
+  Alcotest.(check bool "removing I from map makes it empty" true
+              (M.is_empty (M.remove I m)));
+  Alcotest.(check bool "removing S from map makes it not empty" false
+              (M.is_empty (M.remove S m)));
+  Alcotest.check m_check "add overwrites" (M.singleton I 10) (M.add I 10 m);
+  Alcotest.(check (option m_check) "add_unless_bound does not overwrite" None
+              (M.add_unless_bound I 10 m));
+  Alcotest.check m_check "update updates" (M.singleton I 20)
+    (M.update I (fun _ -> Some 20) m);
+  Alcotest.(check (option b_check) "min_binding is I 5" (Some (M.B (I, 5)))
+              (M.min_binding m));
+  Alcotest.(check (option b_check) "max_binding is I 5" (Some (M.B (I, 5)))
+              (M.max_binding m));
+  Alcotest.(check (option b_check) "any_binding is I 5" (Some (M.B (I, 5)))
+              (M.any_binding m));
+  Alcotest.(check (list b_check) "bindings is [ I 5 ]" [ M.B (I, 5) ]
+              (M.bindings m))
+
+let bad_eq_false : type a. a key -> a -> a -> bool = fun _ _ _ -> false
+let bad_eq_true : type a. a key -> a -> a -> bool = fun _ _ _ -> true
+
+let eq () =
+  let m = M.singleton I 5 in
+  Alcotest.(check bool "m equal is ok" true (M.equal { f = eq_m } m m));
+  Alcotest.(check bool "m equal is ok with singleton" true
+              (M.equal { f = eq_m } m (M.singleton I 5)));
+  Alcotest.(check bool "m equal is false" false
+              (M.equal { f = eq_m } m M.empty));
+  Alcotest.(check bool "m equal is false" false
+              (M.equal { f = eq_m } m (M.singleton S "foo")));
+  Alcotest.(check bool "m equal is false" false
+              (M.equal { f = eq_m } m (M.singleton I 10)));
+  Alcotest.(check bool "m equal is false" false
+              (M.equal { f = eq_m } m (M.add S "foo" (M.singleton I 10))));
+  Alcotest.(check bool "m bad equal is always false" false
+              (M.equal { f = bad_eq_false } m m));
+  Alcotest.(check bool "m bad equal is always true" true
+              (M.equal { f = bad_eq_true } m m))
+
+let preds () =
+  let m = M.singleton I 5 in
+  let m' = M.add S "foobar" m in
+  let m'' = M.singleton I 10 in
+  let p (M.B (k, v)) = match k with I -> v = 5 | _ -> false in
+  Alcotest.(check bool "for_all works" true (M.for_all p m));
+  Alcotest.(check bool "for_all works m'" false (M.for_all p m'));
+  Alcotest.(check bool "for_all works m''" false (M.for_all p m''));
+  Alcotest.(check bool "exists works" true (M.exists p m));
+  Alcotest.(check bool "exists works m'" true (M.exists p m'));
+  Alcotest.(check bool "exists works m''" false (M.exists p m''));
+  Alcotest.check m_check "filter works" m (M.filter p m);
+  Alcotest.check m_check "filter works m'" m (M.filter p m');
+  Alcotest.check m_check "filter works m''" M.empty (M.filter p m'')
+
+let map () =
+  let m = M.singleton I 5 in
+  let map : type a . a key -> a -> a = fun k _v ->
+    match k with
+    | I -> 100
+    | S -> "Foo"
+  in
+  Alcotest.check m_check "mapped m is equal as expected"
+    (M.singleton I 100) (M.map { f = map } m);
+  Alcotest.check m_check "mapped m is equal as expected"
+    (M.add S "Foo" (M.singleton I 100))
+    (M.map { f = map } (M.add S "barf" m))
+
+let l_wins : type a . a key -> a -> a -> a option = fun _ v _ -> Some v
+let r_wins : type a . a key -> a -> a -> a option = fun _ _ v' -> Some v'
+let no_wins : type a . a key -> a -> a -> a option = fun _ _ _ -> None
+
+let union () =
+  let m = M.add I 100 (M.singleton S "foo") in
+  Alcotest.check m_check "union map left wins is good" m
+    (M.union { f = l_wins } m (M.singleton S "bar"));
+  Alcotest.check m_check "union map right wins is good"
+    (M.add I 100 (M.singleton S "bar"))
+    (M.union { f = r_wins } m (M.singleton S "bar"));
+  Alcotest.check m_check "union map right wins is good"
+    (M.singleton I 100)
+    (M.union { f = no_wins } m (M.singleton S "bar"))
+
+let tests = [
+  "empty gmap", `Quick, empty ;
+  "basic gmap", `Quick, basic ;
+  "equality", `Quick, eq ;
+  "predicates", `Quick, preds ;
+  "map", `Quick, map ;
+  "union", `Quick, union ;
+]
+
+let () = Alcotest.run "gmap tests" [ "gmap suite", tests ]