From e3c05d344d56a5a5cd178a9e8e5995f20bac5e7c Mon Sep 17 00:00:00 2001 From: public-release Date: Tue, 29 Aug 2023 18:32:07 +0100 Subject: [PATCH] v0.17~preview.128.37+01 --- src/applicative.ml | 12 + src/applicative_intf.ml | 1 + src/base.ml | 2 + src/dictionary_immutable.ml | 1 + src/dictionary_immutable.mli | 1 + src/dictionary_immutable_intf.ml | 704 ++++++++++++++++++++++++++ src/dictionary_mutable.ml | 1 + src/dictionary_mutable.mli | 1 + src/dictionary_mutable_intf.ml | 692 +++++++++++++++++++++++++ src/dune | 3 +- src/float.ml | 12 +- src/float.mli | 8 +- src/float0.ml | 47 +- src/float_stubs.c | 17 + src/hashtbl_intf.ml | 25 +- src/int.ml | 2 +- src/int32.ml | 6 +- src/int63_emul.ml | 2 +- src/int64.ml | 2 +- src/int_math_stubs.c | 4 +- src/map_intf.ml | 27 +- src/nativeint.ml | 2 +- src/nothing.ml | 3 +- src/nothing.mli | 3 + src/runtime.js | 11 + src/string.mli | 1 + src/type_equal.ml | 22 +- src/type_equal.mli | 221 +------- src/type_equal_intf.ml | 265 ++++++++++ src/uniform_array.ml | 7 + src/uniform_array.mli | 2 + test/test_dictionary_module_types.ml | 225 ++++++++ test/test_dictionary_module_types.mli | 1 + test/test_float.ml | 29 ++ 34 files changed, 2092 insertions(+), 270 deletions(-) create mode 100644 src/dictionary_immutable.ml create mode 100644 src/dictionary_immutable.mli create mode 100644 src/dictionary_immutable_intf.ml create mode 100644 src/dictionary_mutable.ml create mode 100644 src/dictionary_mutable.mli create mode 100644 src/dictionary_mutable_intf.ml create mode 100644 src/float_stubs.c create mode 100644 src/type_equal_intf.ml create mode 100644 test/test_dictionary_module_types.ml create mode 100644 test/test_dictionary_module_types.mli diff --git a/src/applicative.ml b/src/applicative.ml index 0859ae26..3d5e526c 100644 --- a/src/applicative.ml +++ b/src/applicative.ml @@ -258,3 +258,15 @@ module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t = struct let map = `Custom custom_map end) end + +module Ident = struct + type 'a t = 'a + + include Make_using_map2_local (struct + type nonrec 'a t = 'a t + + let return = Fn.id + let map2 a b ~f = f a b + let map = `Custom (fun a ~f -> f a) + end) +end diff --git a/src/applicative_intf.ml b/src/applicative_intf.ml index 19266d13..37bb8cee 100644 --- a/src/applicative_intf.ml +++ b/src/applicative_intf.ml @@ -476,6 +476,7 @@ module type Applicative = sig module type S_local = S_local module type S2_local = S2_local + module Ident : S_local with type 'a t = 'a module S2_to_S (T : T.T) (X : S2) : S with type 'a t = ('a, T.t) X.t module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t module S3_to_S2 (T : T.T) (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, T.t) X.t diff --git a/src/base.ml b/src/base.ml index 7b591272..d7734aa9 100644 --- a/src/base.ml +++ b/src/base.ml @@ -114,6 +114,8 @@ module Int64 = Int64 module Intable = Intable module Int_math = Int_math module Invariant = Invariant +module Dictionary_immutable = Dictionary_immutable +module Dictionary_mutable = Dictionary_mutable module Lazy = Lazy module List = List module Map = Map diff --git a/src/dictionary_immutable.ml b/src/dictionary_immutable.ml new file mode 100644 index 00000000..69214019 --- /dev/null +++ b/src/dictionary_immutable.ml @@ -0,0 +1 @@ +include Dictionary_immutable_intf.Definitions diff --git a/src/dictionary_immutable.mli b/src/dictionary_immutable.mli new file mode 100644 index 00000000..f60c9180 --- /dev/null +++ b/src/dictionary_immutable.mli @@ -0,0 +1 @@ +include Dictionary_immutable_intf.Dictionary_immutable (** @inline *) diff --git a/src/dictionary_immutable_intf.ml b/src/dictionary_immutable_intf.ml new file mode 100644 index 00000000..82ebb8ed --- /dev/null +++ b/src/dictionary_immutable_intf.ml @@ -0,0 +1,704 @@ +(** Interfaces for immutable dictionary types, such as [Map.t]. + + We define separate interfaces for [Accessors] and [Creators], along with [S] combining + both. These interfaces are written once in their most general form, which involves + extra type definitions and type parameters that most instances do not need. + + We then provide instantiations of these interfaces with 1, 2, and 3 type parameters + for [t]. These cover more common usage patterns for the interfaces. *) + +open! Import + +(** These definitions are re-exported by [Dictionary_immutable]. *) +module Definitions = struct + module type Accessors = sig + (** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed + type for dictionaries with monomorphic keys. *) + type 'key key + + (** Dictionaries. Their keys have type ['key key]. Each key's associated value has + type ['data]. The dictionary may be distinguished by a ['phantom] type. *) + type ('key, 'data, 'phantom) t + + (** The type of accessor functions ['fn] that operate on [('key, 'data, 'phantom) t]. + May take extra arguments before ['fn], such as a comparison function. *) + type ('fn, 'key, 'data, 'phantom) accessor + + (** Whether the dictionary is empty. *) + val is_empty : (_, _, _) t -> bool + + (** How many key/value pairs the dictionary contains. *) + val length : (_, _, _) t -> int + + (** All key/value pairs. *) + val to_alist : ('key, 'data, _) t -> ('key key * 'data) list + + (** All keys in the dictionary, in the same order as [to_alist]. *) + val keys : ('key, _, _) t -> 'key key list + + (** All values in the dictionary, in the same order as [to_alist]. *) + val data : (_, 'data, _) t -> 'data list + + (** Like [to_alist]. Produces a sequence. *) + val to_sequence : ('key, 'data, 'phantom) t -> ('key key * 'data) Sequence.t + + (** Whether [key] has a value. *) + val mem : (('key, _, 'phantom) t -> 'key key -> bool, 'key, 'data, 'phantom) accessor + + (** Produces the current value, or absence thereof, for a given key. *) + val find + : ( ('key, 'data, 'phantom) t -> 'key key -> 'data option + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [find]. Raises if there is no value for the given key. *) + val find_exn + : (('key, 'data, 'phantom) t -> 'key key -> 'data, 'key, 'data, 'phantom) accessor + + (** Adds a key/value pair for a key the dictionary does not contain, or reports a + duplicate. *) + val add + : ( ('key, 'data, 'phantom) t + -> key:'key key + -> data:'data + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate ] + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [add]. Raises on duplicates. *) + val add_exn + : ( ('key, 'data, 'phantom) t + -> key:'key key + -> data:'data + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds or replaces a key/value pair in the dictionary. *) + val set + : ( ('key, 'data, 'phantom) t + -> key:'key key + -> data:'data + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Removes any value for the given key. *) + val remove + : ( ('key, 'data, 'phantom) t -> 'key key -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds, replaces, or removes the value for a given key, depending on its current + value or lack thereof. *) + val change + : ( ('key, 'data, 'phantom) t + -> 'key key + -> f:(('data option -> 'data option)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds or replaces the value for a given key, depending on its current value or + lack thereof. *) + val update + : ( ('key, 'data, 'phantom) t + -> 'key key + -> f:(('data option -> 'data)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds [data] to the existing key/value pair for [key]. Interprets a missing key as + having an empty list. *) + val add_multi + : ( ('key, 'data list, 'phantom) t + -> key:'key key + -> data:'data + -> ('key, 'data list, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Removes one element from the existing key/value pair for [key]. Removes the key + entirely if the new list is empty. *) + val remove_multi + : ( ('key, 'data list, 'phantom) t -> 'key key -> ('key, 'data list, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Produces the list associated with the corresponding key. Interprets a missing + key as having an empty list. *) + val find_multi + : ( ('key, 'data list, 'phantom) t -> 'key key -> 'data list + , 'key + , 'data + , 'phantom ) + accessor + + (** Combines every value in the dictionary. *) + val fold + : ('key, 'data, _) t + -> init:'acc + -> f:((key:'key key -> data:'data -> 'acc -> 'acc)[@local]) + -> 'acc + + (** Like [fold]. May stop before completing the iteration. *) + val fold_until + : ('key, 'data, _) t + -> init:'acc + -> f: + ((key:'key key + -> data:'data + -> 'acc + -> ('acc, 'final) Container.Continue_or_stop.t) + [@local]) + -> finish:(('acc -> 'final)[@local]) + -> 'final + + (** Whether every value satisfies [f]. *) + val for_all : ('key, 'data, _) t -> f:(('data -> bool)[@local]) -> bool + + (** Like [for_all]. The predicate may also depend on the associated key. *) + val for_alli + : ('key, 'data, _) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> bool + + (** Whether at least one value satisfies [f]. *) + val exists : ('key, 'data, _) t -> f:(('data -> bool)[@local]) -> bool + + (** Like [exists]. The predicate may also depend on the associated key. *) + val existsi + : ('key, 'data, _) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> bool + + (** How many values satisfy [f]. *) + val count : ('key, 'data, _) t -> f:(('data -> bool)[@local]) -> int + + (** Like [count]. The predicate may also depend on the associated key. *) + val counti + : ('key, 'data, _) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> int + + (** Produces the key/value pair with the smallest key if non-empty. *) + val min_elt : ('key, 'data, _) t -> ('key key * 'data) option + + (** Like [min_elt]. Raises if empty. *) + val min_elt_exn : ('key, 'data, _) t -> 'key key * 'data + + (** Produces the key/value pair with the largest key if non-empty. *) + val max_elt : ('key, 'data, _) t -> ('key key * 'data) option + + (** Like [max_elt]. Raises if empty. *) + val max_elt_exn : ('key, 'data, _) t -> 'key key * 'data + + (** Calls [f] for every key. *) + val iter_keys : ('key, _, _) t -> f:(('key key -> unit)[@local]) -> unit + + (** Calls [f] for every value. *) + val iter : (_, 'data, _) t -> f:(('data -> unit)[@local]) -> unit + + (** Calls [f] for every key/value pair. *) + val iteri + : ('key, 'data, _) t + -> f:((key:'key key -> data:'data -> unit)[@local]) + -> unit + + (** Transforms every value. *) + val map + : ('key, 'data1, 'phantom) t + -> f:(('data1 -> 'data2)[@local]) + -> ('key, 'data2, 'phantom) t + + (** Like [map]. The transformation may also depend on the associated key. *) + val mapi + : ('key, 'data1, 'phantom) t + -> f:((key:'key key -> data:'data1 -> 'data2)[@local]) + -> ('key, 'data2, 'phantom) t + + (** Produces only those key/value pairs whose key satisfies [f]. *) + val filter_keys + : ('key, 'data, 'phantom) t + -> f:(('key key -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Produces only those key/value pairs whose value satisfies [f]. *) + val filter + : ('key, 'data, 'phantom) t + -> f:(('data -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Produces only those key/value pairs which satisfy [f]. *) + val filteri + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Produces key/value pairs for which [f] produces [Some]. *) + val filter_map + : ('key, 'data1, 'phantom) t + -> f:(('data1 -> 'data2 option)[@local]) + -> ('key, 'data2, 'phantom) t + + (** Like [filter_map]. The new value may also depend on the associated key. *) + val filter_mapi + : ('key, 'data1, 'phantom) t + -> f:((key:'key key -> data:'data1 -> 'data2 option)[@local]) + -> ('key, 'data2, 'phantom) t + + (** Splits one dictionary into two. The first contains key/value pairs for which the + value satisfies [f]. The second contains the remainder. *) + val partition_tf + : ('key, 'data, 'phantom) t + -> f:(('data -> bool)[@local]) + -> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t + + (** Like [partition_tf]. The predicate may also depend on the associated key. *) + val partitioni_tf + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t + + (** Splits one dictionary into two, corresponding respectively to [First _] and + [Second _] results from [f]. *) + val partition_map + : ('key, 'data1, 'phantom) t + -> f:(('data1 -> ('data2, 'data3) Either.t)[@local]) + -> ('key, 'data2, 'phantom) t * ('key, 'data3, 'phantom) t + + (** Like [partition_map]. The split may also depend on the associated key. *) + val partition_mapi + : ('key, 'data1, 'phantom) t + -> f:((key:'key key -> data:'data1 -> ('data2, 'data3) Either.t)[@local]) + -> ('key, 'data2, 'phantom) t * ('key, 'data3, 'phantom) t + + (** Produces an error combining all error messages from key/value pairs, or a + dictionary of all [Ok] values if none are [Error]. *) + val combine_errors + : ( ('key, 'data Or_error.t, 'phantom) t -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + accessor + + (** Splits the [fst] and [snd] components of values associated with keys into separate + dictionaries. *) + val unzip + : ('key, 'data1 * 'data2, 'phantom) t + -> ('key, 'data1, 'phantom) t * ('key, 'data2, 'phantom) t + + (** Merges two dictionaries by fully traversing both. Not suitable for efficiently + merging lists of dictionaries. See [merge_skewed] instead. *) + val merge + : ( ('key, 'data1, 'phantom) t + -> ('key, 'data2, 'phantom) t + -> f: + ((key:'key key + -> [ `Left of 'data1 | `Right of 'data2 | `Both of 'data1 * 'data2 ] + -> 'data3 option) + [@local]) + -> ('key, 'data3, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Merges two dictionaries by traversing only the smaller of the two. Adds key/value + pairs missing from the larger dictionary, and [combine]s duplicate values. *) + val merge_skewed + : ( ('key, 'data, 'phantom) t + -> ('key, 'data, 'phantom) t + -> combine:((key:'key key -> 'data -> 'data -> 'data)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + accessor + + (** Computes a sequence of differences between two dictionaries. *) + val symmetric_diff + : ( ('key, 'data, 'phantom) t + -> ('key, 'data, 'phantom) t + -> data_equal:('data -> 'data -> bool) + -> ('key key * [ `Left of 'data | `Right of 'data | `Unequal of 'data * 'data ]) + Sequence.t + , 'key + , 'data + , 'phantom ) + accessor + + (** Folds over the result of [symmetric_diff]. May be more performant. *) + val fold_symmetric_diff + : ( ('key, 'data, 'phantom) t + -> ('key, 'data, 'phantom) t + -> data_equal:(('data -> 'data -> bool)[@local]) + -> init:'acc + -> f: + (('acc + -> 'key key + * [ `Left of 'data | `Right of 'data | `Unequal of 'data * 'data ] + -> 'acc) + [@local]) + -> 'acc + , 'key + , 'data + , 'phantom ) + accessor + end + + module type Accessors1 = sig + type key + type 'data t + + (** @inline *) + include + Accessors + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) accessor := 'fn + end + + module type Accessors2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + + (** @inline *) + include + Accessors + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + end + + module type Accessors3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + + (** @inline *) + include + Accessors + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + end + + module type Creators = sig + (** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed + type for dictionaries with monomorphic keys. *) + type 'key key + + (** Dictionaries. Their keys have type ['key key]. Each key's associated value has + type ['data]. The dictionary may be distinguished by a ['phantom] type. *) + type ('key, 'data, 'phantom) t + + (** The type of creator functions ['fn] that operate on [('key, 'data, 'phantom) t]. + May take extra arguments before ['fn], such as a comparison function. *) + type ('fn, 'key, 'data, 'phantom) creator + + (** The empty dictionary. *) + val empty : (('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator + + (** Dictionary with a single key/value pair. *) + val singleton + : ('key key -> 'data -> ('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator + + (** Dictionary containing the given key/value pairs. Fails if there are duplicate + keys. *) + val of_alist + : ( ('key key * 'data) list + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Returns a [Result.t]. *) + val of_alist_or_error + : ( ('key key * 'data) list -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Raises on duplicates. *) + val of_alist_exn + : ( ('key key * 'data) list -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Produces a dictionary mapping each key to a list of associated values. *) + val of_alist_multi + : ( ('key key * 'data) list -> ('key, 'data list, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Produces a dictionary using each key/value pair. Combines all values for a given + key with [init] using [f]. *) + val of_alist_fold + : ( ('key key * 'data) list + -> init:'acc + -> f:(('acc -> 'data -> 'acc)[@local]) + -> ('key, 'acc, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Produces a dictionary using each key/value pair. Combines multiple values for a + given key using [f]. *) + val of_alist_reduce + : ( ('key key * 'data) list + -> f:(('data -> 'data -> 'data)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Consumes a sequence. *) + val of_sequence + : ( ('key key * 'data) Sequence.t + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_or_error]. Consumes a sequence. *) + val of_sequence_or_error + : ( ('key key * 'data) Sequence.t -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_exn]. Consumes a sequence. *) + val of_sequence_exn + : ( ('key key * 'data) Sequence.t -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_multi]. Consumes a sequence. *) + val of_sequence_multi + : ( ('key key * 'data) Sequence.t -> ('key, 'data list, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_fold]. Consumes a sequence. *) + val of_sequence_fold + : ( ('key key * 'data) Sequence.t + -> init:'c + -> f:(('c -> 'data -> 'c)[@local]) + -> ('key, 'c, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_reduce]. Consumes a sequence. *) + val of_sequence_reduce + : ( ('key key * 'data) Sequence.t + -> f:(('data -> 'data -> 'data)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Consume values for which keys can be computed. *) + val of_list_with_key + : ( 'data list + -> get_key:(('data -> 'key key)[@local]) + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_or_error]. Consume values for which keys can be computed. *) + val of_list_with_key_or_error + : ( 'data list + -> get_key:(('data -> 'key key)[@local]) + -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_exn]. Consume values for which keys can be computed. *) + val of_list_with_key_exn + : ( 'data list -> get_key:(('data -> 'key key)[@local]) -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_multi]. Consume values for which keys can be computed. *) + val of_list_with_key_multi + : ( 'data list + -> get_key:(('data -> 'key key)[@local]) + -> ('key, 'data list, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Produces a dictionary of all key/value pairs that [iteri] passes to [~f]. Fails if + a duplicate key is found. *) + val of_iteri + : ( iteri:((f:((key:'key key -> data:'data -> unit)[@local]) -> unit)[@local]) + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_iteri]. Raises on duplicate key. *) + val of_iteri_exn + : ( iteri:((f:((key:'key key -> data:'data -> unit)[@local]) -> unit)[@local]) + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + end + + module type Creators1 = sig + type key + type 'data t + + (** @inline *) + include + Creators + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) creator := 'fn + end + + module type Creators2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) creator + + (** @inline *) + include + Creators + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + + module type Creators3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + Creators + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + + module type S = sig + type 'key key + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + Accessors + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + + (** @inline *) + include + Creators + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key key + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + + module type S1 = sig + type key + type 'data t + + (** @inline *) + include + S + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) accessor := 'fn + and type ('fn, _, _, _) creator := 'fn + end + + module type S2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + type ('fn, 'key, 'data) creator + + (** @inline *) + include + S + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + + module type S3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + S + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end +end + +module type Dictionary_immutable = sig + (** @inline *) + include module type of struct + include Definitions (** @inline *) + end +end diff --git a/src/dictionary_mutable.ml b/src/dictionary_mutable.ml new file mode 100644 index 00000000..9f67e683 --- /dev/null +++ b/src/dictionary_mutable.ml @@ -0,0 +1 @@ +include Dictionary_mutable_intf.Definitions diff --git a/src/dictionary_mutable.mli b/src/dictionary_mutable.mli new file mode 100644 index 00000000..de752597 --- /dev/null +++ b/src/dictionary_mutable.mli @@ -0,0 +1 @@ +include Dictionary_mutable_intf.Dictionary_mutable diff --git a/src/dictionary_mutable_intf.ml b/src/dictionary_mutable_intf.ml new file mode 100644 index 00000000..f0108f68 --- /dev/null +++ b/src/dictionary_mutable_intf.ml @@ -0,0 +1,692 @@ +(** Interfaces for mutable dictionary types, such as [Hashtbl.t]. + + We define separate interfaces for [Accessors] and [Creators], along with [S] combining + both. These interfaces are written once in their most general form, which involves + extra type definitions and type parameters that most instances do not need. + + We then provide instantiations of these interfaces with 1, 2, and 3 type parameters + for [t]. These cover more common usage patterns for the interfaces. *) + +open! Import + +(** These definitions are re-exported by [Dictionary_mutable]. *) +module Definitions = struct + (** @canonical Base.Dictionary_mutable.Merge_into_action *) + module Merge_into_action = struct + type 'data t = + | Remove + | Set_to of 'data + end + + module type Accessors = sig + (** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed + type for dictionaries with monomorphic keys. *) + type 'key key + + (** Dictionaries. Their keys have type ['key key]. Each key's associated value has + type ['data]. The dictionary may be distinguished by a ['phantom] type. *) + type ('key, 'data, 'phantom) t + + (** The type of accessor functions ['fn] that operate on [('key, 'data, 'phantom) t]. + May take extra arguments before ['fn], such as a comparison function. *) + type ('fn, 'key, 'data, 'phantom) accessor + + (** Whether the dictionary is empty. *) + val is_empty : (_, _, 'phantom) t -> bool + + (** How many key/value pairs the dictionary contains. *) + val length : (_, _, 'phantom) t -> int + + (** All key/value pairs. *) + val to_alist : ('key, 'data, 'phantom) t -> ('key key * 'data) list + + (** All keys in the dictionary, in the same order as [to_alist]. *) + val keys : ('key, _, 'phantom) t -> 'key key list + + (** All values in the dictionary, in the same order as [to_alist]. *) + val data : (_, 'data, 'phantom) t -> 'data list + + (** Removes all key/value pairs from the dictionary. *) + val clear : (_, _, 'phantom) t -> unit + + (** A new dictionary containing the same key/value pairs. *) + val copy : ('key, 'data, 'phantom) t -> ('key, 'data, 'phantom) t + + (** Whether [key] has a value. *) + val mem + : (('key, 'data, 'phantom) t -> 'key key -> bool, 'key, 'data, 'phantom) accessor + + (** Produces the current value, or absence thereof, for a given key. *) + val find + : ( ('key, 'data, 'phantom) t -> 'key key -> 'data option + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [find]. Raises if there is no value for the given key. *) + val find_exn + : (('key, 'data, 'phantom) t -> 'key key -> 'data, 'key, 'data, 'phantom) accessor + + (** Like [find]. Adds the value [default ()] if none exists, then returns it. *) + val find_or_add + : ( ('key, 'data, 'phantom) t + -> 'key key + -> default:((unit -> 'data)[@local]) + -> 'data + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [find]. Adds [default key] if no value exists. *) + val findi_or_add + : ( ('key, 'data, 'phantom) t + -> 'key key + -> default:(('key key -> 'data)[@local]) + -> 'data + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [find]. Calls [if_found data] if a value exists, or [if_not_found key] + otherwise. Avoids allocation [Some]. *) + val find_and_call + : ( ('key, 'data, 'phantom) t + -> 'key key + -> if_found:(('data -> 'c)[@local]) + -> if_not_found:(('key key -> 'c)[@local]) + -> 'c + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [findi]. Calls [if_found ~key ~data] if a value exists. *) + val findi_and_call + : ( ('key, 'data, 'phantom) t + -> 'key key + -> if_found:((key:'key key -> data:'data -> 'c)[@local]) + -> if_not_found:(('key key -> 'c)[@local]) + -> 'c + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [find]. Removes the value for [key], if any, from the dictionary before + returning it. *) + val find_and_remove + : ( ('key, 'data, 'phantom) t -> 'key key -> 'data option + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds a key/value pair for a key the dictionary does not contain, or reports a + duplicate. *) + val add + : ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> [ `Ok | `Duplicate ] + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [add]. Raises on duplicates. *) + val add_exn + : ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds or replaces a key/value pair in the dictionary. *) + val set + : ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Removes any value for the given key. *) + val remove + : (('key, 'data, 'phantom) t -> 'key key -> unit, 'key, 'data, 'phantom) accessor + + (** Adds, replaces, or removes the value for a given key, depending on its current + value or lack thereof. *) + val change + : ( ('key, 'data, 'phantom) t + -> 'key key + -> f:(('data option -> 'data option)[@local]) + -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds or replaces the value for a given key, depending on its current value or + lack thereof. *) + val update + : ( ('key, 'data, 'phantom) t + -> 'key key + -> f:(('data option -> 'data)[@local]) + -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Like [update]. Returns the new value. *) + val update_and_return + : ('key, 'data, 'phantom) t + -> 'key key + -> f:(('data option -> 'data)[@local]) + -> 'data + + (** Adds [by] to the value for [key], default 0 if [key] is absent. May remove [key] + if the result is [0], depending on [remove_if_zero]. *) + val incr + : ( ?by:int (** default: 1 *) + -> ?remove_if_zero:bool (** default: false *) + -> ('key, int, 'phantom) t + -> 'key key + -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Subtracts [by] from the value for [key], default 0 if [key] is absent. May remove + [key] if the result is [0], depending on [remove_if_zero]. *) + val decr + : ( ?by:int (** default: 1 *) + -> ?remove_if_zero:bool (** default: false *) + -> ('key, int, 'phantom) t + -> 'key key + -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Adds [data] to the existing key/value pair for [key]. Interprets a missing key as + having an empty list. *) + val add_multi + : ( ('key, 'data list, 'phantom) t -> key:'key key -> data:'data -> unit + , 'key + , 'data + , 'phantom ) + accessor + + (** Removes one element from the existing key/value pair for [key]. Removes the key + entirely if the new list is empty. *) + val remove_multi + : (('key, _ list, 'phantom) t -> 'key key -> unit, 'key, 'data, 'phantom) accessor + + (** Produces the list associated with the corresponding key. Interprets a missing + key as having an empty list. *) + val find_multi + : ( ('key, 'data list, 'phantom) t -> 'key key -> 'data list + , 'key + , 'data + , 'phantom ) + accessor + + (** Combines every value in the dictionary. *) + val fold + : ('key, 'data, 'phantom) t + -> init:'acc + -> f:((key:'key key -> data:'data -> 'acc -> 'acc)[@local]) + -> 'acc + + (** Whether every value satisfies [f]. *) + val for_all : (_, 'data, 'phantom) t -> f:(('data -> bool)[@local]) -> bool + + (** Like [for_all]. The predicate may also depend on the associated key. *) + val for_alli + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> bool + + (** Whether at least one value satisfies [f]. *) + val exists : (_, 'data, 'phantom) t -> f:(('data -> bool)[@local]) -> bool + + (** Like [exists]. The predicate may also depend on the associated key. *) + val existsi + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> bool + + (** How many values satisfy [f]. *) + val count : (_, 'data, 'phantom) t -> f:(('data -> bool)[@local]) -> int + + (** Like [count]. The predicate may also depend on the associated key. *) + val counti + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> int + + (** Arbitrary, deterministic key/value pair if non-empty. *) + val choose : ('key, 'data, 'phantom) t -> ('key key * 'data) option + + (** Like [choose]. Raises if empty. *) + val choose_exn : ('key, 'data, 'phantom) t -> 'key key * 'data + + (** Arbitrary, pseudo-random key/value pair if non-empty. *) + val choose_randomly + : ?random_state:Random.State.t + -> ('key, 'data, 'phantom) t + -> ('key key * 'data) option + + (** Like [choose_randomly]. Raises if empty. *) + val choose_randomly_exn + : ?random_state:Random.State.t + -> ('key, 'data, 'phantom) t + -> 'key key * 'data + + (** Calls [f] for every key. *) + val iter_keys : ('key, _, 'phantom) t -> f:(('key key -> unit)[@local]) -> unit + + (** Calls [f] for every value. *) + val iter : (_, 'data, 'phantom) t -> f:(('data -> unit)[@local]) -> unit + + (** Calls [f] for every key/value pair. *) + val iteri + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> unit)[@local]) + -> unit + + (** Transforms every value. *) + val map + : ('key, 'data, 'phantom) t + -> f:(('data -> 'c)[@local]) + -> ('key, 'c, 'phantom) t + + (** Like [map]. The transformation may also depend on the associated key. *) + val mapi + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> 'c)[@local]) + -> ('key, 'c, 'phantom) t + + (** Like [map]. Modifies the input. *) + val map_inplace : (_, 'data, 'phantom) t -> f:(('data -> 'data)[@local]) -> unit + + (** Like [mapi]. Modifies the input. *) + val mapi_inplace + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> 'data)[@local]) + -> unit + + (** Produces only those key/value pairs whose key satisfies [f]. *) + val filter_keys + : ('key, 'data, 'phantom) t + -> f:(('key key -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Produces only those key/value pairs whose value satisfies [f]. *) + val filter + : ('key, 'data, 'phantom) t + -> f:(('data -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Produces only those key/value pairs which satisfy [f]. *) + val filteri + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> ('key, 'data, 'phantom) t + + (** Like [filter_keys]. Modifies the input. *) + val filter_keys_inplace + : ('key, _, 'phantom) t + -> f:(('key key -> bool)[@local]) + -> unit + + (** Like [filter]. Modifies the input. *) + val filter_inplace : (_, 'data, 'phantom) t -> f:(('data -> bool)[@local]) -> unit + + (** Like [filteri]. Modifies the input. *) + val filteri_inplace + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> unit + + (** Produces key/value pairs for which [f] produces [Some]. *) + val filter_map + : ('key, 'data, 'phantom) t + -> f:(('data -> 'c option)[@local]) + -> ('key, 'c, 'phantom) t + + (** Like [filter_map]. The new value may also depend on the associated key. *) + val filter_mapi + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> 'c option)[@local]) + -> ('key, 'c, 'phantom) t + + (** Like [filter_map]. Modifies the input. *) + val filter_map_inplace + : (_, 'data, 'phantom) t + -> f:(('data -> 'data option)[@local]) + -> unit + + (** Like [filter_mapi]. Modifies the input. *) + val filter_mapi_inplace + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> 'data option)[@local]) + -> unit + + (** Splits one dictionary into two. The first contains key/value pairs for which the + value satisfies [f]. The second contains the remainder. *) + val partition_tf + : ('key, 'data, 'phantom) t + -> f:(('data -> bool)[@local]) + -> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t + + (** Like [partition_tf]. The predicate may also depend on the associated key. *) + val partitioni_tf + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> bool)[@local]) + -> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t + + (** Splits one dictionary into two, corresponding respectively to [First _] and + [Second _] results from [f]. *) + val partition_map + : ('key, 'data, 'phantom) t + -> f:(('data -> ('c, 'd) Either.t)[@local]) + -> ('key, 'c, 'phantom) t * ('key, 'd, 'phantom) t + + (** Like [partition_map]. The split may also depend on the associated key. *) + val partition_mapi + : ('key, 'data, 'phantom) t + -> f:((key:'key key -> data:'data -> ('c, 'd) Either.t)[@local]) + -> ('key, 'c, 'phantom) t * ('key, 'd, 'phantom) t + + (** Merges two dictionaries by fully traversing both. Not suitable for efficiently + merging lists of dictionaries. See [merge_into] instead. *) + val merge + : ( ('key, 'data1, 'phantom) t + -> ('key, 'data2, 'phantom) t + -> f: + ((key:'key key + -> [ `Left of 'data1 | `Right of 'data2 | `Both of 'data1 * 'data2 ] + -> 'data3 option) + [@local]) + -> ('key, 'data3, 'phantom) t + , 'key + , 'data3 + , 'phantom ) + accessor + + (** Merges two dictionaries by traversing [src] and adding to [dst]. Computes the + effect on [dst] of each key/value pair in [src] using [f]. *) + val merge_into + : ( src:('key, 'data1, 'phantom) t + -> dst:('key, 'data2, 'phantom) t + -> f: + ((key:'key key -> 'data1 -> 'data2 option -> 'data2 Merge_into_action.t) + [@local]) + -> unit + , 'key + , 'data + , 'phantom ) + accessor + end + + module type Accessors1 = sig + type key + type 'data t + + include + Accessors + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) accessor := 'fn + end + + module type Accessors2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + + include + Accessors + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + end + + module type Accessors3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + + include + Accessors + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + end + + module type Creators = sig + (** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed + type for dictionaries with monomorphic keys. *) + type 'key key + + (** Dictionaries. Their keys have type ['key key]. Each key's associated value has + type ['data]. The dictionary may be distinguished by a ['phantom] type. *) + type ('key, 'data, 'phantom) t + + (** The type of creator functions ['fn] that operate on [('key, 'data, 'phantom) t]. + May take extra arguments before ['fn], such as a comparison function. *) + type ('fn, 'key, 'data, 'phantom) creator + + (** Creates a new empty dictionary. *) + val create : (unit -> ('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator + + (** Dictionary containing the given key/value pairs. Fails if there are duplicate + keys. *) + val of_alist + : ( ('key key * 'data) list + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. On failure, provides all duplicate keys instead of a single + representative. *) + val of_alist_report_all_dups + : ( ('key key * 'data) list + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Returns a [Result.t]. *) + val of_alist_or_error + : ( ('key key * 'data) list -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Raises on duplicates. *) + val of_alist_exn + : ( ('key key * 'data) list -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Produces a dictionary mapping each key to a list of associated values. *) + val of_alist_multi + : ( ('key key * 'data) list -> ('key, 'data list, 'phantom) t + , 'key + , 'data list + , 'phantom ) + creator + + (** Like [of_alist]. Consume a list of elements for which key/value pairs can be + computed. *) + val create_mapped + : ( get_key:(('a -> 'key key)[@local]) + -> get_data:(('a -> 'data)[@local]) + -> 'a list + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist]. Consume values for which keys can be computed. *) + val create_with_key + : ( get_key:(('data -> 'key key)[@local]) + -> 'data list + -> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ] + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_or_error]. Consume values for which keys can be computed. *) + val create_with_key_or_error + : ( get_key:(('data -> 'key key)[@local]) + -> 'data list + -> ('key, 'data, 'phantom) t Or_error.t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [of_alist_exn]. Consume values for which keys can be computed. *) + val create_with_key_exn + : ( get_key:(('data -> 'key key)[@local]) -> 'data list -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + + (** Like [create_mapped]. Multiple values for a key are [combine]d rather than + producing an error. *) + val group + : ( get_key:(('a -> 'key key)[@local]) + -> get_data:(('a -> 'data)[@local]) + -> combine:(('data -> 'data -> 'data)[@local]) + -> 'a list + -> ('key, 'data, 'phantom) t + , 'key + , 'data + , 'phantom ) + creator + end + + module type Creators1 = sig + type key + type 'data t + + (** @inline *) + include + Creators + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) creator := 'fn + end + + module type Creators2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) creator + + (** @inline *) + include + Creators + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + + module type Creators3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + Creators + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + + module type S = sig + type 'key key + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + Accessors + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + + (** @inline *) + include + Creators + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key key + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + + module type S1 = sig + type key + type 'data t + + (** @inline *) + include + S + with type (_, 'data, _) t := 'data t + and type _ key := key + and type ('fn, _, _, _) accessor := 'fn + and type ('fn, _, _, _) creator := 'fn + end + + module type S2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + type ('fn, 'key, 'data) creator + + (** @inline *) + include + S + with type ('key, 'data, _) t := ('key, 'data) t + and type 'key key := 'key + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + + module type S3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + (** @inline *) + include + S + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type 'key key := 'key + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end +end + +module type Dictionary_mutable = sig + (** @inline *) + include module type of struct + include Definitions (** @inline *) + end +end diff --git a/src/dune b/src/dune index 36564622..0b93568a 100644 --- a/src/dune +++ b/src/dune @@ -11,7 +11,8 @@ (ocamlopt_flags :standard (:include ocamlopt-flags)) (libraries base_internalhash_types sexplib0 shadow_stdlib) (c_flags :standard -D_LARGEFILE64_SOURCE (:include mpopcnt.sexp)) - (c_names bytes_stubs exn_stubs int_math_stubs hash_stubs am_testing) + (c_names bytes_stubs exn_stubs float_stubs int_math_stubs hash_stubs + am_testing) (preprocess no_preprocessing) (lint (pps ppx_base ppx_base_lint -check-doc-comments -type-conv-keep-w32=both diff --git a/src/float.ml b/src/float.ml index b46ccf95..9f723f8b 100644 --- a/src/float.ml +++ b/src/float.ml @@ -864,13 +864,21 @@ let clamp_exn t ~min ~max = (* Also fails if [min] or [max] is nan *) assert (min <= max); (* clamp_unchecked is in float0.ml *) - clamp_unchecked t ~min ~max + clamp_unchecked + ~to_clamp_maybe_nan:t + ~min_which_is_not_nan:min + ~max_which_is_not_nan:max ;; let clamp t ~min ~max = (* Also fails if [min] or [max] is nan *) if min <= max - then Ok (clamp_unchecked t ~min ~max) + then + Ok + (clamp_unchecked + ~to_clamp_maybe_nan:t + ~min_which_is_not_nan:min + ~max_which_is_not_nan:max) else Or_error.error_s (Sexp.message diff --git a/src/float.mli b/src/float.mli index e52f502f..5e768174 100644 --- a/src/float.mli +++ b/src/float.mli @@ -664,7 +664,13 @@ end https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val box : t -> t - val clamp_unchecked : t -> min:t -> max:t -> t + + val clamp_unchecked + : to_clamp_maybe_nan:t + -> min_which_is_not_nan:t + -> max_which_is_not_nan:t + -> t + val lower_bound_for_int : int -> t val upper_bound_for_int : int -> t val specialized_hash : t -> int diff --git a/src/float0.ml b/src/float0.ml index 6b51de58..1ba3a058 100644 --- a/src/float0.ml +++ b/src/float0.ml @@ -191,12 +191,49 @@ let lower_bound_for_int num_bits = min_int_as_float) ;; -(* Float clamping is structured slightly differently than clamping for other types, so - that we get the behavior of [clamp_unchecked nan ~min ~max = nan] (for any [min] and - [max]) for free. +(* X86 docs say: + + If only one value is a NaN (SNaN or QNaN) for this instruction, the second source + operand, either a NaN or a valid floating-point value + is written to the result. + + So we have to be VERY careful how we use these! + + These intrinsics were copied from [Ocaml_intrinsics] to avoid build deps we don't want *) -let clamp_unchecked (t : float) ~min ~max = - if t < min then min else if max < t then max else t +module Intrinsics_with_weird_nan_behavior = struct + (** Equivalent to [if x < y then x else y]. + + On an x86-64 machine, this compiles to [minsd xmm0, xmm1]. *) + external min + : (float[@unboxed]) + -> (float[@unboxed]) + -> (float[@unboxed]) + = "caml_float_min" "caml_float_min_unboxed" + [@@noalloc] [@@builtin] [@@no_effects] [@@no_coeffects] + + (** Equivalent to [if x > y then x else y]. + + On an x86-64 machine, this compiles to [maxsd xmm0, xmm1]. *) + external max + : (float[@unboxed]) + -> (float[@unboxed]) + -> (float[@unboxed]) + = "caml_float_max" "caml_float_max_unboxed" + [@@noalloc] [@@builtin] [@@no_effects] [@@no_coeffects] +end + +let clamp_unchecked + ~(to_clamp_maybe_nan : float) + ~min_which_is_not_nan + ~max_which_is_not_nan + = + (* We want to propagate nans; as per the x86 docs, this means we have to use them as the + _second_ argument. *) + let t_maybe_nan = + Intrinsics_with_weird_nan_behavior.max min_which_is_not_nan to_clamp_maybe_nan + in + Intrinsics_with_weird_nan_behavior.min max_which_is_not_nan t_maybe_nan ;; let box = diff --git a/src/float_stubs.c b/src/float_stubs.c new file mode 100644 index 00000000..70830a79 --- /dev/null +++ b/src/float_stubs.c @@ -0,0 +1,17 @@ +#include +#include + +#include +#include + +double caml_float_min_unboxed(double x, double y) { return x < y ? x : y; } + +CAMLprim value caml_float_min(value x, value y) { + return caml_copy_double(caml_float_min_unboxed(Double_val(x), Double_val(y))); +} + +double caml_float_max_unboxed(double x, double y) { return x > y ? x : y; } + +CAMLprim value caml_float_max(value x, value y) { + return caml_copy_double(caml_float_max_unboxed(Double_val(x), Double_val(y))); +} diff --git a/src/hashtbl_intf.ml b/src/hashtbl_intf.ml index 3d8a4916..6f2e234a 100644 --- a/src/hashtbl_intf.ml +++ b/src/hashtbl_intf.ml @@ -19,12 +19,7 @@ module Key = struct type 'a t = (module S with type t = 'a) end -(** @canonical Base.Hashtbl.Merge_into_action *) -module Merge_into_action = struct - type 'a t = - | Remove - | Set_to of 'a -end +module Merge_into_action = Dictionary_mutable.Merge_into_action module type Accessors = sig (** {2 Accessors} *) @@ -32,6 +27,13 @@ module type Accessors = sig type ('a, 'b) t type 'a key + (** @inline *) + include + Dictionary_mutable.Accessors + with type 'key key := 'key key + and type ('key, 'data, _) t := ('key, 'data) t + and type ('fn, _, _, _) accessor := 'fn + val sexp_of_key : ('a, _) t -> 'a key -> Sexp.t val clear : (_, _) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t @@ -309,7 +311,9 @@ module type Accessors = sig val merge_into : src:('k, 'a) t -> dst:('k, 'b) t - -> f:((key:'k key -> 'a -> 'b option -> 'b Merge_into_action.t)[@local]) + -> f: + ((key:'k key -> 'a -> 'b option -> 'b Dictionary_mutable.Merge_into_action.t) + [@local]) -> unit (** Returns the list of all keys for given hashtable. *) @@ -389,6 +393,13 @@ module type Creators_generic = sig type 'a key type ('key, 'data, 'z) create_options + (** @inline *) + include + Dictionary_mutable.Creators + with type 'key key := 'key key + and type ('key, 'data, _) t := ('key, 'data) t + and type ('fn, 'key, 'data, _) creator := ('key key, 'data, 'fn) create_options + val create : ('a key, 'b, unit -> ('a, 'b) t) create_options diff --git a/src/int.ml b/src/int.ml index e2992e8a..d0070a73 100644 --- a/src/int.ml +++ b/src/int.ml @@ -108,7 +108,7 @@ open! Int_replace_polymorphic_compare let invariant (_ : t) = () let between t ~low ~high = low <= t && t <= high -let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max +let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_ let clamp_exn t ~min ~max = assert (min <= max); diff --git a/src/int32.ml b/src/int32.ml index 07f50f13..5da73b41 100644 --- a/src/int32.ml +++ b/src/int32.ml @@ -92,12 +92,12 @@ module Compare = struct let compare__local = compare__local let ascending = compare let descending x y = compare y x - let min (x : t) y = if x < y then x else y - let max (x : t) y = if x > y then x else y + let min x y = Bool0.select (x <= y) x y + let max x y = Bool0.select (x >= y) x y let equal (x : t) y = x = y let equal__local ((x : t) [@local]) (y [@local]) = Poly.equal x y let between t ~low ~high = low <= t && t <= high - let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max + let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_ let clamp_exn t ~min ~max = assert (min <= max); diff --git a/src/int63_emul.ml b/src/int63_emul.ml index 981e7591..89ede33e 100644 --- a/src/int63_emul.ml +++ b/src/int63_emul.ml @@ -330,7 +330,7 @@ include Comparable.With_zero (struct end) let between t ~low ~high = low <= t && t <= high -let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max +let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_ let clamp_exn t ~min ~max = assert (min <= max); diff --git a/src/int64.ml b/src/int64.ml index b3939218..0f7674d1 100644 --- a/src/int64.ml +++ b/src/int64.ml @@ -103,7 +103,7 @@ open Int64_replace_polymorphic_compare let invariant (_ : t) = () let between t ~low ~high = low <= t && t <= high -let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max +let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_ let clamp_exn t ~min ~max = assert (min <= max); diff --git a/src/int_math_stubs.c b/src/int_math_stubs.c index 4e81623e..08897ce0 100644 --- a/src/int_math_stubs.c +++ b/src/int_math_stubs.c @@ -189,7 +189,7 @@ CAMLprim value Base_int_math_nativeint_ctz(value v) { return Val_int(Base_int_math_nativeint_ctz_unboxed(Nativeint_val(v))); } -CAMLprim CAMLweakdef value -caml_csel_value(value v_cond, value v_true, value v_false) { +CAMLprim CAMLweakdef value caml_csel_value(value v_cond, value v_true, + value v_false) { return (Bool_val(v_cond) ? v_true : v_false); } diff --git a/src/map_intf.ml b/src/map_intf.ml index 4577806e..45a86703 100644 --- a/src/map_intf.ml +++ b/src/map_intf.ml @@ -394,6 +394,13 @@ module type Accessors_generic = sig type 'cmp cmp type ('a, 'cmp, 'z) access_options + (** @inline *) + include + Dictionary_immutable.Accessors + with type 'key key := 'key key + and type ('key, 'data, 'cmp) t := ('key, 'data, 'cmp) t + and type ('fn, 'key, _, 'cmp) accessor := ('key, 'cmp, 'fn) access_options + val invariants : ('k, 'cmp, ('k, 'v, 'cmp) t -> bool) access_options val is_empty : (_, _, _) t -> bool val length : (_, _, _) t -> int @@ -746,6 +753,13 @@ module type Creators_generic = sig type ('a, 'cmp, 'z) access_options type 'cmp cmp + (** @inline *) + include + Dictionary_immutable.Creators + with type 'key key := 'key key + and type ('key, 'data, 'cmp) t := ('key, 'data, 'cmp) t + and type ('fn, 'key, _, 'cmp) creator := ('key, 'cmp, 'fn) create_options + val empty : ('k, 'cmp, ('k, _, 'cmp) t) create_options val singleton : ('k, 'cmp, 'k key -> 'v -> ('k, 'v, 'cmp) t) create_options @@ -1124,12 +1138,13 @@ module type Map = sig Example: {[ - # let map = String.Map.of_alist_fold - [ "a", 1; "a", 10; "b", 2; "b", 20; "b", 200 ] - ~init:Int.Set.empty - ~f:Set.add - in - print_s [%sexp (map : Int.Set.t String.Map.t)];; + # (let map = + String.Map.of_alist_fold + [ "a", 1; "a", 10; "b", 2; "b", 20; "b", 200 ] + ~init:Int.Set.empty + ~f:Set.add + in + print_s [%sexp (map : Int.Set.t String.Map.t)]);; ((a (1 10)) (b (2 20 200))) - : unit = () ]} diff --git a/src/nativeint.ml b/src/nativeint.ml index aaf81e52..b6923c00 100644 --- a/src/nativeint.ml +++ b/src/nativeint.ml @@ -205,7 +205,7 @@ end include Pow2 let between t ~low ~high = low <= t && t <= high -let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max +let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_ let clamp_exn t ~min ~max = assert (min <= max); diff --git a/src/nothing.ml b/src/nothing.ml index 0ccd4fb1..5c04425c 100644 --- a/src/nothing.ml +++ b/src/nothing.ml @@ -3,10 +3,11 @@ open! Import module T = struct type t = | - let unreachable_code = function + let unreachable_code_local = function | (_ : t) -> . ;; + let unreachable_code x = unreachable_code_local x let all = [] let hash_fold_t _ t = unreachable_code t let hash = unreachable_code diff --git a/src/nothing.mli b/src/nothing.mli index ec5e20e0..7c39d94a 100644 --- a/src/nothing.mli +++ b/src/nothing.mli @@ -51,6 +51,9 @@ val t_sexp_grammar : t Sexplib0.Sexp_grammar.t *) val unreachable_code : t -> _ +(** The same as [unreachable_code], but for local [t]s. *) +val unreachable_code_local : (t[@local]) -> _ + (** It may seem weird that this is identifiable, but we're just trying to anticipate all the contexts in which people may need this. It would be a crying shame if you had some variant type involving [Nothing.t] that you wished to make identifiable, but were diff --git a/src/runtime.js b/src/runtime.js index 8c616805..dedd96e5 100644 --- a/src/runtime.js +++ b/src/runtime.js @@ -172,3 +172,14 @@ function caml_make_local_vect(v_len, v_elt) { // In javascript there's no local allocation. return caml_make_vect (v_len, v_elt); } + + +//Provides: caml_float_min +function caml_float_min(x,y) { + return x < y ? x : y; +} + +//Provides: caml_float_max +function caml_float_max(x, y) { + return x > y ? x : y; +} diff --git a/src/string.mli b/src/string.mli index 1e9c7a0c..c81f784e 100644 --- a/src/string.mli +++ b/src/string.mli @@ -233,6 +233,7 @@ val to_list_rev : t -> char list val rev : t -> t (** [is_suffix s ~suffix] returns [true] if [s] ends with [suffix]. *) + val is_suffix : t -> suffix:t -> bool (** [is_prefix s ~prefix] returns [true] if [s] starts with [prefix]. *) diff --git a/src/type_equal.ml b/src/type_equal.ml index 4ce37dbd..53c92d2a 100644 --- a/src/type_equal.ml +++ b/src/type_equal.ml @@ -16,6 +16,10 @@ let sexp_of_t : type ('a, 'b) equal = ('a, 'b) t +include Type_equal_intf.Definitions (struct + type ('a, 'b) t = ('a, 'b) equal + end) + let refl = T let sym (type a b) (T : (a, b) t) : (b, a) t = T let trans (type a b c) (T : (a, b) t) (T : (b, c) t) : (a, c) t = T @@ -56,24 +60,6 @@ let detuple2 (type a1 a2 b1 b2) (T : (a1 * a2, b1 * b2) t) : (a1, b1) t * (a2, b let tuple2 (type a1 a2 b1 b2) (T : (a1, b1) t) (T : (a2, b2) t) : (a1 * a2, b1 * b2) t = T -module type Injective = sig - type 'a t - - val strip : ('a t, 'b t) equal -> ('a, 'b) equal -end - -module type Injective2 = sig - type ('a1, 'a2) t - - val strip : (('a1, 'a2) t, ('b1, 'b2) t) equal -> ('a1, 'b1) equal * ('a2, 'b2) equal -end - -module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) = struct - type 'a t = 'a M1.t M2.t - - let strip e = M1.strip (M2.strip e) -end - module Id = struct module Uid = Int diff --git a/src/type_equal.mli b/src/type_equal.mli index 8b815b99..b1dead84 100644 --- a/src/type_equal.mli +++ b/src/type_equal.mli @@ -1,220 +1 @@ -(** The purpose of [Type_equal] is to represent type equalities that the type checker - otherwise would not know, perhaps because the type equality depends on dynamic data, - or perhaps because the type system isn't powerful enough. - - A value of type [(a, b) Type_equal.t] represents that types [a] and [b] are equal. - One can think of such a value as a proof of type equality. The [Type_equal] module - has operations for constructing and manipulating such proofs. For example, the - functions [refl], [sym], and [trans] express the usual properties of reflexivity, - symmetry, and transitivity of equality. - - If one has a value [t : (a, b) Type_equal.t] that proves types [a] and [b] are equal, - there are two ways to use [t] to safely convert a value of type [a] to a value of type - [b]: [Type_equal.conv] or pattern matching on [Type_equal.T]: - - {[ - let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = - Type_equal.conv t a - - let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = - let Type_equal.T = t in a - ]} - - At runtime, conversion by either means is just the identity -- nothing is changing - about the value. Consistent with this, a value of type [Type_equal.t] is always just - a constructor [Type_equal.T]; the value has no interesting semantic content. - [Type_equal] gets its power from the ability to, in a type-safe way, prove to the type - checker that two types are equal. The [Type_equal.t] value that is passed is - necessary for the type-checker's rules to be correct, but the compiler could, in - principle, not pass around values of type [Type_equal.t] at runtime. -*) - -open! Import -open T - -type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] - -val sexp_of_t - : ('a -> Sexplib0.Sexp.t) - -> ('b -> Sexplib0.Sexp.t) - -> ('a, 'b) t - -> Sexplib0.Sexp.t - -[@@@end] - -(** just an alias, needed when [t] gets shadowed below *) -type ('a, 'b) equal = ('a, 'b) t - -(** [refl], [sym], and [trans] construct proofs that type equality is reflexive, - symmetric, and transitive. *) - -val refl : ('a, 'a) t -val sym : ('a, 'b) t -> ('b, 'a) t -val trans : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t - -(** [conv t x] uses the type equality [t : (a, b) t] as evidence to safely cast [x] - from type [a] to type [b]. [conv] is semantically just the identity function. - - In a program that has [t : (a, b) t] where one has a value of type [a] that one wants - to treat as a value of type [b], it is often sufficient to pattern match on - [Type_equal.T] rather than use [conv]. However, there are situations where OCaml's - type checker will not use the type equality [a = b], and one must use [conv]. For - example: - - {[ - module F (M1 : sig type t end) (M2 : sig type t end) : sig - val f : (M1.t, M2.t) equal -> M1.t -> M2.t - end = struct - let f equal (m1 : M1.t) = conv equal m1 - end - ]} - - If one wrote the body of [F] using pattern matching on [T]: - - {[ - let f (T : (M1.t, M2.t) equal) (m1 : M1.t) = (m1 : M2.t) - ]} - - this would give a type error. *) -val conv : ('a, 'b) t -> 'a -> 'b - -(** It is always safe to conclude that if type [a] equals [b], then for any type ['a t], - type [a t] equals [b t]. The OCaml type checker uses this fact when it can. However, - sometimes, e.g., when using [conv], one needs to explicitly use this fact to construct - an appropriate [Type_equal.t]. The [Lift*] functors do this. *) - -module Lift (X : T1) : sig - val lift : ('a, 'b) t -> ('a X.t, 'b X.t) t -end - -module Lift2 (X : T2) : sig - val lift : ('a1, 'b1) t -> ('a2, 'b2) t -> (('a1, 'a2) X.t, ('b1, 'b2) X.t) t -end - -module Lift3 (X : T3) : sig - val lift - : ('a1, 'b1) t - -> ('a2, 'b2) t - -> ('a3, 'b3) t - -> (('a1, 'a2, 'a3) X.t, ('b1, 'b2, 'b3) X.t) t -end - -(** [tuple2] and [detuple2] convert between equality on a 2-tuple and its components. *) - -val detuple2 : ('a1 * 'a2, 'b1 * 'b2) t -> ('a1, 'b1) t * ('a2, 'b2) t -val tuple2 : ('a1, 'b1) t -> ('a2, 'b2) t -> ('a1 * 'a2, 'b1 * 'b2) t - -(** [Injective] is an interface that states that a type is injective, where the type is - viewed as a function from types to other types. The typical usage is: - - {[ - type 'a t - include Injective with type 'a t := 'a t - ]} - - For example, ['a list] is an injective type, because whenever ['a list = 'b list], we - know that ['a] = ['b]. On the other hand, if we define: - - {[ - type 'a t = unit - ]} - - then clearly [t] isn't injective, because, e.g., [int t = bool t], but [int <> bool]. - - If [module M : Injective], then [M.strip] provides a way to get a proof that two types - are equal from a proof that both types transformed by [M.t] are equal. - - OCaml has no built-in language feature to state that a type is injective, which is why - we have [module type Injective]. However, OCaml can infer that a type is injective, - and we can use this to match [Injective]. A typical implementation will look like - this: - - {[ - let strip (type a) (type b) - (Type_equal.T : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = - Type_equal.T - ]} - - This will not type check for all type constructors (certainly not for non-injective - ones!), but it's always safe to try the above implementation if you are unsure. If - OCaml accepts this definition, then the type is injective. On the other hand, if - OCaml doesn't, then the type may or may not be injective. For example, if the - definition of the type depends on abstract types that match [Injective], OCaml will - not automatically use their injectivity, and one will have to write a more complicated - definition of [strip] that causes OCaml to use that fact. For example: - - {[ - module F (M : Type_equal.Injective) : Type_equal.Injective = struct - type 'a t = 'a M.t * int - - let strip (type a) (type b) - (e : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = - let e1, _ = Type_equal.detuple2 e in - M.strip e1 - ;; - end - ]} - - If in the definition of [F] we had written the simpler implementation of [strip] that - didn't use [M.strip], then OCaml would have reported a type error. -*) -module type Injective = sig - type 'a t - - val strip : ('a t, 'b t) equal -> ('a, 'b) equal -end - -(** [Injective2] is for a binary type that is injective in both type arguments. *) -module type Injective2 = sig - type ('a1, 'a2) t - - val strip : (('a1, 'a2) t, ('b1, 'b2) t) equal -> ('a1, 'b1) equal * ('a2, 'b2) equal -end - -(** [Composition_preserves_injectivity] is a functor that proves that composition of - injective types is injective. *) -module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) : - Injective with type 'a t = 'a M1.t M2.t - -(** [Id] provides identifiers for types, and the ability to test (via [Id.same]) at - runtime if two identifiers are equal, and if so to get a proof of equality of their - types. Unlike values of type [Type_equal.t], values of type [Id.t] do have semantic - content and must have a nontrivial runtime representation. *) -module Id : sig - type 'a t [@@deriving_inline sexp_of] - - val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t - - [@@@end] - - (** Every [Id.t] contains a unique id that is distinct from the [Uid.t] in any other - [Id.t]. *) - module Uid : Identifiable.S - - val uid : _ t -> Uid.t - - (** [create ~name] defines a new type identity. Two calls to [create] will result in - two distinct identifiers, even for the same arguments with the same type. If the - type ['a] doesn't support sexp conversion, then a good practice is to have the - converter be [[%sexp_of: _]], (or [sexp_of_opaque], if not using ppx_sexp_conv). *) - val create : name:string -> ('a -> Sexp.t) -> 'a t - - (** Accessors *) - - val hash : _ t -> int - val name : _ t -> string - val to_sexp : 'a t -> 'a -> Sexp.t - val hash_fold_t : Hash.state -> _ t -> Hash.state - - (** [same_witness t1 t2] and [same_witness_exn t1 t2] return a type equality proof iff - the two identifiers are the same (i.e., physically equal, resulting from the same - call to [create]). This is a useful way to achieve a sort of dynamic typing. - [same_witness] does not allocate a [Some] every time it is called. - - [same t1 t2 = is_some (same_witness t1 t2)]. - *) - - val same : _ t -> _ t -> bool - val same_witness : 'a t -> 'b t -> ('a, 'b) equal option - val same_witness_exn : 'a t -> 'b t -> ('a, 'b) equal -end +include Type_equal_intf.Type_equal (** @inline *) diff --git a/src/type_equal_intf.ml b/src/type_equal_intf.ml new file mode 100644 index 00000000..f7d96f58 --- /dev/null +++ b/src/type_equal_intf.ml @@ -0,0 +1,265 @@ +(** The purpose of [Type_equal] is to represent type equalities that the type checker + otherwise would not know, perhaps because the type equality depends on dynamic data, + or perhaps because the type system isn't powerful enough. + + A value of type [(a, b) Type_equal.t] represents that types [a] and [b] are equal. + One can think of such a value as a proof of type equality. The [Type_equal] module + has operations for constructing and manipulating such proofs. For example, the + functions [refl], [sym], and [trans] express the usual properties of reflexivity, + symmetry, and transitivity of equality. + + If one has a value [t : (a, b) Type_equal.t] that proves types [a] and [b] are equal, + there are two ways to use [t] to safely convert a value of type [a] to a value of type + [b]: [Type_equal.conv] or pattern matching on [Type_equal.T]: + + {[ + let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = + Type_equal.conv t a + + let f (type a) (type b) (t : (a, b) Type_equal.t) (a : a) : b = + let Type_equal.T = t in a + ]} + + At runtime, conversion by either means is just the identity -- nothing is changing + about the value. Consistent with this, a value of type [Type_equal.t] is always just + a constructor [Type_equal.T]; the value has no interesting semantic content. + [Type_equal] gets its power from the ability to, in a type-safe way, prove to the type + checker that two types are equal. The [Type_equal.t] value that is passed is + necessary for the type-checker's rules to be correct, but the compiler could, in + principle, not pass around values of type [Type_equal.t] at runtime. +*) + +open! Import +open T + +(**/**) + +module Definitions (Type_equal : T.T2) = struct + (** The [Lift*] module types are used by the [Lift*] functors. See below. *) + + module type Lift = sig + type 'a t + + val lift : ('a, 'b) Type_equal.t -> ('a t, 'b t) Type_equal.t + end + + module type Lift2 = sig + type ('a, 'b) t + + val lift + : ('a1, 'b1) Type_equal.t + -> ('a2, 'b2) Type_equal.t + -> (('a1, 'a2) t, ('b1, 'b2) t) Type_equal.t + end + + module type Lift3 = sig + type ('a, 'b, 'c) t + + val lift + : ('a1, 'b1) Type_equal.t + -> ('a2, 'b2) Type_equal.t + -> ('a3, 'b3) Type_equal.t + -> (('a1, 'a2, 'a3) t, ('b1, 'b2, 'b3) t) Type_equal.t + end + + (** [Injective] is an interface that states that a type is injective, where the type is + viewed as a function from types to other types. It predates OCaml's support for + explicit injectivity annotations in the type system. + + The typical prior usage was: + + {[ + type 'a t + include Injective with type 'a t := 'a t + ]} + + For example, ['a list] is an injective type, because whenever ['a list = 'b list], + we know that ['a] = ['b]. On the other hand, if we define: + + {[ + type 'a t = unit + ]} + + then clearly [t] isn't injective, because, e.g., [int t = bool t], but + [int <> bool]. + + If [module M : Injective], then [M.strip] provides a way to get a proof that two + types are equal from a proof that both types transformed by [M.t] are equal. A + typical implementation looked like this: + + {[ + let strip (type a) (type b) + (Type_equal.T : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = + Type_equal.T + ]} + + This will not type check for all type constructors (certainly not for non-injective + ones!), but it's always safe to try the above implementation if you are unsure. If + OCaml accepts this definition, then the type is injective. On the other hand, if + OCaml doesn't, then the type may or may not be injective. For example, if the + definition of the type depends on abstract types that match [Injective], OCaml will + not automatically use their injectivity, and one will have to write a more + complicated definition of [strip] that causes OCaml to use that fact. For example: + + {[ + module F (M : Type_equal.Injective) : Type_equal.Injective = struct + type 'a t = 'a M.t * int + + let strip (type a) (type b) + (e : (a t, b t) Type_equal.t) : (a, b) Type_equal.t = + let e1, _ = Type_equal.detuple2 e in + M.strip e1 + ;; + end + ]} + + If in the definition of [F] we had written the simpler implementation of [strip] that + didn't use [M.strip], then OCaml would have reported a type error. + *) + module type Injective = sig + type 'a t + + val strip : ('a t, 'b t) Type_equal.t -> ('a, 'b) Type_equal.t + end + [@@deprecated + "[since 2023-08] OCaml now supports injectivity annotations. [type !'a t] declares \ + that ['a t] is injective with respect to ['a]."] + + (** [Injective2] is for a binary type that is injective in both type arguments. *) + module type Injective2 = sig + type ('a1, 'a2) t + + val strip + : (('a1, 'a2) t, ('b1, 'b2) t) Type_equal.t + -> ('a1, 'b1) Type_equal.t * ('a2, 'b2) Type_equal.t + end + [@@deprecated + "[since 2023-08] OCaml now supports injectivity annotations. [type !'a t] declares \ + that ['a t] is injective with respect to ['a]."] + + (** [Composition_preserves_injectivity] is a functor that proves that composition of + injective types is injective. *) + module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) : + Injective with type 'a t = 'a M1.t M2.t = struct + type 'a t = 'a M1.t M2.t + + let strip e = M1.strip (M2.strip e) + end + [@@alert "-deprecated"] + [@@deprecated + "[since 2023-08] OCaml now supports injectivity annotations. [type !'a t] declares \ + that ['a t] is injective with respect to ['a]."] +end + +(**/**) + +module type Type_equal = sig + type ('a, 'b) t = T : ('a, 'a) t [@@deriving_inline sexp_of] + + val sexp_of_t + : ('a -> Sexplib0.Sexp.t) + -> ('b -> Sexplib0.Sexp.t) + -> ('a, 'b) t + -> Sexplib0.Sexp.t + + [@@@end] + + (** just an alias, needed when [t] gets shadowed below *) + type ('a, 'b) equal = ('a, 'b) t + + (** @inline *) + include module type of Definitions (struct + type ('a, 'b) t = ('a, 'b) equal + end) + + (** [refl], [sym], and [trans] construct proofs that type equality is reflexive, + symmetric, and transitive. *) + + val refl : ('a, 'a) t + val sym : ('a, 'b) t -> ('b, 'a) t + val trans : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t + + (** [conv t x] uses the type equality [t : (a, b) t] as evidence to safely cast [x] + from type [a] to type [b]. [conv] is semantically just the identity function. + + In a program that has [t : (a, b) t] where one has a value of type [a] that one + wants to treat as a value of type [b], it is often sufficient to pattern match on + [Type_equal.T] rather than use [conv]. However, there are situations where OCaml's + type checker will not use the type equality [a = b], and one must use [conv]. For + example: + + {[ + module F (M1 : sig type t end) (M2 : sig type t end) : sig + val f : (M1.t, M2.t) equal -> M1.t -> M2.t + end = struct + let f equal (m1 : M1.t) = conv equal m1 + end + ]} + + If one wrote the body of [F] using pattern matching on [T]: + + {[ + let f (T : (M1.t, M2.t) equal) (m1 : M1.t) = (m1 : M2.t) + ]} + + this would give a type error. *) + val conv : ('a, 'b) t -> 'a -> 'b + + (** It is always safe to conclude that if type [a] equals [b], then for any type ['a t], + type [a t] equals [b t]. The OCaml type checker uses this fact when it can. However, + sometimes, e.g., when using [conv], one needs to explicitly use this fact to + construct an appropriate [Type_equal.t]. The [Lift*] functors do this. *) + + module Lift (T : T1) : Lift with type 'a t := 'a T.t + module Lift2 (T : T2) : Lift2 with type ('a, 'b) t := ('a, 'b) T.t + module Lift3 (T : T3) : Lift3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) T.t + + (** [tuple2] and [detuple2] convert between equality on a 2-tuple and its components. *) + + val detuple2 : ('a1 * 'a2, 'b1 * 'b2) t -> ('a1, 'b1) t * ('a2, 'b2) t + val tuple2 : ('a1, 'b1) t -> ('a2, 'b2) t -> ('a1 * 'a2, 'b1 * 'b2) t + + (** [Id] provides identifiers for types, and the ability to test (via [Id.same]) at + runtime if two identifiers are equal, and if so to get a proof of equality of their + types. Unlike values of type [Type_equal.t], values of type [Id.t] do have semantic + content and must have a nontrivial runtime representation. *) + module Id : sig + type 'a t [@@deriving_inline sexp_of] + + val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t + + [@@@end] + + (** Every [Id.t] contains a unique id that is distinct from the [Uid.t] in any other + [Id.t]. *) + module Uid : Identifiable.S + + val uid : _ t -> Uid.t + + (** [create ~name] defines a new type identity. Two calls to [create] will result in + two distinct identifiers, even for the same arguments with the same type. If the + type ['a] doesn't support sexp conversion, then a good practice is to have the + converter be [[%sexp_of: _]], (or [sexp_of_opaque], if not using ppx_sexp_conv). + *) + val create : name:string -> ('a -> Sexp.t) -> 'a t + + (** Accessors *) + + val hash : _ t -> int + val name : _ t -> string + val to_sexp : 'a t -> 'a -> Sexp.t + val hash_fold_t : Hash.state -> _ t -> Hash.state + + (** [same_witness t1 t2] and [same_witness_exn t1 t2] return a type equality proof iff + the two identifiers are the same (i.e., physically equal, resulting from the same + call to [create]). This is a useful way to achieve a sort of dynamic typing. + [same_witness] does not allocate a [Some] every time it is called. + + [same t1 t2 = is_some (same_witness t1 t2)]. + *) + + val same : _ t -> _ t -> bool + val same_witness : 'a t -> 'b t -> ('a, 'b) equal option + val same_witness_exn : 'a t -> 'b t -> ('a, 'b) equal + end +end diff --git a/src/uniform_array.ml b/src/uniform_array.ml index 2893085e..0361ac75 100644 --- a/src/uniform_array.ml +++ b/src/uniform_array.ml @@ -361,3 +361,10 @@ module Sort = Array.Private.Sorter (struct end) let sort = Sort.sort + +include Binary_searchable.Make1 (struct + type nonrec 'a t = 'a t + + let length = length + let get = unsafe_get + end) diff --git a/src/uniform_array.mli b/src/uniform_array.mli index 13b22779..aa7b42af 100644 --- a/src/uniform_array.mli +++ b/src/uniform_array.mli @@ -109,6 +109,8 @@ val max_elt : 'a t -> compare:(('a -> 'a -> int)[@local]) -> 'a option and [len] indicating how many elements to sort. *) val sort : ?pos:int -> ?len:int -> 'a t -> compare:(('a -> 'a -> int)[@local]) -> unit +include Binary_searchable.S1 with type 'a t := 'a t + (** {2 Extra lowlevel and unsafe functions} *) (** The behavior is undefined if you access an element before setting it. *) diff --git a/test/test_dictionary_module_types.ml b/test/test_dictionary_module_types.ml new file mode 100644 index 00000000..3c9bf113 --- /dev/null +++ b/test/test_dictionary_module_types.ml @@ -0,0 +1,225 @@ +(** This file tests the consistency of [Dictionary_immutable] module types. + + We compare each module type S to the most generic version G that exports the same set + of values. We create a module type I by instantiating G to mimic S, such as by + dropping a type parameter. We then test that S = I by writing two identity functors, + one from S to I and one from I to S. *) + +open! Base + +module _ : module type of Dictionary_immutable = struct + (* The generic interface for accessors. *) + module type Accessors = Dictionary_immutable.Accessors + + (* Ensure that Accessors1 is Accessors with only a data type argument. *) + module type Accessors1 = Dictionary_immutable.Accessors1 + + open struct + module type Accessors_instance1 = sig + type key + type 'data t + + include + Accessors + with type _ key := key + and type (_, 'data, _) t := 'data t + and type ('fn, _, _, _) accessor := 'fn + end + end + + module _ (M : Accessors1) : Accessors_instance1 = M + module _ (M : Accessors_instance1) : Accessors1 = M + + (* Ensure that Accessors2 is Accessors with no phantom type argument. *) + module type Accessors2 = Dictionary_immutable.Accessors2 + + open struct + module type Accessors_instance2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + + include + Accessors + with type 'key key := 'key + and type ('key, 'data, _) t := ('key, 'data) t + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + end + end + + module _ (M : Accessors2) : Accessors_instance2 = M + module _ (M : Accessors_instance2) : Accessors2 = M + + (* Ensure that Accessors3 is Accessors with no [key] type. *) + module type Accessors3 = Dictionary_immutable.Accessors3 + + open struct + module type Accessors_instance3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + + include + Accessors + with type 'key key := 'key + and type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + end + end + + module _ (M : Accessors3) : Accessors_instance3 = M + module _ (M : Accessors_instance3) : Accessors3 = M + + (* The generic interface for creators. *) + module type Creators = Dictionary_immutable.Creators + + (* Ensure that Creators1 is Creators with only a data type argument. *) + module type Creators1 = Dictionary_immutable.Creators1 + + open struct + module type Creators_instance1 = sig + type key + type 'data t + + include + Creators + with type _ key := key + and type (_, 'data, _) t := 'data t + and type ('fn, _, _, _) creator := 'fn + end + end + + module _ (M : Creators1) : Creators_instance1 = M + module _ (M : Creators_instance1) : Creators1 = M + + (* Ensure that Creators2 is Creators with no phantom type argument. *) + module type Creators2 = Dictionary_immutable.Creators2 + + open struct + module type Creators_instance2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) creator + + include + Creators + with type 'key key := 'key + and type ('key, 'data, _) t := ('key, 'data) t + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + end + + module _ (M : Creators2) : Creators_instance2 = M + module _ (M : Creators_instance2) : Creators2 = M + + (* Ensure that Creators3 is Creators with no [key] type. *) + module type Creators3 = Dictionary_immutable.Creators3 + + open struct + module type Creators_instance3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) creator + + include + Creators + with type 'key key := 'key + and type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + end + + module _ (M : Creators3) : Creators_instance3 = M + module _ (M : Creators_instance3) : Creators3 = M + + (* The generic type for creators + accessors. *) + module type S = Dictionary_immutable.S + + open struct + module type Creators_and_accessors = sig + type 'key key + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + include + Accessors + with type 'key key := 'key key + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + with type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + + include + Creators + with type 'key key := 'key key + with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + with type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + end + + module _ (M : S) : Creators_and_accessors = M + module _ (M : Creators_and_accessors) : S = M + + (* Ensure that S1 is S with only a data type argument. *) + module type S1 = Dictionary_immutable.S1 + + open struct + module type S_instance1 = sig + type key + type 'data t + + include + S + with type _ key := key + and type (_, 'data, _) t := 'data t + and type ('fn, _, _, _) accessor := 'fn + and type ('fn, _, _, _) creator := 'fn + end + end + + module _ (M : S1) : S_instance1 = M + module _ (M : S_instance1) : S1 = M + + (* Ensure that S2 is S with no phantom type argument. *) + module type S2 = Dictionary_immutable.S2 + + open struct + module type S_instance2 = sig + type ('key, 'data) t + type ('fn, 'key, 'data) accessor + type ('fn, 'key, 'data) creator + + include + S + with type 'key key := 'key + and type ('key, 'data, _) t := ('key, 'data) t + and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor + and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator + end + end + + module _ (M : S2) : S_instance2 = M + module _ (M : S_instance2) : S2 = M + + (* Ensure that S3 is S with no [key] type. *) + module type S3 = Dictionary_immutable.S3 + + open struct + module type S_instance3 = sig + type ('key, 'data, 'phantom) t + type ('fn, 'key, 'data, 'phantom) accessor + type ('fn, 'key, 'data, 'phantom) creator + + include + S + with type 'key key := 'key + and type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t + and type ('fn, 'key, 'data, 'phantom) accessor := + ('fn, 'key, 'data, 'phantom) accessor + and type ('fn, 'key, 'data, 'phantom) creator := + ('fn, 'key, 'data, 'phantom) creator + end + end + + module _ (M : S3) : S_instance3 = M + module _ (M : S_instance3) : S3 = M +end diff --git a/test/test_dictionary_module_types.mli b/test/test_dictionary_module_types.mli new file mode 100644 index 00000000..74bb7298 --- /dev/null +++ b/test/test_dictionary_module_types.mli @@ -0,0 +1 @@ +(*_ This signature is deliberately empty. *) diff --git a/test/test_float.ml b/test/test_float.ml index 45239d6f..e06070f4 100644 --- a/test/test_float.ml +++ b/test/test_float.ml @@ -123,6 +123,35 @@ let%test_module "clamp" = ;; let%test "clamp bad" = Or_error.is_error (clamp 2.5 ~min:3. ~max:2.) + let%test "clamp also bad" = Or_error.is_error (clamp 2.5 ~min:nan ~max:3.) + let%test "clamp also bad 2" = Or_error.is_error (clamp 2.5 ~min:2. ~max:nan) + let%test "clamp also bad 3" = Or_error.is_error (clamp 2.5 ~min:nan ~max:nan) + let%test "clamp also bad 4" = Or_error.is_error (clamp nan ~min:nan ~max:nan) + + let%test_unit "clamp_exn bad" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + clamp_exn 2.5 ~min:3. ~max:2.) + ;; + + let%test_unit "clamp_exn also bad" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + clamp_exn 2.5 ~min:nan ~max:3.) + ;; + + let%test_unit "clamp_exn also bad 2" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + clamp_exn 2.5 ~min:2. ~max:nan) + ;; + + let%test_unit "clamp_exn also bad 3" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + clamp_exn 2.5 ~min:nan ~max:nan) + ;; + + let%test_unit "clamp_exn also bad 4" = + Expect_test_helpers_base.require_does_raise [%here] (fun () -> + clamp_exn nan ~min:nan ~max:nan) + ;; end) ;;