pax_global_header00006660000000000000000000000064135645304060014520gustar00rootroot0000000000000052 comment=9661335e6c9d48bf9a9c31e11af611be858f7f91 ppx_compare-0.13.0/000077500000000000000000000000001356453040600141165ustar00rootroot00000000000000ppx_compare-0.13.0/.gitignore000066400000000000000000000000411356453040600161010ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_compare-0.13.0/CHANGES.md000066400000000000000000000012261356453040600155110ustar00rootroot00000000000000## 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.13.0/CONTRIBUTING.md000066400000000000000000000044101356453040600163460ustar00rootroot00000000000000This 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.13.0/LICENSE.md000066400000000000000000000021351356453040600155230ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2019 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.13.0/Makefile000066400000000000000000000004031356453040600155530ustar00rootroot00000000000000INSTALL_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.13.0/README.md000066400000000000000000000114221356453040600153750ustar00rootroot00000000000000ppx_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). 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 prefered 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] ``` ppx_compare-0.13.0/dune000066400000000000000000000000001356453040600147620ustar00rootroot00000000000000ppx_compare-0.13.0/dune-project000066400000000000000000000000171356453040600164360ustar00rootroot00000000000000(lang dune 1.5)ppx_compare-0.13.0/expander/000077500000000000000000000000001356453040600157245ustar00rootroot00000000000000ppx_compare-0.13.0/expander/dune000066400000000000000000000002651356453040600166050ustar00rootroot00000000000000(library (name ppx_compare_expander) (public_name ppx_compare.expander) (libraries base ppxlib) (ppx_runtime_libraries ppx_compare.runtime-lib) (preprocess (pps ppxlib.metaquot)))ppx_compare-0.13.0/expander/ppx_compare_expander.ml000066400000000000000000000420201356453040600224570ustar00rootroot00000000000000(* 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 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 Ppx_compare_lib.polymorphic_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 Ppx_compare_lib.(&&) [%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 Ppx_compare_lib.polymorphic_equal [%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 ~tys 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 tys ~f:(fun t -> gen_symbol ~prefix:"t" (), t) in let pattern = let l = List.map names_types ~f:(fun (n, _) -> pvar ~loc n) in ppat_tuple ~loc l 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 Ppx_compare_lib.phys_equal [%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_ ~loc ty = [%type: [%t ty] -> [%t ty] -> [%t result_type ~loc]] let function_name = function | "t" -> name | s -> name ^ "_" ^ s let compare_ignore ~loc value1 value2 = [%expr let _ = [%e value1] and _ = [%e value2] in [%e const ~loc Equal]] let rec compare_applied ~constructor ~args value1 value2 = let args = List.map args ~f:(compare_of_ty_fun ~type_constraint:false) @ [value1; value2] in type_constr_conv ~loc:(Located.loc constructor) constructor args ~f:function_name and compare_of_tuple loc tys value1 value2 = with_tuple loc ~value:value1 ~tys (fun elems1 -> with_tuple loc ~value:value2 ~tys (fun elems2 -> let exprs = List.map2_exn elems1 elems2 ~f:(fun (v1, t) (v2, _) -> compare_of_ty t v1 v2) in chain_if ~loc exprs)) and compare_variant loc row_fields value1 value2 = let map = fun 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 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 ~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 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 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 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 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 begin (* the compiler will optimize the polymorphic comparison to an integer one *) poly ~loc value1 value2 end else begin let mcs = branches_of_sum cds in let e = pexp_match ~loc (pexp_tuple ~loc [value1; value2]) mcs in phys_equal_first value1 value2 e end and compare_of_ty ty value1 value2 = let loc = ty.ptyp_loc in if core_type_is_ignored ty then compare_ignore ~loc value1 value2 else match ty.ptyp_desc with | Ptyp_constr (constructor, args) -> compare_applied ~constructor ~args value1 value2 | Ptyp_tuple tys -> compare_of_tuple loc 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 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 ~type_constraint ty = let loc = ty.ptyp_loc 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 eta_reduce_if_possible [%expr fun [%p mk_pat a] [%p mk_pat b] -> [%e compare_of_ty ty e_a e_b] ] and compare_of_record_no_phys_equal 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 ld.pld_type (pexp_field ~loc value1 label) (pexp_field ~loc value2 label)) |> chain_if ~loc let compare_of_record loc lds value1 value2 = compare_of_record_no_phys_equal 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 td = let loc = td.ptype_loc in let type_ = combinator_type_of_type_declaration td ~f:type_ 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 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 loc cds v_a v_b | Ptype_record lds -> compare_of_record 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 loc row_fields v_a v_b | _ -> compare_of_ty 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 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 td)) ~expr:body else value_binding ~loc ~pat:bnd ~expr:(pexp_constraint ~loc body (scheme_of_td td)) let str_type_decl ~loc ~path:_ (rec_flag, tds) = 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 let bindings = List.map tds ~f:(compare_of_td ~rec_flag) in [ pstr_value ~loc rec_flag bindings ] let sig_type_decl ~loc:_ ~path:_ (_rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in List.map tds ~f:(fun td -> let compare_of = combinator_type_of_type_declaration td ~f:type_ in let name = function_name 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:[])) let compare_core_type ty = compare_of_ty_fun ~type_constraint:true ty let core_type = compare_core_type end module Compare = struct include Make(Compare_params) let equal_core_type ty = let loc = ty.ptyp_loc in let arg1 = gen_symbol () in let arg2 = gen_symbol () in [%expr (fun [%p pvar ~loc arg1] [%p pvar ~loc arg2] -> match [%e compare_core_type ty] [%e evar ~loc arg1] [%e evar ~loc arg2] with | 0 -> true | _ -> false ) ] end module Equal = Make(Equal_params) ppx_compare-0.13.0/expander/ppx_compare_expander.mli000066400000000000000000000004521356453040600226330ustar00rootroot00000000000000open Ppxlib module type S = Ppx_compare_expander_intf.S module Compare : sig include S (** [equal_core_type ty] is an expression of type [ty -> ty -> bool], using the comparison function generated by [core_type] *) val equal_core_type : core_type -> expression end module Equal : S ppx_compare-0.13.0/expander/ppx_compare_expander_intf.ml000066400000000000000000000014331356453040600235020ustar00rootroot00000000000000open 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_ ty] is [ty -> ty -> result_type] where [result_type] is [int] for [compare] and [bool] for [equal]. *) val type_ : loc:Location.t -> core_type -> core_type (** [core_type ty] is an expression of type [ty -> ty -> result_type] *) val core_type : core_type -> expression val str_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure val sig_type_decl : loc:Location.t -> path:string -> rec_flag * type_declaration list -> signature module Attrs : Attrs val str_attributes : Attribute.packed list end ppx_compare-0.13.0/ppx_compare.opam000066400000000000000000000013161356453040600173120ustar00rootroot00000000000000opam-version: "2.0" version: "v0.13.0" maintainer: "opensource@janestreet.com" 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" {>= "4.04.2"} "base" {>= "v0.13" & < "v0.14"} "dune" {>= "1.5.1"} "ppxlib" {>= "0.9.0"} ] synopsis: "Generation of comparison functions from types" description: " Part of the Jane Street's PPX rewriters collection. " ppx_compare-0.13.0/runtime-lib/000077500000000000000000000000001356453040600163455ustar00rootroot00000000000000ppx_compare-0.13.0/runtime-lib/dune000066400000000000000000000001661356453040600172260ustar00rootroot00000000000000(library (name ppx_compare_lib) (public_name ppx_compare.runtime-lib) (libraries base) (preprocess no_preprocessing))ppx_compare-0.13.0/runtime-lib/ppx_compare_lib.ml000066400000000000000000000000701356453040600220370ustar00rootroot00000000000000include Base.Exported_for_specific_uses.Ppx_compare_lib ppx_compare-0.13.0/src/000077500000000000000000000000001356453040600147055ustar00rootroot00000000000000ppx_compare-0.13.0/src/dune000066400000000000000000000002261356453040600155630ustar00rootroot00000000000000(library (name ppx_compare) (public_name ppx_compare) (kind ppx_deriver) (libraries base ppxlib ppx_compare_expander) (preprocess no_preprocessing))ppx_compare-0.13.0/src/ppx_compare.ml000066400000000000000000000030521356453040600175540ustar00rootroot00000000000000open Base open Ppxlib open Ppx_compare_expander let add_deriver name (module E : Ppx_compare_expander.S) = let str_type_decl = Deriving.Generator.make_noarg E.str_type_decl ~attributes:E.str_attributes in let sig_type_decl = Deriving.Generator.make_noarg 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 () = List.iter [ "compare" , Compare.type_ , Compare.core_type ; "equal" , Equal.type_ , Equal.core_type ; "@compare.equal" , Equal.type_ , Compare.equal_core_type ] ~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_ ~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.13.0/src/ppx_compare.mli000066400000000000000000000000751356453040600177270ustar00rootroot00000000000000open Ppxlib val compare : Deriving.t val equal : Deriving.t ppx_compare-0.13.0/test/000077500000000000000000000000001356453040600150755ustar00rootroot00000000000000ppx_compare-0.13.0/test/check_optims.ml000066400000000000000000000027201356453040600201000ustar00rootroot00000000000000open Ppx_compare_lib type enum = A | B | C module Compare = struct let optim_bool : bool compare = polymorphic_compare let optim_char : char compare = polymorphic_compare let optim_float : float compare = polymorphic_compare let optim_int : int compare = polymorphic_compare let optim_int32 : int32 compare = polymorphic_compare let optim_int64 : int64 compare = polymorphic_compare let optim_nativeint : nativeint compare = polymorphic_compare let optim_string : string compare = polymorphic_compare let optim_unit : unit compare = polymorphic_compare let optim_enum : enum compare = polymorphic_compare end module Equal = struct let optim_bool : bool equal = polymorphic_equal let optim_char : char equal = polymorphic_equal let optim_float : float equal = polymorphic_equal let optim_int : int equal = polymorphic_equal let optim_int32 : int32 equal = polymorphic_equal let optim_nativeint : nativeint equal = polymorphic_equal let optim_string : string equal = polymorphic_equal let optim_unit : unit equal = polymorphic_equal let optim_enum : enum equal = polymorphic_equal let optim_int64 = if Sys.word_size = 32 then (* On 32bits, polymmorphic comparison of int64 values is not specialized *) (fun _ _ -> false) else (polymorphic_equal : int64 equal) end ppx_compare-0.13.0/test/compare_test.mlt000066400000000000000000000003461356453040600203030ustar00rootroot00000000000000open 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.13.0/test/dune000066400000000000000000000004541356453040600157560ustar00rootroot00000000000000(library (name comparelib_test) (preprocess (pps ppxlib ppx_compare ppx_inline_test))) (alias (name DEFAULT) (deps test.ml.pp)) (alias (name runtest) (deps comparelib_test__Check_optims.o) (action (bash "objdump -t comparelib_test__Check_optims.o | { ! grep -Eq 'caml_(compare|equal)'; }")))ppx_compare-0.13.0/test/errors.mlt000066400000000000000000000011761356453040600171340ustar00rootroot00000000000000open 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.13.0/test/test.ml000066400000000000000000000237001356453040600164100ustar00rootroot00000000000000open 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 M1 = struct type t = unit [@@deriving compare, equal] end module M2 = struct type t = int [@@deriving compare, equal] end module M3 = struct type t = bool [@@deriving compare, equal] end module M4 = struct type t = int32 [@@deriving compare, equal] end module M5 = struct type t = nativeint [@@deriving compare, equal] end module M6 = struct type t = int64 [@@deriving compare, equal] end module M7 = struct type t = float [@@deriving compare, equal] end module M8 = struct type t = bool * float [@@deriving compare, equal] end module M9 = struct type t = bool * float * int [@@deriving compare, equal] end module M10 = struct type t = bool * float * int * string [@@deriving compare, equal] end module M11 = struct type t = int ref [@@deriving compare, equal] end module M12 = struct type t = (float * float) option [@@deriving compare, equal] end module M13 = struct type t = float array [@@deriving compare, equal] end module M14 = struct type t = (int * int) array [@@deriving compare, equal] end module M15 = struct type t = float array array [@@deriving compare, equal] end module M16 = struct type t = int list [@@deriving compare, equal] end module M17 = struct type t = { s : string; b : float array list; mutable c : (int * int64 option); } [@@deriving compare, equal] end module M18 = struct type t = { a : float; b : float; c : float; } [@@deriving compare, equal] end module M19 = struct type t = Foo [@@deriving compare, equal] end module M20 = struct type t = Foo of int [@@deriving compare, equal] end module M21 = struct type t = Foo of int * float [@@deriving compare, equal] end module M22 = struct type t = Foo | Bar of int | Baz of string option [@@deriving compare, equal] end module M23 = struct type t = [`Foo | `Bar of string * string] [@@deriving compare, equal] end module M24 = struct type t = int * string * [`Foo | `Bar ] [@@deriving compare, equal] end module M25 = struct type t = String.t [@@deriving compare, equal] end module M26 = struct type 'a t = 'a array [@@deriving compare, equal] end module MyList = struct type 'a t = Nil | Node of 'a * 'a t [@@deriving compare, equal] end module M27 = struct type t = int [@@deriving compare, equal] module Inner = struct type nonrec t = t list [@@deriving compare, equal] 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] 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] end module M30 = struct type ('a, 'b) t = A of { a : 'a; b : 'b; c : float; } | B of 'a * 'b [@@deriving compare, equal] end module Polyrec = struct type ('a, 'b) t = T of ('a option, 'b) t [@@deriving compare, equal] 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] end module type Variance_sig = sig type +'a t [@@deriving compare, equal] end module Variance = struct type -'a t [@@deriving compare, equal] type (-'a, +'b) u = 'a t * 'b [@@deriving compare, equal] 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] type 'a type2 = [ 'a type1 | `T2 ] [@@deriving compare, equal] type 'a type3 = [ `T3 | 'a type1 ] [@@deriving compare, equal] type 'a type4 = [ 'a type2 | `T4 | 'a type3 ] [@@deriving compare, equal] type 'a id = 'a [@@deriving compare, equal] type ('a, 'b) u = [`u of 'a * 'b] [@@deriving compare, equal] type t = [ | (int, int) u ] [@@deriving compare, equal] 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 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] end end = struct module type S = sig type 'a t val compare : 'a t -> 'a t -> int val equal : '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__589_ -> fun b__590_ -> if Ppx_compare_lib.phys_equal a__589_ b__590_ then 0 else (match compare_int a__589_.b b__590_.b with | 0 -> compare_int a__589_.c b__590_.c | n -> n) : t -> t -> int) let _ = compare let equal = (fun a__591_ -> fun b__592_ -> if Ppx_compare_lib.phys_equal a__591_ b__592_ then true else Ppx_compare_lib.(&&) (equal_int a__591_.b b__592_.b) (equal_int a__591_.c b__592_.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__609_ -> fun b__610_ -> if Ppx_compare_lib.phys_equal a__609_ b__610_ then 0 else (let (t__611_, t__612_) = a__609_.a in let (t__613_, t__614_) = b__610_.a in match let _ = t__611_ and _ = t__613_ in 0 with | 0 -> compare_string t__612_ t__614_ | n -> n) : t -> t -> int) let _ = compare let equal = (fun a__615_ -> fun b__616_ -> if Ppx_compare_lib.phys_equal a__615_ b__616_ then true else (let (t__617_, t__618_) = a__615_.a in let (t__619_, t__620_) = b__616_.a in Ppx_compare_lib.(&&) (let _ = t__617_ and _ = t__619_ in true) (equal_string t__618_ t__620_)) : 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 Enum_optim = struct type t = A | B | C [@@deriving_inline compare, equal] let _ = fun (_ : t) -> () let compare = (Ppx_compare_lib.polymorphic_compare : t -> t -> int) let _ = compare let equal = (Ppx_compare_lib.polymorphic_equal : 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 compare_a () () = assert false type b = int * a [@@deriving compare, equal] 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] 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] type _ opaque [@@deriving compare, equal] end = struct type _ transparent = int [@@deriving compare, equal] 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] 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