pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=898b96da6ccd3c33d6a5cb35af6b80affe67137f ppx_compare-0.17.0/000077500000000000000000000000001461647336100141275ustar00rootroot00000000000000ppx_compare-0.17.0/.gitignore000066400000000000000000000000411461647336100161120ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_compare-0.17.0/.ocamlformat000066400000000000000000000000231461647336100164270ustar00rootroot00000000000000profile=janestreet ppx_compare-0.17.0/CHANGES.md000066400000000000000000000013771461647336100155310ustar00rootroot00000000000000## Release v0.17.0 * Support comparing locally-allocated values via `[@@deriving compare ~localize]`. ## git version - Optimized comparison for sum types when all constructors are constant. ## v0.11 Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, ppx\_metaquot and ppx\_type\_conv. ## v0.10 - Disallowed `[%equal]`; use `[%compare.equal]` - Added `@compare.ignore` record-field attribute; `ppx_compare` and `ppx_hash` skip record fields annotated with `@compare.ignore`. - Added support to `%compare` syntax for underscore (`_`) as meaning a comparison function that ignores both its arguments and returns zero. ## v0.9 ## 113.43.00 - use the new context-free API ## 113.24.00 - Follow evolution of `Ppx_core` and `Type_conv`. ppx_compare-0.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100163570ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_compare-0.17.0/LICENSE.md000066400000000000000000000021461461647336100155360ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_compare-0.17.0/Makefile000066400000000000000000000004031461647336100155640ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_compare-0.17.0/README.md000066400000000000000000000137371461647336100154210ustar00rootroot00000000000000ppx_compare =========== Generation of fast comparison and equality functions from type expressions and definitions. Ppx_compare is a ppx rewriter that derives comparison and equality functions from type representations. The scaffolded functions are usually much faster than ocaml's `Pervasives.compare` and `Pervasives.(=)`. Scaffolding functions also gives you more flexibility by allowing you to override them for a specific type and more safety by making sure that you only compare comparable values. Syntax ------ Type definitions: `[@@deriving compare, equal]` Expressions: `[%compare: TYPE]`, `[%equal: TYPE]` and `[%compare.equal: TYPE]` Types, record fields: `[@compare.ignore]`, `[@equal.ignore]` Basic usage ----------- We use `ppx_deriving`/`ppx_type_conv`, so type definitions are annotated this way: ```ocaml type s = v * w [@@deriving compare] ``` This will generate `compare_s : s -> s -> int` function that relies on `compare_v : v -> v -> int` and `compare_w : w -> w -> int`. Compare is not DWIM (do what I mean): it will scaffold a fast well behaved comparison (reflexive, transitive, symmetric...) function however it does not try to follow any "natural ordering". For instance arrays of characters are not sorted lexicographically. Base types (options,int,array,lists,char,floats...) have the same comparison order as Pervasives.compare (provided their type parameters also do for the polymorphic ones). Comparisons for these types must be brought in scope with `open Base`, `open Core`, or `open Ppx_compare_lib.Builtin`. Records fields are compared in the order they are defined (left to right); tuples fields are compared left to right. When we compare two branches of a sum whichever ones comes first in the definition is considered lowest. Variants compare in the order they are listed (increasing top-to-bottom). Polymorphic variants use the same ordering as the ocaml runtime. The same applies to equality functions. ### Float equality The functions derived by `[@@deriving equal]` are consistent with the compare functions derived by `[@@deriving compare]` and in particular do not respect IEEE float comparison. Calling `compare` for type `t`s ------------------------------- In compliance (or conformance) with Janestreet's coding standard we assume that type named `t` are the main types in a module and ```ocaml type t = S.t * T.t [@@deriving compare] ``` will call the functions `S.compare` and `T.compare` instead of calling `S.compare_t` and `T.compare_t`. This will also generate a `compare : t -> t -> int` function. The same applies to equality functions. Signature --------- `type t [@@deriving compare]` in a module signature will add `val compare : t -> t -> int` in the signature. The same applies to equality functions. Comparison without a type definition ------------------------------------ Sometimes you just want a comparison without having to create a new type. You can create such a comparison function using the `[%compare: ..]` extension point: ```ocaml let gt x y = [%compare: float * int * [`A | `B | `C] ] x y ``` You can use the type `_`, in which case the corresponding values will be ignored (i.e. compared using `fun _ _ -> 0`). For instance: ```ocaml assert ([%compare: _ list] [ true ] [ false ] = 0); assert ([%compare: _ list] [] [ false ] <> 0); ``` The same applies to equality functions. You can also check for equality using `[%compare.equal: ..]`, which produces a function that returns `true` precisely when `[%compare: ..]` returns `0`. `[%equal: ..]` is preferred over `[%compare.equal: ..]` and in particular is expected to be slightly faster. However, `[%compare.equal: ..]` can come in handy for types that only have `[@@deriving compare]`. In particular, support for `[@@deriving equal]` was added long after the project started, which means that many types out there only support `[@deriving compare]`. Ignoring part of types ---------------------- The comparison ignores any part of the type declaration that is under a `[@compare.ignore]` annotation: ```ocaml type t = (float [@compare.ignore]) * string [@@deriving compare] ``` The same applies for `[@@deriving equal]` by using `[@equal.ignore]`. In order to ignore part of a type for both comparison and equality, you can simply use `[@ignore]`. However, be aware that the general `[@ignore]` attribute will apply to any deriver that recognize it, not just `compare` and `equal`. Note that if you use both the `compare` and `equal` derivers, you need to use either both `[@compare.ignore]` and `[@equal.ignore]` or `[@ignore]`. However, you cannot use only one of them. For convenience, you can also ignore record fields instead of the type of record field. In other words, ```ocaml type t = { a : (float [@compare.ignore]) ; b : string } [@@deriving compare] ``` can be abbreviated: ```ocaml type t = { a : float [@compare.ignore] ; b : string } [@@deriving compare] ``` Local-accepting compare functions ---------------------------- This ppx includes the option to support local allocation, a nonstandard OCaml extension available at: https://github.com/ocaml-flambda/ocaml-jst In both structures and signatures, `[@@deriving compare ~localize]` (and similarly for `equal`) generates definitions with the following types, in addition to the usual definitions: ``` (* Monomorphic types *) val compare__local : local_ t -> local_ t -> int val equal__local : local_ t -> local_ t -> bool (* Parameterized types *) val compare__local : (local_ 'a -> local_ 'a -> int) -> local_ 'a t -> local_ 'a t -> int val equal__local : (local_ 'a -> local_ 'a -> bool) -> local_ 'a t -> local_ 'a t -> bool ``` You can also use the `[%compare_local: _]`, `[%equal_local: _]` and `[%compare_local.equal: _]` extension points to generate the corresponding types and functions. For types named something other than `t`, the naming pattern is similar to the non-local versions: ```ocaml type foo val compare_foo__local : local_ foo -> local_ foo -> int ``` ppx_compare-0.17.0/dune000066400000000000000000000000001461647336100147730ustar00rootroot00000000000000ppx_compare-0.17.0/dune-project000066400000000000000000000000211461647336100164420ustar00rootroot00000000000000(lang dune 3.11) ppx_compare-0.17.0/expander/000077500000000000000000000000001461647336100157355ustar00rootroot00000000000000ppx_compare-0.17.0/expander/dune000066400000000000000000000003341461647336100166130ustar00rootroot00000000000000(library (name ppx_compare_expander) (public_name ppx_compare.expander) (libraries base compiler-libs.common ppxlib ppxlib_jane) (ppx_runtime_libraries ppx_compare.runtime-lib) (preprocess (pps ppxlib.metaquot))) ppx_compare-0.17.0/expander/ppx_compare_expander.ml000066400000000000000000000553461461647336100225070ustar00rootroot00000000000000(* Generated code should depend on the environment in scope as little as possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It is especially important to not use polymorphic comparisons, since we are moving more and more to code that doesn't have them in scope. *) (* Note: I am introducing a few unnecessary explicit closures, (not all of them some are unnecessary due to the value restriction). *) open Base open Ppxlib open Ast_builder.Default include Ppx_compare_expander_intf (* Two-argument function, possibly with [local_] arguments *) let ptyp_arrow2 ~loc ~local_args arg1 arg2 res = if local_args then [%type: [%t arg1] -> [%t arg2] -> [%t res]] else [%type: [%t arg1] -> [%t arg2] -> [%t res]] ;; type kind = | Compare | Equal module type Params = sig val name : string val kind : kind val chain : expression -> expression -> expression val const : loc:Location.t -> Ordering.t -> expression val result_type : loc:Location.t -> core_type val poly : loc:Location.t -> expression -> expression -> expression val abstract : loc:Location.t -> type_name:string -> expression -> expression -> expression module Attrs : Attrs end module Make_attrs (Name : sig val name : string end) : Attrs = struct let ignore_label_declaration = Attribute.declare (Name.name ^ ".ignore") Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let ignore_core_type = Attribute.declare (Name.name ^ ".ignore") Attribute.Context.core_type Ast_pattern.(pstr nil) () ;; end module Compare_params : Params = struct let name = "compare" let kind = Compare let chain a b = let loc = a.pexp_loc in [%expr match [%e a] with | 0 -> [%e b] | n -> n] ;; let const ~loc (ord : Ordering.t) = eint ~loc (match ord with | Less -> -1 | Equal -> 0 | Greater -> 1) ;; let result_type ~loc = [%type: int] let poly ~loc a b = [%expr Stdlib.compare [%e a] [%e b]] let abstract ~loc ~type_name a b = [%expr Ppx_compare_lib.compare_abstract ~type_name:[%e estring ~loc type_name] [%e a] [%e b]] ;; module Attrs = Make_attrs (struct let name = name end) end module Equal_params : Params = struct let name = "equal" let kind = Equal let chain a b = let loc = a.pexp_loc in [%expr Stdlib.( && ) [%e a] [%e b]] ;; let const ~loc (ord : Ordering.t) = match ord with | Equal -> [%expr true] | Less | Greater -> [%expr false] ;; let result_type ~loc = [%type: bool] let poly ~loc a b = [%expr Stdlib.( = ) [%e a] [%e b]] let abstract ~loc ~type_name a b = [%expr Ppx_compare_lib.equal_abstract ~type_name:[%e estring ~loc type_name] [%e a] [%e b]] ;; module Attrs = Make_attrs (struct let name = name end) end module Make (Params : Params) = struct open Params module Attrs = Attrs let str_attributes = [ Attribute.T Attrs.ignore_label_declaration; Attribute.T Attrs.ignore_core_type ] ;; let is_ignored_gen ~loc ~compare_attr ~equal_attr ast = match kind, Attribute.get compare_attr ast, Attribute.get equal_attr ast with | _, Some (), Some () | Compare, Some (), None | Equal, None, Some () -> true | _, None, None -> false | Compare, None, Some () -> Location.raise_errorf ~loc "Cannot use [@@equal.ignore] with [@@@@deriving compare]." | Equal, Some (), None -> Location.raise_errorf ~loc "Cannot use [@@compare.ignore] with [@@@@deriving equal]" ;; let core_type_is_ignored ty = is_ignored_gen ~loc:ty.ptyp_loc ~compare_attr:Compare_params.Attrs.ignore_core_type ~equal_attr:Equal_params.Attrs.ignore_core_type ty ;; let label_is_ignored ld = is_ignored_gen ~loc:ld.pld_loc ~compare_attr:Compare_params.Attrs.ignore_label_declaration ~equal_attr:Equal_params.Attrs.ignore_label_declaration ld ;; let with_tuple loc ~value ~ltys f = (* generate let id_1, id_2, id_3, ... id_n = value in expr where expr is the result of (f [id_1, ty_1 ; id_2, ty_2; ...]) *) let names_types = List.map ltys ~f:(fun (lbl, t) -> gen_symbol ~prefix:"t" (), lbl, t) in let pattern = let l = List.map names_types ~f:(fun (n, lbl, _) -> lbl, pvar ~loc n) in Ppxlib_jane.Jane_syntax.Pattern.pat_of ~loc ~attrs:[] (Jpat_tuple (l, Closed)) in let e = f (List.map names_types ~f:(fun (n, _, t) -> evar ~loc n, t)) in let binding = value_binding ~loc ~pat:pattern ~expr:value in pexp_let ~loc Nonrecursive [ binding ] e ;; let phys_equal_first a b cmp = let loc = cmp.pexp_loc in [%expr if Stdlib.( == ) [%e a] [%e b] then [%e const ~loc Equal] else [%e cmp]] ;; let rec chain_if ~loc = function | [] -> const ~loc Equal | [ x ] -> x | x :: xs -> chain x (chain_if ~loc:x.pexp_loc xs) ;; let tp_name n = Printf.sprintf "_cmp__%s" n let type_ ~with_local ~hide ~loc ty = let loc = { loc with loc_ghost = true } in let ptyp_attributes = if hide then Merlin_helpers.hide_attribute :: ty.ptyp_attributes else ty.ptyp_attributes in let hty = { ty with ptyp_attributes } in ptyp_arrow2 ~loc ~local_args:with_local ty hty (result_type ~loc) ;; let function_name ~with_local typename = let name = match typename with | "t" -> name | s -> name ^ "_" ^ s in if with_local then name ^ "__local" else name ;; let compare_ignore ~loc value1 value2 = [%expr let (_ : _) = [%e value1] and (_ : _) = [%e value2] in [%e const ~loc Equal]] ;; let rec compare_applied ~hide ~with_local ~constructor ~args value1 value2 = let args = List.map args ~f:(compare_of_ty_fun ~hide ~with_local ~type_constraint:false) @ [ value1; value2 ] in type_constr_conv ~loc:(Located.loc constructor) constructor args ~f:(function_name ~with_local) and compare_of_tuple ~hide ~with_local loc ltys value1 value2 = with_tuple loc ~value:value1 ~ltys (fun elems1 -> with_tuple loc ~value:value2 ~ltys (fun elems2 -> let exprs = List.map2_exn elems1 elems2 ~f:(fun (v1, t) (v2, _) -> compare_of_ty ~hide ~with_local t v1 v2) in chain_if ~loc exprs)) and compare_variant ~hide ~with_local loc row_fields value1 value2 = let map row = match row.prf_desc with | Rtag ({ txt = cnstr; _ }, true, _) | Rtag ({ txt = cnstr; _ }, _, []) -> case ~guard:None ~lhs: (ppat_tuple ~loc [ ppat_variant ~loc cnstr None; ppat_variant ~loc cnstr None ]) ~rhs:(const ~loc Equal) | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> let v1 = gen_symbol ~prefix:"_left" () and v2 = gen_symbol ~prefix:"_right" () in let body = compare_of_ty ~hide ~with_local tp (evar ~loc v1) (evar ~loc v2) in case ~guard:None ~lhs: (ppat_tuple ~loc [ ppat_variant ~loc cnstr (Some (pvar ~loc v1)) ; ppat_variant ~loc cnstr (Some (pvar ~loc v2)) ]) ~rhs:body | Rinherit { ptyp_desc = Ptyp_constr (id, args); _ } -> (* quite sadly, this code doesn't handle: type 'a id = 'a with compare type t = [ `a | [ `b ] id ] with compare because it will generate a pattern #id, when id is not even a polymorphic variant in the first place. The culprit is caml though, since it only allows #id but not #([`b] id) *) let v1 = gen_symbol ~prefix:"_left" () and v2 = gen_symbol ~prefix:"_right" () in case ~guard:None ~lhs: (ppat_tuple ~loc [ ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v1) ; ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc v2) ]) ~rhs: (compare_applied ~hide ~with_local ~constructor:id ~args (evar ~loc v1) (evar ~loc v2)) | Rinherit ty -> Location.raise_errorf ~loc:ty.ptyp_loc "Ppx_compare.compare_variant: unknown type" in let e = let matched = pexp_tuple ~loc [ value1; value2 ] in match List.map ~f:map row_fields with | [ v ] -> pexp_match ~loc matched [ v ] | l -> pexp_match ~loc matched (l @ (* Providing we didn't screw up badly we now know that the tags of the variants are different. We let pervasive do its magic. *) [ case ~guard:None ~lhs:[%pat? x, y] ~rhs:(poly ~loc [%expr x] [%expr y]) ]) in phys_equal_first value1 value2 e and branches_of_sum ~hide ~with_local cds = let rightmost_index = List.length cds - 1 in List.concat (List.mapi cds ~f:(fun i cd -> let rightmost = i = rightmost_index in let loc = cd.pcd_loc in if Option.is_some cd.pcd_res then (* If we get GADTs support, fix the constant sum type optimization for them *) Location.raise_errorf ~loc "GADTs are not supported by comparelib"; match cd.pcd_args with | Pcstr_record lds -> let value1 = gen_symbol ~prefix:"_a" () in let value2 = gen_symbol ~prefix:"_b" () in let res = case ~guard:None ~lhs: (ppat_tuple ~loc [ pconstruct cd (Some (pvar ~loc value1)) ; pconstruct cd (Some (pvar ~loc value2)) ]) ~rhs: (compare_of_record_no_phys_equal ~hide ~with_local loc lds (evar ~loc value1) (evar ~loc value2)) in if rightmost then [ res ] else ( let pany = ppat_any ~loc in let pcnstr = pconstruct cd (Some pany) in let case l r ord = case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) in [ res; case pcnstr pany Less; case pany pcnstr Greater ]) | Pcstr_tuple pcd_args -> (match pcd_args with | [] -> let pcnstr = pconstruct cd None in let pany = ppat_any ~loc in let case l r ord = case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) in if rightmost then [ case pcnstr pcnstr Equal ] else [ case pcnstr pcnstr Equal ; case pcnstr pany Less ; case pany pcnstr Greater ] | tps -> let ids_ty = List.map tps ~f:(fun ty -> let a = gen_symbol ~prefix:"_a" () in let b = gen_symbol ~prefix:"_b" () in a, b, ty) in let lpatt = List.map ids_ty ~f:(fun (l, _r, _ty) -> pvar ~loc l) |> ppat_tuple ~loc and rpatt = List.map ids_ty ~f:(fun (_l, r, _ty) -> pvar ~loc r) |> ppat_tuple ~loc and body = List.map ids_ty ~f:(fun (l, r, ty) -> compare_of_ty ~hide ~with_local ty (evar ~loc l) (evar ~loc r)) |> chain_if ~loc in let res = case ~guard:None ~lhs: (ppat_tuple ~loc [ pconstruct cd (Some lpatt); pconstruct cd (Some rpatt) ]) ~rhs:body in if rightmost then [ res ] else ( let pany = ppat_any ~loc in let pcnstr = pconstruct cd (Some pany) in let case l r ord = case ~guard:None ~lhs:(ppat_tuple ~loc [ l; r ]) ~rhs:(const ~loc ord) in [ res; case pcnstr pany Less; case pany pcnstr Greater ])))) and compare_sum ~hide ~with_local loc cds value1 value2 = let is_sum_type_with_all_constant_constructors = List.for_all cds ~f:(fun cd -> Option.is_none cd.pcd_res && (* we could support GADTs, but the general case doesn't, so let's hold off *) match cd.pcd_args with | Pcstr_tuple l -> List.is_empty l | Pcstr_record l -> List.is_empty l) in if is_sum_type_with_all_constant_constructors then (* the compiler will optimize the polymorphic comparison to an integer one *) poly ~loc value1 value2 else ( let mcs = branches_of_sum ~hide ~with_local cds in let e = pexp_match ~loc (pexp_tuple ~loc [ value1; value2 ]) mcs in phys_equal_first value1 value2 e) and compare_of_ty ~hide ~with_local ty value1 value2 = let loc = ty.ptyp_loc in if core_type_is_ignored ty then compare_ignore ~loc value1 value2 else ( match Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with | Some (Jtyp_tuple ltps, _attrs) -> compare_of_tuple ~hide ~with_local loc ltps value1 value2 | Some (Jtyp_layout _, _) -> Location.raise_errorf ~loc "Layout annotations are not currently supported with [ppx_compare]." | None -> (match ty.ptyp_desc with | Ptyp_constr (constructor, args) -> compare_applied ~hide ~with_local ~constructor ~args value1 value2 | Ptyp_tuple tys -> compare_of_tuple ~hide ~with_local loc (List.map ~f:(fun ty -> None, ty) tys) value1 value2 | Ptyp_var name -> eapply ~loc (evar ~loc (tp_name name)) [ value1; value2 ] | Ptyp_arrow _ -> Location.raise_errorf ~loc "ppx_compare: Functions can not be compared." | Ptyp_variant (row_fields, Closed, None) -> compare_variant ~hide ~with_local loc row_fields value1 value2 | Ptyp_any -> compare_ignore ~loc value1 value2 | _ -> Location.raise_errorf ~loc "ppx_compare: unknown type")) and compare_of_ty_fun ~hide ~with_local ~type_constraint ty = let loc = { ty.ptyp_loc with loc_ghost = true } in let do_hide hide_fun x = if hide then hide_fun x else x in let a = gen_symbol ~prefix:"a" () in let b = gen_symbol ~prefix:"b" () in let e_a = evar ~loc a in let e_b = evar ~loc b in let mk_pat x = if type_constraint then ppat_constraint ~loc (pvar ~loc x) ty else pvar ~loc x in let body = do_hide Merlin_helpers.hide_expression (compare_of_ty ~hide ~with_local ty e_a e_b) in eta_reduce_if_possible [%expr fun [%p mk_pat a] [%p do_hide Merlin_helpers.hide_pattern (mk_pat b)] -> [%e body]] and compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2 = let is_evar = function | { pexp_desc = Pexp_ident _; _ } -> true | _ -> false in assert (is_evar value1); assert (is_evar value2); List.filter lds ~f:(fun ld -> not (label_is_ignored ld)) |> List.map ~f:(fun ld -> let loc = ld.pld_loc in let label = Located.map lident ld.pld_name in compare_of_ty ~hide ~with_local ld.pld_type (pexp_field ~loc value1 label) (pexp_field ~loc value2 label)) |> chain_if ~loc ;; let compare_of_record ~hide ~with_local loc lds value1 value2 = compare_of_record_no_phys_equal ~hide ~with_local loc lds value1 value2 |> phys_equal_first value1 value2 ;; let compare_abstract loc type_name v_a v_b = abstract ~loc ~type_name v_a v_b let scheme_of_td ~hide ~with_local td = let loc = td.ptype_loc in let type_ = combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local) in match td.ptype_params with | [] -> type_ | l -> let vars = List.map l ~f:get_type_param_name in ptyp_poly ~loc vars type_ ;; let compare_of_td ~hide ~with_local td ~rec_flag = let loc = td.ptype_loc in let a = gen_symbol ~prefix:"a" () in let b = gen_symbol ~prefix:"b" () in let v_a = evar ~loc a in let v_b = evar ~loc b in let function_body = match td.ptype_kind with | Ptype_variant cds -> compare_sum ~hide ~with_local loc cds v_a v_b | Ptype_record lds -> compare_of_record ~hide ~with_local loc lds v_a v_b | Ptype_open -> Location.raise_errorf ~loc "ppx_compare: open types are not yet supported" | Ptype_abstract -> (match td.ptype_manifest with | None -> compare_abstract loc td.ptype_name.txt v_a v_b | Some ty -> (match ty.ptyp_desc with | Ptyp_variant (_, Open, _) | Ptyp_variant (_, Closed, Some (_ :: _)) -> Location.raise_errorf ~loc:ty.ptyp_loc "ppx_compare: cannot compare open polymorphic variant types" | Ptyp_variant (row_fields, _, _) -> compare_variant ~hide ~with_local loc row_fields v_a v_b | _ -> compare_of_ty ~hide ~with_local ty v_a v_b)) in let extra_names = List.map td.ptype_params ~f:(fun p -> tp_name (get_type_param_name p).txt) in let patts = List.map (extra_names @ [ a; b ]) ~f:(pvar ~loc) and bnd = pvar ~loc (function_name ~with_local td.ptype_name.txt) in let poly_scheme = match extra_names with | [] -> false | _ :: _ -> true in let body = eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts function_body) in if poly_scheme then value_binding ~loc ~pat:(ppat_constraint ~loc bnd (scheme_of_td ~hide ~with_local td)) ~expr:body else value_binding ~loc ~pat:bnd ~expr:(pexp_constraint ~loc body (scheme_of_td ~hide ~with_local td)) ;; let bindings_of_tds tds ~hide ~with_local ~rec_flag = List.map tds ~f:(fun td -> compare_of_td td ~hide ~with_local ~rec_flag) ;; let eta_expand2 ~loc f = eabstract ~loc [ pvar ~loc "a"; pvar ~loc "b" ] (eapply ~loc f [ evar ~loc "a"; evar ~loc "b" ]) ;; let aliases_of_tds tds ~hide = (* So that ~localize doesn't double the size of the generated code, we define the non local_ function as an alias to the local_ function. This only works for ground types, as [('a -> 'a -> int) -> 'a list -> 'a list -> int] is a type that is neither stronger nor weaker than the same type with local_ on the 'a and 'a list. If the compiler supports polymorphism over locality one day, we may be able to only generate one version of the code, the local version. *) if List.for_all tds ~f:(fun td -> List.is_empty td.ptype_params) then Some (List.map tds ~f:(fun td -> let loc = td.ptype_name.loc in value_binding ~loc ~pat:(pvar ~loc (function_name ~with_local:false td.ptype_name.txt)) ~expr: (pexp_constraint ~loc (eta_expand2 ~loc (evar ~loc (function_name ~with_local:true td.ptype_name.txt))) (scheme_of_td ~hide ~with_local:false td)))) else None ;; let str_type_decl ~ctxt (rec_flag, tds) localize = let loc = Expansion_context.Deriver.derived_item_loc ctxt in let hide = not (Expansion_context.Deriver.inline ctxt) in let tds = List.map tds ~f:name_type_params_in_td in let rec_flag = (object inherit type_is_recursive rec_flag tds as super method! label_declaration ld = if not (label_is_ignored ld) then super#label_declaration ld method! core_type ty = if not (core_type_is_ignored ty) then super#core_type ty end) #go () in if localize then [ pstr_value ~loc rec_flag (bindings_of_tds tds ~hide ~with_local:true ~rec_flag) ; (match aliases_of_tds tds ~hide with | Some values -> pstr_value ~loc Nonrecursive values | None -> pstr_value ~loc rec_flag (bindings_of_tds tds ~hide ~with_local:false ~rec_flag)) ] else [ pstr_value ~loc rec_flag (bindings_of_tds tds ~hide ~with_local:false ~rec_flag) ] ;; let mk_sig ~ctxt ~localize (_rec_flag, tds) = let hide = not (Expansion_context.Deriver.inline ctxt) in let tds = List.map tds ~f:name_type_params_in_td in List.concat_map tds ~f:(fun td -> let generate ~with_local = let compare_of = combinator_type_of_type_declaration td ~f:(type_ ~hide ~with_local) in let name = function_name ~with_local td.ptype_name.txt in let loc = td.ptype_loc in psig_value ~loc (value_description ~loc ~name:{ td.ptype_name with txt = name } ~type_:compare_of ~prim:[]) in if localize then [ generate ~with_local:false; generate ~with_local:true ] else [ generate ~with_local:false ]) ;; let sig_type_decl ~ctxt (rec_flag, tds) localize = let loc = Expansion_context.Deriver.derived_item_loc ctxt in let module_name = match kind with | Compare -> "Comparable" | Equal -> "Equal" in let mk_named_sig ~with_local = let module_type_name = if with_local then "S_local" else "S" in let sg_name = Printf.sprintf "Ppx_compare_lib.%s.%s" module_name module_type_name in mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant:false tds in match mk_named_sig ~with_local:false, mk_named_sig ~with_local:true with | Some include_infos, _ when not localize -> [ psig_include ~loc include_infos ] | Some include_infos, Some include_infos_local when localize -> [ psig_include ~loc include_infos; psig_include ~loc include_infos_local ] | _ -> mk_sig ~ctxt ~localize (rec_flag, tds) ;; let compare_core_type ~with_local ty = compare_of_ty_fun ~hide:true ~with_local ~type_constraint:true ty ;; let core_type ~with_local = compare_core_type ~with_local end module Compare = struct include Make (Compare_params) let equal_core_type ~with_local ty = let loc = { ty.ptyp_loc with loc_ghost = true } in let arg1 = gen_symbol () in let arg2 = gen_symbol () in let body = Merlin_helpers.hide_expression [%expr match [%e compare_core_type ~with_local ty] [%e evar ~loc arg1] [%e evar ~loc arg2] with | 0 -> true | _ -> false] in [%expr fun ([%p pvar ~loc arg1] : [%t ty]) [%p pvar ~loc arg2] -> [%e body]] ;; end module Equal = Make (Equal_params) ppx_compare-0.17.0/expander/ppx_compare_expander.mli000066400000000000000000000006011461647336100226400ustar00rootroot00000000000000open Ppxlib module type S = Ppx_compare_expander_intf.S module Compare : sig include S (** [equal_core_type ~with_local ty] is an expression of type [ty -> ty -> bool], using the comparison function generated by [core_type] [~with_local:true] will make the arguments local *) val equal_core_type : with_local:bool -> core_type -> expression end module Equal : S ppx_compare-0.17.0/expander/ppx_compare_expander_intf.ml000066400000000000000000000036621461647336100235210ustar00rootroot00000000000000open Ppxlib module type Attrs = sig val ignore_label_declaration : (label_declaration, unit) Attribute.t val ignore_core_type : (core_type, unit) Attribute.t end module type S = sig (** [type_ ~with_local ~hide ty] is [ty -> ty -> result_type] where [result_type] is [int] for [compare] and [bool] for [equal]. [hide] controls whether some [[@merlin.hide]] attributes should be added. [with_local] adds local_ annotation around the input types. *) val type_ : with_local:bool -> hide:bool -> loc:Location.t -> core_type -> core_type (** [core_type ~with_local ty] is an expression of type [ty -> ty -> result_type] [~with_local:true] will make the arguments local *) val core_type : with_local:bool -> core_type -> expression (** In [str_type_decl] and [sig_type_decl], passing [true] for the third argument generates additional functions that take local arguments. We generate, e.g. [val compare__local : local_ t -> local_ t -> int] in addition to [compare] in order to incrementally grow the portion of the tree which supports local comparison. We need both [compare] and [compare__local] since neither has a stronger type than the other. In the case of polymorphic types, this is due to the fact that [compare__local] requires local compare functions for each of its type arguments, and in the case of monomorphic types, this is due to the possibility of partial application producing a local closure. *) val str_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> bool (** [true] means generate a definition with local arguments *) -> structure val sig_type_decl : ctxt:Expansion_context.Deriver.t -> rec_flag * type_declaration list -> bool (** [true] means generate a signature with local arguments *) -> signature module Attrs : Attrs val str_attributes : Attribute.packed list end ppx_compare-0.17.0/ppx_compare.opam000066400000000000000000000014331461647336100173230ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_compare" bug-reports: "https://github.com/janestreet/ppx_compare/issues" dev-repo: "git+https://github.com/janestreet/ppx_compare.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_compare/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Generation of comparison functions from types" description: " Part of the Jane Street's PPX rewriters collection. " ppx_compare-0.17.0/runtime-lib/000077500000000000000000000000001461647336100163565ustar00rootroot00000000000000ppx_compare-0.17.0/runtime-lib/dune000066400000000000000000000001721461647336100172340ustar00rootroot00000000000000(library (name ppx_compare_lib) (public_name ppx_compare.runtime-lib) (libraries base) (preprocess no_preprocessing)) ppx_compare-0.17.0/runtime-lib/ppx_compare_lib.ml000066400000000000000000000000701461647336100220500ustar00rootroot00000000000000include Base.Exported_for_specific_uses.Ppx_compare_lib ppx_compare-0.17.0/src/000077500000000000000000000000001461647336100147165ustar00rootroot00000000000000ppx_compare-0.17.0/src/dune000066400000000000000000000003131461647336100155710ustar00rootroot00000000000000(library (name ppx_compare) (public_name ppx_compare) (kind ppx_deriver) (ppx_runtime_libraries ppx_compare.runtime-lib) (libraries base ppxlib ppx_compare_expander) (preprocess no_preprocessing)) ppx_compare-0.17.0/src/ppx_compare.ml000066400000000000000000000036061461647336100175720ustar00rootroot00000000000000open Base open Ppxlib open Ppx_compare_expander let add_deriver name (module E : Ppx_compare_expander.S) = let flags () = Deriving.Args.(empty +> flag "localize") in let str_type_decl = Deriving.Generator.V2.make (flags ()) E.str_type_decl ~attributes:E.str_attributes in let sig_type_decl = Deriving.Generator.V2.make (flags ()) E.sig_type_decl in Deriving.add name ~str_type_decl ~sig_type_decl ;; let compare = add_deriver "compare" (module Compare) let equal = add_deriver "equal" (module Equal) let replace_underscores_by_variables = let map = object inherit Ast_traverse.map as super method! core_type_desc = function | Ptyp_any -> Ptyp_var (gen_symbol ~prefix:"a" ()) | t -> super#core_type_desc t end in map#core_type ;; let () = [ "compare", "compare_local", Compare.type_, Compare.core_type ; "equal", "equal_local", Equal.type_, Equal.core_type ; "@compare.equal", "@compare_local.equal", Equal.type_, Compare.equal_core_type ] |> List.concat_map ~f:(fun (name, local_name, type_, core_type) -> [ name, type_ ~with_local:false, core_type ~with_local:false ; local_name, type_ ~with_local:true, core_type ~with_local:true ]) |> List.iter ~f:(fun (name, type_, core_type) -> Driver.register_transformation (String.strip name ~drop:(Char.equal '@')) ~rules: [ Context_free.Rule.extension (Extension.declare name Core_type Ast_pattern.(ptyp __) (fun ~loc ~path:_ ty -> type_ ~hide:true ~loc (replace_underscores_by_variables ty))) ; Context_free.Rule.extension (Extension.declare name Expression Ast_pattern.(ptyp __) (fun ~loc:_ ~path:_ ty -> core_type ty)) ]) ;; ppx_compare-0.17.0/src/ppx_compare.mli000066400000000000000000000000751461647336100177400ustar00rootroot00000000000000open Ppxlib val compare : Deriving.t val equal : Deriving.t ppx_compare-0.17.0/test/000077500000000000000000000000001461647336100151065ustar00rootroot00000000000000ppx_compare-0.17.0/test/check_optims.ml000066400000000000000000000023371461647336100201150ustar00rootroot00000000000000open Ppx_compare_lib type enum = | A | B | C module Compare = struct let optim_bool : bool compare = Stdlib.compare let optim_char : char compare = Stdlib.compare let optim_float : float compare = Stdlib.compare let optim_int : int compare = Stdlib.compare let optim_int32 : int32 compare = Stdlib.compare let optim_int64 : int64 compare = Stdlib.compare let optim_nativeint : nativeint compare = Stdlib.compare let optim_string : string compare = Stdlib.compare let optim_unit : unit compare = Stdlib.compare let optim_enum : enum compare = Stdlib.compare end module Equal = struct let optim_bool : bool equal = Stdlib.( = ) let optim_char : char equal = Stdlib.( = ) let optim_float : float equal = Stdlib.( = ) let optim_int : int equal = Stdlib.( = ) let optim_int32 : int32 equal = Stdlib.( = ) let optim_nativeint : nativeint equal = Stdlib.( = ) let optim_string : string equal = Stdlib.( = ) let optim_unit : unit equal = Stdlib.( = ) let optim_enum : enum equal = Stdlib.( = ) let optim_int64 = if Sys.word_size = 32 then (* On 32bits, polymmorphic comparison of int64 values is not specialized *) fun _ _ -> false else (Stdlib.( = ) : int64 equal) ;; end ppx_compare-0.17.0/test/compare_test.mlt000066400000000000000000000003501461647336100203070ustar00rootroot00000000000000open Base module No_comparing2 = struct (* Checks that we don't trigger an 'unused rec' warning. *) type t = { a : t [@compare.ignore] ; b : (t[@compare.ignore]) * int } [@@deriving compare] end [%%expect {| |}] ppx_compare-0.17.0/test/dune000066400000000000000000000002071461647336100157630ustar00rootroot00000000000000(library (name comparelib_test) (preprocess (pps ppxlib ppx_compare ppx_inline_test))) (alias (name DEFAULT) (deps test.ml.pp)) ppx_compare-0.17.0/test/errors.mlt000066400000000000000000000012011461647336100171320ustar00rootroot00000000000000open Ppx_compare_lib.Builtin type t = { x : int [@compare.ignore] ; y : int } [@@deriving equal] [%%expect {| Line _, characters _-_: Error: Cannot use [@compare.ignore] with [@@deriving equal] |}] type t = { x : int [@equal.ignore] ; y : int } [@@deriving compare, equal] [%%expect {| Line _, characters _-_: Error: Cannot use [@equal.ignore] with [@@deriving compare]. |}] (* The following ones are OK: *) type t = { x : int [@compare.ignore] [@equal.ignore] ; y : int } [@@deriving compare, equal] [%%expect {| |}] type t = { x : int [@ignore] ; y : int } [@@deriving compare, equal] [%%expect {| |}] ppx_compare-0.17.0/test/test.ml000066400000000000000000000467311461647336100164320ustar00rootroot00000000000000open Ppx_compare_lib.Builtin let failwith = `Should_refer_to_runtime_lib let ignore = `Should_refer_to_runtime_lib let ( = ) = `Should_refer_to_runtime_lib let ( <> ) = `Should_refer_to_runtime_lib let ( == ) = `Should_refer_to_runtime_lib let ( != ) = `Should_refer_to_runtime_lib let ( > ) = `Should_refer_to_runtime_lib let ( < ) = `Should_refer_to_runtime_lib let ( >= ) = `Should_refer_to_runtime_lib let ( <= ) = `Should_refer_to_runtime_lib let max = `Should_refer_to_runtime_lib let min = `Should_refer_to_runtime_lib let equal = `Should_refer_to_runtime_lib let compare = `Should_refer_to_runtime_lib module type M1_sig = sig type t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_compare_lib.Equal.S with type t := t include Ppx_compare_lib.Comparable.S with type t := t include Ppx_compare_lib.Comparable.S_local with type t := t include Ppx_compare_lib.Equal.S with type t := t include Ppx_compare_lib.Equal.S_local with type t := t end [@@ocaml.doc "@inline"] [@@@end] end module type M1_sig_wrong_name = sig type t1 [@@deriving_inline compare, equal, compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] val compare_t1 : t1 -> t1 -> int val equal_t1 : t1 -> t1 -> bool val compare_t1 : t1 -> t1 -> int val compare_t1__local : t1 -> t1 -> int val equal_t1 : t1 -> t1 -> bool val equal_t1__local : t1 -> t1 -> bool end [@@ocaml.doc "@inline"] [@@@end] end module type M2_sig = sig type 'a t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Comparable.S_local1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S_local1 with type 'a t := 'a t end [@@ocaml.doc "@inline"] [@@@end] end module type M2_sig_wrong_name = sig type 'a t1 [@@deriving_inline compare, equal, compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] val compare_t1 : ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int val equal_t1 : ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool val compare_t1 : ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int val compare_t1__local : ('a -> 'a -> int) -> 'a t1 -> 'a t1 -> int val equal_t1 : ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool val equal_t1__local : ('a -> 'a -> bool) -> 'a t1 -> 'a t1 -> bool end [@@ocaml.doc "@inline"] [@@@end] end module M1 = struct type t = unit [@@deriving compare, equal, compare ~localize, equal ~localize] end module M2 = struct type t = int [@@deriving compare, equal, compare ~localize, equal ~localize] end module M3 = struct type t = bool [@@deriving compare, equal, compare ~localize, equal ~localize] end module M4 = struct type t = int32 [@@deriving compare, equal, compare ~localize, equal ~localize] end module M5 = struct type t = nativeint [@@deriving compare, equal, compare ~localize, equal ~localize] end module M6 = struct type t = int64 [@@deriving compare, equal, compare ~localize, equal ~localize] end module M7 = struct type t = float [@@deriving compare, equal, compare ~localize, equal ~localize] end module M8 = struct type t = bool * float [@@deriving compare, equal, compare ~localize, equal ~localize] end module M9 = struct type t = bool * float * int [@@deriving compare, equal, compare ~localize, equal ~localize] end module M10 = struct type t = bool * float * int * string [@@deriving compare, equal, compare ~localize, equal ~localize] end module M11 = struct type t = int ref [@@deriving compare, equal, compare ~localize, equal ~localize] end module M12 = struct type t = (float * float) option [@@deriving compare, equal, compare ~localize, equal ~localize] end module M13 = struct type t = float array [@@deriving compare, equal, compare ~localize, equal ~localize] end module M14 = struct type t = (int * int) array [@@deriving compare, equal, compare ~localize, equal ~localize] end module M15 = struct type t = float array array [@@deriving compare, equal, compare ~localize, equal ~localize] end module M16 = struct type t = int list [@@deriving compare, equal, compare ~localize, equal ~localize] end module M17 = struct type t = { s : string ; b : float array list ; mutable c : int * int64 option } [@@deriving compare, equal, compare ~localize, equal ~localize] end module M18 = struct type t = { a : float ; b : float ; c : float } [@@deriving compare, equal, compare ~localize, equal ~localize] end module M19 = struct type t = Foo [@@deriving compare, equal, compare ~localize, equal ~localize] end module M20 = struct type t = Foo of int [@@deriving compare, equal, compare ~localize, equal ~localize] end module M21 = struct type t = Foo of int * float [@@deriving compare, equal, compare ~localize, equal ~localize] end module M22 = struct type t = | Foo | Bar of int | Baz of string option [@@deriving compare, equal, compare ~localize, equal ~localize] end module M23 = struct type t = [ `Foo | `Bar of string * string ] [@@deriving compare, equal, compare ~localize, equal ~localize] end module M24 = struct type t = int * string * [ `Foo | `Bar ] [@@deriving compare, equal, compare ~localize, equal ~localize] end module M25 = struct (* no local comparison for String.t, only for string, so we don't test that *) type t = String.t [@@deriving compare, equal] end module type M26_sig = sig type 'a t [@@deriving_inline compare, equal, compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t include Ppx_compare_lib.Comparable.S_local1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S1 with type 'a t := 'a t include Ppx_compare_lib.Equal.S_local1 with type 'a t := 'a t end [@@ocaml.doc "@inline"] [@@@end] end module M26 = struct type 'a t = 'a array [@@deriving compare, equal, compare ~localize, equal ~localize] end module MyList = struct type 'a t = | Nil | Node of 'a * 'a t [@@deriving compare, equal, compare ~localize, equal ~localize] end module M27 = struct type t = int [@@deriving compare, equal, compare ~localize, equal ~localize] module Inner = struct type nonrec t = t list [@@deriving compare, equal, compare ~localize, equal ~localize] let _ = ((compare : int list -> int list -> int) : t -> t -> int) end end module M28 = struct (* making sure that nobody is reversing the type parameters *) type ('a, 'b) t = ('a * 'b) list [@@deriving compare, equal, compare ~localize, equal ~localize] let (_ : (int, float) t -> int) = [%compare: (int, float) t] [ 1, nan ] end module M29 = struct type t = | A of { a : float ; b : float ; c : float } | B of float * float * float [@@deriving compare, equal, compare ~localize, equal ~localize] end module M30 = struct type ('a, 'b) t = | A of { a : 'a ; b : 'b ; c : float } | B of 'a * 'b [@@deriving compare, equal, compare ~localize, equal ~localize] end module type Polyrec_sig = sig type ('a, 'b) t = T of ('a option, 'b) t [@@deriving_inline compare, equal] include sig [@@@ocaml.warning "-32"] include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t include Ppx_compare_lib.Equal.S2 with type ('a, 'b) t := ('a, 'b) t end [@@ocaml.doc "@inline"] [@@@end] type ('a, 'b) t1 = T of ('a option, 'b) t2 and ('a, 'b) t2 = | T1 of ('a list, 'b) t1 | T2 of ('a, 'b list) t2 [@@deriving_inline compare, equal] include sig [@@@ocaml.warning "-32"] val compare_t1 : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t1 -> ('a, 'b) t1 -> int val compare_t2 : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a, 'b) t2 -> ('a, 'b) t2 -> int val equal_t1 : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t1 -> ('a, 'b) t1 -> bool val equal_t2 : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t2 -> ('a, 'b) t2 -> bool end [@@ocaml.doc "@inline"] [@@@end] end module Polyrec = struct type ('a, 'b) t = T of ('a option, 'b) t [@@deriving compare, equal, compare ~localize, equal ~localize] type ('a, 'b) t1 = T of ('a option, 'b) t2 and ('a, 'b) t2 = | T1 of ('a list, 'b) t1 | T2 of ('a, 'b list) t2 [@@deriving compare, equal, compare ~localize, equal ~localize] end module type Variance_sig = sig type +'a t [@@deriving compare, equal, compare ~localize, equal ~localize] end module Variance = struct type -'a t [@@deriving compare, equal, compare ~localize, equal ~localize] type (-'a, +'b) u = 'a t * 'b [@@deriving compare, equal, compare ~localize, equal ~localize] end module Test = struct let ( = ) : int -> int -> bool = Base.Poly.( = ) (* checking that for the types mentioned in the readme, we compare structurally *) let%test _ = [%compare: unit option] None (Some ()) = Base.Poly.compare None (Some ()) let%test _ = [%compare: unit list] [] [ () ] = Base.Poly.compare [] [ () ] let%test _ = [%compare: int array] [| 0; 1 |] [| 1 |] = Base.Poly.compare [| 0; 1 |] [| 1 |] ;; let%test _ = Base.Poly.( = ) (List.sort [%compare: int option] [ Some 3; None; Some 2; Some 1 ]) [ None; Some 1; Some 2; Some 3 ] ;; end module Variant_inclusion = struct type 'a type1 = [ `T1 of 'a ] [@@deriving compare, equal, compare ~localize, equal ~localize] type 'a type2 = [ 'a type1 | `T2 ] [@@deriving compare, equal, compare ~localize, equal ~localize] type 'a type3 = [ `T3 | 'a type1 ] [@@deriving compare, equal, compare ~localize, equal ~localize] type 'a type4 = [ 'a type2 | `T4 | 'a type3 ] [@@deriving compare, equal, compare ~localize, equal ~localize] type 'a id = 'a [@@deriving compare, equal, compare ~localize, equal ~localize] type ('a, 'b) u = [ `u of 'a * 'b ] [@@deriving compare, equal, compare ~localize, equal ~localize] type t = [ | (int, int) u ] [@@deriving compare, equal, compare ~localize, equal ~localize] end module Equal = struct let%test _ = [%compare.equal: int list] [ 7; 8; 9 ] [ 7; 8; 9 ] let%test _ = not ([%compare.equal: int list] [ 7; 8 ] [ 7; 8; 9 ]) let%test _ = match [%compare: int * int] (1, 2) (1, 3) with | -1 -> true | _ -> false ;; let%test _ = match [%compare: int * int] (1, 3) (1, 2) with | 1 -> true | _ -> false ;; let%test _ = [%compare.equal: string option] None None let%test _ = not ([%compare.equal: string option] (Some "foo") None) let%test _ = [%compare.equal: string] "hello" "hello" let%test _ = not ([%compare.equal: string] "hello" "goodbye") end module Equal_local = struct let%test _ = [%compare_local.equal: int list] [ 7; 8; 9 ] [ 7; 8; 9 ] let%test _ = not ([%compare_local.equal: int list] [ 7; 8 ] [ 7; 8; 9 ]) let%test _ = match [%compare_local: int * int] (1, 2) (1, 3) with | -1 -> true | _ -> false ;; let%test _ = match [%compare_local: int * int] (1, 3) (1, 2) with | 1 -> true | _ -> false ;; let%test _ = [%compare_local.equal: string option] None None let%test _ = not ([%compare_local.equal: string option] (Some "foo") None) let%test _ = [%compare_local.equal: string] "hello" "hello" let%test _ = not ([%compare_local.equal: string] "hello" "goodbye") end module Type_extensions : sig (* Making sure we don't generate [_ t -> _ t -> int], as that's too general. *) module type S = sig type 'a t val compare : [%compare: _ t] val equal : [%compare.equal: _ t] val compare__local : [%compare_local: _ t] val equal__local : [%compare_local.equal: _ t] end end = struct module type S = sig type 'a t val compare : 'a t -> 'a t -> int val equal : 'a t -> 'a t -> bool val compare__local : 'a t -> 'a t -> int val equal__local : 'a t -> 'a t -> bool end end module Ignoring_field = struct type t = { a : int [@ignore] ; b : int ; c : int } [@@deriving_inline compare, equal] let _ = fun (_ : t) -> () let compare = (fun a__1375_ b__1376_ -> if Stdlib.( == ) a__1375_ b__1376_ then 0 else ( match compare_int a__1375_.b b__1376_.b with | 0 -> compare_int a__1375_.c b__1376_.c | n -> n) : t -> t -> int) ;; let _ = compare let equal = (fun a__1377_ b__1378_ -> if Stdlib.( == ) a__1377_ b__1378_ then true else Stdlib.( && ) (equal_int a__1377_.b b__1378_.b) (equal_int a__1377_.c b__1378_.c) : t -> t -> bool) ;; let _ = equal [@@@deriving.end] let equal = [%compare.equal: t] end module Ignoring_inline = struct type t = int * int * int let compare = [%compare: _ * (int[@ignore]) * int] let _ = compare let equal = [%compare.equal: t] let%test _ = equal (0, 1, 2) (9, 1, 2) let%test _ = equal (0, 1, 2) (0, 9, 2) let%test _ = not (equal (0, 1, 2) (0, 1, 9)) end module Ignoring = struct type t = { a : (int[@ignore]) * string } [@@deriving_inline compare, equal] let _ = fun (_ : t) -> () let compare = (fun a__1395_ b__1396_ -> if Stdlib.( == ) a__1395_ b__1396_ then 0 else ( let t__1397_, t__1398_ = a__1395_.a in let t__1399_, t__1400_ = b__1396_.a in match let (_ : _) = t__1397_ and (_ : _) = t__1399_ in 0 with | 0 -> compare_string t__1398_ t__1400_ | n -> n) : t -> t -> int) ;; let _ = compare let equal = (fun a__1401_ b__1402_ -> if Stdlib.( == ) a__1401_ b__1402_ then true else ( let t__1403_, t__1404_ = a__1401_.a in let t__1405_, t__1406_ = b__1402_.a in Stdlib.( && ) (let (_ : _) = t__1403_ and (_ : _) = t__1405_ in true) (equal_string t__1404_ t__1406_)) : t -> t -> bool) ;; let _ = equal [@@@deriving.end] let%test _ = equal { a = 1, "hi" } { a = 2, "hi" } let%test _ = not (equal { a = 1, "hi" } { a = 1, "ho" }) end module Ignoring_with_type = struct type t = { a : int ; b : (int[@compare.ignore]) } [@@deriving_inline compare] let _ = fun (_ : t) -> () let compare = (fun a__1407_ b__1408_ -> if Stdlib.( == ) a__1407_ b__1408_ then 0 else ( match compare_int a__1407_.a b__1408_.a with | 0 -> let (_ : _) = a__1407_.b and (_ : _) = b__1408_.b in 0 | n -> n) : t -> t -> int) ;; let _ = compare [@@@deriving.end] end module Enum_optim = struct type t = | A | B | C [@@deriving_inline compare, equal] let _ = fun (_ : t) -> () let compare = (Stdlib.compare : t -> t -> int) let _ = compare let equal = (Stdlib.( = ) : t -> t -> bool) let _ = equal [@@@deriving.end] end module Lazy_behavior = struct (* Test that the generated functions don't evaluate more than necessary *) type a = unit let equal_a () () = assert false let equal_a__local () () = assert false let compare_a () () = assert false let compare_a__local () () = assert false type b = int * a [@@deriving compare, equal, compare ~localize, equal ~localize] let%test _ = not (equal_b (0, ()) (1, ())) let%test _ = Base.Poly.( < ) (compare_b (0, ()) (1, ())) 0 end module Not_ieee_compliant = struct type t = float [@@deriving compare, equal, compare ~localize, equal ~localize] let%test _ = [%equal: t] nan nan let%test _ = Base.Poly.( = ) ([%compare: t] nan nan) 0 end module Wildcard : sig type _ transparent = int [@@deriving compare, equal, compare ~localize, equal ~localize] type _ opaque [@@deriving compare, equal, compare ~localize, equal ~localize] end = struct type _ transparent = int [@@deriving compare, equal, compare ~localize, equal ~localize] let%test _ = [%equal: string transparent] 1 1 let%test _ = not ([%equal: string transparent] 1 2) let%test _ = Base.Poly.( < ) ([%compare: string transparent] 1 2) 0 let%test _ = Base.Poly.( = ) ([%compare: string transparent] 1 1) 0 let%test _ = Base.Poly.( > ) ([%compare: string transparent] 2 1) 0 type 'a opaque = 'a option [@@deriving compare, equal, compare ~localize, equal ~localize] let%test _ = [%equal: int opaque] (Some 1) (Some 1) let%test _ = not ([%equal: int opaque] None (Some 1)) let%test _ = not ([%equal: int opaque] (Some 1) (Some 2)) let%test _ = Base.Poly.( < ) ([%compare: int opaque] None (Some 1)) 0 let%test _ = Base.Poly.( = ) ([%compare: int opaque] (Some 1) (Some 1)) 0 let%test _ = Base.Poly.( > ) ([%compare: int opaque] (Some 2) (Some 1)) 0 end module Local_with_aliased_comparisons : sig type t = | Int of int | Add of t * t | Sub of t * t [@@deriving_inline compare ~localize, equal ~localize] include sig [@@@ocaml.warning "-32"] include Ppx_compare_lib.Comparable.S with type t := t include Ppx_compare_lib.Comparable.S_local with type t := t include Ppx_compare_lib.Equal.S with type t := t include Ppx_compare_lib.Equal.S_local with type t := t end [@@ocaml.doc "@inline"] [@@@end] end = struct type t = | Int of int | Add of t * t | Sub of t * t [@@deriving_inline compare ~localize, equal ~localize] let _ = fun (_ : t) -> () let rec compare__local = (fun a__1541_ b__1542_ -> if Stdlib.( == ) a__1541_ b__1542_ then 0 else ( match a__1541_, b__1542_ with | Int _a__1543_, Int _b__1544_ -> compare_int__local _a__1543_ _b__1544_ | Int _, _ -> -1 | _, Int _ -> 1 | Add (_a__1545_, _a__1547_), Add (_b__1546_, _b__1548_) -> (match compare__local _a__1545_ _b__1546_ with | 0 -> compare__local _a__1547_ _b__1548_ | n -> n) | Add _, _ -> -1 | _, Add _ -> 1 | Sub (_a__1549_, _a__1551_), Sub (_b__1550_, _b__1552_) -> (match compare__local _a__1549_ _b__1550_ with | 0 -> compare__local _a__1551_ _b__1552_ | n -> n)) : t -> t -> int) ;; let _ = compare__local let compare = (fun a b -> compare__local a b : t -> t -> int) let _ = compare let rec equal__local = (fun a__1553_ b__1554_ -> if Stdlib.( == ) a__1553_ b__1554_ then true else ( match a__1553_, b__1554_ with | Int _a__1555_, Int _b__1556_ -> equal_int__local _a__1555_ _b__1556_ | Int _, _ -> false | _, Int _ -> false | Add (_a__1557_, _a__1559_), Add (_b__1558_, _b__1560_) -> Stdlib.( && ) (equal__local _a__1557_ _b__1558_) (equal__local _a__1559_ _b__1560_) | Add _, _ -> false | _, Add _ -> false | Sub (_a__1561_, _a__1563_), Sub (_b__1562_, _b__1564_) -> Stdlib.( && ) (equal__local _a__1561_ _b__1562_) (equal__local _a__1563_ _b__1564_)) : t -> t -> bool) ;; let _ = equal__local let equal = (fun a b -> equal__local a b : t -> t -> bool) let _ = equal [@@@end] end