├── dune ├── dune-project ├── .ocamlformat ├── test ├── comparelib_test.ml ├── dune ├── compare_test.mlt ├── check_optims.ml ├── errors.mlt ├── ppx_template_interaction.ml ├── modalities.ml ├── global_modality.ml └── test.ml ├── .gitignore ├── test-explicit-locality ├── comparelib_explicit_locality_test.ml ├── dune ├── test.ml └── test.mli ├── runtime ├── ppx_compare_lib.mli ├── dune ├── ppx_compare_lib_intf.ml └── ppx_compare_lib.ml ├── src ├── ppx_compare.mli ├── dune └── ppx_compare.ml ├── expander ├── dune ├── ppx_compare_expander.mli ├── ppx_compare_expander_intf.ml └── ppx_compare_expander.ml ├── Makefile ├── ppx_compare.opam ├── CHANGES.md ├── LICENSE.md ├── CONTRIBUTING.md └── README.md /dune: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /test/comparelib_test.ml: -------------------------------------------------------------------------------- 1 | (* Test library *) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /test-explicit-locality/comparelib_explicit_locality_test.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /runtime/ppx_compare_lib.mli: -------------------------------------------------------------------------------- 1 | include Ppx_compare_lib_intf.Ppx_compare_lib (** @inline *) 2 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_compare_lib) 3 | (public_name ppx_compare.runtime-lib) 4 | (libraries) 5 | (preprocess 6 | (pps ppx_template ppx_shorthand))) 7 | -------------------------------------------------------------------------------- /test-explicit-locality/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name comparelib_explicit_locality_test) 3 | (libraries base) 4 | (preprocess 5 | (pps ppx_jane -compare-require-explicit-locality ppx_template))) 6 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name comparelib_test) 3 | (libraries base) 4 | (preprocess 5 | (pps ppxlib ppx_compare ppx_inline_test ppx_template))) 6 | 7 | (alias 8 | (name default) 9 | (deps test.ml.pp)) 10 | -------------------------------------------------------------------------------- /src/ppx_compare.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (*_ Exposed so other derivers can list them as dependencies. *) 4 | 5 | val compare : Deriving.t 6 | val compare_local : Deriving.t 7 | val equal : Deriving.t 8 | val equal_local : Deriving.t 9 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_compare) 3 | (public_name ppx_compare) 4 | (kind ppx_deriver) 5 | (ppx_runtime_libraries ppx_compare.runtime-lib) 6 | (libraries ppx_compare_expander ppxlib ppxlib_jane ppxlib.stdppx) 7 | (preprocess no_preprocessing)) 8 | -------------------------------------------------------------------------------- /expander/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_compare_expander) 3 | (public_name ppx_compare.expander) 4 | (libraries compiler-libs.common ppx_helpers ppxlib ppxlib_jane ppxlib.stdppx) 5 | (ppx_runtime_libraries ppx_compare.runtime-lib) 6 | (preprocess 7 | (pps ppxlib.metaquot))) 8 | -------------------------------------------------------------------------------- /test/compare_test.mlt: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module No_comparing2 = struct 4 | (* Checks that we don't trigger an 'unused rec' warning. *) 5 | type t = 6 | { a : t [@compare.ignore] 7 | ; b : (t[@compare.ignore]) * int 8 | } 9 | [@@deriving compare] 10 | end 11 | 12 | [%%expect {| |}] 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /expander/ppx_compare_expander.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module type S = Ppx_compare_expander_intf.S 4 | 5 | module Compare : sig 6 | include S 7 | 8 | (** [equal_core_type ~with_local ty] is an expression of type [ty -> ty -> bool], using 9 | the comparison function generated by [core_type] 10 | 11 | [~with_local:true] will make the arguments local *) 12 | val equal_core_type : with_local:bool -> core_type -> expression 13 | end 14 | 15 | module Equal : S 16 | -------------------------------------------------------------------------------- /test-explicit-locality/test.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module Localize_prevents_flag_from_raising = struct 4 | type t = int [@@deriving compare ~localize] 5 | end 6 | 7 | module Underscore_global_prevents_flag_from_raising = struct 8 | type t = int [@@deriving compare__global] 9 | end 10 | 11 | module Ppx_template_explicit_prevents_flag_from_raising = struct 12 | module Local = struct 13 | type%template t = int [@@deriving compare [@mode.explicit local]] 14 | end 15 | 16 | module Global = struct 17 | type%template t = int [@@deriving compare [@mode.explicit global]] 18 | end 19 | 20 | module Both = struct 21 | type%template t = int 22 | [@@mode m = (local, global)] [@@deriving compare [@mode.explicit m]] 23 | end 24 | end 25 | -------------------------------------------------------------------------------- /ppx_compare.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ppx_compare" 5 | bug-reports: "https://github.com/janestreet/ppx_compare/issues" 6 | dev-repo: "git+https://github.com/janestreet/ppx_compare.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_compare/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "ppx_helpers" 15 | "ppx_shorthand" 16 | "ppx_template" 17 | "ppxlib_jane" 18 | "dune" {>= "3.17.0"} 19 | "ppxlib" {>= "0.33.0" & < "0.36.0"} 20 | ] 21 | available: arch != "arm32" & arch != "x86_32" 22 | synopsis: "Generation of comparison functions from types" 23 | description: " 24 | Part of the Jane Street's PPX rewriters collection. 25 | " 26 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | 3 | * Support comparing locally-allocated values via `[@@deriving compare ~localize]`. 4 | 5 | 6 | ## git version 7 | 8 | - Optimized comparison for sum types when all constructors are constant. 9 | 10 | ## v0.11 11 | 12 | Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, 13 | ppx\_metaquot and ppx\_type\_conv. 14 | 15 | ## v0.10 16 | 17 | - Disallowed `[%equal]`; use `[%compare.equal]` 18 | 19 | - Added `@compare.ignore` record-field attribute; `ppx_compare` and `ppx_hash` 20 | skip record fields annotated with `@compare.ignore`. 21 | 22 | - Added support to `%compare` syntax for underscore (`_`) as meaning a 23 | comparison function that ignores both its arguments and returns zero. 24 | 25 | ## v0.9 26 | 27 | ## 113.43.00 28 | 29 | - use the new context-free API 30 | 31 | ## 113.24.00 32 | 33 | - Follow evolution of `Ppx_core` and `Type_conv`. 34 | -------------------------------------------------------------------------------- /test-explicit-locality/test.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | (* NOTE: I tried to add the flag to an mlt but got the following error: 4 | 5 | {[ 6 | Error: It is currently not possible to pass preprocessor flags to toplevel expect 7 | tests. 8 | ]} 9 | 10 | So I'm using this library to manually test that it works. 11 | *) 12 | 13 | module Localize_prevents_flag_from_raising : sig 14 | type t = int [@@deriving compare ~localize] 15 | end 16 | 17 | module Underscore_global_prevents_flag_from_raising : sig 18 | type t = int [@@deriving compare__global] 19 | end 20 | 21 | module Ppx_template_explicit_prevents_flag_from_raising : sig 22 | module Local : sig 23 | type%template t = int [@@deriving compare [@mode.explicit local]] 24 | end 25 | 26 | module Global : sig 27 | type%template t = int [@@deriving compare [@mode.explicit global]] 28 | end 29 | 30 | module Both : sig 31 | type%template t = int 32 | [@@mode m = (local, global)] [@@deriving compare [@mode.explicit m]] 33 | end 34 | end 35 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2015--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test/check_optims.ml: -------------------------------------------------------------------------------- 1 | open Ppx_compare_lib 2 | 3 | type enum = 4 | | A 5 | | B 6 | | C 7 | 8 | module Compare = struct 9 | let optim_bool : bool compare = Stdlib.compare 10 | let optim_char : char compare = Stdlib.compare 11 | let optim_float : float compare = Stdlib.compare 12 | let optim_int : int compare = Stdlib.compare 13 | let optim_int32 : int32 compare = Stdlib.compare 14 | let optim_int64 : int64 compare = Stdlib.compare 15 | let optim_nativeint : nativeint compare = Stdlib.compare 16 | let optim_string : string compare = Stdlib.compare 17 | let optim_unit : unit compare = Stdlib.compare 18 | let optim_enum : enum compare = Stdlib.compare 19 | end 20 | 21 | module Equal = struct 22 | let optim_bool : bool equal = Stdlib.( = ) 23 | let optim_char : char equal = Stdlib.( = ) 24 | let optim_float : float equal = Stdlib.( = ) 25 | let optim_int : int equal = Stdlib.( = ) 26 | let optim_int32 : int32 equal = Stdlib.( = ) 27 | let optim_nativeint : nativeint equal = Stdlib.( = ) 28 | let optim_string : string equal = Stdlib.( = ) 29 | let optim_unit : unit equal = Stdlib.( = ) 30 | let optim_enum : enum equal = Stdlib.( = ) 31 | 32 | let optim_int64 = 33 | if Sys.word_size = 32 34 | then 35 | (* On 32bits, polymmorphic comparison of int64 values is not specialized *) 36 | fun _ _ -> 37 | false 38 | else (Stdlib.( = ) : int64 equal) 39 | ;; 40 | end 41 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /expander/ppx_compare_expander_intf.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | module type Attrs = sig 4 | val ignore_label_declaration : (label_declaration, unit) Attribute.t 5 | val ignore_core_type : (core_type, unit) Attribute.t 6 | val custom_core_type : (core_type, expression) Attribute.t 7 | end 8 | 9 | module type S = sig 10 | (** [type_ ~with_local ~hide ty] is [ty -> ty -> result_type] where [result_type] is 11 | [int] for [compare] and [bool] for [equal]. 12 | 13 | [hide] controls whether some [[@merlin.hide]] attributes should be added. 14 | 15 | [with_local] adds local_ annotation around the input types. *) 16 | val type_ : with_local:bool -> hide:bool -> loc:Location.t -> core_type -> core_type 17 | 18 | (** [core_type ~with_local ty] is an expression of type [ty -> ty -> result_type] 19 | 20 | [~with_local:true] will make the arguments local *) 21 | val core_type : with_local:bool -> core_type -> expression 22 | 23 | (** [pattern ~with_local ty] is a pattern binding the compare function for the type 24 | [ty]. [~with_local:true] is the local version *) 25 | val pattern : with_local:bool -> core_type -> pattern 26 | 27 | (** In [str_type_decl] and [sig_type_decl], passing [true] for the third argument 28 | generates additional functions that take local arguments. We generate, e.g. 29 | [val compare__local : local_ t -> local_ t -> int] in addition to [compare] in order 30 | to incrementally grow the portion of the tree which supports local comparison. 31 | 32 | We need both [compare] and [compare__local] since neither has a stronger type than 33 | the other. In the case of polymorphic types, this is due to the fact that 34 | [compare__local] requires local compare functions for each of its type arguments, 35 | and in the case of monomorphic types, this is due to the possibility of partial 36 | application producing a local closure. *) 37 | 38 | val str_type_decl 39 | : ctxt:Expansion_context.Deriver.t 40 | -> rec_flag * type_declaration list 41 | -> localize:bool (** [true] means generate a definition with local arguments *) 42 | -> portable:bool (** [true] means generate a definition annotated as [@@ portable] *) 43 | -> structure 44 | 45 | val sig_type_decl 46 | : ctxt:Expansion_context.Deriver.t 47 | -> rec_flag * type_declaration list 48 | -> localize:bool (** [true] means generate a declaration with local arguments *) 49 | -> portable:bool (** [true] means generate a declaration annotated as [@@ portable] *) 50 | -> signature_item list 51 | 52 | module Attrs : Attrs 53 | 54 | val str_attributes : Attribute.packed list 55 | end 56 | -------------------------------------------------------------------------------- /runtime/ppx_compare_lib_intf.ml: -------------------------------------------------------------------------------- 1 | (** Runtime support for auto-generated comparators. Users are not intended to use this 2 | module directly. *) 3 | 4 | module Definitions = struct 5 | [%%template 6 | [@@@mode.default l = (global, local)] 7 | 8 | type 'a compare = 'a -> 'a -> int 9 | type 'a equal = 'a -> 'a -> bool] 10 | 11 | module Comparable = struct 12 | [%%template 13 | [@@@mode.default l = (global, local)] 14 | 15 | module type S = sig 16 | type t 17 | 18 | val compare : (t compare[@mode l]) [@@mode l] 19 | end 20 | 21 | module type S1 = sig 22 | type 'a t 23 | 24 | val compare : ('a compare[@mode l]) -> ('a t compare[@mode l]) [@@mode l] 25 | end 26 | 27 | module type S2 = sig 28 | type ('a, 'b) t 29 | 30 | val compare 31 | : ('a compare[@mode l]) 32 | -> ('b compare[@mode l]) 33 | -> (('a, 'b) t compare[@mode l]) 34 | [@@mode l] 35 | end 36 | 37 | module type S3 = sig 38 | type ('a, 'b, 'c) t 39 | 40 | val compare 41 | : ('a compare[@mode l]) 42 | -> ('b compare[@mode l]) 43 | -> ('c compare[@mode l]) 44 | -> (('a, 'b, 'c) t compare[@mode l]) 45 | [@@mode l] 46 | end] 47 | end 48 | 49 | module Equal = struct 50 | [%%template 51 | [@@@mode.default l = (global, local)] 52 | 53 | module type S = sig 54 | type t 55 | 56 | val equal : (t equal[@mode l]) [@@mode l] 57 | end 58 | 59 | module type S1 = sig 60 | type 'a t 61 | 62 | val equal : ('a equal[@mode l]) -> ('a t equal[@mode l]) [@@mode l] 63 | end 64 | 65 | module type S2 = sig 66 | type ('a, 'b) t 67 | 68 | val equal 69 | : ('a equal[@mode l]) 70 | -> ('b equal[@mode l]) 71 | -> (('a, 'b) t equal[@mode l]) 72 | [@@mode l] 73 | end 74 | 75 | module type S3 = sig 76 | type ('a, 'b, 'c) t 77 | 78 | val equal 79 | : ('a equal[@mode l]) 80 | -> ('b equal[@mode l]) 81 | -> ('c equal[@mode l]) 82 | -> (('a, 'b, 'c) t equal[@mode l]) 83 | [@@mode l] 84 | end] 85 | end 86 | end 87 | 88 | module type Ppx_compare_lib = sig 89 | include module type of struct 90 | include Definitions 91 | end 92 | 93 | (** Raise when fully applied *) 94 | val compare_abstract : type_name:string -> _ compare__local 95 | 96 | val equal_abstract : type_name:string -> _ equal__local 97 | 98 | module Builtin : sig 99 | [%%template: 100 | [@@@mode.default l = (global, local)] 101 | 102 | val compare_bool : (bool compare[@mode l]) [@@zero_alloc arity 2] 103 | val compare_char : (char compare[@mode l]) [@@zero_alloc arity 2] 104 | val compare_float : (float compare[@mode l]) [@@zero_alloc arity 2] 105 | val compare_int : (int compare[@mode l]) [@@zero_alloc arity 2] 106 | val compare_int32 : (int32 compare[@mode l]) [@@zero_alloc arity 2] 107 | val compare_int64 : (int64 compare[@mode l]) [@@zero_alloc arity 2] 108 | val compare_nativeint : (nativeint compare[@mode l]) [@@zero_alloc arity 2] 109 | val compare_string : (string compare[@mode l]) [@@zero_alloc arity 2] 110 | val compare_bytes : (bytes compare[@mode l]) [@@zero_alloc arity 2] 111 | val compare_unit : (unit compare[@mode l]) [@@zero_alloc arity 2] 112 | 113 | val compare_array : 'a. ('a compare[@mode l]) -> ('a array compare[@mode l]) 114 | [@@kind k = base_with_imm] 115 | 116 | val compare_list : 'a. ('a compare[@mode l]) -> ('a list compare[@mode l]) 117 | val compare_option : 'a. ('a compare[@mode l]) -> ('a option compare[@mode l]) 118 | val compare_ref : 'a. ('a compare[@mode l]) -> ('a ref compare[@mode l]) 119 | val equal_bool : (bool equal[@mode l]) [@@zero_alloc arity 2] 120 | val equal_char : (char equal[@mode l]) [@@zero_alloc arity 2] 121 | val equal_float : (float equal[@mode l]) [@@zero_alloc arity 2] 122 | val equal_int : (int equal[@mode l]) [@@zero_alloc arity 2] 123 | val equal_int32 : (int32 equal[@mode l]) [@@zero_alloc arity 2] 124 | val equal_int64 : (int64 equal[@mode l]) [@@zero_alloc arity 2] 125 | val equal_nativeint : (nativeint equal[@mode l]) [@@zero_alloc arity 2] 126 | val equal_string : (string equal[@mode l]) [@@zero_alloc arity 2] 127 | val equal_bytes : (bytes equal[@mode l]) [@@zero_alloc arity 2] 128 | val equal_unit : (unit equal[@mode l]) [@@zero_alloc arity 2] 129 | 130 | val equal_array : 'a. ('a equal[@mode l]) -> ('a array equal[@mode l]) 131 | [@@kind k = base_with_imm] 132 | 133 | val equal_list : 'a. ('a equal[@mode l]) -> ('a list equal[@mode l]) 134 | val equal_option : 'a. ('a equal[@mode l]) -> ('a option equal[@mode l]) 135 | val equal_ref : 'a. ('a equal[@mode l]) -> ('a ref equal[@mode l])] 136 | end 137 | end 138 | -------------------------------------------------------------------------------- /runtime/ppx_compare_lib.ml: -------------------------------------------------------------------------------- 1 | include Ppx_compare_lib_intf.Definitions 2 | 3 | external ( = ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%equal" 4 | external ( <> ) : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%notequal" 5 | external compare : (int[@local_opt]) -> (int[@local_opt]) -> int = "%compare" 6 | external equal : (int[@local_opt]) -> (int[@local_opt]) -> bool = "%equal" 7 | 8 | module Poly = struct 9 | external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare" 10 | external equal : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" 11 | end 12 | 13 | module Array = struct 14 | external length : 'a. 'a array -> int = "%array_length" [@@layout_poly] 15 | external unsafe_get : 'a. 'a array -> int -> 'a = "%array_unsafe_get" [@@layout_poly] 16 | end 17 | 18 | let compare_abstract ~type_name _ _ = 19 | Printf.ksprintf 20 | failwith 21 | "Compare called on the type %s, which is abstract in an implementation." 22 | type_name 23 | ;; 24 | 25 | let equal_abstract ~type_name _ _ = 26 | Printf.ksprintf 27 | failwith 28 | "Equal called on the type %s, which is abstract in an implementation." 29 | type_name 30 | ;; 31 | 32 | module Builtin = struct 33 | [%%template 34 | [@@@mode.default l = (global, local)] 35 | 36 | let compare_bool : (bool compare[@mode l]) = fun x y -> Poly.compare x y 37 | let compare_char : (char compare[@mode l]) = fun x y -> Poly.compare x y 38 | let compare_float : (float compare[@mode l]) = fun x y -> Poly.compare x y 39 | let compare_int : (int compare[@mode l]) = fun x y -> Poly.compare x y 40 | let compare_int32 : (int32 compare[@mode l]) = fun x y -> Poly.compare x y 41 | let compare_int64 : (int64 compare[@mode l]) = fun x y -> Poly.compare x y 42 | let compare_nativeint : (nativeint compare[@mode l]) = fun x y -> Poly.compare x y 43 | let compare_string : (string compare[@mode l]) = fun x y -> Poly.compare x y 44 | let compare_bytes : (bytes compare[@mode l]) = fun x y -> Poly.compare x y 45 | let compare_unit : (unit compare[@mode l]) = fun x y -> Poly.compare x y 46 | 47 | let rec compare_list compare_elt a b = 48 | match a, b with 49 | | [], [] -> 0 50 | | [], _ -> -1 51 | | _, [] -> 1 52 | | x :: xs, y :: ys -> 53 | let res = compare_elt x y in 54 | if res <> 0 then res else (compare_list [@mode l]) compare_elt xs ys 55 | ;; 56 | 57 | let compare_option compare_elt a b = 58 | match a, b with 59 | | None, None -> 0 60 | | None, Some _ -> -1 61 | | Some _, None -> 1 62 | | Some a, Some b -> compare_elt a b 63 | ;;] 64 | 65 | [%%template 66 | [@@@kind.default k = base_with_imm] 67 | 68 | let[@mode local] compare_array (type a) compare_elt (a : a array) (b : a array) = 69 | if a == b 70 | then 0 71 | else ( 72 | let len_a = Array.length a in 73 | let len_b = Array.length b in 74 | let ret = compare len_a len_b in 75 | if ret <> 0 76 | then ret 77 | else ( 78 | let rec loop i = 79 | if i = len_a 80 | then 0 81 | else ( 82 | let l = Array.unsafe_get a i 83 | and r = Array.unsafe_get b i in 84 | let res = compare_elt l r in 85 | if res <> 0 then res else loop (i + 1)) 86 | in 87 | loop 0 [@nontail])) 88 | ;; 89 | 90 | let compare_array = [%eta3 compare_array [@kind k] [@mode local]]] 91 | 92 | [%%template 93 | let[@mode local] compare_ref compare_elt a b = compare_elt !a !b 94 | let compare_ref = [%eta3 compare_ref [@mode local]]] 95 | 96 | [%%template 97 | [@@@mode.default l = (global, local)] 98 | 99 | let equal_bool : (bool equal[@mode l]) = fun x y -> Poly.equal x y 100 | let equal_char : (char equal[@mode l]) = fun x y -> Poly.equal x y 101 | let equal_int : (int equal[@mode l]) = fun x y -> Poly.equal x y 102 | let equal_int32 : (int32 equal[@mode l]) = fun x y -> Poly.equal x y 103 | let equal_int64 : (int64 equal[@mode l]) = fun x y -> Poly.equal x y 104 | let equal_nativeint : (nativeint equal[@mode l]) = fun x y -> Poly.equal x y 105 | let equal_string : (string equal[@mode l]) = fun x y -> Poly.equal x y 106 | let equal_bytes : (bytes equal[@mode l]) = fun x y -> Poly.equal x y 107 | let equal_unit : (unit equal[@mode l]) = fun x y -> Poly.equal x y 108 | 109 | (* [Poly.equal] is IEEE compliant, which is not what we want here. *) 110 | let equal_float x y = equal_int ((compare_float [@mode l]) x y) 0 111 | 112 | let rec equal_list equal_elt a b = 113 | match a, b with 114 | | [], [] -> true 115 | | [], _ | _, [] -> false 116 | | x :: xs, y :: ys -> equal_elt x y && (equal_list [@mode l]) equal_elt xs ys 117 | ;; 118 | 119 | let equal_option equal_elt a b = 120 | match a, b with 121 | | None, None -> true 122 | | None, Some _ | Some _, None -> false 123 | | Some a, Some b -> equal_elt a b 124 | ;;] 125 | 126 | [%%template 127 | [@@@kind.default k = base_with_imm] 128 | 129 | let[@mode local] equal_array (type a) equal_elt (a : a array) (b : a array) = 130 | a == b 131 | || 132 | let len_a = Array.length a in 133 | let len_b = Array.length b in 134 | equal len_a len_b 135 | && 136 | let rec loop i = 137 | i = len_a 138 | || 139 | let l = Array.unsafe_get a i 140 | and r = Array.unsafe_get b i in 141 | equal_elt l r && loop (i + 1) 142 | in 143 | loop 0 [@nontail] 144 | ;; 145 | 146 | let equal_array = [%eta3 equal_array [@kind k] [@mode local]]] 147 | 148 | [%%template 149 | let[@mode local] equal_ref equal_elt a b = equal_elt !a !b 150 | let equal_ref = [%eta3 equal_ref [@mode local]]] 151 | end 152 | -------------------------------------------------------------------------------- /test/errors.mlt: -------------------------------------------------------------------------------- 1 | open Ppx_compare_lib.Builtin 2 | 3 | (* Warning when a modifier attribute is present for only one of [compare] or [equal]. *) 4 | 5 | type t = 6 | { x : int [@compare.ignore] 7 | ; y : int 8 | } 9 | [@@deriving compare, equal] 10 | 11 | [%%expect 12 | {| 13 | Line _, characters _-_: 14 | Error: Using [@compare.ignore] without [@equal.ignore] is likely to lead to incompatible [compare] and [equal] functions. 15 | |}] 16 | 17 | type t = 18 | { x : int [@equal.ignore] 19 | ; y : int 20 | } 21 | [@@deriving compare, equal] 22 | 23 | [%%expect 24 | {| 25 | Line _, characters _-_: 26 | Error: Using [@equal.ignore] without [@compare.ignore] is likely to lead to incompatible [compare] and [equal] functions. 27 | |}] 28 | 29 | type t = 30 | { x : (int[@compare.custom compare_int]) 31 | ; y : int 32 | } 33 | [@@deriving compare, equal] 34 | 35 | [%%expect 36 | {| 37 | Line _, characters _-_: 38 | Error: Using [@compare.custom] without [@equal.custom] is likely to lead to incompatible [compare] and [equal] functions. 39 | |}] 40 | 41 | type t = 42 | { x : (int[@compare.custom compare_int]) 43 | ; y : int 44 | } 45 | [@@deriving compare] 46 | 47 | [%%expect {| |}] 48 | 49 | type t = 50 | { x : (int[@equal.custom equal_int]) 51 | ; y : int 52 | } 53 | [@@deriving compare, equal] 54 | 55 | [%%expect 56 | {| 57 | Line _, characters _-_: 58 | Error: Using [@equal.custom] without [@compare.custom] is likely to lead to incompatible [compare] and [equal] functions. 59 | |}] 60 | 61 | type t = 62 | { x : (int[@equal.custom equal_int]) 63 | ; y : int 64 | } 65 | [@@deriving equal] 66 | 67 | [%%expect {| |}] 68 | 69 | type t = 70 | { x : (int[@compare.custom fun _ _ -> 0]) 71 | ; y : int 72 | } 73 | [@@deriving compare, hash] 74 | 75 | [%%expect 76 | {| 77 | Line _: 78 | Error: Using [@compare.custom] without [@hash.custom] is not allowed, because it would be easy violate the invariant that [compare x y = 0] implies [hash x = hash y]. You should provide a custom comparison function that upholds this invariant. 79 | |}] 80 | 81 | (* Unused attributes warnings work. *) 82 | 83 | type t = 84 | { x : int [@compare.ignore] [@equal.ignore] 85 | ; y : int 86 | } 87 | [@@deriving compare] 88 | 89 | [%%expect 90 | {| 91 | Line _, characters _-_: 92 | Error: Attribute `equal.ignore' was not used 93 | |}] 94 | 95 | type t = 96 | { x : int [@compare.ignore] [@equal.ignore] 97 | ; y : int 98 | } 99 | [@@deriving equal] 100 | 101 | [%%expect 102 | {| 103 | Line _, characters _-_: 104 | Error: Attribute `compare.ignore' was not used 105 | |}] 106 | 107 | type t = 108 | { x : (int[@compare.custom compare_int] [@equal.custom equal_int]) 109 | ; y : int 110 | } 111 | [@@deriving compare] 112 | 113 | [%%expect 114 | {| 115 | Line _, characters _-_: 116 | Error: Attribute `equal.custom' was not used 117 | |}] 118 | 119 | type t = 120 | { x : (int[@compare.custom compare_int] [@equal.custom equal_int]) 121 | ; y : int 122 | } 123 | [@@deriving equal] 124 | 125 | [%%expect 126 | {| 127 | Line _, characters _-_: 128 | Error: Attribute `compare.custom' was not used 129 | |}] 130 | 131 | (* [custom] attribute on wrong level warns *) 132 | 133 | type t = 134 | { x : int [@compare.custom compare_int] [@equal.custom equal_int] 135 | ; y : int 136 | } 137 | [@@deriving compare, equal] 138 | 139 | [%%expect 140 | {| 141 | Line _, characters _-_: 142 | Error: Attribute `compare.custom' was not used. 143 | Hint: `compare.custom' is available for core types but is used here in 144 | the 145 | context of a label declaration. 146 | Did you put it at the wrong level? 147 | |}] 148 | 149 | (* Warn when both ignore and custom are present *) 150 | 151 | type t = 152 | { x : (int[@compare.ignore] [@compare.custom fun _ _ -> 0]) 153 | ; y : int 154 | } 155 | [@@deriving compare] 156 | 157 | [%%expect 158 | {| 159 | Line _, characters _-_: 160 | Error: Attribute `compare.custom' was not used 161 | |}] 162 | 163 | (* [custom] attributes must be qualified *) 164 | 165 | type t = 166 | { x : (int[@custom]) 167 | ; y : int 168 | } 169 | [@@deriving compare, equal] 170 | 171 | [%%expect 172 | {| 173 | Line _, characters _-_: 174 | Error: Attribute `custom' was not used 175 | |}] 176 | 177 | (* The following ones are OK: *) 178 | 179 | type t = 180 | { x : int [@compare.ignore] [@equal.ignore] 181 | ; y : int 182 | } 183 | [@@deriving compare, equal] 184 | 185 | [%%expect {| |}] 186 | 187 | type t = 188 | { x : int [@ignore] 189 | ; y : int 190 | } 191 | [@@deriving compare, equal] 192 | 193 | [%%expect {| |}] 194 | 195 | let [%compare: M.N(K).t] = () 196 | 197 | [%%expect 198 | {| 199 | Line _, characters _-_: 200 | Error: Invalid identifier M.N(K).t for converter in pattern position. Only 201 | simple identifiers (like t or string) or applications of functors with 202 | simple identifiers (like M(K).t) are supported. 203 | |}] 204 | 205 | let [%compare: unit * unit] = () 206 | 207 | [%%expect 208 | {| 209 | Line _, characters _-_: 210 | Error: Only type variables and constructors are allowed here (e.g. ['a], [t], 211 | ['a t], or [M(X).t]). 212 | |}] 213 | 214 | (* Use [compare ~portable] in structure context to get a better error message. *) 215 | 216 | module Non_portable : sig 217 | type t [@@deriving compare] 218 | end @ nonportable = 219 | Int 220 | 221 | type t = 222 | { portable : int 223 | ; non_portable : Non_portable.t 224 | } 225 | [@@deriving compare ~portable] 226 | 227 | [%%expect 228 | {| 229 | Line _, characters _-_: 230 | Error: The value Non_portable.compare is nonportable 231 | but is expected to be portable because it is used inside a function 232 | which is expected to be portable. 233 | |}] 234 | -------------------------------------------------------------------------------- /src/ppx_compare.ml: -------------------------------------------------------------------------------- 1 | open Stdppx 2 | open Ppxlib 3 | open Ppx_compare_expander 4 | 5 | let require_explicit_locality = ref false 6 | 7 | let () = 8 | Driver.add_arg 9 | "-compare-require-explicit-locality" 10 | (Set require_explicit_locality) 11 | ~doc: 12 | "If this flag is passed, [ppx_compare] will require locality to be stated \ 13 | explicitly. This means either using [[@@deriving compare__global]], [[@@deriving \ 14 | compare__local]], or the equivalent [[@@deriving compare [@mode m]]] with \ 15 | [ppx_template]." 16 | ;; 17 | 18 | let generator f ~explicit_localize ~name = 19 | match explicit_localize with 20 | | None -> 21 | Deriving.Generator.V2.make 22 | Deriving.Args.(empty +> flag "localize" +> flag "portable") 23 | (fun ~ctxt ast localize portable -> 24 | if !require_explicit_locality && not localize 25 | then 26 | Location.raise_errorf 27 | ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) 28 | "deriving %s: must specify global/local" 29 | name; 30 | f ~ctxt ast ~localize ~portable) 31 | | Some localize -> 32 | Deriving.Generator.V2.make 33 | Deriving.Args.(empty +> flag "portable") 34 | (fun ~ctxt ast portable -> f ~ctxt ast ~localize ~portable) 35 | ;; 36 | 37 | let deriver name (module M : S) ~explicit_localize = 38 | Deriving.add 39 | name 40 | ~str_type_decl:(generator M.str_type_decl ~explicit_localize ~name) 41 | ~sig_type_decl:(generator M.sig_type_decl ~explicit_localize ~name) 42 | ;; 43 | 44 | let compare = deriver "compare" (module Compare) ~explicit_localize:None 45 | let equal = deriver "equal" (module Equal) ~explicit_localize:None 46 | 47 | let () = 48 | deriver "compare__global" (module Compare) ~explicit_localize:(Some false) 49 | |> Deriving.ignore 50 | ;; 51 | 52 | let () = 53 | deriver "equal__global" (module Equal) ~explicit_localize:(Some false) 54 | |> Deriving.ignore 55 | ;; 56 | 57 | let compare_local = 58 | deriver "compare__local" (module Compare) ~explicit_localize:(Some true) 59 | ;; 60 | 61 | let equal_local = deriver "equal__local" (module Equal) ~explicit_localize:(Some true) 62 | 63 | let replace_underscores_by_variables = 64 | let map = 65 | object 66 | inherit Ast_traverse.map as super 67 | 68 | method! core_type_desc t = 69 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree t with 70 | | Ptyp_any jkind -> 71 | Ppxlib_jane.Shim.Core_type_desc.to_parsetree 72 | (Ptyp_var (gen_symbol ~prefix:"a" (), jkind)) 73 | | _ -> super#core_type_desc t 74 | end 75 | in 76 | map#core_type 77 | ;; 78 | 79 | let declare_maybe_raise_if_not_explicit name context pattern f ~explicit = 80 | Extension.declare name context pattern (fun ~loc ~path a -> 81 | if !require_explicit_locality && not explicit 82 | then Location.raise_errorf ~loc "deriving %s: must specify global/local" name; 83 | f ~loc ~path a) 84 | ;; 85 | 86 | let () = 87 | [ ( "compare" 88 | , "compare_local" 89 | , "compare__local" 90 | , "compare__global" 91 | , Compare.type_ 92 | , Compare.core_type 93 | , Some Compare.pattern ) 94 | ; ( "equal" 95 | , "equal_local" 96 | , "equal__local" 97 | , "equal__global" 98 | , Equal.type_ 99 | , Equal.core_type 100 | , Some Equal.pattern ) 101 | ; ( "@compare.equal" 102 | , "@compare_local.equal" 103 | , "@compare.equal__local" 104 | , "@compare.equal__global" 105 | , Equal.type_ 106 | , Compare.equal_core_type 107 | , None ) 108 | ] 109 | |> List.concat_map 110 | ~f: 111 | (fun 112 | ( name 113 | , local_name 114 | , local_name_with_two_underscores_for_ppx_template 115 | , global_name_with_two_underscores_for_ppx_template 116 | , type_ 117 | , core_type 118 | , pattern ) 119 | -> 120 | let global_extension_types name ~explicit = 121 | ( name 122 | , type_ ~with_local:false 123 | , core_type ~with_local:false 124 | , Option.map pattern ~f:(fun pattern -> pattern ~with_local:false) 125 | , explicit ) 126 | in 127 | let local_extension_types name ~explicit = 128 | ( name 129 | , type_ ~with_local:true 130 | , core_type ~with_local:true 131 | , Option.map pattern ~f:(fun pattern -> pattern ~with_local:true) 132 | , explicit ) 133 | in 134 | [ global_extension_types name ~explicit:false 135 | ; global_extension_types 136 | global_name_with_two_underscores_for_ppx_template 137 | ~explicit:true 138 | ; local_extension_types local_name ~explicit:false 139 | ; local_extension_types 140 | local_name_with_two_underscores_for_ppx_template 141 | ~explicit:true 142 | ]) 143 | |> List.iter ~f:(fun (name, type_, core_type, pattern, explicit) -> 144 | Driver.register_transformation 145 | (if String.is_prefix name ~prefix:"@" then String.drop_prefix name 1 else name) 146 | ~rules: 147 | (Context_free.Rule.extension 148 | (declare_maybe_raise_if_not_explicit 149 | name 150 | Core_type 151 | Ast_pattern.(ptyp __) 152 | (fun ~loc ~path:_ ty -> 153 | type_ ~hide:true ~loc (replace_underscores_by_variables ty)) 154 | ~explicit) 155 | :: Context_free.Rule.extension 156 | (declare_maybe_raise_if_not_explicit 157 | name 158 | Expression 159 | Ast_pattern.(ptyp __) 160 | (fun ~loc:_ ~path:_ ty -> core_type ty) 161 | ~explicit) 162 | :: 163 | (match pattern with 164 | | None -> [] 165 | | Some pattern -> 166 | [ Context_free.Rule.extension 167 | (declare_maybe_raise_if_not_explicit 168 | name 169 | Pattern 170 | Ast_pattern.(ptyp __) 171 | (fun ~loc:_ ~path:_ ty -> pattern ty) 172 | ~explicit) 173 | ]))) 174 | ;; 175 | -------------------------------------------------------------------------------- /test/ppx_template_interaction.ml: -------------------------------------------------------------------------------- 1 | open Ppx_compare_lib.Builtin 2 | 3 | (* Demonstrate that [@@deriving compare [@mode local]] is equivalent to 4 | [@@deriving compare ~localize]. *) 5 | module%template With_compare : sig 6 | type t [@@deriving_inline compare [@mode local]] 7 | 8 | include sig 9 | [@@@ocaml.warning "-32"] 10 | 11 | include Ppx_compare_lib.Comparable.S with type t := t 12 | include Ppx_compare_lib.Comparable.S__local with type t := t 13 | end 14 | [@@ocaml.doc "@inline"] 15 | 16 | [@@@end] 17 | end = struct 18 | type t = int [@@deriving_inline compare [@mode local]] 19 | 20 | let _ = fun (_ : t) -> () 21 | let compare__local = (compare_int__local : t -> t -> int) 22 | let _ = compare__local 23 | let compare = (fun a b -> compare__local a b : t -> t -> int) 24 | let _ = compare 25 | 26 | [@@@end] 27 | end 28 | 29 | (* Check that the signatures match. *) 30 | module _ : sig 31 | type t [@@deriving compare ~localize] 32 | end = 33 | With_compare 34 | 35 | module _ : module type of With_compare = struct 36 | type t = int [@@deriving compare ~localize] 37 | end 38 | 39 | (* Demonstrate that [@@deriving equal [@mode local]] is equivalent to 40 | [@@deriving equal ~localize]. *) 41 | module%template With_equal : sig 42 | type t [@@deriving_inline equal [@mode local]] 43 | 44 | include sig 45 | [@@@ocaml.warning "-32"] 46 | 47 | include Ppx_compare_lib.Equal.S with type t := t 48 | include Ppx_compare_lib.Equal.S__local with type t := t 49 | end 50 | [@@ocaml.doc "@inline"] 51 | 52 | [@@@end] 53 | end = struct 54 | type t = int [@@deriving_inline equal [@mode local]] 55 | 56 | let _ = fun (_ : t) -> () 57 | let equal__local = (equal_int__local : t -> t -> bool) 58 | let _ = equal__local 59 | let equal = (fun a b -> equal__local a b : t -> t -> bool) 60 | let _ = equal 61 | 62 | [@@@end] 63 | end 64 | 65 | (* Check that the signatures match. *) 66 | module _ : sig 67 | type t [@@deriving equal ~localize] 68 | end = 69 | With_equal 70 | 71 | module _ : module type of With_equal = struct 72 | type t = int [@@deriving equal ~localize] 73 | end 74 | 75 | (* Demonstrate that the name mangling used by ppx_compare and ppx_template makes it easy 76 | to define implementations of signatures generated for templated types. *) 77 | 78 | module type%template S1_with_compare_and_equal = sig 79 | type 'a t = { boxed : 'a } 80 | [@@deriving compare ~localize, equal ~localize] [@@kind k = (value, bits64, float64)] 81 | end 82 | 83 | module%template S1_manual : S1_with_compare_and_equal = struct 84 | [@@@kind.default k = (value, bits64, float64)] 85 | 86 | type 'a t = { boxed : 'a } 87 | 88 | [@@@mode.default m = (global, local)] 89 | 90 | let compare f t1 t2 = f t1.boxed t2.boxed 91 | let equal f t1 t2 = f t1.boxed t2.boxed 92 | end 93 | 94 | module%template S1_via_extension : S1_with_compare_and_equal = struct 95 | [@@@kind.default k = (value, bits64, float64)] 96 | 97 | type 'a t = ('a S1_manual.t[@kind k]) = { boxed : 'a } 98 | 99 | let compare (type a) compare_a = [%compare: (a S1_manual.t[@kind k])] 100 | let equal (type a) equal_a = [%equal: (a S1_manual.t[@kind k])] 101 | 102 | [@@@mode.default m = local] 103 | 104 | let compare (type a) compare_a__local = [%compare_local: (a S1_manual.t[@kind k])] 105 | let equal (type a) equal_a__local = [%equal_local: (a S1_manual.t[@kind k])] 106 | end 107 | 108 | module%template S1_derived : S1_with_compare_and_equal = struct 109 | type 'a t = { boxed : 'a } 110 | [@@deriving compare ~localize, equal ~localize] [@@kind k = (value, bits64, float64)] 111 | end 112 | 113 | module type%template S2_with_compare_and_equal = sig 114 | type ('a, 'b) t = 115 | { boxed_a : 'a 116 | ; boxed_b : 'b 117 | } 118 | [@@deriving compare ~localize, equal ~localize] 119 | [@@kind ka = (value, bits64, float64), kb = (value, bits64, float64)] 120 | end 121 | 122 | module%template S2_manual : S2_with_compare_and_equal = struct 123 | [@@@kind.default ka = (value, bits64, float64), kb = (value, bits64, float64)] 124 | 125 | type ('a, 'b) t = 126 | { boxed_a : 'a 127 | ; boxed_b : 'b 128 | } 129 | 130 | [@@@mode.default m = (global, local)] 131 | 132 | let compare f_a f_b t1 t2 = 133 | match f_a t1.boxed_a t2.boxed_a with 134 | | 0 -> f_b t1.boxed_b t2.boxed_b 135 | | res -> res 136 | ;; 137 | 138 | let equal f_a f_b t1 t2 = f_a t1.boxed_a t2.boxed_a && f_b t1.boxed_b t2.boxed_b 139 | end 140 | 141 | module%template S2_via_extension : S2_with_compare_and_equal = struct 142 | [@@@kind.default ka = (value, bits64, float64), kb = (value, bits64, float64)] 143 | 144 | type ('a, 'b) t = (('a, 'b) S2_manual.t[@kind ka kb]) = 145 | { boxed_a : 'a 146 | ; boxed_b : 'b 147 | } 148 | 149 | let compare (type a b) compare_a compare_b = 150 | [%compare: ((a, b) S2_manual.t[@kind ka kb])] 151 | ;; 152 | 153 | let equal (type a b) equal_a equal_b = [%equal: ((a, b) S2_manual.t[@kind ka kb])] 154 | 155 | [@@@mode.default m = local] 156 | 157 | let compare (type a b) compare_a__local compare_b__local = 158 | [%compare_local: ((a, b) S2_manual.t[@kind ka kb])] 159 | ;; 160 | 161 | let equal (type a b) equal_a__local equal_b__local = 162 | [%equal_local: ((a, b) S2_manual.t[@kind ka kb])] 163 | ;; 164 | end 165 | 166 | module%template S2_derived : S2_with_compare_and_equal = struct 167 | type ('a, 'b) t = 168 | { boxed_a : 'a 169 | ; boxed_b : 'b 170 | } 171 | [@@deriving compare ~localize, equal ~localize] 172 | [@@kind ka = (value, bits64, float64), kb = (value, bits64, float64)] 173 | end 174 | 175 | (* Demonstrate that [[%equal: _] [@mode m]] is equivalent to [@@deriving equal [@mode 176 | local]] for [m = (global, local)] and similary for [%compare] and [%compare.equal]. 177 | *) 178 | module%template _ : sig 179 | type t [@@deriving_inline (compare [@mode local]), (equal [@mode local])] 180 | 181 | include sig 182 | [@@@ocaml.warning "-32"] 183 | 184 | include Ppx_compare_lib.Comparable.S with type t := t 185 | include Ppx_compare_lib.Comparable.S__local with type t := t 186 | include Ppx_compare_lib.Equal.S with type t := t 187 | include Ppx_compare_lib.Equal.S__local with type t := t 188 | end 189 | [@@ocaml.doc "@inline"] 190 | 191 | [@@@end] 192 | 193 | val%template equal_via_compare : t -> t -> bool [@@mode m = (global, local)] 194 | end = struct 195 | type t = string 196 | 197 | [%%template 198 | [@@@mode.default m = (global, local)] 199 | 200 | let compare = ([%compare: string] [@mode m]) 201 | let equal = ([%equal: string] [@mode m]) 202 | let equal_via_compare = ([%compare.equal: string] [@mode m])] 203 | end 204 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_compare 2 | =========== 3 | 4 | Generation of fast comparison and equality functions from type 5 | expressions and definitions. 6 | 7 | Ppx_compare is a ppx rewriter that derives comparison and equality 8 | functions from type representations. The scaffolded functions are 9 | usually much faster than ocaml's `Pervasives.compare` and 10 | `Pervasives.(=)`. Scaffolding functions also gives you more 11 | flexibility by allowing you to override them for a specific type and 12 | more safety by making sure that you only compare comparable values. 13 | 14 | Syntax 15 | ------ 16 | 17 | - Type definitions: `[@@deriving compare, equal]` 18 | - Expressions: `[%compare: TYPE]`, `[%equal: TYPE]` and `[%compare.equal: TYPE]` 19 | - Types, record fields: `[@compare.ignore]`, `[@equal.ignore]` 20 | - Types: `[@compare.custom CUSTOM_IMPLEMENTATION]`, `[@equal.custom CUSTOM_IMPLEMENTATION]` 21 | 22 | Basic usage 23 | ----------- 24 | 25 | We use `ppx_deriving`/`ppx_type_conv`, so type definitions are annotated this way: 26 | 27 | ```ocaml 28 | type s = v * w [@@deriving compare] 29 | ``` 30 | 31 | This will generate `compare_s : s -> s -> int` function that relies on 32 | `compare_v : v -> v -> int` and `compare_w : w -> w -> int`. 33 | 34 | Compare is not DWIM (do what I mean): it will scaffold a fast well behaved comparison 35 | (reflexive, transitive, symmetric...) function however it does not try to follow any 36 | "natural ordering". For instance arrays of characters are not sorted lexicographically. 37 | 38 | Base types (options,int,array,lists,char,floats...) have the same comparison order as 39 | Pervasives.compare (provided their type parameters also do for the polymorphic ones). 40 | Comparisons for these types must be brought in scope with `open Base`, `open Core`, or 41 | `open Ppx_compare_lib.Builtin`. 42 | 43 | Records fields are compared in the order they are defined (left to right); tuples fields 44 | are compared left to right. When we compare two branches of a sum whichever ones comes 45 | first in the definition is considered lowest. Variants compare in the order they are 46 | listed (increasing top-to-bottom). Polymorphic variants use the same ordering as the 47 | ocaml runtime. 48 | 49 | The same applies to equality functions. 50 | 51 | ### Float equality 52 | 53 | The functions derived by `[@@deriving equal]` are consistent with the 54 | compare functions derived by `[@@deriving compare]` and in particular 55 | do not respect IEEE float comparison. 56 | 57 | Calling `compare` for type `t`s 58 | ------------------------------- 59 | 60 | In compliance (or conformance) with Janestreet's coding standard we assume that 61 | type named `t` are the main types in a module and 62 | 63 | ```ocaml 64 | type t = S.t * T.t [@@deriving compare] 65 | ``` 66 | 67 | will call the functions `S.compare` and `T.compare` instead of calling `S.compare_t` and 68 | `T.compare_t`. This will also generate a `compare : t -> t -> int` function. 69 | 70 | The same applies to equality functions. 71 | 72 | Signature 73 | --------- 74 | 75 | `type t [@@deriving compare]` in a module signature will add `val compare : t -> t -> int` 76 | in the signature. 77 | 78 | The same applies to equality functions. 79 | 80 | Comparison without a type definition 81 | ------------------------------------ 82 | 83 | Sometimes you just want a comparison without having to create a new type. You can create 84 | such a comparison function using the `[%compare: ..]` extension point: 85 | 86 | ```ocaml 87 | let gt x y = [%compare: float * int * [`A | `B | `C] ] x y 88 | ``` 89 | 90 | You can use the type `_`, in which case the corresponding values will be 91 | ignored (i.e. compared using `fun _ _ -> 0`). For instance: 92 | 93 | ```ocaml 94 | assert ([%compare: _ list] [ true ] [ false ] = 0); 95 | assert ([%compare: _ list] [] [ false ] <> 0); 96 | ``` 97 | 98 | The same applies to equality functions. 99 | 100 | You can also check for equality using `[%compare.equal: ..]`, which 101 | produces a function that returns `true` precisely when `[%compare: 102 | ..]` returns `0`. `[%equal: ..]` is preferred over `[%compare.equal: 103 | ..]` and in particular is expected to be slightly faster. However, 104 | `[%compare.equal: ..]` can come in handy for types that only have 105 | `[@@deriving compare]`. In particular, support for `[@@deriving 106 | equal]` was added long after the project started, which means that 107 | many types out there only support `[@deriving compare]`. 108 | 109 | Ignoring part of types 110 | ---------------------- 111 | 112 | The comparison ignores any part of the type declaration that is under 113 | a `[@compare.ignore]` annotation: 114 | 115 | ```ocaml 116 | type t = (float [@compare.ignore]) * string 117 | [@@deriving compare] 118 | ``` 119 | 120 | The same applies for `[@@deriving equal]` by using 121 | `[@equal.ignore]`. In order to ignore part of a type for both 122 | comparison and equality, you can simply use `[@ignore]`. However, be 123 | aware that the general `[@ignore]` attribute will apply to any deriver 124 | that recognize it, not just `compare` and `equal`. 125 | 126 | Note that if you use both the `compare` and `equal` derivers, you need 127 | to use either both `[@compare.ignore]` and `[@equal.ignore]` or 128 | `[@ignore]`. However, you cannot use only one of them. 129 | 130 | For convenience, you can also ignore record fields instead of the 131 | type of record field. In other words, 132 | 133 | ```ocaml 134 | type t = 135 | { a : (float [@compare.ignore]) 136 | ; b : string 137 | } 138 | [@@deriving compare] 139 | ``` 140 | 141 | can be abbreviated: 142 | 143 | ```ocaml 144 | type t = 145 | { a : float [@compare.ignore] 146 | ; b : string 147 | } 148 | [@@deriving compare] 149 | ``` 150 | 151 | 152 | Overriding implementation for parts of types 153 | ------------------------------------------ 154 | 155 | You can use the `[@compare.custom EXPR]` and `[@equal.custom EXPR]` attributes 156 | to provide a custom implementation for part of a type: 157 | 158 | 159 | ```ocaml 160 | type t = 161 | { a : int 162 | ; b : (string[@compare.custom (Comparable.lift [%compare: int] ~f:String.length)]) list 163 | } 164 | [@@deriving compare] 165 | ``` 166 | 167 | Local-accepting compare functions 168 | ---------------------------- 169 | 170 | This ppx includes the option to support local allocation, a nonstandard OCaml extension 171 | available at: https://github.com/ocaml-flambda/ocaml-jst 172 | 173 | In both structures and signatures, `[@@deriving compare ~localize]` (and similarly for 174 | `equal`) generates definitions with the following types, in addition to the usual 175 | definitions: 176 | 177 | ``` 178 | (* Monomorphic types *) 179 | val compare__local : local_ t -> local_ t -> int 180 | val equal__local : local_ t -> local_ t -> bool 181 | 182 | (* Parameterized types *) 183 | val compare__local 184 | : (local_ 'a -> local_ 'a -> int) 185 | -> local_ 'a t 186 | -> local_ 'a t 187 | -> int 188 | val equal__local 189 | : (local_ 'a -> local_ 'a -> bool) 190 | -> local_ 'a t 191 | -> local_ 'a t 192 | -> bool 193 | ``` 194 | 195 | You can also use the `[%compare_local: _]`, `[%equal_local: _]` and 196 | `[%compare_local.equal: _]` extension points to generate the corresponding 197 | types and functions. 198 | 199 | For types named something other than `t`, the naming pattern is similar 200 | to the non-local versions: 201 | 202 | ```ocaml 203 | type foo 204 | 205 | val compare_foo__local : local_ foo -> local_ foo -> int 206 | ``` 207 | -------------------------------------------------------------------------------- /test/modalities.ml: -------------------------------------------------------------------------------- 1 | let compare_int : int -> int -> int = compare 2 | let compare_int__local : int -> int -> int = compare 3 | let equal_int : int -> int -> bool = ( = ) 4 | let equal_int__local : int -> int -> bool = ( = ) 5 | 6 | module Compare : sig 7 | type t [@@deriving_inline compare ~portable] 8 | 9 | include sig 10 | [@@@ocaml.warning "-32"] 11 | 12 | include Ppx_compare_lib.Comparable.S with type t := t 13 | end 14 | [@@ocaml.doc "@inline"] 15 | 16 | [@@@end] 17 | end = struct 18 | type t = int [@@deriving_inline compare ~portable] 19 | 20 | let _ = fun (_ : t) -> () 21 | let compare = (compare_int : t -> t -> int) 22 | let _ = compare 23 | 24 | [@@@end] 25 | end 26 | 27 | module Compare_u : sig 28 | type u [@@deriving_inline compare ~portable] 29 | 30 | include sig 31 | [@@@ocaml.warning "-32"] 32 | 33 | val compare_u : u -> u -> int 34 | end 35 | [@@ocaml.doc "@inline"] 36 | 37 | [@@@end] 38 | end = struct 39 | type u = int [@@deriving_inline compare ~portable] 40 | 41 | let _ = fun (_ : u) -> () 42 | let compare_u = (compare_int : u -> u -> int) 43 | let _ = compare_u 44 | 45 | [@@@end] 46 | end 47 | 48 | module Compare_local : sig 49 | type t [@@deriving_inline compare ~localize ~portable] 50 | 51 | include sig 52 | [@@@ocaml.warning "-32"] 53 | 54 | include Ppx_compare_lib.Comparable.S with type t := t 55 | include Ppx_compare_lib.Comparable.S__local with type t := t 56 | end 57 | [@@ocaml.doc "@inline"] 58 | 59 | [@@@end] 60 | end = struct 61 | type t = int [@@deriving_inline compare ~localize ~portable] 62 | 63 | let _ = fun (_ : t) -> () 64 | let compare__local = (compare_int__local : t -> t -> int) 65 | let _ = compare__local 66 | let compare = (fun a b -> compare__local a b : t -> t -> int) 67 | let _ = compare 68 | 69 | [@@@end] 70 | end 71 | 72 | module%template [@mode local] Compare : sig 73 | type t [@@deriving_inline (compare [@mode local]) ~portable] 74 | 75 | include sig 76 | [@@@ocaml.warning "-32"] 77 | 78 | include Ppx_compare_lib.Comparable.S with type t := t 79 | include Ppx_compare_lib.Comparable.S__local with type t := t 80 | end 81 | [@@ocaml.doc "@inline"] 82 | 83 | [@@@end] 84 | end = struct 85 | type t = 86 | { a : int 87 | ; b : int 88 | } 89 | [@@deriving_inline (compare [@mode local]) ~portable] 90 | 91 | let _ = fun (_ : t) -> () 92 | 93 | let compare__local = 94 | (fun a__008_ b__009_ -> 95 | if Stdlib.( == ) a__008_ b__009_ 96 | then 0 97 | else ( 98 | match compare_int__local a__008_.a b__009_.a with 99 | | 0 -> compare_int__local a__008_.b b__009_.b 100 | | n -> n) 101 | : t -> t -> int) 102 | ;; 103 | 104 | let _ = compare__local 105 | let compare = (fun a b -> compare__local a b : t -> t -> int) 106 | let _ = compare 107 | 108 | [@@@end] 109 | end 110 | 111 | module Equal : sig 112 | type t [@@deriving_inline equal ~portable] 113 | 114 | include sig 115 | [@@@ocaml.warning "-32"] 116 | 117 | include Ppx_compare_lib.Equal.S with type t := t 118 | end 119 | [@@ocaml.doc "@inline"] 120 | 121 | [@@@end] 122 | end = struct 123 | type t = int [@@deriving_inline equal ~portable] 124 | 125 | let _ = fun (_ : t) -> () 126 | let equal = (equal_int : t -> t -> bool) 127 | let _ = equal 128 | 129 | [@@@end] 130 | end 131 | 132 | module Equal_u : sig 133 | type u [@@deriving_inline equal ~portable] 134 | 135 | include sig 136 | [@@@ocaml.warning "-32"] 137 | 138 | val equal_u : u -> u -> bool 139 | end 140 | [@@ocaml.doc "@inline"] 141 | 142 | [@@@end] 143 | end = struct 144 | type u = int [@@deriving_inline equal ~portable] 145 | 146 | let _ = fun (_ : u) -> () 147 | let equal_u = (equal_int : u -> u -> bool) 148 | let _ = equal_u 149 | 150 | [@@@end] 151 | end 152 | 153 | module Equal_local : sig 154 | type t [@@deriving_inline equal ~localize ~portable] 155 | 156 | include sig 157 | [@@@ocaml.warning "-32"] 158 | 159 | include Ppx_compare_lib.Equal.S with type t := t 160 | include Ppx_compare_lib.Equal.S__local with type t := t 161 | end 162 | [@@ocaml.doc "@inline"] 163 | 164 | [@@@end] 165 | end = struct 166 | type t = int [@@deriving_inline equal ~localize ~portable] 167 | 168 | let _ = fun (_ : t) -> () 169 | let equal__local = (equal_int__local : t -> t -> bool) 170 | let _ = equal__local 171 | let equal = (fun a b -> equal__local a b : t -> t -> bool) 172 | let _ = equal 173 | 174 | [@@@end] 175 | end 176 | 177 | module%template [@mode local] Equal : sig 178 | type t [@@deriving_inline (equal [@mode local]) ~portable] 179 | 180 | include sig 181 | [@@@ocaml.warning "-32"] 182 | 183 | include Ppx_compare_lib.Equal.S with type t := t 184 | include Ppx_compare_lib.Equal.S__local with type t := t 185 | end 186 | [@@ocaml.doc "@inline"] 187 | 188 | [@@@end] 189 | end = struct 190 | type t = int [@@deriving_inline equal ~localize ~portable] 191 | 192 | let _ = fun (_ : t) -> () 193 | let equal__local = (equal_int__local : t -> t -> bool) 194 | let _ = equal__local 195 | let equal = (fun a b -> equal__local a b : t -> t -> bool) 196 | let _ = equal 197 | 198 | [@@@end] 199 | end 200 | 201 | module Recursive : sig 202 | type t 203 | and 'a u 204 | and ('a, 'b) v [@@deriving_inline compare ~portable] 205 | 206 | include sig 207 | [@@@ocaml.warning "-32"] 208 | 209 | val compare : t -> t -> int 210 | val compare_u : 'a. ('a -> 'a -> int) -> 'a u -> 'a u -> int 211 | 212 | val compare_v 213 | : 'a 'b. 214 | ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) v -> ('a, 'b) v -> int 215 | end 216 | [@@ocaml.doc "@inline"] 217 | 218 | [@@@end] 219 | end = struct 220 | type t = 221 | { a : int 222 | ; u : int u 223 | } 224 | 225 | and 'a u = 226 | { b : 'a 227 | ; v : (int, 'a) v 228 | } 229 | 230 | and ('a, 'b) v = 231 | { a : 'a 232 | ; b : 'b 233 | ; t : t 234 | } 235 | [@@deriving_inline compare ~portable] 236 | 237 | let _ = fun (_ : t) -> () 238 | let _ = fun (_ : 'a u) -> () 239 | let _ = fun (_ : ('a, 'b) v) -> () 240 | 241 | let rec compare = 242 | (fun a__019_ b__020_ -> 243 | if Stdlib.( == ) a__019_ b__020_ 244 | then 0 245 | else ( 246 | match compare_int a__019_.a b__020_.a with 247 | | 0 -> 248 | compare_u 249 | (fun a__021_ b__022_ -> compare_int a__021_ b__022_) 250 | a__019_.u 251 | b__020_.u 252 | | n -> n) 253 | : t -> t -> int) 254 | 255 | and compare_u : 'a. ('a -> 'a -> int) -> 'a u -> 'a u -> int = 256 | fun _cmp__a a__023_ b__024_ -> 257 | if Stdlib.( == ) a__023_ b__024_ 258 | then 0 259 | else ( 260 | match _cmp__a a__023_.b b__024_.b with 261 | | 0 -> 262 | compare_v 263 | (fun a__025_ b__026_ -> compare_int a__025_ b__026_) 264 | (fun a__027_ b__028_ -> _cmp__a a__027_ b__028_) 265 | a__023_.v 266 | b__024_.v 267 | | n -> n) 268 | 269 | and compare_v 270 | : 'a 'b. ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) v -> ('a, 'b) v -> int 271 | = 272 | fun _cmp__a _cmp__b a__029_ b__030_ -> 273 | if Stdlib.( == ) a__029_ b__030_ 274 | then 0 275 | else ( 276 | match _cmp__a a__029_.a b__030_.a with 277 | | 0 -> 278 | (match _cmp__b a__029_.b b__030_.b with 279 | | 0 -> compare a__029_.t b__030_.t 280 | | n -> n) 281 | | n -> n) 282 | ;; 283 | 284 | let _ = compare 285 | and _ = compare_u 286 | and _ = compare_v 287 | 288 | [@@@end] 289 | end 290 | -------------------------------------------------------------------------------- /test/global_modality.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | module A : sig 4 | type t 5 | 6 | val compare : t -> t -> int 7 | val equal : t -> t -> bool 8 | end = struct 9 | type t = int [@@deriving compare, equal] 10 | end 11 | 12 | module A1 : sig 13 | type 'a t 14 | 15 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 16 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 17 | end = struct 18 | type 'a t = 'a list [@@deriving compare, equal] 19 | end 20 | 21 | (* Tests without inline *) 22 | 23 | module No_inline = struct 24 | type simple_rec = 25 | { x : int 26 | ; y : A.t 27 | } 28 | [@@deriving compare ~localize, equal ~localize] 29 | 30 | type simple_var = 31 | | A of int 32 | | B of A.t 33 | [@@deriving compare ~localize, equal ~localize] 34 | 35 | type simple_rec1 = 36 | { x : int 37 | ; y : string A1.t 38 | } 39 | [@@deriving compare ~localize, equal ~localize] 40 | 41 | type simple_var1 = 42 | | A of int 43 | | B of string A1.t 44 | [@@deriving compare ~localize, equal ~localize] 45 | 46 | type 'a might_need_eta_rec = 47 | { x : 'a 48 | ; y : 'a A1.t 49 | } 50 | [@@deriving compare ~localize, equal ~localize] 51 | 52 | type 'a might_need_eta_var = 53 | | A of 'a 54 | | B of 'a A1.t 55 | [@@deriving compare ~localize, equal ~localize] 56 | 57 | type 'a mut = 58 | { x : int 59 | ; mutable y : A.t 60 | } 61 | [@@deriving compare ~localize, equal ~localize] 62 | 63 | type recursive = 64 | { x : int 65 | ; y : recursive A1.t 66 | } 67 | [@@deriving compare ~localize, equal ~localize] 68 | 69 | type 'a recursive1 = 70 | { x : int 71 | ; y : 'a A1.t recursive1 72 | } 73 | [@@deriving compare ~localize, equal ~localize] 74 | 75 | module Test_nonrec = struct 76 | type nonrec 'a recursive1 = 77 | { x : int 78 | ; y : 'a A1.t recursive1 79 | } 80 | [@@deriving compare ~localize, equal ~localize] 81 | end 82 | end 83 | 84 | (* Tests with [[@globalized]] attribute *) 85 | module Via_public_release_attribute = struct 86 | (* The purpose of the [[@globalized]] attribute is to be used in public release, where 87 | modes are not checked. We simulate this by using a type [t] that crosses locality for 88 | the fields that are marked [[@globalized]] *) 89 | module A : sig 90 | type t 91 | 92 | val compare : t -> t -> int 93 | val equal : t -> t -> bool 94 | end = struct 95 | type t = int [@@deriving compare, equal] 96 | end 97 | 98 | module A1 : sig 99 | type 'a t 100 | 101 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 102 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 103 | end = struct 104 | type 'a t = int [@@deriving compare, equal] 105 | end 106 | 107 | type simple_rec = 108 | { x : int 109 | ; y : A.t [@globalized] 110 | } 111 | [@@deriving compare ~localize, equal ~localize] 112 | 113 | type simple_var = 114 | | A of int 115 | | B of (A.t[@globalized]) 116 | [@@deriving compare ~localize, equal ~localize] 117 | 118 | type simple_rec1 = 119 | { x : int 120 | ; y : string A1.t [@globalized] 121 | } 122 | [@@deriving compare ~localize, equal ~localize] 123 | 124 | type simple_var1 = 125 | | A of int 126 | | B of (string A1.t[@globalized]) 127 | [@@deriving compare ~localize, equal ~localize] 128 | 129 | type 'a might_need_eta_rec = 130 | { x : 'a 131 | ; y : 'a A1.t [@globalized] 132 | } 133 | [@@deriving compare ~localize, equal ~localize] 134 | 135 | type 'a might_need_eta_var = 136 | | A of 'a 137 | | B of ('a A1.t[@globalized]) 138 | [@@deriving compare ~localize, equal ~localize] 139 | 140 | type 'a mut = 141 | { x : int 142 | ; mutable y : A.t 143 | } 144 | [@@deriving compare ~localize, equal ~localize] 145 | 146 | type recursive = 147 | { x : int 148 | ; y : recursive A1.t [@globalized] 149 | } 150 | [@@deriving compare ~localize, equal ~localize] 151 | end 152 | 153 | (* Tests with inline --- there was previously a bug in [deriving_inline] interaction that 154 | resulted in extra eta-reductions that caused type errors in the last two tests. *) 155 | 156 | module Inline = struct 157 | type simple_rec = 158 | { x : int 159 | ; y : A.t 160 | } 161 | [@@deriving_inline compare ~localize, equal ~localize] 162 | 163 | let _ = fun (_ : simple_rec) -> () 164 | 165 | let compare_simple_rec__local = 166 | (fun a__277_ b__278_ -> 167 | if Stdlib.( == ) a__277_ b__278_ 168 | then 0 169 | else ( 170 | match compare_int__local a__277_.x b__278_.x with 171 | | 0 -> A.compare a__277_.y b__278_.y 172 | | n -> n) 173 | : simple_rec -> simple_rec -> int) 174 | ;; 175 | 176 | let _ = compare_simple_rec__local 177 | 178 | let compare_simple_rec = 179 | (fun a b -> compare_simple_rec__local a b : simple_rec -> simple_rec -> int) 180 | ;; 181 | 182 | let _ = compare_simple_rec 183 | 184 | let equal_simple_rec__local = 185 | (fun a__279_ b__280_ -> 186 | if Stdlib.( == ) a__279_ b__280_ 187 | then true 188 | else 189 | Stdlib.( && ) 190 | (equal_int__local a__279_.x b__280_.x) 191 | (A.equal a__279_.y b__280_.y) 192 | : simple_rec -> simple_rec -> bool) 193 | ;; 194 | 195 | let _ = equal_simple_rec__local 196 | 197 | let equal_simple_rec = 198 | (fun a b -> equal_simple_rec__local a b : simple_rec -> simple_rec -> bool) 199 | ;; 200 | 201 | let _ = equal_simple_rec 202 | 203 | [@@@end] 204 | 205 | type simple_var = 206 | | A of int 207 | | B of A.t 208 | [@@deriving_inline compare ~localize, equal ~localize] 209 | 210 | let _ = fun (_ : simple_var) -> () 211 | 212 | let compare_simple_var__local = 213 | (fun a__281_ b__282_ -> 214 | if Stdlib.( == ) a__281_ b__282_ 215 | then 0 216 | else ( 217 | match a__281_, b__282_ with 218 | | A _a__283_, A _b__284_ -> compare_int__local _a__283_ _b__284_ 219 | | A _, _ -> -1 220 | | _, A _ -> 1 221 | | B _a__285_, B _b__286_ -> A.compare _a__285_ _b__286_) 222 | : simple_var -> simple_var -> int) 223 | ;; 224 | 225 | let _ = compare_simple_var__local 226 | 227 | let compare_simple_var = 228 | (fun a b -> compare_simple_var__local a b : simple_var -> simple_var -> int) 229 | ;; 230 | 231 | let _ = compare_simple_var 232 | 233 | let equal_simple_var__local = 234 | (fun a__287_ b__288_ -> 235 | if Stdlib.( == ) a__287_ b__288_ 236 | then true 237 | else ( 238 | match a__287_, b__288_ with 239 | | A _a__289_, A _b__290_ -> equal_int__local _a__289_ _b__290_ 240 | | A _, _ -> false 241 | | _, A _ -> false 242 | | B _a__291_, B _b__292_ -> A.equal _a__291_ _b__292_) 243 | : simple_var -> simple_var -> bool) 244 | ;; 245 | 246 | let _ = equal_simple_var__local 247 | 248 | let equal_simple_var = 249 | (fun a b -> equal_simple_var__local a b : simple_var -> simple_var -> bool) 250 | ;; 251 | 252 | let _ = equal_simple_var 253 | 254 | [@@@end] 255 | 256 | type simple_rec1 = 257 | { x : int 258 | ; y : string A1.t 259 | } 260 | [@@deriving_inline compare ~localize, equal ~localize] 261 | 262 | let _ = fun (_ : simple_rec1) -> () 263 | 264 | let compare_simple_rec1__local = 265 | (fun a__293_ b__294_ -> 266 | if Stdlib.( == ) a__293_ b__294_ 267 | then 0 268 | else ( 269 | match compare_int__local a__293_.x b__294_.x with 270 | | 0 -> 271 | A1.compare 272 | (fun a__295_ b__296_ -> compare_string a__295_ b__296_) 273 | a__293_.y 274 | b__294_.y 275 | | n -> n) 276 | : simple_rec1 -> simple_rec1 -> int) 277 | ;; 278 | 279 | let _ = compare_simple_rec1__local 280 | 281 | let compare_simple_rec1 = 282 | (fun a b -> compare_simple_rec1__local a b : simple_rec1 -> simple_rec1 -> int) 283 | ;; 284 | 285 | let _ = compare_simple_rec1 286 | 287 | let equal_simple_rec1__local = 288 | (fun a__297_ b__298_ -> 289 | if Stdlib.( == ) a__297_ b__298_ 290 | then true 291 | else 292 | Stdlib.( && ) 293 | (equal_int__local a__297_.x b__298_.x) 294 | (A1.equal 295 | (fun a__299_ b__300_ -> equal_string a__299_ b__300_) 296 | a__297_.y 297 | b__298_.y) 298 | : simple_rec1 -> simple_rec1 -> bool) 299 | ;; 300 | 301 | let _ = equal_simple_rec1__local 302 | 303 | let equal_simple_rec1 = 304 | (fun a b -> equal_simple_rec1__local a b : simple_rec1 -> simple_rec1 -> bool) 305 | ;; 306 | 307 | let _ = equal_simple_rec1 308 | 309 | [@@@end] 310 | 311 | type simple_var1 = 312 | | A of int 313 | | B of string A1.t 314 | [@@deriving_inline compare ~localize, equal ~localize] 315 | 316 | let _ = fun (_ : simple_var1) -> () 317 | 318 | let compare_simple_var1__local = 319 | (fun a__301_ b__302_ -> 320 | if Stdlib.( == ) a__301_ b__302_ 321 | then 0 322 | else ( 323 | match a__301_, b__302_ with 324 | | A _a__303_, A _b__304_ -> compare_int__local _a__303_ _b__304_ 325 | | A _, _ -> -1 326 | | _, A _ -> 1 327 | | B _a__305_, B _b__306_ -> 328 | A1.compare 329 | (fun a__307_ b__308_ -> compare_string a__307_ b__308_) 330 | _a__305_ 331 | _b__306_) 332 | : simple_var1 -> simple_var1 -> int) 333 | ;; 334 | 335 | let _ = compare_simple_var1__local 336 | 337 | let compare_simple_var1 = 338 | (fun a b -> compare_simple_var1__local a b : simple_var1 -> simple_var1 -> int) 339 | ;; 340 | 341 | let _ = compare_simple_var1 342 | 343 | let equal_simple_var1__local = 344 | (fun a__309_ b__310_ -> 345 | if Stdlib.( == ) a__309_ b__310_ 346 | then true 347 | else ( 348 | match a__309_, b__310_ with 349 | | A _a__311_, A _b__312_ -> equal_int__local _a__311_ _b__312_ 350 | | A _, _ -> false 351 | | _, A _ -> false 352 | | B _a__313_, B _b__314_ -> 353 | A1.equal 354 | (fun a__315_ b__316_ -> equal_string a__315_ b__316_) 355 | _a__313_ 356 | _b__314_) 357 | : simple_var1 -> simple_var1 -> bool) 358 | ;; 359 | 360 | let _ = equal_simple_var1__local 361 | 362 | let equal_simple_var1 = 363 | (fun a b -> equal_simple_var1__local a b : simple_var1 -> simple_var1 -> bool) 364 | ;; 365 | 366 | let _ = equal_simple_var1 367 | 368 | [@@@end] 369 | 370 | type 'a might_need_eta_rec = 371 | { x : 'a 372 | ; y : 'a A1.t 373 | } 374 | [@@deriving_inline compare ~localize, equal ~localize] 375 | 376 | let _ = fun (_ : 'a might_need_eta_rec) -> () 377 | 378 | let compare_might_need_eta_rec__local 379 | : 'a. ('a -> 'a -> int) -> 'a might_need_eta_rec -> 'a might_need_eta_rec -> int 380 | = 381 | fun _cmp__a a__317_ b__318_ -> 382 | if Stdlib.( == ) a__317_ b__318_ 383 | then 0 384 | else ( 385 | match _cmp__a a__317_.x b__318_.x with 386 | | 0 -> 387 | A1.compare (fun a__319_ b__320_ -> _cmp__a a__319_ b__320_) a__317_.y b__318_.y 388 | | n -> n) 389 | ;; 390 | 391 | let _ = compare_might_need_eta_rec__local 392 | 393 | let compare_might_need_eta_rec 394 | : 'a. ('a -> 'a -> int) -> 'a might_need_eta_rec -> 'a might_need_eta_rec -> int 395 | = 396 | fun _cmp__a a__321_ b__322_ -> 397 | if Stdlib.( == ) a__321_ b__322_ 398 | then 0 399 | else ( 400 | match _cmp__a a__321_.x b__322_.x with 401 | | 0 -> 402 | A1.compare (fun a__323_ b__324_ -> _cmp__a a__323_ b__324_) a__321_.y b__322_.y 403 | | n -> n) 404 | ;; 405 | 406 | let _ = compare_might_need_eta_rec 407 | 408 | let equal_might_need_eta_rec__local 409 | : 'a. ('a -> 'a -> bool) -> 'a might_need_eta_rec -> 'a might_need_eta_rec -> bool 410 | = 411 | fun _cmp__a a__325_ b__326_ -> 412 | if Stdlib.( == ) a__325_ b__326_ 413 | then true 414 | else 415 | Stdlib.( && ) 416 | (_cmp__a a__325_.x b__326_.x) 417 | (A1.equal (fun a__327_ b__328_ -> _cmp__a a__327_ b__328_) a__325_.y b__326_.y) 418 | ;; 419 | 420 | let _ = equal_might_need_eta_rec__local 421 | 422 | let equal_might_need_eta_rec 423 | : 'a. ('a -> 'a -> bool) -> 'a might_need_eta_rec -> 'a might_need_eta_rec -> bool 424 | = 425 | fun _cmp__a a__329_ b__330_ -> 426 | if Stdlib.( == ) a__329_ b__330_ 427 | then true 428 | else 429 | Stdlib.( && ) 430 | (_cmp__a a__329_.x b__330_.x) 431 | (A1.equal (fun a__331_ b__332_ -> _cmp__a a__331_ b__332_) a__329_.y b__330_.y) 432 | ;; 433 | 434 | let _ = equal_might_need_eta_rec 435 | 436 | [@@@end] 437 | 438 | type 'a might_need_eta_var = 439 | | A of 'a 440 | | B of 'a A1.t 441 | [@@deriving_inline compare ~localize, equal ~localize] 442 | 443 | let _ = fun (_ : 'a might_need_eta_var) -> () 444 | 445 | let compare_might_need_eta_var__local 446 | : 'a. ('a -> 'a -> int) -> 'a might_need_eta_var -> 'a might_need_eta_var -> int 447 | = 448 | fun _cmp__a a__333_ b__334_ -> 449 | if Stdlib.( == ) a__333_ b__334_ 450 | then 0 451 | else ( 452 | match a__333_, b__334_ with 453 | | A _a__335_, A _b__336_ -> _cmp__a _a__335_ _b__336_ 454 | | A _, _ -> -1 455 | | _, A _ -> 1 456 | | B _a__337_, B _b__338_ -> 457 | A1.compare (fun a__339_ b__340_ -> _cmp__a a__339_ b__340_) _a__337_ _b__338_) 458 | ;; 459 | 460 | let _ = compare_might_need_eta_var__local 461 | 462 | let compare_might_need_eta_var 463 | : 'a. ('a -> 'a -> int) -> 'a might_need_eta_var -> 'a might_need_eta_var -> int 464 | = 465 | fun _cmp__a a__341_ b__342_ -> 466 | if Stdlib.( == ) a__341_ b__342_ 467 | then 0 468 | else ( 469 | match a__341_, b__342_ with 470 | | A _a__343_, A _b__344_ -> _cmp__a _a__343_ _b__344_ 471 | | A _, _ -> -1 472 | | _, A _ -> 1 473 | | B _a__345_, B _b__346_ -> 474 | A1.compare (fun a__347_ b__348_ -> _cmp__a a__347_ b__348_) _a__345_ _b__346_) 475 | ;; 476 | 477 | let _ = compare_might_need_eta_var 478 | 479 | let equal_might_need_eta_var__local 480 | : 'a. ('a -> 'a -> bool) -> 'a might_need_eta_var -> 'a might_need_eta_var -> bool 481 | = 482 | fun _cmp__a a__349_ b__350_ -> 483 | if Stdlib.( == ) a__349_ b__350_ 484 | then true 485 | else ( 486 | match a__349_, b__350_ with 487 | | A _a__351_, A _b__352_ -> _cmp__a _a__351_ _b__352_ 488 | | A _, _ -> false 489 | | _, A _ -> false 490 | | B _a__353_, B _b__354_ -> 491 | A1.equal (fun a__355_ b__356_ -> _cmp__a a__355_ b__356_) _a__353_ _b__354_) 492 | ;; 493 | 494 | let _ = equal_might_need_eta_var__local 495 | 496 | let equal_might_need_eta_var 497 | : 'a. ('a -> 'a -> bool) -> 'a might_need_eta_var -> 'a might_need_eta_var -> bool 498 | = 499 | fun _cmp__a a__357_ b__358_ -> 500 | if Stdlib.( == ) a__357_ b__358_ 501 | then true 502 | else ( 503 | match a__357_, b__358_ with 504 | | A _a__359_, A _b__360_ -> _cmp__a _a__359_ _b__360_ 505 | | A _, _ -> false 506 | | _, A _ -> false 507 | | B _a__361_, B _b__362_ -> 508 | A1.equal (fun a__363_ b__364_ -> _cmp__a a__363_ b__364_) _a__361_ _b__362_) 509 | ;; 510 | 511 | let _ = equal_might_need_eta_var 512 | 513 | [@@@end] 514 | 515 | type 'a mut = 516 | { x : int 517 | ; mutable y : A.t 518 | } 519 | [@@deriving_inline compare ~localize, equal ~localize] 520 | 521 | let _ = fun (_ : 'a mut) -> () 522 | 523 | let compare_mut__local : 'a. ('a -> 'a -> int) -> 'a mut -> 'a mut -> int = 524 | fun _cmp__a a__365_ b__366_ -> 525 | if Stdlib.( == ) a__365_ b__366_ 526 | then 0 527 | else ( 528 | match compare_int__local a__365_.x b__366_.x with 529 | | 0 -> A.compare a__365_.y b__366_.y 530 | | n -> n) 531 | ;; 532 | 533 | let _ = compare_mut__local 534 | 535 | let compare_mut : 'a. ('a -> 'a -> int) -> 'a mut -> 'a mut -> int = 536 | fun _cmp__a a__367_ b__368_ -> 537 | if Stdlib.( == ) a__367_ b__368_ 538 | then 0 539 | else ( 540 | match compare_int a__367_.x b__368_.x with 541 | | 0 -> A.compare a__367_.y b__368_.y 542 | | n -> n) 543 | ;; 544 | 545 | let _ = compare_mut 546 | 547 | let equal_mut__local : 'a. ('a -> 'a -> bool) -> 'a mut -> 'a mut -> bool = 548 | fun _cmp__a a__369_ b__370_ -> 549 | if Stdlib.( == ) a__369_ b__370_ 550 | then true 551 | else 552 | Stdlib.( && ) (equal_int__local a__369_.x b__370_.x) (A.equal a__369_.y b__370_.y) 553 | ;; 554 | 555 | let _ = equal_mut__local 556 | 557 | let equal_mut : 'a. ('a -> 'a -> bool) -> 'a mut -> 'a mut -> bool = 558 | fun _cmp__a a__371_ b__372_ -> 559 | if Stdlib.( == ) a__371_ b__372_ 560 | then true 561 | else Stdlib.( && ) (equal_int a__371_.x b__372_.x) (A.equal a__371_.y b__372_.y) 562 | ;; 563 | 564 | let _ = equal_mut 565 | 566 | [@@@end] 567 | 568 | type recursive = 569 | { x : int 570 | ; y : recursive A1.t 571 | } 572 | [@@deriving_inline compare ~localize, equal ~localize] 573 | 574 | let _ = fun (_ : recursive) -> () 575 | 576 | let rec compare_recursive__local = 577 | (fun a__373_ b__374_ -> 578 | if Stdlib.( == ) a__373_ b__374_ 579 | then 0 580 | else ( 581 | match compare_int__local a__373_.x b__374_.x with 582 | | 0 -> 583 | A1.compare 584 | (fun a__375_ b__376_ -> compare_recursive a__375_ b__376_) 585 | a__373_.y 586 | b__374_.y 587 | | n -> n) 588 | : recursive -> recursive -> int) 589 | 590 | and compare_recursive = 591 | (fun a b -> compare_recursive__local a b : recursive -> recursive -> int) 592 | ;; 593 | 594 | let _ = compare_recursive__local 595 | and _ = compare_recursive 596 | 597 | let rec equal_recursive__local = 598 | (fun a__377_ b__378_ -> 599 | if Stdlib.( == ) a__377_ b__378_ 600 | then true 601 | else 602 | Stdlib.( && ) 603 | (equal_int__local a__377_.x b__378_.x) 604 | (A1.equal 605 | (fun a__379_ b__380_ -> equal_recursive a__379_ b__380_) 606 | a__377_.y 607 | b__378_.y) 608 | : recursive -> recursive -> bool) 609 | 610 | and equal_recursive = 611 | (fun a b -> equal_recursive__local a b : recursive -> recursive -> bool) 612 | ;; 613 | 614 | let _ = equal_recursive__local 615 | and _ = equal_recursive 616 | 617 | [@@@end] 618 | 619 | type 'a recursive1 = 620 | { x : int 621 | ; y : 'a A1.t recursive1 622 | } 623 | [@@deriving_inline compare ~localize, equal ~localize] 624 | 625 | let _ = fun (_ : 'a recursive1) -> () 626 | 627 | let rec compare_recursive1__local 628 | : 'a. ('a -> 'a -> int) -> 'a recursive1 -> 'a recursive1 -> int 629 | = 630 | fun _cmp__a a__381_ b__382_ -> 631 | if Stdlib.( == ) a__381_ b__382_ 632 | then 0 633 | else ( 634 | match compare_int__local a__381_.x b__382_.x with 635 | | 0 -> 636 | compare_recursive1 637 | (fun a__383_ b__384_ -> 638 | A1.compare (fun a__385_ b__386_ -> _cmp__a a__385_ b__386_) a__383_ b__384_) 639 | a__381_.y 640 | b__382_.y 641 | | n -> n) 642 | 643 | and compare_recursive1 : 'a. ('a -> 'a -> int) -> 'a recursive1 -> 'a recursive1 -> int = 644 | fun _cmp__a a__387_ b__388_ -> 645 | if Stdlib.( == ) a__387_ b__388_ 646 | then 0 647 | else ( 648 | match compare_int a__387_.x b__388_.x with 649 | | 0 -> 650 | compare_recursive1 651 | (fun a__389_ b__390_ -> 652 | A1.compare (fun a__391_ b__392_ -> _cmp__a a__391_ b__392_) a__389_ b__390_) 653 | a__387_.y 654 | b__388_.y 655 | | n -> n) 656 | ;; 657 | 658 | let _ = compare_recursive1__local 659 | and _ = compare_recursive1 660 | 661 | let rec equal_recursive1__local 662 | : 'a. ('a -> 'a -> bool) -> 'a recursive1 -> 'a recursive1 -> bool 663 | = 664 | fun _cmp__a a__393_ b__394_ -> 665 | if Stdlib.( == ) a__393_ b__394_ 666 | then true 667 | else 668 | Stdlib.( && ) 669 | (equal_int__local a__393_.x b__394_.x) 670 | (equal_recursive1 671 | (fun a__395_ b__396_ -> 672 | A1.equal (fun a__397_ b__398_ -> _cmp__a a__397_ b__398_) a__395_ b__396_) 673 | a__393_.y 674 | b__394_.y) 675 | 676 | and equal_recursive1 : 'a. ('a -> 'a -> bool) -> 'a recursive1 -> 'a recursive1 -> bool = 677 | fun _cmp__a a__399_ b__400_ -> 678 | if Stdlib.( == ) a__399_ b__400_ 679 | then true 680 | else 681 | Stdlib.( && ) 682 | (equal_int a__399_.x b__400_.x) 683 | (equal_recursive1 684 | (fun a__401_ b__402_ -> 685 | A1.equal (fun a__403_ b__404_ -> _cmp__a a__403_ b__404_) a__401_ b__402_) 686 | a__399_.y 687 | b__400_.y) 688 | ;; 689 | 690 | let _ = equal_recursive1__local 691 | and _ = equal_recursive1 692 | 693 | [@@@end] 694 | 695 | module Test_nonrec = struct 696 | type nonrec 'a recursive1 = 697 | { x : int 698 | ; y : 'a A1.t recursive1 699 | } 700 | [@@deriving_inline compare ~localize, equal ~localize] 701 | 702 | let _ = fun (_ : 'a recursive1) -> () 703 | 704 | let compare_recursive1__local 705 | : 'a. ('a -> 'a -> int) -> 'a recursive1 -> 'a recursive1 -> int 706 | = 707 | fun _cmp__a a__405_ b__406_ -> 708 | if Stdlib.( == ) a__405_ b__406_ 709 | then 0 710 | else ( 711 | match compare_int__local a__405_.x b__406_.x with 712 | | 0 -> 713 | compare_recursive1 714 | (fun a__407_ b__408_ -> 715 | A1.compare (fun a__409_ b__410_ -> _cmp__a a__409_ b__410_) a__407_ b__408_) 716 | a__405_.y 717 | b__406_.y 718 | | n -> n) 719 | ;; 720 | 721 | let _ = compare_recursive1__local 722 | 723 | let compare_recursive1 724 | : 'a. ('a -> 'a -> int) -> 'a recursive1 -> 'a recursive1 -> int 725 | = 726 | fun _cmp__a a__411_ b__412_ -> 727 | if Stdlib.( == ) a__411_ b__412_ 728 | then 0 729 | else ( 730 | match compare_int a__411_.x b__412_.x with 731 | | 0 -> 732 | compare_recursive1 733 | (fun a__413_ b__414_ -> 734 | A1.compare (fun a__415_ b__416_ -> _cmp__a a__415_ b__416_) a__413_ b__414_) 735 | a__411_.y 736 | b__412_.y 737 | | n -> n) 738 | ;; 739 | 740 | let _ = compare_recursive1 741 | 742 | let equal_recursive1__local 743 | : 'a. ('a -> 'a -> bool) -> 'a recursive1 -> 'a recursive1 -> bool 744 | = 745 | fun _cmp__a a__417_ b__418_ -> 746 | if Stdlib.( == ) a__417_ b__418_ 747 | then true 748 | else 749 | Stdlib.( && ) 750 | (equal_int__local a__417_.x b__418_.x) 751 | (equal_recursive1 752 | (fun a__419_ b__420_ -> 753 | A1.equal (fun a__421_ b__422_ -> _cmp__a a__421_ b__422_) a__419_ b__420_) 754 | a__417_.y 755 | b__418_.y) 756 | ;; 757 | 758 | let _ = equal_recursive1__local 759 | 760 | let equal_recursive1 761 | : 'a. ('a -> 'a -> bool) -> 'a recursive1 -> 'a recursive1 -> bool 762 | = 763 | fun _cmp__a a__423_ b__424_ -> 764 | if Stdlib.( == ) a__423_ b__424_ 765 | then true 766 | else 767 | Stdlib.( && ) 768 | (equal_int a__423_.x b__424_.x) 769 | (equal_recursive1 770 | (fun a__425_ b__426_ -> 771 | A1.equal (fun a__427_ b__428_ -> _cmp__a a__427_ b__428_) a__425_ b__426_) 772 | a__423_.y 773 | b__424_.y) 774 | ;; 775 | 776 | let _ = equal_recursive1 777 | 778 | [@@@end] 779 | end 780 | end 781 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | open Ppx_compare_lib.Builtin 2 | 3 | let failwith = `Should_refer_to_runtime_lib 4 | let ignore = `Should_refer_to_runtime_lib 5 | let ( = ) = `Should_refer_to_runtime_lib 6 | let ( <> ) = `Should_refer_to_runtime_lib 7 | let ( == ) = `Should_refer_to_runtime_lib 8 | let ( != ) = `Should_refer_to_runtime_lib 9 | let ( > ) = `Should_refer_to_runtime_lib 10 | let ( < ) = `Should_refer_to_runtime_lib 11 | let ( >= ) = `Should_refer_to_runtime_lib 12 | let ( <= ) = `Should_refer_to_runtime_lib 13 | let max = `Should_refer_to_runtime_lib 14 | let min = `Should_refer_to_runtime_lib 15 | let equal = `Should_refer_to_runtime_lib 16 | let compare = `Should_refer_to_runtime_lib 17 | 18 | module type M1_sig = sig 19 | type t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] 20 | 21 | include sig 22 | [@@@ocaml.warning "-32"] 23 | 24 | include Ppx_compare_lib.Comparable.S with type t := t 25 | include Ppx_compare_lib.Equal.S with type t := t 26 | include Ppx_compare_lib.Comparable.S with type t := t 27 | include Ppx_compare_lib.Comparable.S__local with type t := t 28 | include Ppx_compare_lib.Equal.S with type t := t 29 | include Ppx_compare_lib.Equal.S__local with type t := t 30 | end 31 | [@@ocaml.doc "@inline"] 32 | 33 | [@@@end] 34 | end 35 | 36 | module type M1_sig_wrong_name = sig 37 | type t1 [@@deriving_inline compare, equal, compare ~localize, equal ~localize] 38 | 39 | include sig 40 | [@@@ocaml.warning "-32"] 41 | 42 | val compare_t1 : t1 -> t1 -> int 43 | val equal_t1 : t1 -> t1 -> bool 44 | val compare_t1 : t1 -> t1 -> int 45 | val compare_t1__local : t1 -> t1 -> int 46 | val equal_t1 : t1 -> t1 -> bool 47 | val equal_t1__local : t1 -> t1 -> bool 48 | end 49 | [@@ocaml.doc "@inline"] 50 | 51 | [@@@end] 52 | end 53 | 54 | module type M2_sig = sig 55 | type 'a t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] 56 | 57 | include sig 58 | [@@@ocaml.warning "-32"] 59 | 60 | include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t 61 | include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t 62 | include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t 63 | include Ppx_compare_lib.Comparable.S1__local with type 'a t := 'a t 64 | include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t 65 | include Ppx_compare_lib.Equal.S1__local with type 'a t := 'a t 66 | end 67 | [@@ocaml.doc "@inline"] 68 | 69 | [@@@end] 70 | end 71 | 72 | module type M2_sig_wrong_name = sig 73 | type 'a t1 [@@deriving_inline compare, equal, compare ~localize, equal ~localize] 74 | 75 | include sig 76 | [@@@ocaml.warning "-32"] 77 | 78 | val compare_t1 : 'a. ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int 79 | val equal_t1 : 'a. ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool 80 | val compare_t1 : 'a. ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int 81 | val compare_t1__local : 'a. ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int 82 | val equal_t1 : 'a. ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool 83 | val equal_t1__local : 'a. ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool 84 | end 85 | [@@ocaml.doc "@inline"] 86 | 87 | [@@@end] 88 | end 89 | 90 | module M1 = struct 91 | type t = unit [@@deriving compare, equal, compare ~localize, equal ~localize] 92 | end 93 | 94 | module M2 = struct 95 | type t = int [@@deriving compare, equal, compare ~localize, equal ~localize] 96 | end 97 | 98 | module M3 = struct 99 | type t = bool [@@deriving compare, equal, compare ~localize, equal ~localize] 100 | end 101 | 102 | module M4 = struct 103 | type t = int32 [@@deriving compare, equal, compare ~localize, equal ~localize] 104 | end 105 | 106 | module M5 = struct 107 | type t = nativeint [@@deriving compare, equal, compare ~localize, equal ~localize] 108 | end 109 | 110 | module M6 = struct 111 | type t = int64 [@@deriving compare, equal, compare ~localize, equal ~localize] 112 | end 113 | 114 | module M7 = struct 115 | type t = float [@@deriving compare, equal, compare ~localize, equal ~localize] 116 | end 117 | 118 | module M8 = struct 119 | type t = bool * float [@@deriving compare, equal, compare ~localize, equal ~localize] 120 | end 121 | 122 | module M9 = struct 123 | type t = bool * float * int 124 | [@@deriving compare, equal, compare ~localize, equal ~localize] 125 | end 126 | 127 | module M10 = struct 128 | type t = bool * float * int * string 129 | [@@deriving compare, equal, compare ~localize, equal ~localize] 130 | end 131 | 132 | module M11 = struct 133 | type t = int ref [@@deriving compare, equal, compare ~localize, equal ~localize] 134 | end 135 | 136 | module M12 = struct 137 | type t = (float * float) option 138 | [@@deriving compare, equal, compare ~localize, equal ~localize] 139 | end 140 | 141 | module M13 = struct 142 | type t = float array [@@deriving compare, equal, compare ~localize, equal ~localize] 143 | end 144 | 145 | module M14 = struct 146 | type t = (int * int) array 147 | [@@deriving compare, equal, compare ~localize, equal ~localize] 148 | end 149 | 150 | module M15 = struct 151 | type t = float array array 152 | [@@deriving compare, equal, compare ~localize, equal ~localize] 153 | end 154 | 155 | module M16 = struct 156 | type t = int list [@@deriving compare, equal, compare ~localize, equal ~localize] 157 | end 158 | 159 | module M17 = struct 160 | type t = 161 | { s : string 162 | ; b : float array list 163 | ; mutable c : int * int64 option 164 | } 165 | [@@deriving compare, equal, compare ~localize, equal ~localize] 166 | end 167 | 168 | module M18 = struct 169 | type t = 170 | { a : float 171 | ; b : float 172 | ; c : float 173 | } 174 | [@@deriving compare, equal, compare ~localize, equal ~localize] 175 | end 176 | 177 | module M19 = struct 178 | type t = Foo [@@deriving compare, equal, compare ~localize, equal ~localize] 179 | end 180 | 181 | module M20 = struct 182 | type t = Foo of int [@@deriving compare, equal, compare ~localize, equal ~localize] 183 | end 184 | 185 | module M21 = struct 186 | type t = Foo of int * float 187 | [@@deriving compare, equal, compare ~localize, equal ~localize] 188 | end 189 | 190 | module M22 = struct 191 | type t = 192 | | Foo 193 | | Bar of int 194 | | Baz of string option 195 | [@@deriving compare, equal, compare ~localize, equal ~localize] 196 | end 197 | 198 | module M23 = struct 199 | type t = 200 | [ `Foo 201 | | `Bar of string * string 202 | ] 203 | [@@deriving compare, equal, compare ~localize, equal ~localize] 204 | end 205 | 206 | module M24 = struct 207 | type t = int * string * [ `Foo | `Bar ] 208 | [@@deriving compare, equal, compare ~localize, equal ~localize] 209 | end 210 | 211 | module M25 = struct 212 | (* no local comparison for String.t, only for string, so we don't test that *) 213 | type t = String.t [@@deriving compare, equal] 214 | end 215 | 216 | module type M26_sig = sig 217 | type 'a t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] 218 | 219 | include sig 220 | [@@@ocaml.warning "-32"] 221 | 222 | include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t 223 | include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t 224 | include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t 225 | include Ppx_compare_lib.Comparable.S1__local with type 'a t := 'a t 226 | include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t 227 | include Ppx_compare_lib.Equal.S1__local with type 'a t := 'a t 228 | end 229 | [@@ocaml.doc "@inline"] 230 | 231 | [@@@end] 232 | end 233 | 234 | module M26 = struct 235 | type 'a t = 'a array [@@deriving compare, equal, compare ~localize, equal ~localize] 236 | end 237 | 238 | module MyList = struct 239 | type 'a t = 240 | | Nil 241 | | Node of 'a * 'a t 242 | [@@deriving compare, equal, compare ~localize, equal ~localize] 243 | end 244 | 245 | module M27 = struct 246 | type t = int [@@deriving compare, equal, compare ~localize, equal ~localize] 247 | 248 | module Inner = struct 249 | type nonrec t = t list [@@deriving compare, equal, compare ~localize, equal ~localize] 250 | 251 | let _ = ((compare : int list -> int list -> int) : t -> t -> int) 252 | end 253 | end 254 | 255 | module M28 = struct 256 | (* making sure that nobody is reversing the type parameters *) 257 | type ('a, 'b) t = ('a * 'b) list 258 | [@@deriving compare, equal, compare ~localize, equal ~localize] 259 | 260 | let (_ : (int, float) t -> int) = [%compare: (int, float) t] [ 1, nan ] 261 | end 262 | 263 | module M29 = struct 264 | type t = 265 | | A of 266 | { a : float 267 | ; b : float 268 | ; c : float 269 | } 270 | | B of float * float * float 271 | [@@deriving compare, equal, compare ~localize, equal ~localize] 272 | end 273 | 274 | module M30 = struct 275 | type ('a, 'b) t = 276 | | A of 277 | { a : 'a 278 | ; b : 'b 279 | ; c : float 280 | } 281 | | B of 'a * 'b 282 | [@@deriving compare, equal, compare ~localize, equal ~localize] 283 | end 284 | 285 | module type Polyrec_sig = sig 286 | type ('a, 'b) t = T of ('a option, 'b) t [@@deriving_inline compare, equal] 287 | 288 | include sig 289 | [@@@ocaml.warning "-32"] 290 | 291 | include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t 292 | include Ppx_compare_lib.Equal.S2 with type ('a, 'b) t := ('a, 'b) t 293 | end 294 | [@@ocaml.doc "@inline"] 295 | 296 | [@@@end] 297 | 298 | type ('a, 'b) t1 = T of ('a option, 'b) t2 299 | 300 | and ('a, 'b) t2 = 301 | | T1 of ('a list, 'b) t1 302 | | T2 of ('a, 'b list) t2 303 | [@@deriving_inline compare, equal] 304 | 305 | include sig 306 | [@@@ocaml.warning "-32"] 307 | 308 | val compare_t1 309 | : 'a 'b. 310 | ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t1 -> ('a, 'b) t1 -> int 311 | 312 | val compare_t2 313 | : 'a 'b. 314 | ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t2 -> ('a, 'b) t2 -> int 315 | 316 | val equal_t1 317 | : 'a 'b. 318 | ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t1 -> ('a, 'b) t1 -> bool 319 | 320 | val equal_t2 321 | : 'a 'b. 322 | ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t2 -> ('a, 'b) t2 -> bool 323 | end 324 | [@@ocaml.doc "@inline"] 325 | 326 | [@@@end] 327 | end 328 | 329 | module Polyrec = struct 330 | type ('a, 'b) t = T of ('a option, 'b) t 331 | [@@deriving compare, equal, compare ~localize, equal ~localize] 332 | 333 | type ('a, 'b) t1 = T of ('a option, 'b) t2 334 | 335 | and ('a, 'b) t2 = 336 | | T1 of ('a list, 'b) t1 337 | | T2 of ('a, 'b list) t2 338 | [@@deriving compare, equal, compare ~localize, equal ~localize] 339 | end 340 | 341 | module type Variance_sig = sig 342 | type +'a t [@@deriving compare, equal, compare ~localize, equal ~localize] 343 | end 344 | 345 | module Variance = struct 346 | type -'a t [@@deriving compare, equal, compare ~localize, equal ~localize] 347 | 348 | type (-'a, +'b) u = 'a t * 'b 349 | [@@deriving compare, equal, compare ~localize, equal ~localize] 350 | end 351 | 352 | module Test = struct 353 | let ( = ) : int -> int -> bool = Base.Poly.( = ) 354 | 355 | (* checking that for the types mentioned in the readme, we compare structurally *) 356 | let%test _ = [%compare: unit option] None (Some ()) = Base.Poly.compare None (Some ()) 357 | let%test _ = [%compare: unit list] [] [ () ] = Base.Poly.compare [] [ () ] 358 | 359 | let%test _ = 360 | [%compare: int array] [| 0; 1 |] [| 1 |] = Base.Poly.compare [| 0; 1 |] [| 1 |] 361 | ;; 362 | 363 | let%test _ = 364 | Base.Poly.( = ) 365 | (List.sort [%compare: int option] [ Some 3; None; Some 2; Some 1 ]) 366 | [ None; Some 1; Some 2; Some 3 ] 367 | ;; 368 | end 369 | 370 | module Variant_inclusion = struct 371 | type 'a type1 = [ `T1 of 'a ] 372 | [@@deriving compare, equal, compare ~localize, equal ~localize] 373 | 374 | type 'a type2 = 375 | [ 'a type1 376 | | `T2 377 | ] 378 | [@@deriving compare, equal, compare ~localize, equal ~localize] 379 | 380 | type 'a type3 = 381 | [ `T3 382 | | 'a type1 383 | ] 384 | [@@deriving compare, equal, compare ~localize, equal ~localize] 385 | 386 | type 'a type4 = 387 | [ 'a type2 388 | | `T4 389 | | 'a type3 390 | ] 391 | [@@deriving compare, equal, compare ~localize, equal ~localize] 392 | 393 | type 'a id = 'a [@@deriving compare, equal, compare ~localize, equal ~localize] 394 | 395 | type ('a, 'b) u = [ `u of 'a * 'b ] 396 | [@@deriving compare, equal, compare ~localize, equal ~localize] 397 | 398 | type t = [ | (int, int) u ] 399 | [@@deriving compare, equal, compare ~localize, equal ~localize] 400 | end 401 | 402 | module Equal = struct 403 | let%test _ = [%compare.equal: int list] [ 7; 8; 9 ] [ 7; 8; 9 ] 404 | let%test _ = not ([%compare.equal: int list] [ 7; 8 ] [ 7; 8; 9 ]) 405 | 406 | let%test _ = 407 | match [%compare: int * int] (1, 2) (1, 3) with 408 | | -1 -> true 409 | | _ -> false 410 | ;; 411 | 412 | let%test _ = 413 | match [%compare: int * int] (1, 3) (1, 2) with 414 | | 1 -> true 415 | | _ -> false 416 | ;; 417 | 418 | let%test _ = [%compare.equal: string option] None None 419 | let%test _ = not ([%compare.equal: string option] (Some "foo") None) 420 | let%test _ = [%compare.equal: string] "hello" "hello" 421 | let%test _ = not ([%compare.equal: string] "hello" "goodbye") 422 | end 423 | 424 | module Equal_local = struct 425 | let%test _ = [%compare_local.equal: int list] [ 7; 8; 9 ] [ 7; 8; 9 ] 426 | let%test _ = not ([%compare_local.equal: int list] [ 7; 8 ] [ 7; 8; 9 ]) 427 | 428 | let%test _ = 429 | match [%compare_local: int * int] (1, 2) (1, 3) with 430 | | -1 -> true 431 | | _ -> false 432 | ;; 433 | 434 | let%test _ = 435 | match [%compare_local: int * int] (1, 3) (1, 2) with 436 | | 1 -> true 437 | | _ -> false 438 | ;; 439 | 440 | let%test _ = [%compare_local.equal: string option] None None 441 | let%test _ = not ([%compare_local.equal: string option] (Some "foo") None) 442 | let%test _ = [%compare_local.equal: string] "hello" "hello" 443 | let%test _ = not ([%compare_local.equal: string] "hello" "goodbye") 444 | end 445 | 446 | module Type_extensions : sig 447 | (* Making sure we don't generate [_ t -> _ t -> int], as 448 | that's too general. *) 449 | module type S = sig 450 | type 'a t 451 | 452 | val compare : [%compare: _ t] 453 | val equal : [%compare.equal: _ t] 454 | val compare__local : [%compare_local: _ t] 455 | val equal__local : [%compare_local.equal: _ t] 456 | end 457 | end = struct 458 | module type S = sig 459 | type 'a t 460 | 461 | val compare : 'a t -> 'a t -> int 462 | val equal : 'a t -> 'a t -> bool 463 | val compare__local : 'a t -> 'a t -> int 464 | val equal__local : 'a t -> 'a t -> bool 465 | end 466 | end 467 | 468 | module Ignoring_field = struct 469 | type t = 470 | { a : int [@ignore] 471 | ; b : int 472 | ; c : int 473 | } 474 | [@@deriving_inline compare, equal] 475 | 476 | let _ = fun (_ : t) -> () 477 | 478 | let compare = 479 | (fun a__1375_ b__1376_ -> 480 | if Stdlib.( == ) a__1375_ b__1376_ 481 | then 0 482 | else ( 483 | match compare_int a__1375_.b b__1376_.b with 484 | | 0 -> compare_int a__1375_.c b__1376_.c 485 | | n -> n) 486 | : t -> t -> int) 487 | ;; 488 | 489 | let _ = compare 490 | 491 | let equal = 492 | (fun a__1377_ b__1378_ -> 493 | if Stdlib.( == ) a__1377_ b__1378_ 494 | then true 495 | else 496 | Stdlib.( && ) (equal_int a__1377_.b b__1378_.b) (equal_int a__1377_.c b__1378_.c) 497 | : t -> t -> bool) 498 | ;; 499 | 500 | let _ = equal 501 | 502 | [@@@end] 503 | 504 | let equal = [%compare.equal: t] 505 | end 506 | 507 | module Ignoring_inline = struct 508 | type t = int * int * int 509 | 510 | let compare = [%compare: _ * (int[@ignore]) * int] 511 | let _ = compare 512 | let equal = [%compare.equal: t] 513 | let%test _ = equal (0, 1, 2) (9, 1, 2) 514 | let%test _ = equal (0, 1, 2) (0, 9, 2) 515 | let%test _ = not (equal (0, 1, 2) (0, 1, 9)) 516 | end 517 | 518 | module Ignoring = struct 519 | type t = { a : (int[@ignore]) * string } [@@deriving_inline compare, equal] 520 | 521 | let _ = fun (_ : t) -> () 522 | 523 | let compare = 524 | (fun a__1395_ b__1396_ -> 525 | if Stdlib.( == ) a__1395_ b__1396_ 526 | then 0 527 | else ( 528 | let t__1397_, t__1398_ = a__1395_.a in 529 | let t__1399_, t__1400_ = b__1396_.a in 530 | match 531 | let _ : _ = t__1397_ 532 | and _ : _ = t__1399_ in 533 | 0 534 | with 535 | | 0 -> compare_string t__1398_ t__1400_ 536 | | n -> n) 537 | : t -> t -> int) 538 | ;; 539 | 540 | let _ = compare 541 | 542 | let equal = 543 | (fun a__1401_ b__1402_ -> 544 | if Stdlib.( == ) a__1401_ b__1402_ 545 | then true 546 | else ( 547 | let t__1403_, t__1404_ = a__1401_.a in 548 | let t__1405_, t__1406_ = b__1402_.a in 549 | Stdlib.( && ) 550 | (let _ : _ = t__1403_ 551 | and _ : _ = t__1405_ in 552 | true) 553 | (equal_string t__1404_ t__1406_)) 554 | : t -> t -> bool) 555 | ;; 556 | 557 | let _ = equal 558 | 559 | [@@@end] 560 | 561 | let%test _ = equal { a = 1, "hi" } { a = 2, "hi" } 562 | let%test _ = not (equal { a = 1, "hi" } { a = 1, "ho" }) 563 | end 564 | 565 | module Ignoring_with_type = struct 566 | type t = 567 | { a : int 568 | ; b : (int[@compare.ignore]) 569 | } 570 | [@@deriving_inline compare] 571 | 572 | let _ = fun (_ : t) -> () 573 | 574 | let compare = 575 | (fun a__1407_ b__1408_ -> 576 | if Stdlib.( == ) a__1407_ b__1408_ 577 | then 0 578 | else ( 579 | match compare_int a__1407_.a b__1408_.a with 580 | | 0 -> 581 | let _ : _ = a__1407_.b 582 | and _ : _ = b__1408_.b in 583 | 0 584 | | n -> n) 585 | : t -> t -> int) 586 | ;; 587 | 588 | let _ = compare 589 | 590 | [@@@end] 591 | end 592 | 593 | module Enum_optim = struct 594 | type t = 595 | | A 596 | | B 597 | | C 598 | [@@deriving_inline compare, equal] 599 | 600 | let _ = fun (_ : t) -> () 601 | let compare = (Stdlib.compare : t -> t -> int) 602 | let _ = compare 603 | let equal = (Stdlib.( = ) : t -> t -> bool) 604 | let _ = equal 605 | 606 | [@@@end] 607 | end 608 | 609 | module Poly_enum_optim = struct 610 | type t = 611 | [ `A 612 | | `B 613 | | `C 614 | ] 615 | [@@deriving_inline compare, equal] 616 | 617 | let _ = fun (_ : t) -> () 618 | let compare = (Stdlib.compare : t -> t -> int) 619 | let _ = compare 620 | let equal = (Stdlib.( = ) : t -> t -> bool) 621 | let _ = equal 622 | 623 | [@@@end] 624 | end 625 | 626 | module Lazy_behavior = struct 627 | (* Test that the generated functions don't evaluate more than necessary *) 628 | type a = unit 629 | 630 | let equal_a () () = assert false 631 | let equal_a__local () () = assert false 632 | let compare_a () () = assert false 633 | let compare_a__local () () = assert false 634 | 635 | type b = int * a [@@deriving compare, equal, compare ~localize, equal ~localize] 636 | 637 | let%test _ = not (equal_b (0, ()) (1, ())) 638 | let%test _ = Base.Poly.( < ) (compare_b (0, ()) (1, ())) 0 639 | end 640 | 641 | module Not_ieee_compliant = struct 642 | type t = float [@@deriving compare, equal, compare ~localize, equal ~localize] 643 | 644 | let%test _ = [%equal: t] nan nan 645 | let%test _ = Base.Poly.( = ) ([%compare: t] nan nan) 0 646 | end 647 | 648 | module Wildcard : sig 649 | type _ transparent = int [@@deriving compare, equal, compare ~localize, equal ~localize] 650 | type _ opaque [@@deriving compare, equal, compare ~localize, equal ~localize] 651 | end = struct 652 | type _ transparent = int [@@deriving compare, equal, compare ~localize, equal ~localize] 653 | 654 | let%test _ = [%equal: string transparent] 1 1 655 | let%test _ = not ([%equal: string transparent] 1 2) 656 | let%test _ = Base.Poly.( < ) ([%compare: string transparent] 1 2) 0 657 | let%test _ = Base.Poly.( = ) ([%compare: string transparent] 1 1) 0 658 | let%test _ = Base.Poly.( > ) ([%compare: string transparent] 2 1) 0 659 | 660 | type 'a opaque = 'a option 661 | [@@deriving compare, equal, compare ~localize, equal ~localize] 662 | 663 | let%test _ = [%equal: int opaque] (Some 1) (Some 1) 664 | let%test _ = not ([%equal: int opaque] None (Some 1)) 665 | let%test _ = not ([%equal: int opaque] (Some 1) (Some 2)) 666 | let%test _ = Base.Poly.( < ) ([%compare: int opaque] None (Some 1)) 0 667 | let%test _ = Base.Poly.( = ) ([%compare: int opaque] (Some 1) (Some 1)) 0 668 | let%test _ = Base.Poly.( > ) ([%compare: int opaque] (Some 2) (Some 1)) 0 669 | end 670 | 671 | module Local_with_aliased_comparisons : sig 672 | type t = 673 | | Int of int 674 | | Add of t * t 675 | | Sub of t * t 676 | [@@deriving_inline compare ~localize, equal ~localize] 677 | 678 | include sig 679 | [@@@ocaml.warning "-32"] 680 | 681 | include Ppx_compare_lib.Comparable.S with type t := t 682 | include Ppx_compare_lib.Comparable.S__local with type t := t 683 | include Ppx_compare_lib.Equal.S with type t := t 684 | include Ppx_compare_lib.Equal.S__local with type t := t 685 | end 686 | [@@ocaml.doc "@inline"] 687 | 688 | [@@@end] 689 | end = struct 690 | type t = 691 | | Int of int 692 | | Add of t * t 693 | | Sub of t * t 694 | [@@deriving_inline compare ~localize, equal ~localize] 695 | 696 | let _ = fun (_ : t) -> () 697 | 698 | let rec compare__local = 699 | (fun a__1545_ b__1546_ -> 700 | if Stdlib.( == ) a__1545_ b__1546_ 701 | then 0 702 | else ( 703 | match a__1545_, b__1546_ with 704 | | Int _a__1547_, Int _b__1548_ -> compare_int__local _a__1547_ _b__1548_ 705 | | Int _, _ -> -1 706 | | _, Int _ -> 1 707 | | Add (_a__1549_, _a__1551_), Add (_b__1550_, _b__1552_) -> 708 | (match compare__local _a__1549_ _b__1550_ with 709 | | 0 -> compare__local _a__1551_ _b__1552_ 710 | | n -> n) 711 | | Add _, _ -> -1 712 | | _, Add _ -> 1 713 | | Sub (_a__1553_, _a__1555_), Sub (_b__1554_, _b__1556_) -> 714 | (match compare__local _a__1553_ _b__1554_ with 715 | | 0 -> compare__local _a__1555_ _b__1556_ 716 | | n -> n)) 717 | : t -> t -> int) 718 | 719 | and compare = (fun a b -> compare__local a b : t -> t -> int) 720 | 721 | let _ = compare__local 722 | and _ = compare 723 | 724 | let rec equal__local = 725 | (fun a__1557_ b__1558_ -> 726 | if Stdlib.( == ) a__1557_ b__1558_ 727 | then true 728 | else ( 729 | match a__1557_, b__1558_ with 730 | | Int _a__1559_, Int _b__1560_ -> equal_int__local _a__1559_ _b__1560_ 731 | | Int _, _ -> false 732 | | _, Int _ -> false 733 | | Add (_a__1561_, _a__1563_), Add (_b__1562_, _b__1564_) -> 734 | Stdlib.( && ) 735 | (equal__local _a__1561_ _b__1562_) 736 | (equal__local _a__1563_ _b__1564_) 737 | | Add _, _ -> false 738 | | _, Add _ -> false 739 | | Sub (_a__1565_, _a__1567_), Sub (_b__1566_, _b__1568_) -> 740 | Stdlib.( && ) 741 | (equal__local _a__1565_ _b__1566_) 742 | (equal__local _a__1567_ _b__1568_)) 743 | : t -> t -> bool) 744 | 745 | and equal = (fun a b -> equal__local a b : t -> t -> bool) 746 | 747 | let _ = equal__local 748 | and _ = equal 749 | 750 | [@@@end] 751 | end 752 | 753 | module Test__global_exists : sig 754 | type t [@@deriving compare__global, equal__global] 755 | end = struct 756 | type t [@@deriving compare__global, equal__global] 757 | end 758 | 759 | module Test__global_extensions_exists : sig 760 | type t [@@deriving compare__global, equal__global] 761 | 762 | val equal_via_compare : t -> t -> bool 763 | end = struct 764 | type t = int 765 | 766 | let compare = [%compare__global: int] 767 | let equal = [%equal__global: int] 768 | let equal_via_compare = [%compare.equal__global: int] 769 | end 770 | 771 | module Test__local_exists : sig 772 | type t [@@deriving compare ~localize, equal ~localize] 773 | 774 | val equal_via_compare : t -> t -> bool 775 | val equal_via_compare__local : t -> t -> bool 776 | end = struct 777 | type t = string 778 | 779 | let compare = [%compare: string] 780 | let compare__local = [%compare__local: string] 781 | let equal = [%equal: string] 782 | let equal__local = [%equal__local: string] 783 | let equal_via_compare = [%compare.equal: string] 784 | let equal_via_compare__local = [%compare.equal__local: string] 785 | end 786 | 787 | module Polymorphic_variants_fully_poly_inputs : sig 788 | module Upper_bound_only : sig 789 | val compare : [< `A | `B | `C of int ] -> [< `A | `B | `C of int ] -> int 790 | val equal : [< `A | `B | `C of int ] -> [< `A | `B | `C of int ] -> bool 791 | end 792 | 793 | module Upper_and_lower_bounds : sig 794 | val compare : [< `A | `B | `C of int > `A ] -> [< `A | `B | `C of int > `A ] -> int 795 | val equal : [< `A | `B | `C of int > `A ] -> [< `A | `B | `C of int > `A ] -> bool 796 | end 797 | end = struct 798 | module Upper_bound_only = struct 799 | let compare = [%compare: [< `A | `B | `C of int ]] 800 | let equal = [%compare.equal: [< `A | `B | `C of int ]] 801 | end 802 | 803 | module Upper_and_lower_bounds = struct 804 | let compare = [%compare: [< `A | `B | `C of int > `A ]] 805 | let equal = [%compare.equal: [< `A | `B | `C of int > `A ]] 806 | end 807 | end 808 | 809 | module Define_comparison_manually : sig 810 | module Non_parameterized : sig 811 | type t [@@deriving compare] 812 | 813 | module type Comparable = sig 814 | type t [@@deriving compare] 815 | end 816 | 817 | module Functor (M : Comparable) : Comparable with type t = t 818 | module T : Comparable with type t = t 819 | 820 | type with_functor = { x : Functor(T).t } [@@deriving compare] 821 | end 822 | 823 | module Parameterized : sig 824 | type 'a t [@@deriving compare] 825 | 826 | module type Comparable = sig 827 | type 'a t [@@deriving compare] 828 | end 829 | 830 | module Functor (M : Comparable) : Comparable with type 'a t = 'a t 831 | module T : Comparable with type 'a t = 'a t 832 | 833 | type 'a with_functor = { x : 'a Functor(T).t } [@@deriving compare] 834 | end 835 | end = struct 836 | module Non_parameterized = struct 837 | type t = int list 838 | 839 | let [%compare: t] = fun x y -> [%compare: int] (List.length x) (List.length y) 840 | 841 | module type Comparable = sig 842 | type t [@@deriving compare] 843 | end 844 | 845 | module T = struct 846 | type nonrec t = t 847 | 848 | let [%compare: t] = [%compare: t] 849 | end 850 | 851 | module Functor (M : Comparable) = struct 852 | module _ = M 853 | 854 | type nonrec t = t [@@deriving compare] 855 | end 856 | 857 | let [%compare: Functor(T).t] = 858 | fun (module M : Comparable) -> 859 | let module _ = M in 860 | [%compare: t] 861 | ;; 862 | 863 | type with_functor = { x : Functor(T).t } [@@deriving compare] 864 | end 865 | 866 | module Parameterized = struct 867 | type 'a t = 'a list 868 | 869 | let [%compare: 'a t] = fun [%compare: 'a] -> [%compare: 'a list] 870 | 871 | module type Comparable = sig 872 | type 'a t [@@deriving compare] 873 | end 874 | 875 | module T = struct 876 | type nonrec 'a t = 'a t 877 | 878 | let [%compare: 'a t] = fun (type a) [%compare: a] -> [%compare: a t] 879 | end 880 | 881 | module Functor (M : Comparable) = struct 882 | module _ = M 883 | 884 | type nonrec 'a t = 'a t [@@deriving compare] 885 | end 886 | 887 | let [%compare: 'a Functor(T).t] = 888 | fun (module M : Comparable) (type a) compare_a -> 889 | let module _ = M in 890 | [%compare: a t] 891 | ;; 892 | 893 | type 'a with_functor = { x : 'a Functor(T).t } [@@deriving compare] 894 | end 895 | end 896 | 897 | module Custom_attributes = struct 898 | type t = 899 | { x : 900 | (string 901 | [@compare.custom 902 | fun x y -> 903 | match x, y with 904 | | "foo", "foo" -> 0 905 | | "foo", _ -> -1 906 | | _, "foo" -> 1 907 | | _, _ -> 0] 908 | [@equal.custom 909 | fun x y -> 910 | match x, y with 911 | | "bar", _ | _, "bar" -> true 912 | | _, _ -> true]) 913 | } 914 | [@@deriving_inline compare ~localize, equal] 915 | 916 | let _ = fun (_ : t) -> () 917 | 918 | let compare__local = 919 | (fun a__1655_ b__1656_ -> 920 | if Stdlib.( == ) a__1655_ b__1656_ 921 | then 0 922 | else 923 | (fun x y -> 924 | match x, y with 925 | | "foo", "foo" -> 0 926 | | "foo", _ -> -1 927 | | _, "foo" -> 1 928 | | _, _ -> 0) 929 | a__1655_.x 930 | b__1656_.x 931 | : t -> t -> int) 932 | ;; 933 | 934 | let _ = compare__local 935 | let compare = (fun a b -> compare__local a b : t -> t -> int) 936 | let _ = compare 937 | 938 | let equal = 939 | (fun a__1657_ b__1658_ -> 940 | if Stdlib.( == ) a__1657_ b__1658_ 941 | then true 942 | else 943 | (fun x y -> 944 | match x, y with 945 | | "bar", _ | _, "bar" -> true 946 | | _, _ -> true) 947 | a__1657_.x 948 | b__1658_.x 949 | : t -> t -> bool) 950 | ;; 951 | 952 | let _ = equal 953 | 954 | [@@@end] 955 | end 956 | -------------------------------------------------------------------------------- /expander/ppx_compare_expander.ml: -------------------------------------------------------------------------------- 1 | (* Generated code should depend on the environment in scope as little as possible. 2 | E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It 3 | is especially important to not use polymorphic comparisons, since we are moving more 4 | and more to code that doesn't have them in scope. *) 5 | 6 | (* Note: I am introducing a few unnecessary explicit closures, (not all of them some are 7 | unnecessary due to the value restriction). 8 | *) 9 | 10 | open Stdppx 11 | open Ppxlib 12 | open Ast_builder.Default 13 | include Ppx_compare_expander_intf 14 | 15 | (* Two-argument function, possibly with [local_] arguments *) 16 | let ptyp_arrow2 ~loc ~local_args arg1 arg2 res = 17 | if local_args 18 | then [%type: [%t arg1] -> [%t arg2] -> [%t res]] 19 | else [%type: [%t arg1] -> [%t arg2] -> [%t res]] 20 | ;; 21 | 22 | let make_field_expr base field_name ~loc ~unboxed = 23 | if unboxed 24 | then Ppxlib_jane.Ast_builder.Default.pexp_unboxed_field base field_name ~loc 25 | else pexp_field base field_name ~loc 26 | ;; 27 | 28 | let has_global_modality ~modalities ~attrs ~mut = 29 | let explicit_modality () = 30 | (* An explicit [global] modality is present *) 31 | List.exists modalities ~f:(function 32 | | { txt = Ppxlib_jane.Modality "global"; _ } -> true 33 | | _ -> false) 34 | in 35 | let crosses_locality () = 36 | (* The user manually specified that a particular type crosses locality *) 37 | List.exists attrs ~f:(function 38 | | { attr_name = { txt = "globalized"; loc = _ } 39 | ; attr_payload = PStr [] 40 | ; attr_loc = _ 41 | } as attr -> 42 | Attribute.mark_as_handled_manually attr; 43 | true 44 | | _ -> false) 45 | in 46 | let mutable_implied_modality () = 47 | (* The field of a record is mutable *) 48 | match mut with 49 | | None | Some Immutable -> false 50 | | Some Mutable -> 51 | not 52 | (List.exists attrs ~f:(function 53 | | { attr_name = { txt = "no_mutable_implied_modalities"; loc = _ } 54 | ; attr_payload = PStr [] 55 | ; attr_loc = _ 56 | } -> 57 | (* This is an OxCaml compiler attribute; we do not have to "handle" it. *) 58 | true 59 | | _ -> false)) 60 | in 61 | explicit_modality () || crosses_locality () || mutable_implied_modality () 62 | ;; 63 | 64 | type kind = 65 | | Compare 66 | | Equal 67 | 68 | module Ordering = struct 69 | type t = 70 | | Less 71 | | Equal 72 | | Greater 73 | end 74 | 75 | module type Params = sig 76 | val name : string 77 | val kind : kind 78 | val chain : expression -> expression -> expression 79 | val const : loc:Location.t -> Ordering.t -> expression 80 | val result_type : loc:Location.t -> core_type 81 | val poly : loc:Location.t -> expression -> expression -> expression 82 | 83 | val abstract 84 | : loc:Location.t 85 | -> type_name:string 86 | -> expression 87 | -> expression 88 | -> expression 89 | 90 | module Attrs : Attrs 91 | end 92 | 93 | module Make_attrs (Name : sig 94 | val name : string 95 | end) : Attrs = struct 96 | let ignore_label_declaration = 97 | Attribute.declare 98 | (Name.name ^ ".ignore") 99 | Attribute.Context.label_declaration 100 | Ast_pattern.(pstr nil) 101 | () 102 | ;; 103 | 104 | let ignore_core_type = 105 | Attribute.declare 106 | (Name.name ^ ".ignore") 107 | Attribute.Context.core_type 108 | Ast_pattern.(pstr nil) 109 | () 110 | ;; 111 | 112 | let custom_core_type = 113 | Attribute.declare 114 | ("@" ^ Name.name ^ ".custom") 115 | Attribute.Context.core_type 116 | Ast_pattern.(single_expr_payload __) 117 | Fn.id 118 | ;; 119 | end 120 | 121 | module Compare_params : Params = struct 122 | let name = "compare" 123 | let kind = Compare 124 | 125 | let chain a b = 126 | let loc = a.pexp_loc in 127 | [%expr 128 | match [%e a] with 129 | | 0 -> [%e b] 130 | | n -> n] 131 | ;; 132 | 133 | let const ~loc (ord : Ordering.t) = 134 | eint 135 | ~loc 136 | (match ord with 137 | | Less -> -1 138 | | Equal -> 0 139 | | Greater -> 1) 140 | ;; 141 | 142 | let result_type ~loc = [%type: int] 143 | let poly ~loc a b = [%expr Stdlib.compare [%e a] [%e b]] 144 | 145 | let abstract ~loc ~type_name a b = 146 | [%expr 147 | Ppx_compare_lib.compare_abstract 148 | ~type_name:[%e estring ~loc type_name] 149 | [%e a] 150 | [%e b]] 151 | ;; 152 | 153 | module Attrs = Make_attrs (struct 154 | let name = name 155 | end) 156 | end 157 | 158 | module Equal_params : Params = struct 159 | let name = "equal" 160 | let kind = Equal 161 | 162 | let chain a b = 163 | let loc = a.pexp_loc in 164 | [%expr Stdlib.( && ) [%e a] [%e b]] 165 | ;; 166 | 167 | let const ~loc (ord : Ordering.t) = 168 | match ord with 169 | | Equal -> [%expr true] 170 | | Less | Greater -> [%expr false] 171 | ;; 172 | 173 | let result_type ~loc = [%type: bool] 174 | let poly ~loc a b = [%expr Stdlib.( = ) [%e a] [%e b]] 175 | 176 | let abstract ~loc ~type_name a b = 177 | [%expr 178 | Ppx_compare_lib.equal_abstract ~type_name:[%e estring ~loc type_name] [%e a] [%e b]] 179 | ;; 180 | 181 | module Attrs = Make_attrs (struct 182 | let name = name 183 | end) 184 | end 185 | 186 | module Make (Params : Params) = struct 187 | open Params 188 | module Attrs = Attrs 189 | 190 | let str_attributes = 191 | [ Attribute.T Attrs.ignore_label_declaration 192 | ; Attribute.T Attrs.ignore_core_type 193 | ; Attribute.T Attrs.custom_core_type 194 | ] 195 | ;; 196 | 197 | let get_attr ~loc ~compare_attr ~equal_attr ~attr_name ast = 198 | let error ~present ~missing = 199 | Location.raise_errorf 200 | ~loc 201 | "Using [@@%s.%s] without [@@%s.%s] is likely to lead to incompatible [compare] \ 202 | and [equal] functions." 203 | present 204 | attr_name 205 | missing 206 | attr_name 207 | in 208 | let value_compare = 209 | Attribute.get compare_attr ast ~mark_as_seen:(Poly.equal kind Compare) 210 | in 211 | let value_equal = 212 | Attribute.get equal_attr ast ~mark_as_seen:(Poly.equal kind Equal) 213 | in 214 | match kind, value_compare, value_equal with 215 | | Compare, Some value, _ | Equal, _, Some value -> Some value 216 | | _, None, None -> None 217 | | Compare, None, Some _ -> error ~present:"equal" ~missing:"compare" 218 | | Equal, Some _, None -> error ~present:"compare" ~missing:"equal" 219 | ;; 220 | 221 | let core_type_custom_implementation ty = 222 | get_attr 223 | ~loc:ty.ptyp_loc 224 | ~compare_attr:Compare_params.Attrs.custom_core_type 225 | ~equal_attr:Equal_params.Attrs.custom_core_type 226 | ~attr_name:"custom" 227 | ty 228 | ;; 229 | 230 | let core_type_is_ignored ty = 231 | get_attr 232 | ~loc:ty.ptyp_loc 233 | ~compare_attr:Compare_params.Attrs.ignore_core_type 234 | ~equal_attr:Equal_params.Attrs.ignore_core_type 235 | ~attr_name:"ignore" 236 | ty 237 | |> Option.is_some 238 | ;; 239 | 240 | let label_is_ignored ld = 241 | get_attr 242 | ~loc:ld.pld_loc 243 | ~compare_attr:Compare_params.Attrs.ignore_label_declaration 244 | ~equal_attr:Equal_params.Attrs.ignore_label_declaration 245 | ~attr_name:"ignore" 246 | ld 247 | |> Option.is_some 248 | ;; 249 | 250 | let with_tuple loc ~value ~ltys ~unboxed f = 251 | (* generate 252 | let id_1, id_2, id_3, ... id_n = value in expr 253 | where expr is the result of (f [id_1, ty_1 ; id_2, ty_2; ...]) 254 | *) 255 | let names_types = 256 | List.map ltys ~f:(fun (lbl, t) -> gen_symbol ~prefix:"t" (), lbl, t) 257 | in 258 | let pattern = 259 | let l = List.map names_types ~f:(fun (n, lbl, _) -> lbl, pvar ~loc n) in 260 | Ppxlib_jane.Ast_builder.Default.(if unboxed then ppat_unboxed_tuple else ppat_tuple) 261 | ~loc 262 | l 263 | Closed 264 | in 265 | let e = f (List.map names_types ~f:(fun (n, _, t) -> evar ~loc n, t)) in 266 | let binding = value_binding ~loc ~pat:pattern ~expr:value in 267 | pexp_let ~loc Nonrecursive [ binding ] e 268 | ;; 269 | 270 | let phys_equal_first a b cmp = 271 | let loc = cmp.pexp_loc in 272 | [%expr if Stdlib.( == ) [%e a] [%e b] then [%e const ~loc Equal] else [%e cmp]] 273 | ;; 274 | 275 | let rec chain_if ~loc = function 276 | | [] -> const ~loc Equal 277 | | [ x ] -> x 278 | | x :: xs -> chain x (chain_if ~loc:x.pexp_loc xs) 279 | ;; 280 | 281 | let tp_name n = Printf.sprintf "_cmp__%s" n 282 | 283 | let type_ ~with_local ~hide ~loc ty = 284 | let loc = { loc with loc_ghost = true } in 285 | let ptyp_attributes = 286 | if hide 287 | then Merlin_helpers.hide_attribute :: ty.ptyp_attributes 288 | else ty.ptyp_attributes 289 | in 290 | let hty = { ty with ptyp_attributes } in 291 | ptyp_arrow2 ~loc ~local_args:with_local ty hty (result_type ~loc) 292 | ;; 293 | 294 | let function_name ~with_local ?functor_ typename = 295 | let name = 296 | match functor_, typename with 297 | | None, "t" -> name 298 | | None, s when String.is_prefix ~prefix:"t__" s -> 299 | (* We carry [ppx_template] type name mangling over to the function, so that e.g. 300 | [t__bits64] gets a [compare__bits64] *) 301 | let template_suffix = 302 | (* e.g. if [name] is "t__bits64", this is "__bits64" *) 303 | String.drop_prefix s 1 304 | in 305 | name ^ template_suffix 306 | | None, s -> Printf.sprintf "%s_%s" name s 307 | | Some path, s -> Printf.sprintf "%s_%s__%s" name path s 308 | in 309 | if with_local then name ^ "__local" else name 310 | ;; 311 | 312 | let compare_ignore ~loc value1 value2 = 313 | [%expr 314 | let (_ : _) = [%e value1] 315 | and (_ : _) = [%e value2] in 316 | [%e const ~loc Equal]] 317 | ;; 318 | 319 | let rec compare_applied ~hide ~with_local ~constructor ~args value1 value2 = 320 | let args = 321 | List.map args ~f:(compare_of_ty_fun ~hide ~with_local ~type_constraint:false) 322 | @ [ value1; value2 ] 323 | in 324 | Ppx_helpers.type_constr_conv_expr 325 | ~loc:(Located.loc constructor) 326 | constructor 327 | args 328 | ~f:(function_name ~with_local) 329 | 330 | and compare_of_tuple ~hide ~with_local ~unboxed loc ltys value1 value2 = 331 | with_tuple loc ~value:value1 ~ltys ~unboxed (fun elems1 -> 332 | with_tuple loc ~value:value2 ~ltys ~unboxed (fun elems2 -> 333 | let exprs = 334 | List.map2 elems1 elems2 ~f:(fun (v1, t) (v2, _) -> 335 | compare_of_ty ~hide ~with_local t v1 v2) 336 | in 337 | chain_if ~loc exprs)) 338 | 339 | and compare_variant ~hide ~with_local loc row_fields value1 value2 = 340 | let is_sum_type_with_all_constant_constructors = 341 | List.for_all row_fields ~f:(function 342 | | { prf_desc = Rtag (_, true, _); _ } (* includes constant case, or... *) 343 | | { prf_desc = Rtag (_, _, []); _ } (* doesn't include any non-constant cases *) 344 | -> true 345 | | _ -> false) 346 | in 347 | if is_sum_type_with_all_constant_constructors 348 | then poly ~loc value1 value2 349 | else ( 350 | let map row = 351 | match row.prf_desc with 352 | | Rtag ({ txt = cnstr; _ }, true, _) (* includes constant case, or... *) 353 | | Rtag ({ txt = cnstr; _ }, _, []) (* doesn't include any non-constant cases *) -> 354 | case 355 | ~guard:None 356 | ~lhs: 357 | (ppat_tuple 358 | ~loc 359 | [ ppat_variant ~loc cnstr None; ppat_variant ~loc cnstr None ]) 360 | ~rhs:(const ~loc Equal) 361 | | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> 362 | let v1 = gen_symbol ~prefix:"_left" () 363 | and v2 = gen_symbol ~prefix:"_right" () in 364 | let body = compare_of_ty ~hide ~with_local tp (evar ~loc v1) (evar ~loc v2) in 365 | case 366 | ~guard:None 367 | ~lhs: 368 | (ppat_tuple 369 | ~loc 370 | [ ppat_variant ~loc cnstr (Some (pvar ~loc v1)) 371 | ; ppat_variant ~loc cnstr (Some (pvar ~loc v2)) 372 | ]) 373 | ~rhs:body 374 | | Rinherit { ptyp_desc = Ptyp_constr (id, args); _ } -> 375 | (* quite sadly, this code doesn't handle: 376 | type 'a id = 'a with compare 377 | type t = [ `a | [ `b ] id ] with compare 378 | because it will generate a pattern #id, when id is not even a polymorphic 379 | variant in the first place. 380 | The culprit is caml though, since it only allows #id but not #([`b] id) 381 | *) 382 | let v1 = gen_symbol ~prefix:"_left" () 383 | and v2 = gen_symbol ~prefix:"_right" () in 384 | case 385 | ~guard:None 386 | ~lhs: 387 | (ppat_tuple 388 | ~loc 389 | [ ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v1) 390 | ; ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v2) 391 | ]) 392 | ~rhs: 393 | (compare_applied 394 | ~hide 395 | ~with_local 396 | ~constructor:id 397 | ~args 398 | (evar ~loc v1) 399 | (evar ~loc v2)) 400 | | Rinherit ty -> 401 | Location.raise_errorf 402 | ~loc:ty.ptyp_loc 403 | "Ppx_compare.compare_variant: unknown type" 404 | in 405 | let e = 406 | let matched = pexp_tuple ~loc [ value1; value2 ] in 407 | match List.map ~f:map row_fields with 408 | | [ v ] -> pexp_match ~loc matched [ v ] 409 | | l -> 410 | pexp_match 411 | ~loc 412 | matched 413 | (l 414 | @ (* Providing we didn't screw up badly we now know that the tags of the variants 415 | are different. We let pervasive do its magic. *) 416 | [ case ~guard:None ~lhs:[%pat? x, y] ~rhs:(poly ~loc [%expr x] [%expr y]) ]) 417 | in 418 | phys_equal_first value1 value2 e) 419 | 420 | and branches_of_sum ~hide ~with_local cds = 421 | let rightmost_index = List.length cds - 1 in 422 | List.concat 423 | (List.mapi cds ~f:(fun i cd -> 424 | let rightmost = i = rightmost_index in 425 | let loc = cd.pcd_loc in 426 | if Option.is_some cd.pcd_res 427 | then 428 | (* If we get GADTs support, fix the constant sum type optimization for them *) 429 | Location.raise_errorf ~loc "GADTs are not supported by comparelib"; 430 | match cd.pcd_args with 431 | | Pcstr_record lds -> 432 | let value1 = gen_symbol ~prefix:"_a" () in 433 | let value2 = gen_symbol ~prefix:"_b" () in 434 | let res = 435 | case 436 | ~guard:None 437 | ~lhs: 438 | (ppat_tuple 439 | ~loc 440 | [ pconstruct cd (Some (pvar ~loc value1)) 441 | ; pconstruct cd (Some (pvar ~loc value2)) 442 | ]) 443 | ~rhs: 444 | (compare_of_record_no_phys_equal 445 | ~hide 446 | ~with_local 447 | ~unboxed:false 448 | loc 449 | lds 450 | (evar ~loc value1) 451 | (evar ~loc value2)) 452 | in 453 | if rightmost 454 | then [ res ] 455 | else ( 456 | let pany = ppat_any ~loc in 457 | let pcnstr = pconstruct cd (Some pany) in 458 | let case l r ord = 459 | case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) 460 | in 461 | [ res; case pcnstr pany Less; case pany pcnstr Greater ]) 462 | | Pcstr_tuple pcd_args -> 463 | (match pcd_args with 464 | | [] -> 465 | let pcnstr = pconstruct cd None in 466 | let pany = ppat_any ~loc in 467 | let case l r ord = 468 | case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) 469 | in 470 | if rightmost 471 | then [ case pcnstr pcnstr Equal ] 472 | else 473 | [ case pcnstr pcnstr Equal 474 | ; case pcnstr pany Less 475 | ; case pany pcnstr Greater 476 | ] 477 | | args -> 478 | let ids_ty_and_has_global = 479 | List.map args ~f:(fun arg -> 480 | let modalities, ty = 481 | Ppxlib_jane.Shim.Pcstr_tuple_arg.extract_modalities arg 482 | in 483 | let a = gen_symbol ~prefix:"_a" () in 484 | let b = gen_symbol ~prefix:"_b" () in 485 | let has_global = 486 | has_global_modality 487 | ~modalities 488 | ~attrs: 489 | (Ppxlib_jane.Shim.Pcstr_tuple_arg.to_core_type arg) 490 | .ptyp_attributes 491 | ~mut:None 492 | in 493 | a, b, ty, has_global) 494 | in 495 | let lpatt = 496 | List.map ids_ty_and_has_global ~f:(fun (l, _r, _ty, _g) -> pvar ~loc l) 497 | |> ppat_tuple ~loc 498 | and rpatt = 499 | List.map ids_ty_and_has_global ~f:(fun (_l, r, _ty, _g) -> pvar ~loc r) 500 | |> ppat_tuple ~loc 501 | and body = 502 | List.map ids_ty_and_has_global ~f:(fun (l, r, ty, g) -> 503 | compare_of_ty 504 | ~hide 505 | ~with_local:(with_local && not g) 506 | ty 507 | (evar ~loc l) 508 | (evar ~loc r)) 509 | |> chain_if ~loc 510 | in 511 | let res = 512 | case 513 | ~guard:None 514 | ~lhs: 515 | (ppat_tuple 516 | ~loc 517 | [ pconstruct cd (Some lpatt); pconstruct cd (Some rpatt) ]) 518 | ~rhs:body 519 | in 520 | if rightmost 521 | then [ res ] 522 | else ( 523 | let pany = ppat_any ~loc in 524 | let pcnstr = pconstruct cd (Some pany) in 525 | let case l r ord = 526 | case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) 527 | in 528 | [ res; case pcnstr pany Less; case pany pcnstr Greater ])))) 529 | 530 | and compare_sum ~hide ~with_local loc cds value1 value2 = 531 | let is_sum_type_with_all_constant_constructors = 532 | List.for_all cds ~f:(fun cd -> 533 | (not (Option.is_some cd.pcd_res)) 534 | && 535 | (* we could support GADTs, but the general case 536 | doesn't, so let's hold off *) 537 | match cd.pcd_args with 538 | | Pcstr_tuple l -> List.is_empty l 539 | | Pcstr_record l -> List.is_empty l) 540 | in 541 | if is_sum_type_with_all_constant_constructors 542 | then 543 | (* the compiler will optimize the polymorphic comparison to an integer one *) 544 | poly ~loc value1 value2 545 | else ( 546 | let mcs = branches_of_sum ~hide ~with_local cds in 547 | let e = pexp_match ~loc (pexp_tuple ~loc [ value1; value2 ]) mcs in 548 | phys_equal_first value1 value2 e) 549 | 550 | and compare_of_ty ~hide ~with_local ty value1 value2 = 551 | let loc = ty.ptyp_loc in 552 | if core_type_is_ignored ty 553 | then compare_ignore ~loc value1 value2 554 | else ( 555 | match core_type_custom_implementation ty with 556 | | Some custom_implementation -> eapply ~loc custom_implementation [ value1; value2 ] 557 | | None -> 558 | (match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ty.ptyp_desc with 559 | | Ptyp_constr (constructor, args) -> 560 | compare_applied ~hide ~with_local ~constructor ~args value1 value2 561 | | Ptyp_tuple labeled_tys -> 562 | compare_of_tuple ~hide ~with_local ~unboxed:false loc labeled_tys value1 value2 563 | | Ptyp_unboxed_tuple labeled_tys -> 564 | compare_of_tuple ~hide ~with_local ~unboxed:true loc labeled_tys value1 value2 565 | | Ptyp_var (name, None) -> 566 | eapply ~loc (evar ~loc (tp_name name)) [ value1; value2 ] 567 | | Ptyp_arrow _ -> 568 | Location.raise_errorf ~loc "ppx_compare: Functions can not be compared." 569 | | Ptyp_variant (row_fields, Closed, None) -> 570 | compare_variant ~hide ~with_local loc row_fields value1 value2 571 | | Ptyp_variant (row_fields, Closed, Some _) -> 572 | (* We can always cast something of the form [< `A ... `Z > `A ...] to the 573 | most general case [`A ... `Z] 574 | 575 | Then the function signature is 576 | [< `A ... `Z > `A ...] -> [< `A ... `Z > `A ...] -> int_or_bool 577 | and the two inputs don't even have to be the same type. 578 | *) 579 | let v1 = gen_symbol ~prefix:"v1" () 580 | and v2 = gen_symbol ~prefix:"v2" () in 581 | let ty_without_constraints = 582 | { ty with ptyp_desc = Ptyp_variant (row_fields, Closed, None) } 583 | in 584 | [%expr 585 | let [%p pvar ~loc v1] = ([%e value1] :> [%t ty_without_constraints]) 586 | and [%p pvar ~loc v2] = ([%e value2] :> [%t ty_without_constraints]) in 587 | [%e 588 | compare_variant 589 | ~hide 590 | ~with_local 591 | loc 592 | row_fields 593 | (evar ~loc v1) 594 | (evar ~loc v2)]] 595 | | Ptyp_any None -> compare_ignore ~loc value1 value2 596 | | Ptyp_var (_, Some _) | Ptyp_any (Some _) -> 597 | Location.raise_errorf 598 | ~loc 599 | "Layout annotations are not currently supported with [ppx_compare]." 600 | | _ -> Location.raise_errorf ~loc "ppx_compare: unknown type")) 601 | 602 | and compare_of_ty_fun ~hide ~with_local ~type_constraint ty = 603 | let loc = { ty.ptyp_loc with loc_ghost = true } in 604 | let do_hide hide_fun x = if hide then hide_fun x else x in 605 | let a = gen_symbol ~prefix:"a" () in 606 | let b = gen_symbol ~prefix:"b" () in 607 | let e_a = evar ~loc a in 608 | let e_b = evar ~loc b in 609 | let mk_pat x = 610 | if type_constraint then ppat_constraint ~loc (pvar ~loc x) ty else pvar ~loc x 611 | in 612 | let body = 613 | do_hide Merlin_helpers.hide_expression (compare_of_ty ~hide ~with_local ty e_a e_b) 614 | in 615 | [%expr 616 | fun [%p mk_pat a] [%p do_hide Merlin_helpers.hide_pattern (mk_pat b)] -> [%e body]] 617 | 618 | and compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2 ~unboxed = 619 | let is_evar = function 620 | | { pexp_desc = Pexp_ident _; _ } -> true 621 | | _ -> false 622 | in 623 | assert (is_evar value1); 624 | assert (is_evar value2); 625 | List.filter lds ~f:(fun ld -> not (label_is_ignored ld)) 626 | |> List.map ~f:(fun ld -> 627 | let modalities, ld = Ppxlib_jane.Shim.Label_declaration.extract_modalities ld in 628 | let loc = ld.pld_loc in 629 | let label = Located.map lident ld.pld_name in 630 | compare_of_ty 631 | ~hide 632 | ~with_local: 633 | (with_local 634 | && not 635 | (has_global_modality 636 | ~modalities 637 | ~attrs:ld.pld_attributes 638 | ~mut:(Some ld.pld_mutable))) 639 | ld.pld_type 640 | (make_field_expr ~unboxed ~loc value1 label) 641 | (make_field_expr ~unboxed ~loc value2 label)) 642 | |> chain_if ~loc 643 | ;; 644 | 645 | let compare_of_record ~hide ~with_local loc lds value1 value2 = 646 | compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2 ~unboxed:false 647 | |> phys_equal_first value1 value2 648 | ;; 649 | 650 | let compare_abstract loc type_name v_a v_b = abstract ~loc ~type_name v_a v_b 651 | 652 | let scheme_of_td ~hide ~with_local td = 653 | Ppx_helpers.combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local) 654 | |> Ppx_helpers.Polytype.to_core_type 655 | ;; 656 | 657 | let compare_of_td ~hide ~with_local ~portable td ~rec_flag = 658 | let loc = td.ptype_loc in 659 | let a = gen_symbol ~prefix:"a" () in 660 | let b = gen_symbol ~prefix:"b" () in 661 | let v_a = evar ~loc a in 662 | let v_b = evar ~loc b in 663 | let function_body = 664 | match Ppxlib_jane.Shim.Type_kind.of_parsetree td.ptype_kind with 665 | | Ptype_variant cds -> compare_sum ~hide ~with_local loc cds v_a v_b 666 | | Ptype_record lds -> compare_of_record ~hide ~with_local loc lds v_a v_b 667 | | Ptype_record_unboxed_product lds -> 668 | compare_of_record_no_phys_equal ~hide ~with_local ~unboxed:true loc lds v_a v_b 669 | | Ptype_open -> 670 | Location.raise_errorf ~loc "ppx_compare: open types are not yet supported" 671 | | Ptype_abstract -> 672 | (match td.ptype_manifest with 673 | | None -> compare_abstract loc td.ptype_name.txt v_a v_b 674 | | Some ty -> 675 | (match ty.ptyp_desc with 676 | | Ptyp_variant (_, Open, _) | Ptyp_variant (_, Closed, Some (_ :: _)) -> 677 | Location.raise_errorf 678 | ~loc:ty.ptyp_loc 679 | "ppx_compare: cannot compare open polymorphic variant types" 680 | | Ptyp_variant (row_fields, _, _) -> 681 | compare_variant ~hide ~with_local loc row_fields v_a v_b 682 | | _ -> compare_of_ty ~hide ~with_local ty v_a v_b)) 683 | in 684 | let extra_names = 685 | List.map td.ptype_params ~f:(fun p -> tp_name (get_type_param_name p).txt) 686 | in 687 | let patts = List.map (extra_names @ [ a; b ]) ~f:(pvar ~loc) 688 | and bnd = pvar ~loc (function_name ~with_local td.ptype_name.txt) in 689 | let poly_scheme = 690 | match extra_names with 691 | | [] -> false 692 | | _ :: _ -> true 693 | in 694 | let body = 695 | eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts function_body) 696 | in 697 | let modes = 698 | if portable then [ Loc.make (Ppxlib_jane.Mode "portable") ~loc ] else [] 699 | in 700 | if poly_scheme 701 | then 702 | Ppxlib_jane.Ast_builder.Default.value_binding 703 | ~loc 704 | ~pat:(ppat_constraint ~loc bnd (scheme_of_td ~hide ~with_local td)) 705 | ~expr:body 706 | ~modes 707 | else 708 | Ppxlib_jane.Ast_builder.Default.value_binding 709 | ~loc 710 | ~pat:bnd 711 | ~expr:(pexp_constraint ~loc body (scheme_of_td ~hide ~with_local td)) 712 | ~modes 713 | ;; 714 | 715 | let bindings_of_tds tds ~hide ~with_local ~portable ~rec_flag = 716 | List.map tds ~f:(fun td -> compare_of_td td ~hide ~with_local ~portable ~rec_flag) 717 | ;; 718 | 719 | let eta_expand2 ~loc f = 720 | eabstract 721 | ~loc 722 | [ pvar ~loc "a"; pvar ~loc "b" ] 723 | (eapply ~loc f [ evar ~loc "a"; evar ~loc "b" ]) 724 | ;; 725 | 726 | let aliases_of_tds tds ~hide = 727 | (* So that ~localize doesn't double the size of the generated code, we define the non 728 | local_ function as an alias to the local_ function. This only works for ground 729 | types, as [('a -> 'a -> int) -> 'a list -> 'a list -> int] is a type that is 730 | neither stronger nor weaker than the same type with local_ on the 'a and 'a 731 | list. If the compiler supports polymorphism over locality one day, we may be able 732 | to only generate one version of the code, the local version. *) 733 | if List.for_all tds ~f:(fun td -> List.is_empty td.ptype_params) 734 | then 735 | Some 736 | (List.map tds ~f:(fun td -> 737 | let loc = td.ptype_name.loc in 738 | value_binding 739 | ~loc 740 | ~pat:(pvar ~loc (function_name ~with_local:false td.ptype_name.txt)) 741 | ~expr: 742 | (pexp_constraint 743 | ~loc 744 | (eta_expand2 745 | ~loc 746 | (evar ~loc (function_name ~with_local:true td.ptype_name.txt))) 747 | (scheme_of_td ~hide ~with_local:false td)))) 748 | else None 749 | ;; 750 | 751 | let str_type_decl ~ctxt (rec_flag, tds) ~localize ~portable = 752 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 753 | let hide = not (Expansion_context.Deriver.inline ctxt) in 754 | let tds = List.map tds ~f:name_type_params_in_td in 755 | let rec_flag = 756 | (object 757 | inherit type_is_recursive rec_flag tds as super 758 | 759 | method! label_declaration ld = 760 | if not (label_is_ignored ld) then super#label_declaration ld 761 | 762 | method! core_type ty = if not (core_type_is_ignored ty) then super#core_type ty 763 | end) 764 | #go 765 | () 766 | in 767 | let global_bindings () = 768 | bindings_of_tds tds ~hide ~with_local:false ~portable ~rec_flag 769 | in 770 | if localize 771 | then ( 772 | let local_bindings = 773 | bindings_of_tds tds ~hide ~with_local:true ~portable ~rec_flag 774 | in 775 | let global_bindings = 776 | match aliases_of_tds tds ~hide with 777 | | Some values -> values 778 | | None -> global_bindings () 779 | in 780 | match rec_flag with 781 | | Recursive -> 782 | (* In a recursive type, the [@ local] comparators may depend on the [@ global] 783 | ones if the type refers to itself behind an [@@ global] modality. Since the 784 | [@ global] comparator is often defined in terms of the [@ local] one, we want 785 | the [@ local] and [@ global] bindings to be mutually recursive. *) 786 | [ pstr_value ~loc rec_flag (local_bindings @ global_bindings) ] 787 | | Nonrecursive -> 788 | (* In a nonrecursive type, only the [@ global] comparators reference the [@ local] 789 | ones. We define them later, in a second of two sets of non-recursive bindings. *) 790 | [ pstr_value ~loc rec_flag local_bindings 791 | ; pstr_value ~loc rec_flag global_bindings 792 | ]) 793 | else [ pstr_value ~loc rec_flag (global_bindings ()) ] 794 | ;; 795 | 796 | let mk_sig ~ctxt (_rec_flag, tds) ~localize ~portable = 797 | let hide = not (Expansion_context.Deriver.inline ctxt) in 798 | let tds = List.map tds ~f:name_type_params_in_td in 799 | List.concat_map tds ~f:(fun td -> 800 | let generate ~with_local = 801 | let loc = td.ptype_loc in 802 | let compare_of = 803 | Ppx_helpers.combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local) 804 | |> Ppx_helpers.Polytype.to_core_type 805 | in 806 | let name = function_name ~with_local td.ptype_name.txt in 807 | psig_value 808 | ~loc 809 | (Ppxlib_jane.Ast_builder.Default.value_description 810 | ~loc 811 | ~name:{ td.ptype_name with txt = name } 812 | ~type_:compare_of 813 | ~modalities: 814 | (if portable then Ppxlib_jane.Shim.Modalities.portable ~loc else []) 815 | ~prim:[]) 816 | in 817 | if localize 818 | then [ generate ~with_local:false; generate ~with_local:true ] 819 | else [ generate ~with_local:false ]) 820 | ;; 821 | 822 | let sig_type_decl ~ctxt (rec_flag, tds) ~localize ~portable = 823 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 824 | let module_name = 825 | match kind with 826 | | Compare -> "Comparable" 827 | | Equal -> "Equal" 828 | in 829 | let mk_named_sig ~with_local = 830 | let sg_name = Printf.sprintf "Ppx_compare_lib.%s.S" module_name in 831 | mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant:false tds 832 | |> Option.map ~f:(fun incl -> 833 | if with_local then Ppxlib_jane.localize_include_sig incl else incl) 834 | in 835 | let psig_include include_infos = 836 | Ppxlib_jane.Ast_builder.Default.psig_include 837 | ~loc 838 | ~modalities: 839 | (if portable then [ Loc.make ~loc (Ppxlib_jane.Modality "portable") ] else []) 840 | include_infos 841 | in 842 | match mk_named_sig ~with_local:false, mk_named_sig ~with_local:true with 843 | | Some include_infos, _ when not localize -> [ psig_include include_infos ] 844 | | Some include_infos, Some include_infos_local when localize -> 845 | [ psig_include include_infos; psig_include include_infos_local ] 846 | | _ -> mk_sig ~ctxt (rec_flag, tds) ~localize ~portable 847 | ;; 848 | 849 | let compare_core_type ~with_local ty = 850 | compare_of_ty_fun ~hide:true ~with_local ~type_constraint:true ty 851 | ;; 852 | 853 | let core_type ~with_local = compare_core_type ~with_local 854 | 855 | let pattern ~with_local ty = 856 | let loc = { ty.ptyp_loc with loc_ghost = true } in 857 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree ty.ptyp_desc with 858 | | Ptyp_constr (id, _) -> 859 | Ppx_helpers.type_constr_conv_pat ~loc id ~f:(function_name ~with_local) 860 | | Ptyp_var (id, _) -> 861 | let ty = { ty with ptyp_loc = loc } in 862 | [%pat? ([%p pvar ~loc (tp_name id)] : [%t type_ ~with_local ~hide:true ~loc ty])] 863 | | _ -> 864 | Ast_builder.Default.ppat_extension 865 | ~loc 866 | (Location.error_extensionf 867 | ~loc 868 | "Only type variables and constructors are allowed here (e.g. ['a], [t], ['a \ 869 | t], or [M(X).t]).") 870 | ;; 871 | end 872 | 873 | module Compare = struct 874 | include Make (Compare_params) 875 | 876 | let equal_core_type ~with_local ty = 877 | let loc = { ty.ptyp_loc with loc_ghost = true } in 878 | let arg1 = gen_symbol () in 879 | let arg2 = gen_symbol () in 880 | let body = 881 | Merlin_helpers.hide_expression 882 | [%expr 883 | match 884 | [%e compare_core_type ~with_local ty] [%e evar ~loc arg1] [%e evar ~loc arg2] 885 | with 886 | | 0 -> true 887 | | _ -> false] 888 | in 889 | [%expr fun ([%p pvar ~loc arg1] : [%t ty]) [%p pvar ~loc arg2] -> [%e body]] 890 | ;; 891 | end 892 | 893 | module Equal = Make (Equal_params) 894 | --------------------------------------------------------------------------------