[sledge] Add Comparer: type-indexed compare functions

Summary:
A comparer `('a, 'compare_a) t` for type `'a` is a "compare" function
of type `'a -> 'a -> int` tagged with a phantom type `'compare_a`
acting as a singleton type denoting an individual compare function.

The point of these is to enable writing type definitions of containers
that depend on a compare function prior to applying a functor. For
example, a type of sorted lists could be exposed as:
```
type elt
type (elt, 'compare_elt) t = private elt list
```
and the operations manipulating sorted lists would be defined by a
functor that accepts a `Comparer.S` and implements the operations
using
```
let compare = (comparer :> elt -> elt -> int)
```

Reviewed By: ngorogiannis

Differential Revision: D26250528

fbshipit-source-id: ea61844ec

sledge/nonstdlib/NS.ml

@@ -30,6 +30,7 @@ let mapN f e cons xs =
   let xs' = Array.map_endo ~f xs in
   if xs' == xs then e else cons xs'
 
+module Comparer = Comparer
 module Array = Array
 module Float = Float
 module HashSet = HashSet

sledge/nonstdlib/NS.mli

@@ -146,6 +146,7 @@ include module type of Iter.Import
 
 (** Containers *)
 
+module Comparer = Comparer
 module Option = Option
 include module type of Option.Import
 

sledge/nonstdlib/comparer.ml

@@ -0,0 +1,86 @@
+(*
+ * Copyright (c) Facebook, Inc. and its affiliates.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Singleton types for compare functions *)
+
+type ('a, 'compare_a) t = 'a -> 'a -> int
+
+module type S = sig
+  type ('a, 'compare_a) comparer := ('a, 'compare_a) t
+  type t
+  type compare [@@deriving compare, equal, sexp]
+
+  val comparer : (t, compare) comparer
+end
+
+module type S1 = sig
+  type ('a, 'compare_a) comparer := ('a, 'compare_a) t
+  type 'a t
+  type 'compare_a compare [@@deriving compare, equal, sexp]
+
+  val comparer :
+    ('a, 'compare_a) comparer -> ('a t, 'compare_a compare) comparer
+end
+
+module Make (Ord : sig
+  type t [@@deriving compare]
+end) =
+struct
+  include Ord
+
+  type compare [@@deriving compare, equal, sexp]
+
+  let comparer = Ord.compare
+end
+
+module Counterfeit (Ord : sig
+  type t [@@deriving compare]
+  type compare [@@deriving compare, equal, sexp]
+end) =
+struct
+  include Ord
+
+  let comparer = Ord.compare
+end
+
+module Apply (F : sig
+  type ('a, 'compare_a) t [@@deriving compare]
+  type 'compare_a compare [@@deriving compare, equal, sexp]
+end)
+(A : S) =
+struct
+  module A = struct
+    include A
+
+    let compare = comparer
+  end
+
+  type t = (A.t, A.compare) F.t [@@deriving compare]
+  type compare = A.compare F.compare [@@deriving compare, equal, sexp]
+
+  let comparer = compare
+end
+
+module Apply1 (F : sig
+  type ('a, 'b, 'compare_a) t [@@deriving compare]
+  type ('compare_a, 'compare_b) compare [@@deriving compare, equal, sexp]
+end)
+(A : S) =
+struct
+  module A = struct
+    include A
+
+    let compare = comparer
+  end
+
+  type 'b t = (A.t, 'b, A.compare) F.t [@@deriving compare]
+
+  type 'b compare = (A.compare, 'b) F.compare
+  [@@deriving compare, equal, sexp]
+
+  let comparer = compare
+end

sledge/nonstdlib/comparer.mli

@@ -0,0 +1,86 @@
+(*
+ * Copyright (c) Facebook, Inc. and its affiliates.
+ *
+ * This source code is licensed under the MIT license found in the
+ * LICENSE file in the root directory of this source tree.
+ *)
+
+(** Singleton types for compare functions *)
+
+(** A comparer [('a, 'compare_a) t] for type ['a] is a "compare" function of
+    type ['a -> 'a -> int] tagged with a phantom type ['compare_a] acting as
+    a singleton type denoting an individual compare function. *)
+type ('a, 'compare_a) t = private 'a -> 'a -> int
+
+module type S = sig
+  type ('a, 'compare_a) comparer := ('a, 'compare_a) t
+  type t
+
+  (** [compare] types are equipped with functions to support use of
+      [@@deriving compare, equal, sexp] on types parameterized by such
+      singleton types for compare functions. These derived functions are
+      never actually called, since the compare type parameters are phantom. *)
+  type compare [@@deriving compare, equal, sexp]
+
+  val comparer : (t, compare) comparer
+end
+
+(** [Make] takes a [compare] function, mints a fresh [compare] type to act
+    as a singleton type denoting that one compare function, and returns the
+    [compare] function at a type stamped with its singleton type. In this
+    way, [Make] applied to two different compare functions for the same type
+    of values yields comparers with incompatible types. *)
+module Make (Ord : sig
+  type t [@@deriving compare]
+end) : S with type t = Ord.t
+
+(** [Counterfeit] takes a compare function and type and yields a comparer
+    that asserts that the given [compare] type is a singleton for the given
+    [compare] function. This is not checked by the type system. It is the
+    client's responsibility to ensure that distinct types are provided for
+    distinct compare functions. If the same type is used for multiple
+    functions, then [Counterfeit] will produce type-compatible comparers
+    even though the wrapped compare functions differ. *)
+module Counterfeit (Ord : sig
+  type t [@@deriving compare]
+  type compare [@@deriving compare, equal, sexp]
+end) : S with type t = Ord.t with type compare = Ord.compare
+
+(** [Apply (F) (A)] takes a type [('a, 'compare_a) F.t] with a type
+    parameter ['a] and a compare type ['compare_a] for ['a], and a comparer
+    [A], and creates a comparer for [F.t] with ['a] instantiated to [A.t]. *)
+module Apply (F : sig
+  type ('a, 'compare_a) t [@@deriving compare]
+  type 'compare_a compare [@@deriving compare, equal, sexp]
+end)
+(A : S) : sig
+  type t = (A.t, A.compare) F.t [@@deriving compare]
+
+  include S with type t := t with type compare = A.compare F.compare
+end
+
+module type S1 = sig
+  type ('a, 'compare_a) comparer := ('a, 'compare_a) t
+  type 'a t
+  type 'compare_a compare [@@deriving compare, equal, sexp]
+
+  val comparer :
+    ('a, 'compare_a) comparer -> ('a t, 'compare_a compare) comparer
+end
+
+(** [Apply1 (F) (A)] takes a type [('a, 'b, 'compare_a) F.t] with two type
+    parameters ['a], ['b] and a compare type ['compare_a] for ['a], and a
+    comparer [A], and creates a comparer for [F.t] with ['a] instantiated to
+    [A.t]. *)
+module Apply1 (F : sig
+  type ('a, 'b, 'compare_a) t [@@deriving compare]
+  type ('compare_a, 'compare_b) compare [@@deriving compare, equal, sexp]
+end)
+(A : S) : sig
+  type 'b t = (A.t, 'b, A.compare) F.t [@@deriving compare]
+
+  include
+    S1
+      with type 'b t := 'b t
+      with type 'compare_b compare = (A.compare, 'compare_b) F.compare
+end