pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=6f34f2a4b7a35c26ff7edef1296959cc658bb5f1 ppx_hash-0.16.0/000077500000000000000000000000001442175067100134175ustar00rootroot00000000000000ppx_hash-0.16.0/.gitignore000066400000000000000000000000411442175067100154020ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_hash-0.16.0/CHANGES.md000066400000000000000000000007371442175067100150200ustar00rootroot00000000000000## v0.10 - Fixed `[@@deriving hash]` on nested tuples - Added `@compare.ignore` record-field attribute; `ppx_compare` and `ppx_hash` skip record fields annotated with `@compare.ignore`. - Changed `[@@deriving hash]` and `[%hash]` on atomic types to use `hash` rather than `hash_fold`. E.g. `[%hash: M.t]` now expands to `M.hash`. - Renamed `@hash.no_hashing` to `@hash.ignore`. - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and ppx\_metaquot. ppx_hash-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100156470ustar00rootroot00000000000000This 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_hash-0.16.0/LICENSE.md000066400000000000000000000021461442175067100150260ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 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_hash-0.16.0/Makefile000066400000000000000000000004031442175067100150540ustar00rootroot00000000000000INSTALL_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_hash-0.16.0/README.md000066400000000000000000000046771442175067100147140ustar00rootroot00000000000000ppx_hash ======== A ppx writer that generates hash functions from type expressions and definitions. Syntax ------ Type definitions: `[@@deriving hash]` Expressions: `[%hash_fold: TYPE]` and `[%hash: TYPE]` Types, record fields: `[@hash.ignore]` Basic usage ----------- ```ocaml type t = { s : string; x : (int * bool) list; } [@@deriving hash] ``` This will generate a function `hash_fold_t : Hash.state -> t -> Hash.state`. Where `Hash` is `Ppx_hash_lib.Std.Hash`. The generated function follows the structure of the type; allowing user overrides at every level. This is in contrast to ocaml's builtin polymorphic hashing `Hashtbl.hash` which ignores user overrides. Also generated is a direct hash-function `hash : t -> Hash.hash_value`. This function will be named `hash_` when != "t". The direct hash function is the one suitable for `Hashable.Make`. Signature --------- In a module signature, `type t [@@deriving hash]` will add both `hash_fold_t` and `hash` (or `hash_`) to the signature. Hashing without a type definition --------------------------------- A folding hash function is accessed/created as `[%hash_fold: TYPE]`. A direct hash function is accessed/created as `[%hash: TYPE]`. Ignoring part of types ---------------------- Types can be annotated with `[@hash.ignore]` so that they are not incorporated into the computed hash value. ```ocaml type second_only = (string [@hash.ignore]) * int [@@deriving hash] ``` Mutable records fields must have such an annotation. ```ocaml type t = { mutable s : string [@hash.ignore]; x : (int * bool) list; } [@@deriving hash] ``` Special support for `ppx_compare` --------------------------------- The annotation `[@compare.ignore]` (and `[@ignore]`) implies `[@hash.ignore]`, in order to preserve the invariant that `compare x y = 0` implies `hash x = hash y`. Adapting code to `ppx_hash` --------------------------- So long as all types in support hashing, the following common pattern: ```ocaml module T = struct type t = [@@deriving compare, sexp] let hash = Hashtbl.hash end include T include Hashable.Make (T) ``` Can this be written as: ```ocaml module T = struct type t = [@@deriving compare, hash, sexp] end include T include Hashable.Make (T) ``` More information ---------------- ppx/ppx_hash/doc/design.notes ppx/ppx_hash/runtime-lib/make_std.ml ppx_hash-0.16.0/doc/000077500000000000000000000000001442175067100141645ustar00rootroot00000000000000ppx_hash-0.16.0/doc/design.notes000066400000000000000000000152331442175067100165130ustar00rootroot00000000000000 Design for [ppx_hash] syntax extension: (1) [@@deriving hash] From: type t = ... [@@deriving hash] Generate a folding-style function. [hash_fold_t] : [Hash.state -> t -> Hash.state] And generate a direct-style function. [hash] : [t -> Hash.hash_value] (named [hash_] when != "t") where [Hash] is [Ppx_hash_lib.Std.Hash]. The folding-style function [hash_fold_] function is compositional, following the structure of the type; allowing user overrides at every level. This is in contrast to ocaml's builtin polymorphic hashing [Hashtbl.hash] which ignores user overrides. The direct-style function is a wrapper around the folding-style function, and is not used in a compositional way. [hash_fold_t state x] is supposed to disturb the [state] by mixing in all the information present in [x]. It should not discard [state]. To have collision resistance, it should expand to different sequences of built-in mixing functions for different values of [x]. No such sequence is allowed to be a prefix of another. We also support the inline syntax extensions [%hash_fold: TYPE] and [%hash: TYPE] (2) [Hash.state], [Hash.hash_value], [Hash.seed] The [ppx_hash] extension is not tied to any specific hash-function, with the generated code making no assumptions over the detail of these types. These types are defined by the specific hash-function selected as [Ppx_hash_lib.Std.Hash] We have conservatively selected to use the builtin hash-function defined internally in ocaml - which we refer to as "internalhash" - (but used in a compositional way). This hash-function has: [type seed = int] [type hash_value = int] [Hash.state] is abstract, but is an immediate value, so avoiding allocation issues. (3) User interface: Normally hashing is performed with the generated direct-style hash function: hash x Alternatively, the generated folding-style function can be run with [Hash.run]: (In addition, this allows a non-default seed to be passed.) Hash.run ?seed hash_fold_t x Or we can use the syntax extensions: [%hash: T] x Hash.run ?seed [%hash_fold: T] x (4) Code generation: The generated code follows the structure of the type. For leaf types, (in these examples [a], [b] and [c]), the generated function expects the corresponding hash_fold function ([hash_fold_a], [hash_fold_b] and [hash_fold_c]) to be in scope, accompanying the types in scope. Tuples: type t1 = a * b * c [@@deriving hash] let hash_fold_t1 : Hash.t -> t1 -> Hash.t = fun hsv -> fun arg -> let (e0,e1,e2) = arg in hash_fold_c (hash_fold_b (hash_fold_a hsv e0) e1) e2 Records: type t2 = {a: a; b: b; c: c;} [@@deriving hash] let hash_fold_t2 : Hash.t -> t2 -> Hash.t = fun hsv -> fun arg -> hash_fold_c (hash_fold_b (hash_fold_a hsv arg.a) arg.b) arg.c For variants, we also take account of (the position of) the variant tag: type t3 = Foo | Bar of a | Qaz of b * c [@@deriving hash] let hash_fold_t3 : Hash.t -> t3 -> Hash.t = fun hsv -> fun arg -> match arg with | Foo -> Hash.fold_int hsv 0 | Bar a0 -> hash_fold_a (Hash.fold_int hsv 1) a0 | Qaz (a0,a1) -> hash_fold_c (hash_fold_b (Hash.fold_int hsv 2) a0) a1 For polymorphic-variants, we use the ocaml hash value of the polymorphic-variant tag, returned by [Btype.hash_variant]: type t4 = [ `Foo of a | `Bar ] [@@deriving hash] let hash_fold_t4 : Hash.t -> t4 -> Hash.t = fun hsv -> fun arg -> match arg with | `Foo _v -> hash_fold_a (Hash.fold_int hsv 3505894) _v | `Bar -> Hash.fold_int hsv 3303859 For parametrised types we generate a hash function parametrised over the hash function for the element type (nothing new here). type 'a t5 = ('a * 'a) list [@@deriving hash] let hash_fold_t5 : 'a . (Hash.t -> 'a -> Hash.t) -> Hash.t -> 'a t5 -> Hash.t = fun _hash_fold_a -> fun hsv -> fun arg -> hash_fold_list (fun hsv -> fun arg -> let (e0,e1) = arg in _hash_fold_a (_hash_fold_a hsv e0) e1) hsv arg (5) Special support for record fields: Record fields can be annotated with [@hash.ignore] so that they are not incorporated into the computed hash value. In the case of mutable fields, there must be such an annotation. type t = { mutable s : string; [@hash.ignore] i : int; } [@@deriving hash] let hash_fold_t : Hash.t -> t -> Hash.t = fun hsv -> fun arg -> hash_fold_int hsv arg.i (6) Support for builtins: We do nothing special for built-in types such as [int] or [float], or build-in type constructors such as [list] and [option]. We just expect the corresponding [hash_fold_] functions to be in scope. This is the same approach as taken by sexp-conv, but different from ppx_compare, which does treat built-in types & constructors specially, leading to buggy behaviour when those names are redefined. A runtime library defines the hash functions for the built-in types & constructors, and is put in scope by [open Core] as is done for built-in sexp converters. type 'a folder = Hash.t -> 'a -> Hash.t val hash_fold_nativeint : nativeint folder val hash_fold_int64 : int64 folder val hash_fold_int32 : int32 folder val hash_fold_char : char folder val hash_fold_int : int folder val hash_fold_bool : bool folder val hash_fold_string : string folder val hash_fold_float : float folder val hash_fold_unit : unit folder val hash_fold_option : 'a folder -> 'a option folder val hash_fold_list : 'a folder -> 'a list folder val hash_fold_lazy_t : 'a folder -> 'a lazy_t folder (7) Array/Ref: Hash support for [array] and [ref] is not provided directly, because of the danger when hashing mutable values: the computed hash changes when the value mutates. Instead we provide [.._frozen] type aliases, with the corresponding [hash_fold_] function. type 'a ref_frozen = 'a ref type 'a array_frozen = 'a array val hash_fold_ref_frozen : 'a folder -> 'a ref folder val hash_fold_array_frozen : 'a folder -> 'a array folder These are not safe if the ref/array value hashed is mutated. (8) [lazy_t]: We avoid the bug in ocaml's internal function on [lazy_t] values, by defining: let hash_fold_lazy_t hash_fold_elem s x = hash_fold_elem s (Lazy.force x) (9) GADTs: GADTs are not explicitly supported. Some examples will be fine, but examples with existential types wont work and will generate ill-typed code. We make no attempt to distinguish the cases. ppx_hash-0.16.0/dune000066400000000000000000000000001442175067100142630ustar00rootroot00000000000000ppx_hash-0.16.0/dune-project000066400000000000000000000000201442175067100157310ustar00rootroot00000000000000(lang dune 1.10)ppx_hash-0.16.0/expander/000077500000000000000000000000001442175067100152255ustar00rootroot00000000000000ppx_hash-0.16.0/expander/dune000066400000000000000000000003271442175067100161050ustar00rootroot00000000000000(library (name ppx_hash_expander) (public_name ppx_hash.expander) (ppx_runtime_libraries ppx_hash.runtime-lib) (libraries ppx_compare.expander base ppxlib compiler-libs.common) (preprocess (pps ppxlib.metaquot)))ppx_hash-0.16.0/expander/ppx_hash_expander.ml000066400000000000000000000477141442175067100212740ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default module Attrs = struct let ignore_label_declaration = Attribute.declare "hash.ignore" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; let ignore_core_type = Attribute.declare "hash.ignore" Attribute.Context.core_type Ast_pattern.(pstr nil) () ;; let no_hashing_label_declaration = Attribute.declare "hash.no_hashing" Attribute.Context.label_declaration Ast_pattern.(pstr nil) () ;; end let str_attributes = [ Attribute.T Attrs.ignore_core_type ; Attribute.T Attrs.ignore_label_declaration ; Attribute.T Attrs.no_hashing_label_declaration ] ;; let is_ignored_gen attrs t = List.exists attrs ~f:(fun attr -> Option.is_some (Attribute.get attr t)) ;; let core_type_is_ignored ct = is_ignored_gen [ Attrs.ignore_core_type; Ppx_compare_expander.Compare.Attrs.ignore_core_type ] ct ;; let should_ignore_label_declaration ld = let warning = "[@hash.no_hashing] is deprecated. Use [@hash.ignore]." in let is_ignored = is_ignored_gen [ Attrs.ignore_label_declaration ; Ppx_compare_expander.Compare.Attrs.ignore_label_declaration ] ld (* Avoid confusing errors with [ { mutable field : (value[@ignore]) } ] vs [ { mutable field : value [@ignore] } ] by treating them the same. *) || core_type_is_ignored ld.pld_type in match Attribute.get Attrs.no_hashing_label_declaration ld with | None -> (if is_ignored then `ignore else `incorporate), None | Some () -> `ignore, Some (attribute_of_warning ld.pld_loc warning) ;; (* Generate code to compute hash values of type [t] in folding style, following the structure of the type. Incorporate all structure when computing hash values, to maximise hash quality. Don't attempt to detect/avoid cycles - just loop. *) let hash_state_t ~loc = [%type: Ppx_hash_lib.Std.Hash.state] let hash_fold_type ~loc ty = let loc = { loc with loc_ghost = true } in [%type: [%t hash_state_t ~loc] -> [%t ty] -> [%t hash_state_t ~loc]] ;; let hash_type ~loc ty = let loc = { loc with loc_ghost = true } in [%type: [%t ty] -> Ppx_hash_lib.Std.Hash.hash_value] ;; (* [expr] is an expression that doesn't use the [hsv] variable. Currently it's there only for documentation value, but conceptually it can be thought of as an abstract type *) type expr = expression (* Represents an expression that produces a hash value and uses the variable [hsv] in a linear way (mixes it in exactly once). You can think of it as a body of a function of type [Hash.state -> Hash.state] *) module Hsv_expr : sig type t val identity : loc:location -> t val invoke_hash_fold_t : loc:location -> hash_fold_t:expr -> t:expr -> t val compose : loc:location -> t -> t -> t val compile_error : loc:location -> string -> t (** the [_unchecked] functions all break abstraction in some way *) val of_expression_unchecked : expr -> t (** the returned [expression] uses the binding [hsv] bound by [pattern] *) val to_expression : loc:location -> t -> pattern * expression (* [case] is binding a variable that's not [hsv] and uses [hsv] on the rhs exactly once *) type case val compile_error_case : loc:location -> string -> case val pexp_match : loc:location -> expr -> case list -> t (* [lhs] should not bind [hsv] *) val case : lhs:pattern -> guard:expr option -> rhs:t -> case (* [value_binding]s should not bind or use [hsv] *) val pexp_let : loc:location -> rec_flag -> value_binding list -> t -> t val with_attributes : f:(attribute list -> attribute list) -> t -> t end = struct type t = expression type nonrec case = case let invoke_hash_fold_t ~loc ~hash_fold_t ~t = eapply ~loc hash_fold_t [ [%expr hsv]; t ] let identity ~loc = [%expr hsv] let compose ~loc a b = [%expr let hsv = [%e a] in [%e b]] ;; let to_expression ~loc x = [%pat? hsv], x let of_expression_unchecked x = x let pexp_match = pexp_match let case = case let pexp_let = pexp_let let with_attributes ~f x = { x with pexp_attributes = f x.pexp_attributes } let compile_error ~loc s = pexp_extension ~loc (Location.Error.to_extension (Location.Error.createf ~loc "%s" s)) ;; let compile_error_case ~loc s = case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(compile_error ~loc s) ;; end let hash_fold_int ~loc i : Hsv_expr.t = Hsv_expr.invoke_hash_fold_t ~loc ~hash_fold_t:[%expr Ppx_hash_lib.Std.Hash.fold_int] ~t:(eint ~loc i) ;; let special_case_types_named_t = function | `hash_fold -> false | `hash -> true ;; let hash_fold_ tn = match tn with | "t" when special_case_types_named_t `hash_fold -> "hash_fold" | _ -> "hash_fold_" ^ tn ;; let hash_ tn = match tn with | "t" when special_case_types_named_t `hash -> "hash" | _ -> "hash_" ^ tn ;; (** renames [x] avoiding collision with [type_name] *) let rigid_type_var ~type_name x = let prefix = "rigid_" in if String.equal x type_name || String.is_prefix x ~prefix then prefix ^ x ^ "_of_type_" ^ type_name else x ;; let make_type_rigid ~type_name = let map = object inherit Ast_traverse.map as super method! core_type ty = let ptyp_desc = let () = (* making sure [type_name] is the only free type variable *) match ty.ptyp_desc with | Ptyp_constr (name, _args) -> (match name.txt with | Ldot _ | Lapply _ -> () | Lident name -> if not (String.equal name type_name) then Location.raise_errorf ~loc:ty.ptyp_loc "ppx_hash: make_type_rigid: unexpected type %S. expected to only \ find %S" (string_of_core_type ty) type_name; ()) | _ -> () in match ty.ptyp_desc with | Ptyp_var s -> Ptyp_constr (Located.lident ~loc:ty.ptyp_loc (rigid_type_var ~type_name s), []) | desc -> super#core_type_desc desc in { ty with ptyp_desc } end in map#core_type ;; (* The only names we assume to be in scope are [hash_fold_] So we are sure [tp_name] (which start with an [_]) will not capture them. *) let tp_name n = Printf.sprintf "_hash_fold_%s" n let with_tuple loc (value : expr) xs (f : (expr * core_type) list -> Hsv_expr.t) : Hsv_expr.t = let names = List.mapi ~f:(fun i t -> Printf.sprintf "e%d" i, t) xs in let pattern = let l = List.map ~f:(fun (n, _) -> pvar ~loc n) names in ppat_tuple ~loc l in let e = f (List.map ~f:(fun (n, t) -> evar ~loc n, t) names) in let binding = value_binding ~loc ~pat:pattern ~expr:value in Hsv_expr.pexp_let ~loc Nonrecursive [ binding ] e ;; let hash_ignore ~loc value = Hsv_expr.pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:[%pat? _] ~expr:value ] (Hsv_expr.identity ~loc) ;; let ghostify_located (t : 'a loc) : 'a loc = { t with loc = { t.loc with loc_ghost = true } } ;; let rec hash_applied ty value = let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (name, ta) -> let args = List.map ta ~f:(hash_fold_of_ty_fun ~type_constraint:false) in Hsv_expr.invoke_hash_fold_t ~loc ~hash_fold_t:(type_constr_conv ~loc name ~f:hash_fold_ args) ~t:value | _ -> assert false and hash_fold_of_tuple ~loc tys value = with_tuple loc value tys (fun elems1 -> List.fold_right elems1 ~init:(Hsv_expr.identity ~loc) ~f:(fun (v, t) (result : Hsv_expr.t) -> Hsv_expr.compose ~loc (hash_fold_of_ty t v) result)) and hash_variant ~loc row_fields value = let map row = match row.prf_desc with | Rtag ({ txt = cnstr; _ }, true, _) | Rtag ({ txt = cnstr; _ }, _, []) -> Hsv_expr.case ~guard:None ~lhs:(ppat_variant ~loc cnstr None) ~rhs:(hash_fold_int ~loc (Ocaml_common.Btype.hash_variant cnstr)) | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> let v = "_v" in let body = Hsv_expr.compose ~loc (hash_fold_int ~loc (Ocaml_common.Btype.hash_variant cnstr)) (hash_fold_of_ty tp (evar ~loc v)) in Hsv_expr.case ~guard:None ~lhs:(ppat_variant ~loc cnstr (Some (pvar ~loc v))) ~rhs:body | Rinherit ({ ptyp_desc = Ptyp_constr (id, _); _ } as ty) -> (* Generated code from.. type 'a id = 'a [@@deriving hash] type t = [ `a | [ `b ] id ] [@@deriving hash] doesn't compile: Also see the "sadly" note in: ppx_compare_expander.ml *) let v = "_v" in Hsv_expr.case ~guard:None ~lhs:(ppat_alias ~loc (ppat_type ~loc (ghostify_located id)) (Located.mk ~loc v)) ~rhs:(hash_applied ty (evar ~loc v)) | Rinherit ty -> let s = string_of_core_type ty in Hsv_expr.compile_error_case ~loc (Printf.sprintf "ppx_hash: impossible variant case: %s" s) in Hsv_expr.pexp_match ~loc value (List.map ~f:map row_fields) and branch_of_sum hsv ~loc cd = match cd.pcd_args with | Pcstr_tuple [] -> let pcnstr = pconstruct cd None in Hsv_expr.case ~guard:None ~lhs:pcnstr ~rhs:hsv | Pcstr_tuple tps -> let ids_ty = List.mapi tps ~f:(fun i ty -> Printf.sprintf "_a%d" i, ty) in let lpatt = List.map ids_ty ~f:(fun (l, _ty) -> pvar ~loc l) |> ppat_tuple ~loc and body = List.fold_left ids_ty ~init:(Hsv_expr.identity ~loc) ~f:(fun expr (l, ty) -> Hsv_expr.compose ~loc expr (hash_fold_of_ty ty (evar ~loc l))) in Hsv_expr.case ~guard:None ~lhs:(pconstruct cd (Some lpatt)) ~rhs:(Hsv_expr.compose ~loc hsv body) | Pcstr_record lds -> let arg = "_ir" in let pat = pvar ~loc arg in let v = evar ~loc arg in let body = hash_fold_of_record ~loc lds v in Hsv_expr.case ~guard:None ~lhs:(pconstruct cd (Some pat)) ~rhs:(Hsv_expr.compose ~loc hsv body) and branches_of_sum = function | [ cd ] -> (* this is an optimization: we don't need to mix in the constructor tag if the type only has one constructor *) let loc = cd.pcd_loc in [ branch_of_sum (Hsv_expr.identity ~loc) ~loc cd ] | cds -> List.mapi cds ~f:(fun i cd -> let loc = cd.pcd_loc in let hsv = hash_fold_int ~loc i in branch_of_sum hsv ~loc cd) and hash_sum ~loc cds value = Hsv_expr.pexp_match ~loc value (branches_of_sum cds) and hash_fold_of_ty ty value = let loc = { ty.ptyp_loc with loc_ghost = true } in if core_type_is_ignored ty then hash_ignore ~loc value else ( match ty.ptyp_desc with | Ptyp_constr _ -> hash_applied ty value | Ptyp_tuple tys -> hash_fold_of_tuple ~loc tys value | Ptyp_var name -> Hsv_expr.invoke_hash_fold_t ~loc ~hash_fold_t:(evar ~loc (tp_name name)) ~t:value | Ptyp_arrow _ -> Hsv_expr.compile_error ~loc "ppx_hash: functions can not be hashed." | Ptyp_variant (row_fields, Closed, _) -> hash_variant ~loc row_fields value | _ -> let s = string_of_core_type ty in Hsv_expr.compile_error ~loc (Printf.sprintf "ppx_hash: unsupported type: %s" s)) and hash_fold_of_ty_fun ~type_constraint ty = let loc = { ty.ptyp_loc with loc_ghost = true } in let arg = "arg" in let maybe_constrained_arg = if type_constraint then ppat_constraint ~loc (pvar ~loc arg) ty else pvar ~loc arg in let hsv_pat, hsv_expr = Hsv_expr.to_expression ~loc (hash_fold_of_ty ty (evar ~loc arg)) in eta_reduce_if_possible [%expr fun [%p hsv_pat] [%p maybe_constrained_arg] -> [%e hsv_expr]] and hash_fold_of_record ~loc lds value = let is_evar = function | { pexp_desc = Pexp_ident _; _ } -> true | _ -> false in assert (is_evar value); List.fold_left lds ~init:(Hsv_expr.identity ~loc) ~f:(fun hsv ld -> Hsv_expr.compose ~loc hsv (let loc = ld.pld_loc in let label = Located.map lident ld.pld_name in let should_ignore, should_warn = should_ignore_label_declaration ld in let field_handling = match ld.pld_mutable, should_ignore with | Mutable, `incorporate -> `error "require [@hash.ignore] or [@compare.ignore] on mutable record field" | (Mutable | Immutable), `ignore -> `ignore | Immutable, `incorporate -> `incorporate in let hsv = match field_handling with | `error s -> Hsv_expr.compile_error ~loc (Printf.sprintf "ppx_hash: %s" s) | `incorporate -> hash_fold_of_ty ld.pld_type (pexp_field ~loc value label) | `ignore -> Hsv_expr.identity ~loc in match should_warn with | None -> hsv | Some attribute -> Hsv_expr.with_attributes ~f:(fun attributes -> attribute :: attributes) hsv)) ;; let hash_fold_of_abstract ~loc type_name value = let str = Printf.sprintf "hash called on the type %s, which is abstract in an implementation." type_name in Hsv_expr.of_expression_unchecked [%expr let _ = hsv in let _ = [%e value] in failwith [%e estring ~loc str]] ;; (** this does not change behavior (keeps the expression side-effect if any), but it can make the compiler happy when the expression occurs on the rhs of an [let rec] binding. *) let eta_expand ~loc f = [%expr let func = [%e f] in fun x -> func x] ;; let recognize_simple_type ty = match ty.ptyp_desc with | Ptyp_constr (lident, []) -> Some lident | _ -> None ;; let hash_of_ty_fun ~special_case_simple_types ~type_constraint ty = let loc = { ty.ptyp_loc with loc_ghost = true } in let arg = "arg" in let maybe_constrained_arg = if type_constraint then ppat_constraint ~loc (pvar ~loc arg) ty else pvar ~loc arg in match recognize_simple_type ty with | Some lident when special_case_simple_types -> unapplied_type_constr_conv ~loc lident ~f:hash_ | _ -> let hsv_pat, hsv_expr = Hsv_expr.to_expression ~loc (hash_fold_of_ty ty (evar ~loc arg)) in [%expr fun [%p maybe_constrained_arg] -> Ppx_hash_lib.Std.Hash.get_hash_value (let [%p hsv_pat] = Ppx_hash_lib.Std.Hash.create () in [%e hsv_expr])] ;; let hash_structure_item_of_td td = let loc = td.ptype_loc in match td.ptype_params with | _ :: _ -> [] | [] -> [ (let bnd = pvar ~loc (hash_ td.ptype_name.txt) in let typ = combinator_type_of_type_declaration td ~f:hash_type in let pat = ppat_constraint ~loc bnd typ in let expected_scope, expr = let is_simple_type ty = match recognize_simple_type ty with | Some _ -> true | None -> false in match td.ptype_kind, td.ptype_manifest with | Ptype_abstract, Some ty when is_simple_type ty -> ( `uses_rhs , hash_of_ty_fun ~special_case_simple_types:true ~type_constraint:false ty ) | _ -> ( `uses_hash_fold_t_being_defined , hash_of_ty_fun ~special_case_simple_types:false ~type_constraint:false { ptyp_loc = loc ; ptyp_loc_stack = [] ; ptyp_attributes = [] ; ptyp_desc = Ptyp_constr ({ loc; txt = Lident td.ptype_name.txt }, []) } ) in expected_scope, value_binding ~loc ~pat ~expr:(eta_expand ~loc expr)) ] ;; let hash_fold_structure_item_of_td td ~rec_flag = let loc = { td.ptype_loc with loc_ghost = true } in let arg = "arg" in let body = let v = evar ~loc arg in match td.ptype_kind with | Ptype_variant cds -> hash_sum ~loc cds v | Ptype_record lds -> hash_fold_of_record ~loc lds v | Ptype_open -> Hsv_expr.compile_error ~loc "ppx_hash: open types are not supported" | Ptype_abstract -> (match td.ptype_manifest with | None -> hash_fold_of_abstract ~loc td.ptype_name.txt v | Some ty -> (match ty.ptyp_desc with | Ptyp_variant (_, Open, _) | Ptyp_variant (_, Closed, Some (_ :: _)) -> Hsv_expr.compile_error ~loc:ty.ptyp_loc "ppx_hash: cannot hash open polymorphic variant types" | Ptyp_variant (row_fields, _, _) -> hash_variant ~loc row_fields v | _ -> hash_fold_of_ty ty v)) in let vars = List.map td.ptype_params ~f:(fun p -> get_type_param_name p) in let extra_names = List.map vars ~f:(fun x -> tp_name x.txt) in let hsv_pat, hsv_expr = Hsv_expr.to_expression ~loc body in let patts = List.map extra_names ~f:(pvar ~loc) @ [ hsv_pat; pvar ~loc arg ] in let bnd = pvar ~loc (hash_fold_ td.ptype_name.txt) in let scheme = combinator_type_of_type_declaration td ~f:hash_fold_type in let pat = ppat_constraint ~loc bnd (ptyp_poly ~loc vars scheme) in let expr = eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts hsv_expr) in let use_rigid_variables = match td.ptype_kind with | Ptype_variant _ -> true | _ -> false in let expr = if use_rigid_variables then ( let type_name = td.ptype_name.txt in List.fold_right vars ~f:(fun s -> pexp_newtype ~loc { txt = rigid_type_var ~type_name s.txt; loc = s.loc }) ~init:(pexp_constraint ~loc expr (make_type_rigid ~type_name scheme))) else expr in value_binding ~loc ~pat ~expr ;; let pstr_value ~loc rec_flag bindings = match bindings with | [] -> [] | nonempty_bindings -> (* [pstr_value] with zero bindings is invalid *) [ pstr_value ~loc rec_flag nonempty_bindings ] ;; 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 = match fst (should_ignore_label_declaration ld) with | `ignore -> () | `incorporate -> super#label_declaration ld method! core_type ty = if core_type_is_ignored ty then () else super#core_type ty end) #go () in let hash_fold_bindings = List.map ~f:(hash_fold_structure_item_of_td ~rec_flag) tds in let hash_bindings = List.concat (List.map ~f:hash_structure_item_of_td tds) in match rec_flag with | Recursive -> (* if we wanted to maximize the scope hygiene here this would be, in this order: - recursive group of [hash_fold] - nonrecursive group of [hash] that are [`uses_hash_fold_t_being_defined] - recursive group of [hash] that are [`uses_rhs] but fighting the "unused rec flag" warning is just way too hard *) pstr_value ~loc Recursive (hash_fold_bindings @ List.map ~f:snd hash_bindings) | Nonrecursive -> let rely_on_hash_fold_t, use_rhs = List.partition_map hash_bindings ~f:(function | `uses_hash_fold_t_being_defined, binding -> First binding | `uses_rhs, binding -> Second binding) in pstr_value ~loc Nonrecursive (hash_fold_bindings @ use_rhs) @ pstr_value ~loc Nonrecursive rely_on_hash_fold_t ;; let mk_sig ~loc:_ ~path:_ (_rec_flag, tds) = List.concat (List.map tds ~f:(fun td -> let monomorphic = List.is_empty td.ptype_params in let definition ~f_type ~f_name = let type_ = combinator_type_of_type_declaration td ~f:f_type in let name = let tn = td.ptype_name.txt in f_name tn in let loc = td.ptype_loc in psig_value ~loc (value_description ~loc ~name:{ td.ptype_name with txt = name } ~type_ ~prim:[]) in List.concat [ [ definition ~f_type:hash_fold_type ~f_name:hash_fold_ ] ; (if monomorphic then [ definition ~f_type:hash_type ~f_name:hash_ ] else []) ])) ;; let sig_type_decl ~loc ~path (rec_flag, tds) = match mk_named_sig ~loc ~sg_name:"Ppx_hash_lib.Hashable.S" ~handle_polymorphic_variant:true tds with | Some include_info -> [ psig_include ~loc include_info ] | None -> mk_sig ~loc ~path (rec_flag, tds) ;; let hash_fold_core_type ty = hash_fold_of_ty_fun ~type_constraint:true ty let hash_core_type ty = hash_of_ty_fun ~special_case_simple_types:true ~type_constraint:true ty ;; ppx_hash-0.16.0/expander/ppx_hash_expander.mli000066400000000000000000000010771442175067100214350ustar00rootroot00000000000000open Ppxlib val hash_fold_type : loc:Location.t -> core_type -> core_type val hash_fold_core_type : core_type -> expression (** [hash_core_type ty] is an expression of type [Hash.state -> ty -> Hash.state] *) val hash_type : loc:Location.t -> core_type -> core_type val hash_core_type : core_type -> expression val str_attributes : Attribute.packed list 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 ppx_hash-0.16.0/ppx_hash.opam000066400000000000000000000015511442175067100161110ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_hash" bug-reports: "https://github.com/janestreet/ppx_hash/issues" dev-repo: "git+https://github.com/janestreet/ppx_hash.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_hash/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "base" {>= "v0.16" & < "v0.17"} "ppx_compare" {>= "v0.16" & < "v0.17"} "ppx_sexp_conv" {>= "v0.16" & < "v0.17"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "A ppx rewriter that generates hash functions from type expressions and definitions" description: " Part of the Jane Street's PPX rewriters collection. " ppx_hash-0.16.0/runtime-lib/000077500000000000000000000000001442175067100156465ustar00rootroot00000000000000ppx_hash-0.16.0/runtime-lib/bench/000077500000000000000000000000001442175067100167255ustar00rootroot00000000000000ppx_hash-0.16.0/runtime-lib/bench/bench.ml000066400000000000000000000132711442175067100203420ustar00rootroot00000000000000open Core module Hash = Base.Hash module Bench (Hash : Hash.S) = struct let%bench_module ("" [@name_suffix Hash.description]) = (module struct module Ppx_hash_lib = struct module Std = struct module Hash = Base.Hash.F (Hash) end end module Hash = Ppx_hash_lib.Std.Hash open Hash.Builtin type a = int [@@deriving hash] type b = a * float [@@deriving hash] type c = | Foo | Bar | Baz of a * b * c [@@deriving hash] type d = (int * string) list [@@deriving hash] let hash_fold_d : Ppx_hash_lib.Std.Hash.state -> d -> Ppx_hash_lib.Std.Hash.state = (*fun hsv -> fun arg ->*) hash_fold_list (fun hsv arg -> let e0, e1 = arg in hash_fold_string (hash_fold_int hsv e0) e1) ;; (*hsv arg*) let _ = Foo, Bar let a = 32 let b = 32, 42.0 let c1 = Foo let c2 = Baz (a, b, c1) let rec cn n = if n <= 1 then c1 else Baz (n, (n, float_of_int n), cn (n - 1)) let c10 = cn 10 let c100 = cn 100 let rec dn n = if n <= 0 then [] else (n, String.init n ~f:(fun i -> if i mod 2 = 0 then 'j' else 's')) :: dn (n - 1) ;; let d10 = dn 10 let d100 = dn 100 let%bench "hash_init" = Hash.alloc () let state = Hash.alloc () let run folder x = ignore (Hash.get_hash_value (folder (Hash.reset state) x)) let%bench "hash a" = run hash_fold_a a let%bench "hash b" = run hash_fold_b b let%bench "hash c__1" = run hash_fold_c c1 let%bench "hash c__2" = run hash_fold_c c2 let%bench "hash c_10" = run hash_fold_c c10 let%bench "hash c100" = run hash_fold_c c100 let%bench "hash d_10" = run hash_fold_d d10 let%bench "hash d100" = run hash_fold_d d100 let _ = c2, c10, c100, d10, d100 end) ;; end module Bench_hashtbl_hash = struct (* This module is a verbatim copy of the above, except that we use Hashtbl.hash every where. *) let%bench_module "Hashtbl.hash" = (module struct type a = int type b = a * float type c = | Foo | Bar | Baz of a * b * c type d = (int * string) list let hash_a = Hashtbl.hash let hash_b = Hashtbl.hash let hash_c = Hashtbl.hash let hash_d = Hashtbl.hash let _ = Foo, Bar let a = 32 let b = 32, 42.0 let c1 = Foo let c2 = Baz (a, b, c1) let rec cn n = if n <= 1 then c1 else Baz (n, (n, float_of_int n), cn (n - 1)) let c10 = cn 10 let c100 = cn 100 let rec dn n : d = if n <= 0 then [] else (n, String.init n ~f:(fun i -> if i mod 2 = 0 then 'j' else 's')) :: dn (n - 1) ;; let d10 = dn 10 let d100 = dn 100 let run f x = ignore (f x) let%bench "hash a" = run hash_a a let%bench "hash b" = run hash_b b let%bench "hash c__1" = run hash_c c1 let%bench "hash c__2" = run hash_c c2 let%bench "hash c_10" = run hash_c c10 let%bench "hash c100" = run hash_c c100 let%bench "hash d_10" = run hash_d d10 let%bench "hash d100" = run hash_d d100 let _ = c2, c10, c100, d10, d100 end) ;; end module Traverse_only : Hash.S = struct let description = "Traverse_only" type hash_value = int type state = unit type seed = unit let alloc () = () let reset ?seed:_ () = () let get_hash_value () = 0 let fold_int () _ = () let fold_int64 () _ = () let fold_float () _ = () let fold_string () _ = () module For_tests = struct let compare_state _ _ = 0 let state_to_string () = "()" end end (* This module enforces the rules described in ../hash_intf.ml *) module Check_initialized_correctly : Hash.S = struct let description = "Check_initialized_correctly" type hash_value = int type state = { me : int ; valid : int ref } type seed = unit let next_id = let x = ref 0 in fun () -> incr x; !x ;; let alloc () = { me = next_id (); valid = ref (next_id ()) } let reset ?seed:_ t = let me = next_id () in t.valid := me; { me; valid = t.valid } ;; let assert_valid t = assert (t.me = !(t.valid)) let change t = assert_valid t; let me = next_id () in t.valid := me; { me; valid = t.valid } ;; let get_hash_value t = let _ = change t in 0 ;; let fold_int t _ = change t let fold_int64 t _ = change t let fold_float t _ = change t let fold_string t _ = change t module For_tests = struct let compare_state a b = assert_valid a; assert_valid b; 0 ;; let state_to_string _ = "" end let should_fail f = match f () with | exception _e -> () | _ -> failwith "should have failed" ;; let%test_unit _ = should_fail (fun () -> let x = alloc () in let y = reset x in ignore (fold_int y 1); fold_int y 2) ;; let%test_unit _ = should_fail (fun () -> let x = alloc () in let y = reset x in let y2 = reset x in ignore (fold_int y 1); ignore (fold_int y2 1)) ;; let%test_unit _ = should_fail (fun () -> let x = alloc () in ignore (fold_int x 1)) ;; let%test_unit _ = should_fail (fun () -> let x = alloc () in let x = reset x in ignore (get_hash_value x); ignore (fold_int x 1)) ;; end let%bench_module "" = (module Bench (Traverse_only)) let%bench_module "" = (module Bench (Check_initialized_correctly)) let%bench_module "" = (module Bench (Base.Hash)) let%bench_module "" = (module Bench (Siphash_lib.Siphash)) let%bench_module "" = (module Bench (Ppx_hash_runtime_test.Perfect_hash)) ppx_hash-0.16.0/runtime-lib/bench/bench.out000066400000000000000000000346701442175067100205470ustar00rootroot00000000000000Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌──────────────────────────────────────────┬──────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├──────────────────────────────────────────┼──────────┼─────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash a │ 6.40ns │ │ 0.86% │ │ [bench.ml:Bench:.Internalhash] hash a │ 9.49ns │ │ 1.27% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash a │ 11.28ns │ │ 1.51% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash a │ 6.73ns │ │ 0.90% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash a │ 8.03ns │ 5.00w │ 1.08% │ │ [bench.ml:Bench:.Siphash(C)] hash a │ 20.15ns │ │ 2.70% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash a │ 745.78ns │ 120.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash a │ 26.38ns │ │ 3.54% │ └──────────────────────────────────────────┴──────────┴─────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌──────────────────────────────────────────┬────────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├──────────────────────────────────────────┼────────────┼─────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash b │ 9.13ns │ │ 0.61% │ │ [bench.ml:Bench:.Internalhash] hash b │ 17.12ns │ │ 1.14% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash b │ 18.04ns │ │ 1.20% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash b │ 17.72ns │ │ 1.17% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash b │ 30.80ns │ 13.00w │ 2.04% │ │ [bench.ml:Bench:.Siphash(C)] hash b │ 29.43ns │ │ 1.95% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash b │ 1_508.09ns │ 243.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash b │ 53.27ns │ │ 3.53% │ └──────────────────────────────────────────┴────────────┴─────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬──────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────────────────────────┼──────────┼─────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash c__1 │ 6.10ns │ │ 0.84% │ │ [bench.ml:Bench:.Internalhash] hash c__1 │ 9.15ns │ │ 1.25% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash c__1 │ 10.99ns │ │ 1.51% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash c__1 │ 6.41ns │ │ 0.88% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash c__1 │ 7.83ns │ 5.00w │ 1.07% │ │ [bench.ml:Bench:.Siphash(C)] hash c__1 │ 20.02ns │ │ 2.74% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash c__1 │ 729.84ns │ 120.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash c__1 │ 26.61ns │ │ 3.65% │ └─────────────────────────────────────────────┴──────────┴─────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬────────────┬─────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────────────────────────┼────────────┼─────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash c__2 │ 17.78ns │ │ 0.49% │ │ [bench.ml:Bench:.Internalhash] hash c__2 │ 37.97ns │ │ 1.05% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash c__2 │ 37.32ns │ │ 1.03% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash c__2 │ 29.38ns │ │ 0.81% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash c__2 │ 45.86ns │ 28.00w │ 1.27% │ │ [bench.ml:Bench:.Siphash(C)] hash c__2 │ 51.36ns │ │ 1.42% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash c__2 │ 3_614.71ns │ 603.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash c__2 │ 117.32ns │ │ 3.25% │ └─────────────────────────────────────────────┴────────────┴─────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬─────────────┬───────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────────────────────────┼─────────────┼───────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash c_10 │ 122.05ns │ │ 0.45% │ │ [bench.ml:Bench:.Internalhash] hash c_10 │ 305.74ns │ │ 1.14% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash c_10 │ 269.31ns │ │ 1.00% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash c_10 │ 210.97ns │ │ 0.78% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash c_10 │ 378.80ns │ 212.00w │ 1.41% │ │ [bench.ml:Bench:.Siphash(C)] hash c_10 │ 317.78ns │ │ 1.18% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash c_10 │ 26_887.89ns │ 4_467.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash c_10 │ 870.10ns │ │ 3.24% │ └─────────────────────────────────────────────┴─────────────┴───────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬──────────┬─────────┬──────────┬──────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ Percentage │ ├─────────────────────────────────────────────┼──────────┼─────────┼──────────┼──────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash c100 │ 1.20us │ │ │ │ 0.42% │ │ [bench.ml:Bench:.Internalhash] hash c100 │ 2.79us │ │ │ │ 0.97% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash c100 │ 2.59us │ │ │ │ 0.90% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash c100 │ 2.30us │ │ │ │ 0.80% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash c100 │ 3.85us │ 2.28kw │ │ │ 1.34% │ │ [bench.ml:Bench:.Siphash(C)] hash c100 │ 3.18us │ │ │ │ 1.11% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash c100 │ 286.44us │ 47.94kw │ 0.14w │ 0.14w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash c100 │ 9.17us │ │ │ │ 3.20% │ └─────────────────────────────────────────────┴──────────┴─────────┴──────────┴──────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬─────────────┬───────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────────────────────────┼─────────────┼───────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash d_10 │ 80.53ns │ │ 0.47% │ │ [bench.ml:Bench:.Internalhash] hash d_10 │ 196.18ns │ │ 1.14% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash d_10 │ 290.85ns │ │ 1.70% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash d_10 │ 259.83ns │ │ 1.51% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash d_10 │ 348.62ns │ 325.00w │ 2.03% │ │ [bench.ml:Bench:.Siphash(C)] hash d_10 │ 344.75ns │ │ 2.01% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash d_10 │ 17_157.77ns │ 2_883.00w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash d_10 │ 825.77ns │ │ 4.81% │ └─────────────────────────────────────────────┴─────────────┴───────────┴────────────┘ Warning: X_LIBRARY_INLINING is not set to true, benchmarks may be inaccurate. Estimated testing time 16s (8 benchmarks x 2s). Change using -quota SECS. ┌─────────────────────────────────────────────┬──────────────┬─────────┬──────────┬──────────┬────────────┐ │ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ Percentage │ ├─────────────────────────────────────────────┼──────────────┼─────────┼──────────┼──────────┼────────────┤ │ [bench.ml:Bench:.Traverse_only] hash d100 │ 746.80ns │ │ │ │ 0.13% │ │ [bench.ml:Bench:.Internalhash] hash d100 │ 3_930.53ns │ │ │ │ 0.68% │ │ [bench.ml:Bench:.Dumbhash(C,64)] hash d100 │ 4_829.49ns │ │ │ │ 0.83% │ │ [bench.ml:Bench:.Dumbhash(ML,63)] hash d100 │ 7_790.63ns │ │ │ │ 1.34% │ │ [bench.ml:Bench:.Dumbhash(ML,64)] hash d100 │ 21_027.40ns │ 25.75kw │ 0.13w │ 0.13w │ 3.63% │ │ [bench.ml:Bench:.Siphash(C)] hash d100 │ 6_596.03ns │ │ │ │ 1.14% │ │ [bench.ml:Bench:.Siphash(ML,64)] hash d100 │ 579_517.29ns │ 95.90kw │ 0.16w │ 0.16w │ 100.00% │ │ [bench.ml:Bench:.Siphash(ML,63)] hash d100 │ 22_099.60ns │ │ │ │ 3.81% │ └─────────────────────────────────────────────┴──────────────┴─────────┴──────────┴──────────┴────────────┘ ppx_hash-0.16.0/runtime-lib/bench/bench.sh000077500000000000000000000011141442175067100203400ustar00rootroot00000000000000QUOTA=2 args=(-quota "$QUOTA" "$@") ./inline_benchmarks_runner -matching "hash_init" "${args[@]}" ./inline_benchmarks_runner -matching "hash a" "${args[@]}" ./inline_benchmarks_runner -matching "hash b" "${args[@]}" ./inline_benchmarks_runner -matching "hash c__1" "${args[@]}" ./inline_benchmarks_runner -matching "hash c__2" "${args[@]}" ./inline_benchmarks_runner -matching "hash c_10" "${args[@]}" ./inline_benchmarks_runner -matching "hash c100" "${args[@]}" ./inline_benchmarks_runner -matching "hash d_10" "${args[@]}" ./inline_benchmarks_runner -matching "hash d100" "${args[@]}" ppx_hash-0.16.0/runtime-lib/bench/dune000066400000000000000000000002401442175067100175770ustar00rootroot00000000000000(library (name ppx_hash_lib_bench) (libraries core ppx_hash_lib ppx_hash_runtime_test) (preprocess (pps ppx_jane))) (alias (name DEFAULT) (deps bench.ml.pp))ppx_hash-0.16.0/runtime-lib/siphash/000077500000000000000000000000001442175067100173055ustar00rootroot00000000000000ppx_hash-0.16.0/runtime-lib/siphash/dune000066400000000000000000000001361442175067100201630ustar00rootroot00000000000000(library (name siphash_lib) (c_names siphash) (libraries base) (preprocess no_preprocessing))ppx_hash-0.16.0/runtime-lib/siphash/siphash.c000066400000000000000000000207701442175067100211160ustar00rootroot00000000000000/* This file has been modified to be used as one of our hash-folding algorithm. The reference implementation of siphash is kept in siphash.c.txt */ /* SipHash reference C implementation Copyright (c) 2012-2014 Jean-Philippe Aumasson Copyright (c) 2012-2014 Daniel J. Bernstein To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights to this software to the public domain worldwide. This software is distributed without any warranty. You should have received a copy of the CC0 Public Domain Dedication along with this software. If not, see . */ #include #include #include /* default: SipHash-2-4 */ #define cROUNDS 1 #define dROUNDS 3 #define ROTL(x, b) (uint64_t)(((x) << (b)) | ((x) >> (64 - (b)))) #define U32TO8_LE(p, v) \ (p)[0] = (uint8_t)((v)); \ (p)[1] = (uint8_t)((v) >> 8); \ (p)[2] = (uint8_t)((v) >> 16); \ (p)[3] = (uint8_t)((v) >> 24); #define U64TO8_LE(p, v) \ U32TO8_LE((p), (uint32_t)((v))); \ U32TO8_LE((p) + 4, (uint32_t)((v) >> 32)); #define U8TO64_LE(p) \ (((uint64_t)((p)[0])) | ((uint64_t)((p)[1]) << 8) | \ ((uint64_t)((p)[2]) << 16) | ((uint64_t)((p)[3]) << 24) | \ ((uint64_t)((p)[4]) << 32) | ((uint64_t)((p)[5]) << 40) | \ ((uint64_t)((p)[6]) << 48) | ((uint64_t)((p)[7]) << 56)) #define SIPROUND(h) \ do { \ h->v0 += h->v1; \ h->v1 = ROTL(h->v1, 13); \ h->v1 ^= h->v0; \ h->v0 = ROTL(h->v0, 32); \ h->v2 += h->v3; \ h->v3 = ROTL(h->v3, 16); \ h->v3 ^= h->v2; \ h->v0 += h->v3; \ h->v3 = ROTL(h->v3, 21); \ h->v3 ^= h->v0; \ h->v2 += h->v1; \ h->v1 = ROTL(h->v1, 17); \ h->v1 ^= h->v2; \ h->v2 = ROTL(h->v2, 32); \ } while (0) #define TRACE(h) \ do { \ printf(" h->v0 %08x %08x\n", (uint32_t)(h->v0 >> 32), \ (uint32_t)h->v0); \ printf(" h->v1 %08x %08x\n", (uint32_t)(h->v1 >> 32), \ (uint32_t)h->v1); \ printf(" h->v2 %08x %08x\n", (uint32_t)(h->v2 >> 32), \ (uint32_t)h->v2); \ printf(" h->v3 %08x %08x\n", (uint32_t)(h->v3 >> 32), \ (uint32_t)h->v3); \ } while (0) /* The code above this line is mostly a copy and paste from siphash reference implementation. The code below has been substantially modified. */ struct hash_state { uint64_t v0, v1, v2, v3; }; /* internal */ void siphash_fold_uint64(value state, uint64_t i) { struct hash_state * h = (struct hash_state *) state; unsigned round; h->v3 ^= i; for (round = 0; round < cROUNDS; ++round) SIPROUND(h); h->v0 ^= i; } CAMLprim value siphash_fold_int64(value st, value i) { siphash_fold_uint64(st, Int64_val(i)); return st; } CAMLprim value siphash_fold_int(value st, value i) { siphash_fold_uint64(st, Long_val(i)); return st; } /* The code has been 'borrowed' from byterun/hash.c in ocaml */ CAMLexport uint64_t caml_hash_normalize_double_to_int64(double d) { union { double d; uint64_t i64; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32_t h; uint32_t l; } i; #else struct { uint32_t l; uint32_t h; } i; #endif } u; uint32_t h, l; /* Convert to two 32-bit halves */ u.d = d; h = u.i.h; l = u.i.l; /* Normalize NaNs */ if ((h & 0x7FF00000) == 0x7FF00000 && (l | (h & 0xFFFFF)) != 0) { h = 0x7FF00000; l = 0x00000001; } /* Normalize -0 into +0 */ else if (h == 0x80000000 && l == 0) { h = 0; } u.i.h = h; u.i.l = l; return u.i64; } CAMLprim value siphash_fold_float(value st, value i) { uint64_t x = caml_hash_normalize_double_to_int64(Double_val(i)); siphash_fold_uint64(st, x); return st; } CAMLprim value siphash_fold_string(value st, value s) { const mlsize_t len = caml_string_length(s); const int left = len & 7; unsigned char * in; mlsize_t i; uint64_t w; /* The length must be mixed in before the elements to avoid a violation of the rule described by Perfect_hash. */ siphash_fold_uint64(st, ((uint64_t)len)); /* Mix by 64-bit blocks (little-endian) */ for (i = 0; i + 8 <= len; i += 8) { w = U8TO64_LE(Bp_val(s)+i); siphash_fold_uint64(st, w); } in = (uint8_t*)Bp_val(s) + i; w = ((uint64_t)len) << 56; switch (left) { case 7: w |= ((uint64_t)in[6]) << 48; /* fall through */ case 6: w |= ((uint64_t)in[5]) << 40; /* fall through */ case 5: w |= ((uint64_t)in[4]) << 32; /* fall through */ case 4: w |= ((uint64_t)in[3]) << 24; /* fall through */ case 3: w |= ((uint64_t)in[2]) << 16; /* fall through */ case 2: w |= ((uint64_t)in[1]) << 8; /* fall through */ case 1: w |= ((uint64_t)in[0]); break; case 0: break; } siphash_fold_uint64(st,w); return st; } CAMLprim value siphash_alloc () { return caml_alloc_small(sizeof(struct hash_state) / sizeof(value), Abstract_tag); } CAMLprim value siphash_reset (value st, value key) { struct hash_state * h = (struct hash_state *) (Op_val(st)); char buffer[16]; uint64_t k0, k1; unsigned i; unsigned key_len = caml_string_length(key); /* initialize the buffer */ memset(buffer, 0, 16); /* copy the first 16 chars of the key to the buffer */ for (i = 0; i < (key_len > 16 ? 16 : key_len); i++) buffer[i] = Byte_u(key,i); /* initialize k0 and k1 */ k0 = U8TO64_LE(buffer); k1 = U8TO64_LE(buffer + 8); /* Those are verbatim from siphash reference implementation.*/ /* "somepseudorandomlygeneratedbytes" */ h->v0 = 0x736f6d6570736575ULL ^ k0; h->v1 = 0x646f72616e646f6dULL ^ k1; h->v2 = 0x6c7967656e657261ULL ^ k0; h->v3 = 0x7465646279746573ULL ^ k1; /* If we switch to DOUBLE, we need to bring back the rest of siphash init code. */ return st; } /* This function destroy (that is, mixes) the content of the hash state. That means that it is not possible to stop in the middle of a hash, and ask for the current hash value, and continue to hash the rest of a structure. */ CAMLprim value siphash_get_hash_value(value st) { struct hash_state * h = (struct hash_state *) st; uint64_t b; unsigned i; /* This is the final mix step of the reference implementation of siphash, in the "non-DOUBLE" case (that is, where we get a single int64 out of the hash state). */ h->v2 ^= 0xff; for (i = 0; i < dROUNDS; ++i) SIPROUND(h); b = h->v0 ^ h->v1 ^ h->v2 ^ h->v3; /* We lose one bit of precision here. */ return Val_long(b); } CAMLprim value siphash_blit_hash_to_bytes(value st, value bytes) { struct hash_state * h = (struct hash_state *) st; uint8_t *str = (uint8_t *) (Bp_val(bytes)); U64TO8_LE(str + 0, h -> v0); U64TO8_LE(str + 8, h -> v1); U64TO8_LE(str + 16, h -> v2); U64TO8_LE(str + 24, h -> v3); return Val_long(0); } ppx_hash-0.16.0/runtime-lib/siphash/siphash.c.txt000066400000000000000000000124241442175067100217310ustar00rootroot00000000000000/* SipHash reference C implementation Copyright (c) 2012-2014 Jean-Philippe Aumasson Copyright (c) 2012-2014 Daniel J. Bernstein To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights to this software to the public domain worldwide. This software is distributed without any warranty. You should have received a copy of the CC0 Public Domain Dedication along with this software. If not, see . */ #include #include #include /* default: SipHash-2-4 */ #define cROUNDS 2 #define dROUNDS 4 #define ROTL(x, b) (uint64_t)(((x) << (b)) | ((x) >> (64 - (b)))) #define U32TO8_LE(p, v) \ (p)[0] = (uint8_t)((v)); \ (p)[1] = (uint8_t)((v) >> 8); \ (p)[2] = (uint8_t)((v) >> 16); \ (p)[3] = (uint8_t)((v) >> 24); #define U64TO8_LE(p, v) \ U32TO8_LE((p), (uint32_t)((v))); \ U32TO8_LE((p) + 4, (uint32_t)((v) >> 32)); #define U8TO64_LE(p) \ (((uint64_t)((p)[0])) | ((uint64_t)((p)[1]) << 8) | \ ((uint64_t)((p)[2]) << 16) | ((uint64_t)((p)[3]) << 24) | \ ((uint64_t)((p)[4]) << 32) | ((uint64_t)((p)[5]) << 40) | \ ((uint64_t)((p)[6]) << 48) | ((uint64_t)((p)[7]) << 56)) #define SIPROUND \ do { \ v0 += v1; \ v1 = ROTL(v1, 13); \ v1 ^= v0; \ v0 = ROTL(v0, 32); \ v2 += v3; \ v3 = ROTL(v3, 16); \ v3 ^= v2; \ v0 += v3; \ v3 = ROTL(v3, 21); \ v3 ^= v0; \ v2 += v1; \ v1 = ROTL(v1, 17); \ v1 ^= v2; \ v2 = ROTL(v2, 32); \ } while (0) #ifdef DEBUG #define TRACE \ do { \ printf("(%3d) v0 %08x %08x\n", (int)inlen, (uint32_t)(v0 >> 32), \ (uint32_t)v0); \ printf("(%3d) v1 %08x %08x\n", (int)inlen, (uint32_t)(v1 >> 32), \ (uint32_t)v1); \ printf("(%3d) v2 %08x %08x\n", (int)inlen, (uint32_t)(v2 >> 32), \ (uint32_t)v2); \ printf("(%3d) v3 %08x %08x\n", (int)inlen, (uint32_t)(v3 >> 32), \ (uint32_t)v3); \ } while (0) #else #define TRACE #endif int siphash(uint8_t *out, const uint8_t *in, uint64_t inlen, const uint8_t *k) { /* "somepseudorandomlygeneratedbytes" */ uint64_t v0 = 0x736f6d6570736575ULL; uint64_t v1 = 0x646f72616e646f6dULL; uint64_t v2 = 0x6c7967656e657261ULL; uint64_t v3 = 0x7465646279746573ULL; uint64_t b; uint64_t k0 = U8TO64_LE(k); uint64_t k1 = U8TO64_LE(k + 8); uint64_t m; int i; const uint8_t *end = in + inlen - (inlen % sizeof(uint64_t)); const int left = inlen & 7; b = ((uint64_t)inlen) << 56; v3 ^= k1; v2 ^= k0; v1 ^= k1; v0 ^= k0; #ifdef DOUBLE v1 ^= 0xee; #endif for (; in != end; in += 8) { m = U8TO64_LE(in); v3 ^= m; TRACE; for (i = 0; i < cROUNDS; ++i) SIPROUND; v0 ^= m; } switch (left) { case 7: b |= ((uint64_t)in[6]) << 48; case 6: b |= ((uint64_t)in[5]) << 40; case 5: b |= ((uint64_t)in[4]) << 32; case 4: b |= ((uint64_t)in[3]) << 24; case 3: b |= ((uint64_t)in[2]) << 16; case 2: b |= ((uint64_t)in[1]) << 8; case 1: b |= ((uint64_t)in[0]); break; case 0: break; } v3 ^= b; TRACE; for (i = 0; i < cROUNDS; ++i) SIPROUND; v0 ^= b; #ifndef DOUBLE v2 ^= 0xff; #else v2 ^= 0xee; #endif TRACE; for (i = 0; i < dROUNDS; ++i) SIPROUND; b = v0 ^ v1 ^ v2 ^ v3; U64TO8_LE(out, b); #ifdef DOUBLE v1 ^= 0xdd; TRACE; for (i = 0; i < dROUNDS; ++i) SIPROUND; b = v0 ^ v1 ^ v2 ^ v3; U64TO8_LE(out + 8, b); #endif return 0; } ppx_hash-0.16.0/runtime-lib/siphash/siphash.ml000066400000000000000000000020301442175067100212710ustar00rootroot00000000000000let description = "siphash" type state type hash_value = int type seed = string external alloc : unit -> state = "siphash_alloc" external reset_to : state -> seed -> state = "siphash_reset" [@@noalloc] external fold_int64 : state -> int64 -> state = "siphash_fold_int64" [@@noalloc] external fold_int : state -> int -> state = "siphash_fold_int" [@@noalloc] external fold_float : state -> float -> state = "siphash_fold_float" [@@noalloc] external fold_string : state -> string -> state = "siphash_fold_string" [@@noalloc] external get_hash_value : state -> hash_value = "siphash_get_hash_value" [@@noalloc] let default_seed = "the_default_seed" let reset ?(seed = default_seed) t = reset_to t seed module For_tests = struct external blit_state_to_bytes : state -> bytes -> unit = "siphash_blit_hash_to_bytes" [@@noalloc] let state_to_string state = let bytes = Bytes.create (8 * 4) in blit_state_to_bytes state bytes; Bytes.to_string bytes ;; let compare_state a b = compare (state_to_string a) (state_to_string b) end ppx_hash-0.16.0/runtime-lib/siphash/siphash.mli000066400000000000000000000014301442175067100214450ustar00rootroot00000000000000include Base.Hash.S with type seed = string and type hash_value = int (** [Siphash] uses first 16 chars of the [seed] string to initialize/reset the hash state, padding it to the right with zero bytes if it's too short. The rest of the string is discarded. *) external alloc : unit -> state = "siphash_alloc" external reset_to : state -> seed -> state = "siphash_reset" [@@noalloc] external fold_int64 : state -> int64 -> state = "siphash_fold_int64" [@@noalloc] external fold_int : state -> int -> state = "siphash_fold_int" [@@noalloc] external fold_float : state -> float -> state = "siphash_fold_float" [@@noalloc] external fold_string : state -> string -> state = "siphash_fold_string" [@@noalloc] external get_hash_value : state -> int = "siphash_get_hash_value" [@@noalloc] ppx_hash-0.16.0/runtime-lib/src/000077500000000000000000000000001442175067100164355ustar00rootroot00000000000000ppx_hash-0.16.0/runtime-lib/src/dune000066400000000000000000000001771442175067100173200ustar00rootroot00000000000000(library (name ppx_hash_lib) (public_name ppx_hash.runtime-lib) (libraries base) (preprocess (pps ppx_compare ppx_sexp_conv)))ppx_hash-0.16.0/runtime-lib/src/ppx_hash_lib.ml000066400000000000000000000000651442175067100214300ustar00rootroot00000000000000include Base.Exported_for_specific_uses.Ppx_hash_lib ppx_hash-0.16.0/runtime-lib/test/000077500000000000000000000000001442175067100166255ustar00rootroot00000000000000ppx_hash-0.16.0/runtime-lib/test/allocation.ml000066400000000000000000000056031442175067100213100ustar00rootroot00000000000000open Core let words_of_float = if Sys.word_size_in_bits = 64 then 2 else 3 let check_allocation : expect:int -> (unit -> 'a) -> 'a = fun ~expect f -> (* It costs [fudge] words of allocation to discover the allocation! *) let fudge = 18 + (3 * words_of_float) in let n0 = Int.of_float (Gc.stat ()).Gc.Stat.minor_words in let n1 = Int.of_float (Gc.stat ()).Gc.Stat.minor_words in [%test_result: Int.t] ~expect:(n0 + fudge) n1; let res = f () in let n2 = Int.of_float (Gc.stat ()).Gc.Stat.minor_words in let n = n2 - n1 - fudge in if n <> expect then failwithf "check_allocation: expect=%d, got=%d" expect n (); res ;; let check_no_allocation f = check_allocation ~expect:0 f module F (Hash : Base.Hash.S) = struct module Ppx_hash_lib = struct (* override default which is used by generated code *) module Std = struct module Hash = Base.Hash.F (Hash) end end include Ppx_hash_lib.Std open Hash.Builtin type tree = | Leaf of int | Node of tree * tree [@@deriving sexp_of, hash] let create_full ~depth = assert (depth >= 0); let rec build n d = if d = 0 then n + 1, Leaf n else ( let n, t1 = build n (d - 1) in let n, t2 = build n (d - 1) in n, Node (t1, t2)) in let _, t = build 100 depth in t ;; let the_tree = create_full ~depth:3 end module Test_alloc (X : sig module Hash : Base.Hash.S with type hash_value = int val size_of_state : int val seed1 : Hash.seed val seed2 : Hash.seed end) = struct include F (X.Hash) let%test_unit _ = let state = check_allocation ~expect:X.size_of_state (fun () -> Hash.alloc ()) in let _state = check_no_allocation (fun () -> hash_fold_tree state the_tree) in () ;; let run_seeded seed = Hash.run ~seed hash_fold_tree the_tree let%test_unit _ = assert (not (run_seeded X.seed1 = run_seeded X.seed2)) let%test_unit _ = ignore (check_allocation ~expect:X.size_of_state (fun () -> hash_tree the_tree)) ;; let mk_reentrant_folder n = let i = ref n in let rec loop state x = decr i; if !i > 0 then ignore (Hash.run loop x); let state = hash_fold_tree state x in state in Hash.run loop ;; let%test_unit _ = let n = 100 in let reentrant_folder = mk_reentrant_folder n in ignore (check_allocation ~expect:(n * X.size_of_state) (fun () -> reentrant_folder the_tree)) ;; let res1 = hash_tree the_tree let res2 = hash_tree the_tree let%test_unit "hashing is stable2" = [%test_eq: int] res1 res2 end module Test_alloc_internalhash = Test_alloc (struct module Hash = Base.Hash let size_of_state = 0 let seed1 = 1 let seed2 = 2 end) module Test_alloc_siphash = Test_alloc (struct module Hash = Siphash_lib.Siphash let size_of_state = if Sys.word_size_in_bits = 64 then 5 else 9 let seed1 = "1" let seed2 = "2" end) ppx_hash-0.16.0/runtime-lib/test/collisions.ml000066400000000000000000000112651442175067100213420ustar00rootroot00000000000000open Core module Tests (Hash : Base.Hash.S with type hash_value = int) = struct module Ppx_hash_lib = struct module Std = struct module Hash = Base.Hash.F (Hash) end end open Ppx_hash_lib.Std.Hash.Builtin let hash = `dont_use module State = struct module T = struct type t = Hash.state let compare = Hash.For_tests.compare_state let sexp_of_t s : Sexp.t = Atom (Hash.For_tests.state_to_string s) let t_of_sexp _ = assert false end include T include Comparable.Make (T) end let should_have_no_collisions list sexp_of_t hash = let m = State.Map.of_alist_multi (List.map list ~f:(fun v -> hash (Hash.reset (Hash.alloc ())) v, v)) in Map.iteri m ~f:(fun ~key:hash ~data:values -> match values with | [] -> assert false | [ _ ] -> () | _ :: _ :: _ -> failwiths ~here:[%here] "collision" (hash, values) [%sexp_of: State.t * t list]) ;; module Ints = struct let should_have_no_collisions l s f = should_have_no_collisions l s (fun s x -> hash_fold_int s (f x)) ;; (* these tests can have false positives, but those should be fixable by tweaking the [ints] list. *) let ints = [ 0 ; 1 ; 2 ; 3 ; 100 ; 500 ; (*0x1234567812345678;*) -1 ; -2 ] ;; let ( % ) a b = [%hash: int * int] (a, b) let zero = 0 (* The following tests require incrementally increasing hash function quality *) let%test_unit "simple combine2 collisions" = should_have_no_collisions (List.cartesian_product ints ints) [%sexp_of: int * int] (fun (a, b) -> a % b) ;; let%test_unit "more complicated combine2 collisions" = should_have_no_collisions (List.cartesian_product ints ints) [%sexp_of: int * int] (fun (a, b) -> a % (b % zero)) ;; let%test_unit "yet more complicated combine2s collisions" = should_have_no_collisions (List.cartesian_product ints ints) [%sexp_of: int * int] (fun (a, b) -> zero % a % (b % zero)) ;; end let hash_int x = let h = Hash.alloc () in let h = Hash.reset h in Hash.fold_int h x ;; let init () = let h = Hash.alloc () in Hash.reset h ;; let hash_string x = let h = Hash.alloc () in let h = Hash.reset h in Hash.fold_string h x ;; let ( = ) x y = Hash.For_tests.compare_state x y = 0 let assert_different hash_t a b = assert (not (hash_t a = hash_t b)) let%test_unit _ = assert_different hash_int 0 (1 lsl 32) let%test_unit _ = let a1 = String.make 7 'a' in let b = String.make 7 'b' in let a2 = String.make 7 'a' in let c = Some 5 in let a3 = String.make 7 'a' in let d = Obj.new_block Obj.abstract_tag 1 in assert (hash_string a1 = hash_string a2); assert (hash_string a1 = hash_string a3); assert (not (phys_same a1 b)); assert (not (phys_same a1 c)); assert (not (phys_same a1 d)) ;; let%test_unit _ = assert_different hash_string "\200\200\200\200" "\200a\200\200" let%test_unit _ = assert_different hash_string "\200\200\200" "\200a\200" let%test_unit "int collisions" = Map.to_alist (Int.Map.of_alist_multi (List.init 100_000 ~f:(fun i -> Hash.get_hash_value (hash_int i) land ((1 lsl 17) - 1), i))) |> List.iter ~f:(fun (_, vs) -> (* the number 10 is motivated by 0.9999 being close enough to 1 in the following R expression: ppois(10, lambda = 10^5 / 2^17) ^ (2^17) [1] 0.9999167 With enough hand-waving and invocation of Poisson limit theorem I convinced myself that poisson distribution is an OK approximation. *) [%test_pred: int] (fun x -> x <= 10) (List.length vs)) ;; let%test_unit "list collisions" = should_have_no_collisions [ []; [ [] ]; [ [ [] ] ]; [ [ [ "hello" ] ] ]; [ []; [] ] ] [%sexp_of: string list list list] [%hash_fold: string list list list] ;; type 'a array_frozen = 'a array let sexp_of_array_frozen = sexp_of_array let%test_unit "array collisions" = should_have_no_collisions [ [||]; [| [||] |]; [| [| [||] |] |]; [| [| [| "hello" |] |] |]; [| [||]; [||] |] ] [%sexp_of: string array_frozen array_frozen array_frozen] [%hash_fold: string array_frozen array_frozen array_frozen] ;; let%test_unit "string collisions" = should_have_no_collisions [ "", [ 16 lsl 56; 0 ]; String.make 8 '\000' ^ "\002" ^ String.make 7 '\000', [] ] [%sexp_of: string * int list] [%hash_fold: string * int list] ;; end module I = Tests (Base.Hash) module S = Tests (Siphash_lib.Siphash) module P = Tests (Perfect_hash) ppx_hash-0.16.0/runtime-lib/test/dune000066400000000000000000000003501442175067100175010ustar00rootroot00000000000000(library (name ppx_hash_runtime_test) (libraries ppx_hash_lib siphash_lib core core_unix.core_thread core_unix) (preprocess (pps ppx_jane))) (alias (name DEFAULT) (deps tree.ml.pp floats.ml.pp allocation.ml.pp collisions.ml.pp))ppx_hash-0.16.0/runtime-lib/test/floats.ml000066400000000000000000000036451442175067100204570ustar00rootroot00000000000000open Core let ( --> ) a b = (not a) || b let check_safety ~hash ~compare ~sexp_of_t (a, b) = let same_as_determined_by_compare = 0 = compare a b in let hash_a = hash a in let hash_b = hash b in let same_hash = 0 = Int.compare hash_a hash_b in let safe = same_as_determined_by_compare --> same_hash in if not safe then failwiths ~here:[%here] "safety violation: equal values hash differently" ((a, hash_a), (b, hash_b)) [%sexp_of: (t * Int.t) * (t * Int.t)] ;; module Labelled_float = struct type t = string * float let hash (_, f) = [%hash: float] f let compare (_, f1) (_, f2) = compare_float f1 f2 let sexp_of_t (s, f) = sexp_of_string (Printf.sprintf "(%s)%f" s f) end let f int64 float = let module Int64 = struct include Int64 let sexp_of_t t = Sexp.Atom (sprintf "%Lx" t) end in [%test_result: Int64.t] ~expect:int64 (Int64.bits_of_float float); float ;; (* the int64 values of various nan expressions are somehow architecture-specific so instead of writing down the expression we hard-code their exact representations *) let f_nan int64 = let float = Int64.float_of_bits int64 in assert (Float.is_nan float); f int64 float ;; (* hex values to make sure the floats we are testing are actually different *) let labelled () = [ "0.", f 0x0000000000000000L 0. ; "1.", f 0x3ff0000000000000L 1. ; "-0.", f 0x8000000000000000L (-0.) ; "-1.", f 0xbff0000000000000L (-1.) ; "Float.nan", f_nan 0x7ff8000000000001L ; "Float.infinity", f 0x7ff0000000000000L Float.infinity ; "-.Float.nan", f_nan 0xfff8000000000001L ; "-.Float.infinity", f 0xfff0000000000000L (-.Float.infinity) ; "0./.0.", f 0xfff8000000000000L (0. /. 0.) (* nan with a different representation *) ] ;; let%test_unit "float safety test" = let open Labelled_float in List.iter (List.cartesian_product (labelled ()) (labelled ())) ~f:(check_safety ~hash ~compare ~sexp_of_t) ;; ppx_hash-0.16.0/runtime-lib/test/perfect_hash.ml000066400000000000000000000051241442175067100216140ustar00rootroot00000000000000open Core open Poly (* This is not intended as a realistic candidate hash function since it allocates when hashing, but as some kind of `perfect' baseline against which other hash functions can be compared and judged. It is a perfect hash in the sense that it produces no collisions of intermediate state (trivially). It's also achieving about as good quality as possible in [get_hash_value] by virtue of using a (former) cryptographically secure hash function. Additionally, it tries to enforce the invariant well-behaved [hash_fold_t] functions must obey: different values of the same type must produce mix-in sequences of form (a @ [b1] @ c1) and (a @ [b2] @ c2) where b1 and b2 are "meaningfully" different (see the checks in [compare]). This requirement is a way to resolve possible systematic collisions resulting from e.g. forgetting to write down a tag of a variant, or a length of an array. It's not crazy to think about relaxing this requirement, but you can't relax it too much: you can't allow some [hash_fold_t] functions to write their tag to the end because that leads to a problem: even though [1; 2] differs from [1] in last position and [3] differs from [2; 3] in first position, ([1; 2] @ [3]) and ([1] @ [2; 3]) is a collision! *) let description = "perfect hash" type hash_value = int type v = | Int of int | Int64 of int64 | String of string | Float of float [@@deriving sexp] let compare_v a b = match a, b with | Int a, Int b -> compare a b | Int64 a, Int64 b -> compare a b | String a, String b -> compare a b | Float a, Float b -> compare a b | _, _ -> failwith "uncomparable" ;; module State = struct module T = struct type t = v list [@@deriving sexp] let rec compare a b = match a, b with | x :: xs, y :: ys -> [%compare: v * t] (x, xs) (y, ys) | [], [] -> 0 | _, _ -> failwith "perfect hashes of different lengths" ;; let compare a b = compare (List.rev a) (List.rev b) end include T include Comparable.Make (T) end type state = State.t let fold_int t i = Int i :: t let fold_int64 t i = Int64 i :: t let fold_string t i = String i :: t let fold_float t i = Float i :: t type seed = unit let alloc () = [] let reset ?seed:_ _ = [] let get_hash_value t = Stdlib.Int64.to_int (Int64.of_string ("0x" ^ String.prefix (Md5.to_hex (Md5.digest_string (Sexplib.Sexp.to_string (State.sexp_of_t t)))) 16)) ;; module For_tests = struct let state_to_string t = Sexplib.Sexp.to_string (State.sexp_of_t t) let compare_state = State.compare end ppx_hash-0.16.0/runtime-lib/test/perfect_hash.mli000066400000000000000000000003331442175067100217620ustar00rootroot00000000000000open Core module State : sig type t include Comparable.S with type t := t include Sexpable.S with type t := t end include Base.Hash.S with type hash_value = int and type seed = unit with type state = State.t ppx_hash-0.16.0/runtime-lib/test/threads.ml000066400000000000000000000021661442175067100206160ustar00rootroot00000000000000open Core module Unix = Core_unix module Thread = Core_thread module Tests (Hash : Base.Hash.S with type hash_value = int) = struct module Ppx_hash_lib = struct module Std = struct module Hash = Base.Hash.F (Hash) end end module Hash = Ppx_hash_lib.Std.Hash open Hash.Builtin let hash_fold_int s t = (* nanosleep forces threads to yield *) ignore (Unix.nanosleep 0.01); hash_fold_int s t ;; let run_in_two_threads f1 x1 f2 x2 = let res1 = ref None in let t = Thread.create (fun () -> res1 := Some (f1 x1)) ~on_uncaught_exn:`Print_to_stderr () in let res2 = f2 x2 in Thread.join t; let res1 = match !res1 with | Some x -> x | None -> assert false in res1, res2 ;; module T = struct let some_list = List.init 10 ~f:Fn.id let h () = [%hash: int list] some_list let res0 = h () let res1, res2 = run_in_two_threads h () h () let%test_unit _ = [%test_result: int] res1 ~expect:res0 let%test_unit _ = [%test_result: int] res2 ~expect:res0 end end module T1 = Tests (Base.Hash) module T2 = Tests (Siphash_lib.Siphash) ppx_hash-0.16.0/runtime-lib/test/tree.ml000066400000000000000000000017551442175067100201260ustar00rootroot00000000000000open Core (* Demonstrate the behaviour of folding-style hash functions *) type result = | Null | Elem of int | Combine of result * result [@@deriving sexp, compare] let ( % ) a b = Combine (a, b) (* Shadow the standard library *) module Ppx_hash_lib = struct module Std = struct module Hash = struct type hash_value = result type state = result let fold_int s x = Combine (s, Elem x) let get_hash_value = Fn.id type seed = unit let create ?seed:_ () = Null end module Builtin = struct let hash_fold_int = Hash.fold_int end end end open Ppx_hash_lib.Std open Builtin module Tree = struct type t = | L of int | N of t * t [@@deriving hash] end let a, b = 100, 200 let node = 1 let leaf = 0 let tree = Tree.(N (L a, L b)) let%test_unit _ = let v = Tree.hash tree in (* Note: [%] associates to the left *) [%test_result: result] v ~expect:(Null % Elem node % Elem leaf % Elem a % Elem leaf % Elem b) ;; ppx_hash-0.16.0/src/000077500000000000000000000000001442175067100142065ustar00rootroot00000000000000ppx_hash-0.16.0/src/dune000066400000000000000000000002071442175067100150630ustar00rootroot00000000000000(library (name ppx_hash) (public_name ppx_hash) (kind ppx_deriver) (libraries ppxlib ppx_hash_expander) (preprocess no_preprocessing))ppx_hash-0.16.0/src/ppx_hash.ml000066400000000000000000000017511442175067100163560ustar00rootroot00000000000000open Ppxlib let type_extension name f = Context_free.Rule.extension (Extension.declare name Core_type Ast_pattern.(ptyp __) (fun ~loc ~path:_ ty -> f ~loc ty)) ;; let () = let name = "hash_fold" in Deriving.ignore (Deriving.add name ~extension:(fun ~loc:_ ~path:_ ty -> Ppx_hash_expander.hash_fold_core_type ty)); Driver.register_transformation name ~rules:[ type_extension name Ppx_hash_expander.hash_fold_type ] ;; let () = let name = "hash" in Deriving.ignore (Deriving.add name ~str_type_decl: (Deriving.Generator.make_noarg Ppx_hash_expander.str_type_decl ~attributes:Ppx_hash_expander.str_attributes) ~sig_type_decl:(Deriving.Generator.make_noarg Ppx_hash_expander.sig_type_decl) ~extension:(fun ~loc:_ ~path:_ ty -> Ppx_hash_expander.hash_core_type ty)); Driver.register_transformation name ~rules:[ type_extension name Ppx_hash_expander.hash_type ] ;; ppx_hash-0.16.0/src/ppx_hash.mli000066400000000000000000000000551442175067100165230ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_hash-0.16.0/test/000077500000000000000000000000001442175067100143765ustar00rootroot00000000000000ppx_hash-0.16.0/test/closures.ml000066400000000000000000000102111442175067100165620ustar00rootroot00000000000000open! Base (* this no longer allocates closures. hurray! *) module T0 = struct type 'a t = 'a list [@@deriving_inline hash] let _ = fun (_ : 'a t) -> () let hash_fold_t : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state = hash_fold_list ;; let _ = hash_fold_t [@@@deriving.end] end module T1 = struct type 'a t = 'a option list [@@deriving_inline hash] let _ = fun (_ : 'a t) -> () let hash_fold_t : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> hash_fold_list (fun hsv arg -> hash_fold_option _hash_fold_a hsv arg) hsv arg ;; let _ = hash_fold_t [@@@deriving.end] end module T2 = struct type 'a t = ('a * 'a) list [@@deriving_inline hash] let _ = fun (_ : 'a t) -> () let hash_fold_t : 'a. (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> hash_fold_list (fun hsv arg -> let e0, e1 = arg in let hsv = _hash_fold_a hsv e0 in let hsv = _hash_fold_a hsv e1 in hsv) hsv arg ;; let _ = hash_fold_t [@@@deriving.end] end module T3 = struct type 'a t = | Leaf | Node of 'a t list [@@deriving_inline hash] let _ = fun (_ : 'a t) -> () let rec hash_fold_t : type a. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> match arg with | Leaf -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Node _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in hash_fold_list (fun hsv arg -> hash_fold_t _hash_fold_a hsv arg) hsv _a0 ;; let _ = hash_fold_t [@@@deriving.end] let hash_fold_t_no_closure_allocation : type a. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a -> let rec hash_fold_t_of_a hsv arg = match arg with | Leaf -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Node _a0 -> hash_fold_list hash_fold_t_of_a (Ppx_hash_lib.Std.Hash.fold_int hsv 1) _a0 in hash_fold_t_of_a ;; end module T4 = struct type 'a t = | Leaf | Node of ('a * 'a) t list [@@deriving_inline hash] let _ = fun (_ : 'a t) -> () let rec hash_fold_t : type a. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a hsv arg -> match arg with | Leaf -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Node _a0 -> let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in let hsv = hsv in hash_fold_list (fun hsv arg -> hash_fold_t (fun hsv arg -> let e0, e1 = arg in let hsv = _hash_fold_a hsv e0 in let hsv = _hash_fold_a hsv e1 in hsv) hsv arg) hsv _a0 ;; let _ = hash_fold_t [@@@deriving.end] let rec hash_fold_t_lazy_closure_allocation : type a. (Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) -> Ppx_hash_lib.Std.Hash.state -> a t -> Ppx_hash_lib.Std.Hash.state = fun _hash_fold_a -> let hash_fold_t_of_tuple = lazy (hash_fold_t_lazy_closure_allocation (fun hsv arg -> let e0, e1 = arg in _hash_fold_a (_hash_fold_a hsv e0) e1)) in fun hsv arg -> match arg with | Leaf -> Ppx_hash_lib.Std.Hash.fold_int hsv 0 | Node _a0 -> hash_fold_list (Lazy.force hash_fold_t_of_tuple) (Ppx_hash_lib.Std.Hash.fold_int hsv 1) _a0 ;; end ppx_hash-0.16.0/test/dune000066400000000000000000000003041442175067100152510ustar00rootroot00000000000000(library (name ppx_hash_test) (libraries core) (preprocess (pps ppx_jane))) (alias (name DEFAULT) (deps inline_records.ml.pp override_example.ml.pp hash_test.ml.pp record_field_control.ml.pp))ppx_hash-0.16.0/test/examples.mlt000066400000000000000000000112401442175067100167300ustar00rootroot00000000000000open Ppx_hash_lib.Std open Hash.Builtin;; #verbose true module type Interface_for_types_named_t = sig type t [@@deriving hash] end [%%expect {| module type Interface_for_types_named_t = sig type t val hash_fold_t : t Base.Exported_for_specific_uses.Ppx_hash_lib.hash_fold val hash : t -> int end |}] module type Interface_for_types_named_other_than_t = sig type my_type [@@deriving hash] end [%%expect {| module type Interface_for_types_named_other_than_t = sig type my_type val hash_fold_my_type : Base_internalhash_types.state -> my_type -> Base_internalhash_types.state val hash_my_type : my_type -> int end |}] module type Interface_for_poly_types = sig type 'a my_container [@@deriving hash] end [%%expect {| module type Interface_for_poly_types = sig type 'a my_container val hash_fold_my_container : (Base_internalhash_types.state -> 'a -> Base_internalhash_types.state) -> Base_internalhash_types.state -> 'a my_container -> Base_internalhash_types.state end |}] module type Interface_for_poly_types_with_unnamed_argument = sig type _ my_container [@@deriving hash] end [%%expect {| module type Interface_for_poly_types_with_unnamed_argument = sig type _ my_container val hash_fold_my_container : (Base_internalhash_types.state -> 'a__001_ -> Base_internalhash_types.state) -> Base_internalhash_types.state -> 'a__001_ my_container -> Base_internalhash_types.state end |}] module Use_of_hash_fold_syntax_extension = struct let f = [%hash_fold: (int * string) list] end [%%expect {| module Use_of_hash_fold_syntax_extension : sig val f : Base_internalhash_types.state -> (int * string) list -> Base_internalhash_types.state end |}] module Support_for_builtins = struct let f = [%hash_fold: (nativeint * int64 * int32 * char * int * bool * string * float * unit) option list lazy_t] ;; end [%%expect {| module Support_for_builtins : sig val f : Base_internalhash_types.state -> (nativeint * int64 * int32 * char * int * bool * string * float * unit) option list lazy_t -> Base_internalhash_types.state end |}] (* negative tests... *) module No_builtin_support_for_array = struct type fail = int array [@@deriving hash] end [%%expect {| Line _, characters _-_: Error: Unbound value hash_fold_array |}] module No_builtin_support_for_ref = struct type fail = int ref [@@deriving hash] end [%%expect {| Line _, characters _-_: Error: Unbound value hash_fold_ref Hint: Did you mean hash_fold_int? |}] type fail = int -> int [@@deriving hash] [%%expect {| Line _, characters _-_: Error: ppx_hash: functions can not be hashed. |}] type fail = < f : int > [@@deriving hash] [%%expect {| Line _, characters _-_: Error: ppx_hash: unsupported type: < f: int > |}] type fail = .. [@@deriving hash] [%%expect {| Line _, characters _-_: Error: ppx_hash: open types are not supported |}] type fail = private [> `Foo ] [@@deriving hash] [%%expect {| Line _, characters _-_: Error: ppx_hash: cannot hash open polymorphic variant types |}] type fail = { mutable u : int ; s : string } [@@deriving hash] [%%expect {| Line _, characters _-_: Error: ppx_hash: require [@hash.ignore] or [@compare.ignore] on mutable record field |}] type unhashable type ok = { mutable u : unhashable [@compare.ignore] ; s : string } [@@deriving hash] [%%expect {| type unhashable type ok = { mutable u : unhashable; s : string; } val hash_fold_ok : Base_internalhash_types.state -> ok -> Base_internalhash_types.state = val hash_ok : ok -> int = |}] type ok_nested = { u : (unhashable[@ignore]) * int ; s : string } [@@deriving hash] [%%expect {| type ok_nested = { u : unhashable * int; s : string; } val hash_fold_ok_nested : Base_internalhash_types.state -> ok_nested -> Base_internalhash_types.state = val hash_ok_nested : ok_nested -> int = |}] module type Type_extension = sig val f : [%hash_fold: 'a] -> [%hash_fold: 'a * 'a] val g : [%hash_fold: _] -> [%hash_fold: _] end [%%expect {| module type Type_extension = sig val f : (Base_internalhash_types.state -> 'a -> Base_internalhash_types.state) -> Base_internalhash_types.state -> 'a * 'a -> Base_internalhash_types.state val g : (Base_internalhash_types.state -> 'a -> Base_internalhash_types.state) -> Base_internalhash_types.state -> 'b -> Base_internalhash_types.state end |}] type warn = { foo : string [@no_hashing] } [@@deriving hash] [%%expect {| Line _, characters _-_: Error (warning 22 [preprocessor]): [@hash.no_hashing] is deprecated. Use [@hash.ignore]. |}] ppx_hash-0.16.0/test/hash_test.ml000066400000000000000000000176161442175067100167250ustar00rootroot00000000000000open Ppx_hash_lib.Std open Hash.Builtin module Check_struct_items_match_sig_items = struct module M : sig type t0 [@@deriving hash] type _ t1 [@@deriving hash] type (_, _) t2 [@@deriving hash] end = struct type t0 = int [@@deriving hash] type 'a t1 = 'a * int [@@deriving hash] type ('a, 'b) t2 = 'a * 'b * int [@@deriving hash] end end module Examples_from_design_doc = struct type a = int [@@deriving hash] type b = int [@@deriving hash] type c = int [@@deriving hash] type t1 = a * b * c [@@deriving hash] type t2 = { a : a ; b : b ; c : c } [@@deriving hash] type t3 = | Foo | Bar of a | Qaz of b * c [@@deriving hash] type t4 = [ `Foo of a | `Bar ] [@@deriving hash] type 'a t5 = ('a * 'a) list [@@deriving hash] type t6 = int * string list [@@deriving hash] type t7 = int lazy_t [@@deriving hash] end module String = struct include String let hash_fold_t = hash_fold_string let hash = hash_string end let hash = `Should_refer_to_Hashtbl_hash_explicitly type 'a array_frozen = 'a array type 'a ref_frozen = 'a ref module M1s = struct type s = unit [@@deriving hash] end module M2s = struct type s = int [@@deriving hash] end module M1 = struct type t = unit [@@deriving hash] end module M2 = struct type t = int [@@deriving hash] end module M3 = struct type t = bool [@@deriving hash] end module M4 = struct type t = int32 [@@deriving hash] end module M5 = struct type t = nativeint [@@deriving hash] end module M6 = struct type t = int64 [@@deriving hash] end module M7 = struct type t = float [@@deriving hash] end module M8 = struct type t = bool * float [@@deriving hash] end module M9 = struct type t = bool * float * int [@@deriving hash] end module M10 = struct type t = bool * float * int * string [@@deriving hash] end module M11 = struct type t = int ref_frozen [@@deriving hash] end module M12 = struct type t = (float * float) option [@@deriving hash] end module M13 = struct type t = float array_frozen [@@deriving hash] end module M14 = struct type t = (int * int) array_frozen [@@deriving hash] end module M15 = struct type t = float array_frozen array_frozen [@@deriving hash] end module M16 = struct type t = int list [@@deriving hash] end module M17 = struct type t = { s : string ; b : float array_frozen list ; mutable c : int * int64 option [@hash.ignore] } [@@deriving hash] end module M18 = struct type t = { a : float ; b : float ; c : float } [@@deriving hash] end module M19 = struct type t = Foo [@@deriving hash] end module M20 = struct type t = Foo of int [@@deriving hash] end module M21 = struct type t = Foo of int * float [@@deriving hash] end module M22 = struct type t = | Foo | Bar of int | Baz of string option [@@deriving hash] end module M23 = struct type t = [ `Foo | `Bar of string * string ] [@@deriving hash] end module M24 = struct type t = int * string * [ `Foo | `Bar ] [@@deriving hash] end module M25 = struct type t = String.t [@@deriving hash] end module M26 = struct type 'a t = 'a array_frozen [@@deriving hash] end module MyList = struct type 'a t = | Nil | Node of 'a * 'a t [@@deriving hash] end module M27 = struct type t = int [@@deriving hash] module Inner = struct type nonrec t = t list [@@deriving hash] end end module M28 = struct (* making sure that nobody is reversing the type parameters *) type ('a, 'b) t = ('a * 'b) list [@@deriving hash] let _ = [%hash_fold: (int, float) t] (Hash.create ()) [ 1, nan ] end module Polyrec = struct type ('a, 'b) t = T of ('a option, 'b) t [@@deriving hash] 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 hash] end module type Variance_sig = sig type +'a t [@@deriving hash] end module Variance = struct type -'a t [@@deriving hash] type (-'a, +'b) u = 'a t * 'b [@@deriving hash] end module Simple_variant_inclusion = struct type poly_t = [ `Foo of int | `Bar ] [@@deriving hash] type include_poly_t = [ poly_t | `Blah ] [@@deriving hash] end module Variant_inclusion = struct type 'a type1 = [ `T1 of 'a ] [@@deriving hash] type 'a type2 = [ 'a type1 | `T2 ] [@@deriving hash] type 'a type3 = [ `T3 | 'a type1 ] [@@deriving hash] type 'a type4 = [ 'a type2 | `T4 | 'a type3 ] [@@deriving hash] end module SigTU = struct module A : sig type t [@@deriving hash] type u [@@deriving hash] end = struct type t = int [@@deriving hash] type u = float [@@deriving hash] end type p = A.t * A.u [@@deriving hash] end module Gadt = struct type 'a t = | I : int -> int t | F : float -> float t | R : int t * string t -> bool t [@@deriving hash] end module Up_to_polymorphic_variant = struct type 'a t = | A : [ `A ] t | B : [ `B ] t | C : [< `A | `B ] t -> [ `C ] t | D : [< `A | `B > `A ] t -> [ `C ] t [@@deriving hash] end module Clash = struct (* Same name for type-var and type-name; must be careful when introducing rigid type names. *) type 'hey hey = Hey of 'hey [@@deriving hash] type 'hey rigid_hey = Hey of 'hey [@@deriving hash] type ('foo, 'rigid_foo) foo = Foo of 'foo [@@deriving hash] type 'rigid_bar rigid_rigid_bar = Bar [@@deriving hash] end module Ignoring = struct type a = { a : (int[@compare.ignore]) * string } [@@deriving_inline hash] let _ = fun (_ : a) -> () let (hash_fold_a : Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) = fun hsv arg -> let hsv = hsv in let e0, e1 = arg.a in let hsv = let _ = e0 in hsv in let hsv = hash_fold_string hsv e1 in hsv ;; let _ = hash_fold_a let (hash_a : a -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_a hsv arg) in fun x -> func x ;; let _ = hash_a [@@@deriving.end] type b = { b : (int[@hash.ignore]) * string } [@@deriving_inline hash] let _ = fun (_ : b) -> () let (hash_fold_b : Ppx_hash_lib.Std.Hash.state -> b -> Ppx_hash_lib.Std.Hash.state) = fun hsv arg -> let hsv = hsv in let e0, e1 = arg.b in let hsv = let _ = e0 in hsv in let hsv = hash_fold_string hsv e1 in hsv ;; let _ = hash_fold_b let (hash_b : b -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_b hsv arg) in fun x -> func x ;; let _ = hash_b [@@@deriving.end] end module Type_extension = struct let _ = ([%hash_fold: int list] : [%hash_fold: int list]) let _ = ([%hash: int list] : [%hash: int list]) end module Recursion_with_aliases = struct type a = A of c and b = a and c = b [@@deriving hash] end module Nested_tuples = struct type a = int * (string * bool) [@@deriving_inline hash] let _ = fun (_ : a) -> () let (hash_fold_a : Ppx_hash_lib.Std.Hash.state -> a -> Ppx_hash_lib.Std.Hash.state) = fun hsv arg -> let e0, e1 = arg in let hsv = hash_fold_int hsv e0 in let hsv = let e0, e1 = e1 in let hsv = hash_fold_string hsv e0 in let hsv = hash_fold_bool hsv e1 in hsv in hsv ;; let _ = hash_fold_a let (hash_a : a -> Ppx_hash_lib.Std.Hash.hash_value) = let func arg = Ppx_hash_lib.Std.Hash.get_hash_value (let hsv = Ppx_hash_lib.Std.Hash.create () in hash_fold_a hsv arg) in fun x -> func x ;; let _ = hash_a [@@@deriving.end] end module Wildcard : sig type _ transparent = int [@@deriving hash] type _ opaque [@@deriving hash] end = struct type _ transparent = int [@@deriving hash] type 'a opaque = 'a option [@@deriving hash] end ppx_hash-0.16.0/test/inline_records.ml000066400000000000000000000006641442175067100177350ustar00rootroot00000000000000open Core (* record wrapped in variant *) type r = { i : int ; s : string } [@@deriving hash] type vr = | A of r | B [@@deriving hash] let vr = A { i = 42; s = "hey" } (* inline record *) type ir = | A of { i : int ; s : string } | B [@@deriving hash] let ir = A { i = 42; s = "hey" } let%test_unit "hash unchanged by use of inline records" = [%test_eq: int] ([%hash: vr] vr) ([%hash: ir] ir) ;; ppx_hash-0.16.0/test/override_example.ml000066400000000000000000000023161442175067100202640ustar00rootroot00000000000000open Ppx_hash_lib.Std open Hash.Builtin module Barbins_example = struct module X = struct type t = int [@@deriving hash] end module Y = struct type y = int [@@deriving hash] end module Z = struct type t = int [@@deriving hash] end module Example = struct module T = struct type t = { x : X.t ; y : Y.y ; z : Z.t ; mutable cached : int option [@hash.ignore] } [@@deriving hash] end module T_type = struct type t = T.t = { x : X.t ; y : Y.y ; z : Z.t ; mutable cached : int option } end module Unmemoized = T module Memoized = struct include T_type let hash t = match t.cached with | Some x -> x | None -> let cached = T.hash t in (* dont use state *) t.cached <- Some cached; cached ;; let hash_fold_t (state : Hash.state) (t : t) = hash_fold_int state (hash t) (* use state *) end end module Client = struct (* ensure overrides are typed correctly *) type t1 = Example.Unmemoized.t [@@deriving hash] type t3 = Example.Memoized.t [@@deriving hash] end end ppx_hash-0.16.0/test/polymorphic_variants.ml000066400000000000000000000025051442175067100212060ustar00rootroot00000000000000type a = [ `A ] [@@deriving hash] type ab = [ `A | `B ] [@@deriving hash] type abc_v1 = [ ab | `C ] [@@deriving hash] type abc_v2 = [ `A | `B | `C ] [@@deriving hash] (* Check that the same polymorphic variant has the same hash regardless of which type it's in. This property is relied on internally to implement hashing of types like [abc_v1] (see above). We could potentially use this property to justify support of open polymorphic variants in the future. *) let%expect_test "`A hashes the same regardless of which type it's in" = let h1 = [%hash: a] `A in let h2 = [%hash: ab] `A in let h3 = [%hash: abc_v1] `A in let h4 = [%hash: abc_v2] `A in let h5 = [%hash: [ ab | `C ]] `A in assert (h1 = h2); assert (h2 = h3); assert (h3 = h4); assert (h4 = h5) ;; let%expect_test "Up to polymorphic variant functions behave exactly the same as fully \ bounded polymorphic variant functions" = let module H : sig val h1 : [%hash: [ `A | `B ]] val h2 : [%hash: [< `A | `B ]] val h3 : [%hash: [< `A | `B > `A ]] end = struct let h1 = [%hash: [ `A | `B ]] let h2 = [%hash: [< `A | `B ]] let h3 = [%hash: [< `A | `B > `A ]] end in let open H in assert (h1 `A = h2 `A); assert (h1 `A = h3 `A); assert (h1 `B = h2 `B); assert (h1 `B = h3 `B) ;; ppx_hash-0.16.0/test/record_field_control.ml000066400000000000000000000034101442175067100211070ustar00rootroot00000000000000open Core open Ppx_hash_lib.Std open Hash.Builtin (* Tests for record-field attributes [@hash.ignore] *) let check_hash_differently ~hash ~sexp_of_t a b = if hash a = hash b then failwithf !"fail: expect values to hash differently: %{sexp:t} -- %{sexp:t}" a b () ;; let check_hash_same ~hash ~sexp_of_t a b = if not (hash a = hash b) then failwithf !"fail: expect values to hash the same: %{sexp:t} -- %{sexp:t}" a b () ;; module No_string_field = struct type t = { i : int } [@@deriving hash, sexp_of] let v1 = { i = 42 } end module Immutable = struct type t = { s : string ; i : int } [@@deriving hash, sexp_of] let v1 = { s = "hey"; i = 42 } let v2 = { s = "ho"; i = 42 } let%test_unit _ = check_hash_differently ~hash ~sexp_of_t v1 v2 end module Immutable_hash_dot_ignore = struct type t = { s : string [@hash.ignore] ; i : int } [@@deriving hash, sexp_of] let v1 = { s = "hey"; i = 42 } let v2 = { s = "ho"; i = 42 } let%test_unit _ = check_hash_same ~hash ~sexp_of_t v1 v2 let%test_unit _ = [%test_eq: int] (hash v1) No_string_field.(hash v1) end module Mutable_hash_dot_ignore = struct type t = { mutable s : string [@hash.ignore] ; i : int } [@@deriving hash, sexp_of] let v1 = { s = "hey"; i = 42 } let v2 = { s = "ho"; i = 42 } let%test_unit _ = check_hash_same ~hash ~sexp_of_t v1 v2 let%test_unit _ = [%test_eq: int] (hash v1) No_string_field.(hash v1) end module Immutable_compare_ignore = struct type t = { s : string [@compare.ignore] ; i : int } [@@deriving hash, sexp_of] let v1 = { s = "hey"; i = 42 } let v2 = { s = "ho"; i = 42 } let%test_unit _ = check_hash_same ~hash ~sexp_of_t v1 v2 let%test_unit _ = [%test_eq: int] (hash v1) No_string_field.(hash v1) end