pax_global_header00006660000000000000000000000064136631505570014525gustar00rootroot0000000000000052 comment=82c97efc41d49616059184aaaeef0a8faf92093a ppx_bin_prot-0.14.0/000077500000000000000000000000001366315055700143125ustar00rootroot00000000000000ppx_bin_prot-0.14.0/.gitignore000066400000000000000000000000411366315055700162750ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_bin_prot-0.14.0/CHANGES.md000066400000000000000000000005151366315055700157050ustar00rootroot00000000000000## v0.11 Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver and ppx\_type\_conv. ## 113.43.00 - use the new context-free API ## 113.24.01 - Fix the META. ppx\_bin\_prot was not previously treated as a ppx\_deriving plugin, which was causing problems ## 113.24.00 - Minor changes, nothing worth mentionning. ppx_bin_prot-0.14.0/CONTRIBUTING.md000066400000000000000000000044101366315055700165420ustar00rootroot00000000000000This 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_bin_prot-0.14.0/LICENSE.md000066400000000000000000000021351366315055700157170ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2020 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_bin_prot-0.14.0/Makefile000066400000000000000000000004031366315055700157470ustar00rootroot00000000000000INSTALL_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_bin_prot-0.14.0/README.md000066400000000000000000000057751366315055700156070ustar00rootroot00000000000000ppx_bin_prot ============ Generation of binary serialization and deserialization functions from type definitions. There's more information about: - The [bin-prot format](https://github.com/janestreet/bin_prot/blob/master/README.md) - [bin-prot-shape](https://github.com/janestreet/bin_prot/blob/master/shape/README.md), which is useful for checking compatibility of the `bin_prot` representations of different types. ## A note about signatures In signatures, `ppx_bin_prot` tries to generate an include of a named interface, instead of a list of value bindings. That is: ```ocaml type 'a t [@@deriving bin_io] ``` will generate: ```ocaml include Binable.S1 with type 'a t := 'a t ``` instead of: ```ocaml val bin_t : 'a Bin_prot.Type_class.t ‑> 'a t Bin_prot.Type_class.t val bin_read_t : 'a Bin_prot.Read.reader ‑> 'a t Bin_prot.Read.reader val __bin_read_t__ : 'a Bin_prot.Read.reader ‑> (int ‑> 'a t) Bin_prot.Read.reader val bin_reader_t : 'a Bin_prot.Type_class.reader ‑> 'a t Bin_prot.Type_class.reader val bin_size_t : 'a Bin_prot.Size.sizer ‑> 'a t Bin_prot.Size.sizer val bin_write_t : 'a Bin_prot.Write.writer ‑> 'a t Bin_prot.Write.writer val bin_writer_t : 'a Bin_prot.Type_class.writer ‑> 'a t Bin_prot.Type_class.writer val bin_shape_t : Bin_prot.Shape.t ‑> Bin_prot.Shape.t ``` There are however a number of limitations: - the type has to be named t - the type can only have up to 3 parameters - there shouldn't be any constraint on the type parameters If these aren't met, then `ppx_bin_prot` will simply generate a list of value bindings. ### Weird looking type errors In some cases, a type can meet all the conditions listed above, in which case the rewriting will apply, but lead to a type error. This happens when the type `t` is an alias to a type which does have constraints on the parameters, for instance: ```ocaml type 'a s constraint 'a = [> `read ] val bin_s : ([> `read ] as 'a) Type_class.t0 -> 'a s Type_class.t0 val bin_read_s : ([> `read ] as 'a) Read.reader -> 'a s Read.reader val bin_reader_s : ([> `read ] as 'a) Type_class.reader0 -> 'a s Type_class.reader0 val bin_size_s : ([> `read ] as 'a) Size.sizer -> 'a s Size.sizer val bin_write_s : ([> `read ] as 'a) Write.writer -> 'a s Write.writer val bin_writer_s : ([> `read ] as 'a) Type_class.writer0 -> 'a s Type_class.writer0 val bin_shape_s : Shape.t -> Shape.t type 'a t = 'a s [@@deriving_inline bin_io] include Binable.S1 with type 'a t := 'a t [@@@end] ``` will give an error looking like: ``` Error: In this `with' constraint, the new definition of t does not match its original definition in the constrained signature: Type declarations do not match: type 'a t = 'a t constraint 'a = [> `read ] is not included in type 'a t File "binable.ml", line 34, characters 2-11: Expected declaration Their constraints differ. ``` To workaround that error, simply copy the constraint on the type which has the `[@@deriving]` annotation. This will force generating a list of value bindings. ppx_bin_prot-0.14.0/dune000066400000000000000000000000001366315055700151560ustar00rootroot00000000000000ppx_bin_prot-0.14.0/dune-project000066400000000000000000000000201366315055700166240ustar00rootroot00000000000000(lang dune 1.10)ppx_bin_prot-0.14.0/expect_tests/000077500000000000000000000000001366315055700170245ustar00rootroot00000000000000ppx_bin_prot-0.14.0/expect_tests/allocation_tests.ml000066400000000000000000000024621366315055700227310ustar00rootroot00000000000000open! Core_kernel open! Expect_test_helpers_core let%expect_test "No allocation when writing variants" = let module Test = struct type t = | No_arg | One_arg of string | Record_arg of { num : int } [@@deriving bin_io] end in let writer = Test.bin_writer_t in let buf = Bigstring.create 1024 in let _ : int = require_no_allocation [%here] (fun () -> writer.write buf ~pos:0 No_arg) in let one_arg = Test.One_arg "foo" in let () = [%expect {| |}] in let _ : int = require_no_allocation [%here] (fun () -> writer.write buf ~pos:0 one_arg) in let () = [%expect {| |}] in let record_arg = Test.Record_arg { num = 5 } in let _ : int = require_no_allocation [%here] (fun () -> writer.write buf ~pos:0 record_arg) in [%expect {| |}]; ;; let%expect_test "No allocation when writing polymorphic variant" = let module Test = struct type t = [ `No_arg | `One_arg of string ] [@@deriving bin_io] end in let writer = Test.bin_writer_t in let buf = Bigstring.create 1024 in let _ : int = require_no_allocation [%here] (fun () -> writer.write buf ~pos:0 `No_arg) in let one_arg = `One_arg "foo" in let () = [%expect {| |}] in let _ : int = require_no_allocation [%here] (fun () -> writer.write buf ~pos:0 one_arg) in [%expect {| |}] ;; ppx_bin_prot-0.14.0/expect_tests/dune000066400000000000000000000001711366315055700177010ustar00rootroot00000000000000(library (name ppx_bin_prot_expect_tests) (libraries core_kernel expect_test_helpers_core) (preprocess (pps ppx_jane)))ppx_bin_prot-0.14.0/expect_tests/mutually_recursive.mlt000066400000000000000000000050571366315055700235140ustar00rootroot00000000000000open Bin_prot.Std #verbose true;; module Test = struct type ('a, 'm) branch = { branch_on : 'm ; value : float ; if_lt : ('a, 'm) t' ; if_geq : ('a, 'm) t' } and ('a, 'm) t' = [ `leaf of 'a | `branch of ('a, 'm) branch ] [@@deriving bin_io] end [%%expect{| module Test : sig type ('a, 'm) branch = { branch_on : 'm; value : float; if_lt : ('a, 'm) t'; if_geq : ('a, 'm) t'; } and ('a, 'm) t' = [ `branch of ('a, 'm) branch | `leaf of 'a ] val bin_shape_branch : Bin_prot.Shape.t -> Bin_prot.Shape.t -> Bin_prot.Shape.t val bin_shape_t' : Bin_prot.Shape.t -> Bin_prot.Shape.t -> Bin_prot.Shape.t val bin_size_branch : 'a Bin_prot.Size.sizer -> 'm Bin_prot.Size.sizer -> ('a, 'm) branch Bin_prot.Size.sizer val bin_size_t' : 'a Bin_prot.Size.sizer -> 'm Bin_prot.Size.sizer -> ('a, 'm) t' Bin_prot.Size.sizer val bin_write_branch : 'a Bin_prot.Write.writer -> 'm Bin_prot.Write.writer -> ('a, 'm) branch Bin_prot.Write.writer val bin_write_t' : 'a Bin_prot.Write.writer -> 'm Bin_prot.Write.writer -> ('a, 'm) t' Bin_prot.Write.writer val bin_writer_branch : 'a Bin_prot.Type_class.writer0 -> 'b Bin_prot.Type_class.writer0 -> ('a, 'b) branch Bin_prot.Type_class.writer0 val bin_writer_t' : 'a Bin_prot.Type_class.writer0 -> 'b Bin_prot.Type_class.writer0 -> ('a, 'b) t' Bin_prot.Type_class.writer0 val __bin_read_branch__ : 'a Bin_prot.Read.reader -> 'm Bin_prot.Read.reader -> (int -> ('a, 'm) branch) Bin_prot.Read.reader val __bin_read_t'__ : 'a Bin_prot.Read.reader -> 'm Bin_prot.Read.reader -> (int -> ('a, 'm) t') Bin_prot.Read.reader val bin_read_branch : 'a Bin_prot.Read.reader -> 'm Bin_prot.Read.reader -> ('a, 'm) branch Bin_prot.Read.reader val bin_read_t' : 'a Bin_prot.Read.reader -> 'm Bin_prot.Read.reader -> ('a, 'm) t' Bin_prot.Read.reader val bin_reader_branch : 'a Bin_prot.Type_class.reader0 -> 'b Bin_prot.Type_class.reader0 -> ('a, 'b) branch Bin_prot.Type_class.reader0 val bin_reader_t' : 'a Bin_prot.Type_class.reader0 -> 'b Bin_prot.Type_class.reader0 -> ('a, 'b) t' Bin_prot.Type_class.reader0 val bin_branch : 'a Bin_prot.Type_class.t0 -> 'b Bin_prot.Type_class.t0 -> ('a, 'b) branch Bin_prot.Type_class.t0 val bin_t' : 'a Bin_prot.Type_class.t0 -> 'b Bin_prot.Type_class.t0 -> ('a, 'b) t' Bin_prot.Type_class.t0 end |}] ppx_bin_prot-0.14.0/expect_tests/polymorphic_recursion.mlt000066400000000000000000000015221366315055700242000ustar00rootroot00000000000000open Bin_prot.Std #verbose true;; module Simple = struct type 'a t = C of 'a list t * string t [@@deriving bin_io] end [%%expect{| module Simple : sig type 'a t = C of 'a list t * string t val bin_shape_t : Bin_prot.Shape.t -> Bin_prot.Shape.t val bin_size_t : 'a Bin_prot.Size.sizer -> 'a t Bin_prot.Size.sizer val bin_write_t : 'a Bin_prot.Write.writer -> 'a t Bin_prot.Write.writer val bin_writer_t : 'a Bin_prot.Type_class.writer0 -> 'a t Bin_prot.Type_class.writer0 val __bin_read_t__ : 'a Bin_prot.Read.reader -> (int -> 'a t) Bin_prot.Read.reader val bin_read_t : 'a Bin_prot.Read.reader -> 'a t Bin_prot.Read.reader val bin_reader_t : 'a Bin_prot.Type_class.reader0 -> 'a t Bin_prot.Type_class.reader0 val bin_t : 'a Bin_prot.Type_class.t0 -> 'a t Bin_prot.Type_class.t0 end |}] ppx_bin_prot-0.14.0/ppx_bin_prot.opam000066400000000000000000000014571366315055700177020ustar00rootroot00000000000000opam-version: "2.0" version: "v0.14.0" maintainer: "opensource@janestreet.com" authors: ["Jane Street Group, LLC "] homepage: "https://github.com/janestreet/ppx_bin_prot" bug-reports: "https://github.com/janestreet/ppx_bin_prot/issues" dev-repo: "git+https://github.com/janestreet/ppx_bin_prot.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_bin_prot/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.04.2"} "base" {>= "v0.14" & < "v0.15"} "bin_prot" {>= "v0.14" & < "v0.15"} "ppx_here" {>= "v0.14" & < "v0.15"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.11.0"} ] synopsis: "Generation of bin_prot readers and writers from types" description: " Part of the Jane Street's PPX rewriters collection. " ppx_bin_prot-0.14.0/shape/000077500000000000000000000000001366315055700154125ustar00rootroot00000000000000ppx_bin_prot-0.14.0/shape/example0/000077500000000000000000000000001366315055700171255ustar00rootroot00000000000000ppx_bin_prot-0.14.0/shape/example0/dune000066400000000000000000000002001366315055700177730ustar00rootroot00000000000000(library (name bin_shape_gen_example) (libraries) (preprocess (pps ppx_bin_prot))) (alias (name DEFAULT) (deps example.ml.pp))ppx_bin_prot-0.14.0/shape/example0/example.ml000066400000000000000000000012621366315055700211130ustar00rootroot00000000000000 type nonrec int = int [@@deriving bin_shape ~basetype:"int"] type nonrec float = float [@@deriving bin_shape ~basetype:"float"] type nonrec string = string [@@deriving bin_shape ~basetype:"string"] type nonrec 'a list = 'a list [@@deriving bin_shape ~basetype:"list"] module M1 = struct type t = int * float u * string list and 'a u = { foo : 'a; bar : t list } [@@deriving bin_shape] end module M2 : sig type t [@@deriving bin_shape] end = struct type t = int [@@deriving bin_shape] end module M3 = struct type t = int [@@deriving bin_shape] type u = t list [@@deriving bin_shape] type v = int list [@@deriving bin_shape] end ppx_bin_prot-0.14.0/shape/src/000077500000000000000000000000001366315055700162015ustar00rootroot00000000000000ppx_bin_prot-0.14.0/shape/src/bin_shape_expand.ml000066400000000000000000000260251366315055700220270ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default let raise_errorf ~loc fmt = Location.raise_errorf ~loc (Caml.(^^) "ppx_bin_shape: " fmt) let loc_string loc = [%expr Bin_prot.Shape.Location.of_string [%e Ppx_here_expander.lift_position_as_string ~loc]] let app_list ~loc (func:expression) (args:expression list) = [%expr [%e func] [%e elist ~loc args]] let curry_app_list ~loc (func:expression) (args:expression list) = List.fold_left args ~init:func ~f:(fun acc arg -> [%expr [%e acc] [%e arg]]) let bin_shape_ tname = "bin_shape_" ^ tname let bin_shape_lid ~loc id = unapplied_type_constr_conv ~loc id ~f:bin_shape_ let shape_tid ~loc ~(tname:string) = [%expr Bin_prot.Shape.Tid.of_string [%e estring ~loc tname]] let shape_vid ~loc ~(tvar:string) = [%expr Bin_prot.Shape.Vid.of_string [%e estring ~loc tvar]] let shape_rec_app ~loc ~(tname:string) = [%expr Bin_prot.Shape.rec_app [%e shape_tid ~loc ~tname]] let shape_top_app ~loc ~(tname:string) = [%expr Bin_prot.Shape.top_app _group [%e shape_tid ~loc ~tname]] let shape_tuple ~loc (exps:expression list) = [%expr Bin_prot.Shape.tuple [%e elist ~loc exps]] let shape_record ~loc (xs: (string * expression) list) = [%expr Bin_prot.Shape.record [%e elist ~loc ( List.map xs ~f:(fun (s,e) -> [%expr ([%e estring ~loc s], [%e e])]))]] let shape_variant ~loc (xs: (string * expression list) list) = [%expr Bin_prot.Shape.variant [%e elist ~loc ( List.map xs ~f:(fun (s,es) -> [%expr ([%e estring ~loc s], [%e elist ~loc es])]))]] let shape_poly_variant ~loc (xs: expression list) = [%expr Bin_prot.Shape.poly_variant [%e loc_string loc] [%e elist ~loc xs]] type string_literal_or_other_expression = | String_literal of string | Other_expression of expression let string_literal f s = f (String_literal s) let other_expression f e = f (Other_expression e) let shape_annotate ~loc ~name (x:expression) = let name = match name with | Other_expression e -> e | String_literal s -> [%expr Bin_prot.Shape.Uuid.of_string [%e estring ~loc s]] in [%expr Bin_prot.Shape.annotate [%e name] [%e x]] let shape_basetype ~loc ~uuid (xs:expression list) = let uuid = match uuid with | Other_expression e -> e | String_literal s -> [%expr Bin_prot.Shape.Uuid.of_string [%e estring ~loc s]] in app_list ~loc [%expr Bin_prot.Shape.basetype [%e uuid]] xs module Context : sig type t val create : type_declaration list -> t val is_local : t -> tname:string -> bool (* which names are defined in the local group *) end = struct type t = { tds : type_declaration list } let create tds = { tds } let is_local t ~tname = List.exists t.tds ~f:(fun td -> String.equal tname td.ptype_name.txt) end let of_type : ( allow_free_vars: bool -> context:Context.t -> core_type -> expression ) = fun ~allow_free_vars ~context -> let rec traverse_row ~loc ~typ_for_error (row : row_field) : expression = match row.prf_desc with | Rtag (_,true,_::_) | Rtag (_,false,_::_::_) -> raise_errorf ~loc "unsupported '&' in row_field: %s" (string_of_core_type typ_for_error) | Rtag ({ txt; _},true,[]) -> [%expr Bin_prot.Shape.constr [%e estring ~loc txt] None] | Rtag ({ txt; _},false,[t]) -> [%expr Bin_prot.Shape.constr [%e estring ~loc txt] (Some [%e traverse t])] | Rtag (_,false,[]) -> raise_errorf ~loc "impossible row_type: Rtag (_,_,false,[])" | Rinherit t -> [%expr Bin_prot.Shape.inherit_ [%e loc_string { t.ptyp_loc with loc_ghost = true}] [%e traverse t]] and traverse typ = let loc = { typ.ptyp_loc with loc_ghost = true } in match typ.ptyp_desc with | Ptyp_constr (lid,typs) -> let args = List.map typs ~f:traverse in begin match match lid.txt with | Lident tname -> if Context.is_local context ~tname then Some tname else None | _ -> None with | Some tname -> app_list ~loc (shape_rec_app ~loc ~tname) args | None -> curry_app_list ~loc (bin_shape_lid ~loc lid) args end | Ptyp_tuple typs -> shape_tuple ~loc (List.map typs ~f:traverse) | Ptyp_var tvar -> if allow_free_vars then [%expr Bin_prot.Shape.var [%e loc_string loc] [%e shape_vid ~loc ~tvar]] else raise_errorf ~loc "unexpected free type variable: '%s" tvar | Ptyp_variant (rows,_,None) -> shape_poly_variant ~loc (List.map rows ~f:(fun row -> traverse_row ~loc ~typ_for_error:typ row)) | Ptyp_poly (_,_) | Ptyp_variant (_,_,Some _) | Ptyp_any | Ptyp_arrow _ | Ptyp_object _ | Ptyp_class _ | Ptyp_alias _ | Ptyp_package _ | Ptyp_extension _ -> raise_errorf ~loc "unsupported type: %s" (string_of_core_type typ) in traverse let tvars_of_def (td:type_declaration) : string list = List.map td.ptype_params ~f:(fun (typ,_variance) -> let loc = typ.ptyp_loc in match typ with | { ptyp_desc = Ptyp_var tvar; _ } -> tvar | _ -> raise_errorf ~loc "unexpected non-tvar in type params") module Structure : sig val gen : (structure, rec_flag * type_declaration list) Deriving.Generator.t end = struct let of_type = of_type ~allow_free_vars:true let of_label_decs ~loc ~context lds = shape_record ~loc ( List.map lds ~f:(fun ld -> (ld.pld_name.txt, of_type ~context ld.pld_type))) let of_kind ~loc ~context (k:type_kind) : expression option = match k with | Ptype_record lds -> Some (of_label_decs ~loc ~context lds) | Ptype_variant cds -> Some (shape_variant ~loc ( List.map cds ~f:(fun cd -> ( cd.pcd_name.txt, begin match cd.pcd_args with | Pcstr_tuple args -> List.map args ~f:(of_type ~context) | Pcstr_record lds -> [of_label_decs ~loc ~context lds] end)))) | Ptype_abstract -> None | Ptype_open -> raise_errorf ~loc "open types not supported" let expr_of_td ~loc ~context (td : type_declaration) : expression option = let expr = match of_kind ~loc ~context td.ptype_kind with | Some e -> Some e | None -> (* abstract type *) match td.ptype_manifest with | None -> (* A fully abstract type is usually intended to represent an empty type (0-constructor variant). *) Some (shape_variant ~loc []) | Some manifest -> Some (of_type ~context manifest) in expr let gen = Deriving.Generator.make Deriving.Args.( empty +> arg "annotate" ((map ~f:string_literal (estring __)) ||| (map ~f:other_expression __)) +> arg "annotate_provisionally" ((map ~f:string_literal (estring __)) ||| (map ~f:other_expression __)) +> arg "basetype" ((map ~f:string_literal (estring __)) ||| (map ~f:other_expression __)) ) (fun ~loc ~path:_ (rec_flag, tds) annotation_opt annotation_provisionally_opt basetype_opt -> let tds = List.map tds ~f:name_type_params_in_td in let context = match rec_flag with | Recursive -> Context.create tds | Nonrecursive -> Context.create [] in let mk_pat mk_ = let pats = List.map tds ~f:(fun td -> let {Location.loc;txt=tname} = td.ptype_name in let name = mk_ tname in ppat_var ~loc (Loc.make name ~loc) ) in ppat_tuple ~loc pats in let () = match annotation_provisionally_opt with | Some _ -> raise_errorf ~loc "[~annotate_provisionally] was renamed to [~annotate]. \ Please use that." | None -> () in let () = match annotation_opt,basetype_opt with | Some _,Some _ -> raise_errorf ~loc "cannot write both [bin_shape ~annotate] and [bin_shape ~basetype]" | _ -> () in let () = match tds,annotation_opt with | ([] | _::_::_), Some _ -> raise_errorf ~loc "unexpected [~annotate] on multi type-declaration" | _ -> () in let () = match tds,basetype_opt with | ([] | _::_::_), Some _ -> raise_errorf ~loc "unexpected [~basetype] on multi type-declaration" | _ -> () in let annotate_f : (expression -> expression) = match annotation_opt with | None -> (fun e -> e) | Some name -> shape_annotate ~loc ~name in let tagged_schemes = List.filter_map tds ~f:(fun td -> let {Location.loc;txt=tname} = td.ptype_name in let body_opt = expr_of_td ~loc ~context td in match body_opt with | None -> None | Some body -> let tvars = tvars_of_def td in let formals = List.map tvars ~f:(fun tvar -> shape_vid ~loc ~tvar) in [%expr ([%e shape_tid ~loc ~tname], [%e elist ~loc formals], [%e body])] |> fun x -> Some x ) in let mk_exprs mk_init = let exprs = List.map tds ~f:(fun td -> let {Location.loc;txt=tname} = td.ptype_name in let tvars = tvars_of_def td in let args = List.map tvars ~f:(fun tvar -> evar ~loc tvar) in List.fold_right tvars ~init:(mk_init ~tname ~args) ~f:(fun tvar acc -> [%expr fun [%p pvar ~loc tvar] -> [%e acc]]) ) in [%expr [%e pexp_tuple ~loc exprs ] ] in let expr = match basetype_opt with | Some uuid -> mk_exprs (fun ~tname:_ ~args -> shape_basetype ~loc ~uuid args) | None -> [%expr let _group = Bin_prot.Shape.group [%e loc_string loc] [%e elist ~loc tagged_schemes] in [%e mk_exprs (fun ~tname ~args -> annotate_f (app_list ~loc (shape_top_app ~loc ~tname) args) )]] in let bindings = [value_binding ~loc ~pat:(mk_pat bin_shape_) ~expr] in let structure = [ pstr_value ~loc Nonrecursive bindings; ] in structure) end module Signature : sig val gen : (signature, rec_flag * type_declaration list) Deriving.Generator.t end = struct let of_td td : signature_item = let td = name_type_params_in_td td in let {Location.loc;txt=tname} = td.ptype_name in let name = bin_shape_ tname in let tvars = tvars_of_def td in let type_ = List.fold_left tvars ~init: [%type: Bin_prot.Shape.t] ~f:(fun acc _ -> [%type: Bin_prot.Shape.t -> [%t acc]]) in psig_value ~loc (value_description ~loc ~name:(Loc.make name ~loc) ~type_ ~prim:[]) let gen = Deriving.Generator.make Deriving.Args.empty (fun ~loc:_ ~path:_ (_rec_flag, tds) -> List.map tds ~f:of_td ) end let str_gen = Structure.gen let sig_gen = Signature.gen let shape_extension ~loc:_ typ = let context = Context.create [] in let allow_free_vars = false in of_type ~allow_free_vars ~context typ let digest_extension ~loc typ = let loc = { loc with loc_ghost = true } in [%expr Bin_prot.Shape.Digest.to_hex (Bin_prot.Shape.eval_to_digest [%e shape_extension ~loc typ])] ppx_bin_prot-0.14.0/shape/src/bin_shape_expand.mli000066400000000000000000000004551366315055700221770ustar00rootroot00000000000000open Ppxlib open Deriving val str_gen : (structure, rec_flag * type_declaration list) Generator.t val sig_gen : (signature, rec_flag * type_declaration list) Generator.t val shape_extension : loc:Location.t -> core_type -> expression val digest_extension : loc:Location.t -> core_type -> expression ppx_bin_prot-0.14.0/shape/src/dune000066400000000000000000000002321366315055700170540ustar00rootroot00000000000000(library (name bin_shape_expand) (public_name ppx_bin_prot.shape-expander) (libraries base ppxlib ppx_here.expander) (preprocess (pps ppxlib.metaquot)))ppx_bin_prot-0.14.0/shape/test/000077500000000000000000000000001366315055700163715ustar00rootroot00000000000000ppx_bin_prot-0.14.0/shape/test/dune000066400000000000000000000002661366315055700172530ustar00rootroot00000000000000(library (name test_bin_shape) (libraries core) (preprocess (pps ppx_assert ppx_custom_printf ppx_bin_prot ppx_inline_test))) (alias (name DEFAULT) (deps test.ml.pp alias runtest))ppx_bin_prot-0.14.0/shape/test/examples.mlt000066400000000000000000000141371366315055700207330ustar00rootroot00000000000000open Core module Shape = Bin_prot.Shape #verbose true module type Interface_for_types_named_t = sig type t [@@deriving bin_shape] end [%%expect{| module type Interface_for_types_named_t = sig type t val bin_shape_t : Shape.t end |}] module type Interface_for_types_named_other_than_t = sig type my_type [@@deriving bin_shape] end [%%expect{| module type Interface_for_types_named_other_than_t = sig type my_type val bin_shape_my_type : Shape.t end |}] module Record = struct type r = { x : int } [@@deriving bin_shape] end [%%expect{| module Record : sig type r = { x : int; } val bin_shape_r : Shape.t end |}] module Annotation_syntax = struct type t = int [@@deriving bin_shape ~annotate:"my-annotation"] end [%%expect{| module Annotation_syntax : sig type t = int val bin_shape_t : Shape.t end |}] module Annotation_on_multi_type_dec = struct type t = int and u = float [@@deriving bin_shape ~annotate:"this-is-not-allowed"] end [%%expect{| Line _, characters _-_: Error: ppx_bin_shape: unexpected [~annotate] on multi type-declaration |}] module Annotation_syntax_uuid = struct let uuid = Shape.Uuid.of_string "test-it" type t = int [@@deriving bin_shape ~annotate:uuid] end [%%expect{| module Annotation_syntax_uuid : sig val uuid : Shape.Uuid.t type t = int val bin_shape_t : Shape.t end |}] module Annotation_syntax_uuid_wrong_type = struct let uuid = true type t = int [@@deriving bin_shape ~annotate:uuid] end [%%expect{| Line _, characters _-_: Error: This expression has type bool but an expression was expected of type Shape.Uuid.t |}] module Inheriting_from_polymorphic_variant = struct type t1 = [ `A | `B of int ] [@@deriving bin_shape] type t2 = [ `C | t1 ] [@@deriving bin_shape] end [%%expect{| module Inheriting_from_polymorphic_variant : sig type t1 = [ `A | `B of int ] val bin_shape_t1 : Shape.t type t2 = [ `A | `B of int | `C ] val bin_shape_t2 : Shape.t end |}] module Inheriting_from_recursive_polymorphic_variant = struct type t1 = [ `A | `B of t1 ] [@@deriving bin_shape] type t2 = [ `C | t1 ] [@@deriving bin_shape] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2 end [%%expect{| Exception: (Failure "ppx/ppx_bin_prot/shape/test/examples.mlt:84:19: The shape for an inherited type is not described as a polymorphic-variant: (Application ...())") |}] module Inheriting_from_annotated_polymorphic_variant = struct type t1 = [ `A | `B of int ] [@@deriving bin_shape ~annotate:"my-t1"] type t2 = [ `C | t1 ] [@@deriving bin_shape] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2 end [%%expect{| Exception: (Failure "ppx/ppx_bin_prot/shape/test/examples.mlt:96:19: The shape for an inherited type is not described as a polymorphic-variant: (Annotate my-t1 ...)") |}] module Duplicated_variant_constructor_allowed = struct type t1 = T1 [@@deriving bin_shape] type t2 = t1 [@@deriving bin_shape] type v1 = [ `a of t1 ] [@@deriving bin_shape] type v2 = [ `a of t2 ] [@@deriving bin_shape] type t = [ v1 | v2 ] [@@deriving bin_shape] end [%%expect{| module Duplicated_variant_constructor_allowed : sig type t1 = T1 val bin_shape_t1 : Shape.t type t2 = t1 val bin_shape_t2 : Shape.t type v1 = [ `a of t2 ] val bin_shape_v1 : Shape.t type v2 = [ `a of t2 ] val bin_shape_v2 : Shape.t type t = [ `a of t2 ] val bin_shape_t : Shape.t end |}] module Duplicated_variant_constructor_Same_type_diff_serialization = struct type t1 = T1 [@@deriving bin_shape] type t2 = t1 let bin_shape_t2 = Shape.(annotate (Uuid.of_string "t2 has a special meaning") bin_shape_t1) type v1 = [ `a of t1 ] [@@deriving bin_shape] type v2 = [ `a of t2 ] [@@deriving bin_shape] type t = [ v1 | v2 ] [@@deriving bin_shape] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t end [%%expect{| Exception: (Failure "ppx/ppx_bin_prot/shape/test/examples.mlt:136:11: Different shapes for duplicated polymorphic constructor: `a") |}] module No_such_bin_shape_syntax = struct type t = int [@@deriving bin_shape ~floob:"X"] end [%%expect{| Line _, characters _-_: Error: Ppxlib.Deriving: generator 'bin_shape' doesn't accept argument 'floob' |}] module Shapeless = struct type t = int end [%%expect{| module Shapeless : sig type t = int end |}] module Annotation_requires_shape_on_subtypes = struct type t = Shapeless.t [@@deriving bin_shape ~annotate:"my-annotation"] end [%%expect{| Line _, characters _-_: Error: Unbound value Shapeless.bin_shape_t |}] module Not_allowed_both_annotation_and_basetype_syntax = struct type t = int [@@deriving bin_shape ~annotate:"X" ~basetype:"X"] end [%%expect{| Line _, characters _-_: Error: ppx_bin_shape: cannot write both [bin_shape ~annotate] and [bin_shape ~basetype] |}] module Basetype_syntax = struct type t = Shapeless.t [@@deriving bin_shape ~basetype:"my-base"] end [%%expect{| module Basetype_syntax : sig type t = int val bin_shape_t : Shape.t end |}] module Basetype_syntax_kind2 = struct type ('a,'b) t = 'a * 'b [@@deriving bin_shape ~basetype:"my-base-kind2"] end [%%expect{| module Basetype_syntax_kind2 : sig type ('a, 'b) t = 'a * 'b val bin_shape_t : Shape.t -> Shape.t -> Shape.t end |}] module Basetype_on_multi_type_dec = struct type t = int and u = float [@@deriving bin_shape ~basetype:"this-is-not-allowed"] end [%%expect{| Line _, characters _-_: Error: ppx_bin_shape: unexpected [~basetype] on multi type-declaration |}] module Basetype_syntax_uuid = struct let uuid = Shape.Uuid.of_string "test-it" type t = Shapeless.t [@@deriving bin_shape ~basetype:uuid] end [%%expect{| module Basetype_syntax_uuid : sig val uuid : Shape.Uuid.t type t = int val bin_shape_t : Shape.t end |}] module Basetype_syntax_uuid_wrong_type = struct let uuid = true type t = Shapeless.t [@@deriving bin_shape ~basetype:uuid] end [%%expect{| Line _, characters _-_: Error: This expression has type bool but an expression was expected of type Shape.Uuid.t |}] module Cannot_evaluate_shape_containing_type_vars = struct let _ = [%bin_shape: 'a list] end [%%expect{| Line _, characters _-_: Error: ppx_bin_shape: unexpected free type variable: 'a |}] ppx_bin_prot-0.14.0/shape/test/test.ml000066400000000000000000001252501366315055700177070ustar00rootroot00000000000000open Core open Poly module Shape = struct include Bin_prot.Shape let annotate s xs = annotate (Uuid.of_string s) xs let basetype s x = basetype (Uuid.of_string s) x end module Canonical = struct include Shape.Canonical include Shape.Canonical.Create let annotate x t = annotate (Shape.Uuid.of_string x) t let basetype s xs = basetype (Shape.Uuid.of_string s) xs let base0 s = basetype s [] let base1 s t1 = basetype s [t1] let unit = base0 "unit" let bool = base0 "bool" let string = base0 "string" let char = base0 "char" let int = base0 "int" let float = base0 "float" let option = base1 "option" let list = base1 "list" let array = base1 "array" let dvariant x = define (variant x) let poly_variant = poly_variant (Shape.Location.of_string "somewhere") end let expect_raise f = assert(try (f (); false) with | _ -> true) let eval_to_digest (exp:Shape.t) : string = (* Test result from `quick' [eval_to_digest] always matches the `slow' sequence: [eval] ; [to_digest]. *) let res_quick = Shape.eval_to_digest exp in let res_slow = Canonical.to_digest (Shape.eval exp) in [%test_result: Shape.Digest.t] res_quick ~expect:res_slow; Shape.Digest.to_hex res_quick let ensure_all_different exps = let alist = List.map exps ~f:(fun e -> (eval_to_digest e, e)) in let ht = String.Map.of_alist_multi alist in List.iter (Map.to_alist ht) ~f:(fun (h,exps) -> match exps with | [] -> assert false | [_] -> () | e1::_::_ -> failwithf "shapes are not all different: %s -> %s" (Canonical.to_string_hum (Shape.eval e1)) h () ) let ensure_all_same exps = let alist = List.map exps ~f:(fun e -> (eval_to_digest e, e)) in let m = String.Map.of_alist_multi alist in match Map.to_alist m with | [] -> () | [_] -> () | _::_::_ as xs -> failwithf "shapes are not all the same: %s" ( String.concat ~sep:", " ( List.map xs ~f:(fun (h,exps) -> let e1 = (match exps with [] -> assert false | e::_ -> e) in sprintf "%s -> %s" (Canonical.to_string_hum (Shape.eval e1)) h))) () let ensure_shape exp ~expect = (* Test that a Shape.t [exp], evaluates to the expected Canonical.t [expect] *) [%test_result: Canonical.t] (Shape.eval exp) ~expect let (=) x y = (eval_to_digest x = eval_to_digest y) let (!=) x y = not (x = y) (* meta-test that we are using sensible bindings for [=] and [!=] *) let%test _ = ([%bin_shape: int] = [%bin_shape: int]) let%test _ = not ([%bin_shape: int] != [%bin_shape: int]) (* int/string have distinct hashes; but self-equal *) let%test _ = ([%bin_shape: int] = [%bin_shape: int]) let%test _ = ([%bin_shape: string] = [%bin_shape: string]) let%test _ = ([%bin_shape: int] != [%bin_shape: string]) (* existence of some predefined bin_shape_ functions *) let%test _ = ([%bin_shape: int] = bin_shape_int) let%test _ = ([%bin_shape: string] = bin_shape_string) (* different types must have different hashes *) let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: string]; [%bin_shape: float]; [%bin_shape: int * int]; [%bin_shape: int * string]; [%bin_shape: string * int]; [%bin_shape: string * string]; [%bin_shape: int * int * int]; [%bin_shape: (int * int) * int]; [%bin_shape: int * (int * int)]; ] (* deriving for simple type_declaration *) type my_int = int [@@deriving bin_shape] let%test _ = ([%bin_shape: my_int] = [%bin_shape: int]) let%test _ = ([%bin_shape: my_int] = bin_shape_my_int) (* deriving in structures/signatures *) module My_int : sig type t = int [@@deriving bin_shape] end = struct type t = int [@@deriving bin_shape] end (* Tvars in signatures.. *) module Signatures = struct module type P1_sig = sig type 'a t = 'a * int [@@deriving bin_shape] end module P1 : P1_sig = struct type 'a t = 'a * int [@@deriving bin_shape] end module P2 : sig type ('a,'b) t = 'a * int * 'b [@@deriving bin_shape] end = struct type ('a,'b) t = 'a * int * 'b [@@deriving bin_shape] end end let%test _ = ([%bin_shape: My_int.t] = [%bin_shape: int]) let%test _ = ([%bin_shape: My_int.t] = My_int.bin_shape_t) (* tuples *) type ipair = int * int [@@deriving bin_shape] let%test _ = ([%bin_shape: ipair] = bin_shape_ipair) let%test _ = ([%bin_shape: ipair] = [%bin_shape: int * int]) type ipair2 = int * my_int [@@deriving bin_shape] let%test _ = ([%bin_shape: ipair2] = [%bin_shape: ipair]) (* type variables and applications *) type 'a pair = 'a * 'a [@@deriving bin_shape] type 'a i_pair = int * 'a [@@deriving bin_shape] type 'a pair_i = 'a * int [@@deriving bin_shape] type ('a,'b) gpair = 'a * 'b [@@deriving bin_shape] type ('a,'b) gpairR = 'b * 'a [@@deriving bin_shape] (* alias type definitions are expanded *) let%test_unit _ = ensure_shape [%bin_shape: int pair] ~expect:Canonical.(create (tuple [int;int])) let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: int * int]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: int * int]; [%bin_shape: int pair]; [%bin_shape: int i_pair]; [%bin_shape: int pair_i]; [%bin_shape: (int,int) gpair]; [%bin_shape: (int,int) gpairR]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: int * string]; [%bin_shape: string i_pair]; [%bin_shape: (int,string) gpair]; [%bin_shape: (string,int) gpairR]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: string * int]; [%bin_shape: string pair_i]; [%bin_shape: (string,int) gpair]; [%bin_shape: (int,string) gpairR]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: int * (int * int)]; [%bin_shape: (int, int pair) gpair]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: (int * int) * (int * int)]; [%bin_shape: (int pair, int pair) gpair]; [%bin_shape: int pair pair]; ] let%test_unit _ = ensure_shape [%bin_shape: int pair pair] ~expect:Canonical.(create (tuple [tuple [int;int]; tuple [int;int]])) (* records *) type r1 = {i:int; s:string;} [@@deriving bin_shape] type 'a id = 'a [@@deriving bin_shape] type r1_copy1 = r1 [@@deriving bin_shape] type r1_copy2 = r1 id [@@deriving bin_shape] type r1_redef = {i:int; s:string;} [@@deriving bin_shape] type 'a abstracted_r1 = {i:'a; s:string;} [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: r1]; [%bin_shape: r1_copy1]; [%bin_shape: r1_copy2]; [%bin_shape: r1_redef]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: r1]; [%bin_shape: int abstracted_r1]; ] let%test_unit _ = ensure_shape [%bin_shape: r1] ~expect:Canonical.(create ( record [ "i", int; "s", string; ])) type r2 = {i:int; s:int;} [@@deriving bin_shape] type r3 = {i:int*int; s:string;} [@@deriving bin_shape] type r4 = {ii:int; s:string;} [@@deriving bin_shape] type r5 = {i:int; ss:string;} [@@deriving bin_shape] type r6 = {i:int; s:string;x:int} [@@deriving bin_shape] type r7 = {s:string; i:int} [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int * string]; [%bin_shape: string * int]; [%bin_shape: r1]; [%bin_shape: string abstracted_r1]; [%bin_shape: r2]; [%bin_shape: r3]; [%bin_shape: r4]; [%bin_shape: r5]; [%bin_shape: r6]; [%bin_shape: r7]; ] module What_about_this_one = struct type r1 = {i:int;} [@@deriving bin_shape] type r2 = {i:int;} [@@deriving bin_shape] type r1_r1 = r1 * r1 [@@deriving bin_shape] type r1_r2 = r1 * r2 [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: r1_r1]; [%bin_shape: r1_r2]; ] (* for what it's worth, these do actually satisfy the same signature: *) module type S = sig type r1 = {i:int;} type r2 = {i:int;} type r1_r2 = r1 * r2 end module S1 : S = struct type nonrec r1 = r1 = {i:int;} type nonrec r2 = r2 = {i:int;} type r1_r2 = r1 * r2 end module S2 : S = struct type nonrec r1 = r1 = {i:int;} type r2 = r1 = {i:int;} type r1_r2 = r1 * r2 end end module Variants = struct type v1 = E1 | E2 [@@deriving bin_shape] type v2 = E1 | E2 of int [@@deriving bin_shape] type v3 = XE1 | E2 of int [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: v1]; [%bin_shape: v2]; [%bin_shape: v3]; ] type v2_copy1 = E1 | E2 of int [@@deriving bin_shape] type v2_copy2 = E1 | E2 of my_int [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: v2]; [%bin_shape: v2_copy1]; [%bin_shape: v2_copy2]; [%bin_shape: v2_copy2 id]; ] type a1 = A1 | A2 [@@deriving bin_shape] type a2 = A2 | A1 [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: a1]; [%bin_shape: a2]; ] type b1 = A of int * int [@@deriving bin_shape] type b2 = A of (int * int) [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: b1]; [%bin_shape: b2]; ] end module Empty_types = struct type t1 = Nothing.t [@@deriving bin_shape] type t2 [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: t1]; [%bin_shape: t2]; ] end module Recursive_types = struct type nat = Zero | Succ of nat [@@deriving bin_shape] type nat1 = Zero | Succ of nat [@@deriving bin_shape] type nat2 = Zero | Succ of nat2 [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: nat]; [%bin_shape: nat1]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: nat]; [%bin_shape: nat2]; ] end module Mutually_recursive_types = struct type t1 = TT of t1 | TU of u1 | TB and u1 = UT of t1 | UU of u1 | UB [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: t1]; [%bin_shape: u1]; ] type u2 = UT of t2 | UU of u2 | UB (* swap order: t,u *) and t2 = TT of t2 | TU of u2 | TB [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: t1]; [%bin_shape: t2]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: u1]; [%bin_shape: u2]; ] type t3 = TT of u3 | TU of t3 | TB (* swap types w.r.t. t1 *) and u3 = UT of t3 | UU of u3 | UB [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: t1]; [%bin_shape: t3]; [%bin_shape: u1]; [%bin_shape: u3]; ] end module Blowup1 = struct (* No blowup in code here, but the values constructed do increase in size exponentially *) type t0 = int [@@deriving bin_shape] type t1 = t0 * t0 [@@deriving bin_shape] type t2 = t1 * t1 [@@deriving bin_shape] type t3 = t2 * t2 [@@deriving bin_shape] type t4 = t3 * t3 [@@deriving bin_shape] end module Blowup2 = struct (* Exponential blowup in code size here *) type t0 = int and t1 = t0 * t0 and t2 = t1 * t1 and t3 = t2 * t2 and t4 = t3 * t3 [@@deriving bin_shape] end module Blowup3 = struct (* Reverse the order of the decs...*) (* Still have exponential blowup in code size here *) type t4 = t3 * t3 and t3 = t2 * t2 and t2 = t1 * t1 and t1 = t0 * t0 and t0 = int [@@deriving bin_shape] end module Blowup4 = struct type q1 = unit [@@deriving bin_shape] type q2 = q1 * q1 [@@deriving bin_shape] type q3 = q2 * q2 [@@deriving bin_shape] type q4 = q3 * q3 [@@deriving bin_shape] type q5 = q4 * q4 [@@deriving bin_shape] type q6 = q5 * q5 [@@deriving bin_shape] type q7 = q6 * q6 [@@deriving bin_shape] type q8 = q7 * q7 [@@deriving bin_shape] type q9 = q8 * q8 [@@deriving bin_shape] type q10 = q9 * q9 [@@deriving bin_shape] type q11 = q10 * q10 [@@deriving bin_shape] type q12 = q11 * q11 [@@deriving bin_shape] type q13 = q12 * q12 [@@deriving bin_shape] type q14 = q13 * q13 [@@deriving bin_shape] type q15 = q14 * q14 [@@deriving bin_shape] end let%test_unit _ = ensure_all_same [ [%bin_shape: Blowup1.t4]; [%bin_shape: Blowup2.t4]; [%bin_shape: Blowup3.t4]; ] module Tricky_mutual_recursion = struct module A = struct type t1 = A of t1 and t2 = B of t1 * t2 [@@deriving bin_shape] end module B = struct type t0 = t1 and t1 = A of t0 and t2 = B of t1 * t2 [@@deriving bin_shape] end let%test_unit _ = ensure_all_same [ [%bin_shape: A.t2]; [%bin_shape: B.t2]; ] end (* examples which make use of predefined list *) module List_example = struct let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: int list]; [%bin_shape: float list]; [%bin_shape: int list list]; ] type 'a copy_predef_list = 'a list [@@deriving bin_shape] type my_int_predef_list = int list [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: int list]; [%bin_shape: int copy_predef_list]; [%bin_shape: my_int_predef_list]; ] end (* examples which make use of mylist *) module My_list = struct type 'a mylist = Nil | Cons of 'a * 'a mylist [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int list]; [%bin_shape: int mylist]; ] let%test_unit _ = ensure_shape [%bin_shape: int mylist] ~expect:Canonical.(create (apply ( dvariant [ "Nil", []; "Cons", [var 0; recurse 0 [var 0]] ]) [int])) let%test_unit _ = ensure_shape [%bin_shape: int mylist mylist] ~expect:Canonical.(create ( let mylist = dvariant [ "Nil", []; "Cons", [var 0; recurse 0 [var 0]] ] in apply mylist [apply mylist [int]])) end (* Support for predefined types... *) let%test_unit _ = ensure_all_different [ [%bin_shape: unit]; [%bin_shape: bool]; [%bin_shape: string]; [%bin_shape: char]; [%bin_shape: float]; [%bin_shape: int32]; [%bin_shape: int64]; ] let%test_unit _ = ensure_shape [%bin_shape: unit] ~expect:Canonical.(create unit) let%test_unit _ = ensure_shape [%bin_shape: bool] ~expect:Canonical.(create bool) let%test_unit _ = ensure_shape [%bin_shape: char option array] ~expect:Canonical.(create (array(option char))) (* Support for predefined type constructors... *) let%test_unit _ = ensure_all_different [ [%bin_shape: unit]; [%bin_shape: unit ref]; [%bin_shape: unit option]; [%bin_shape: unit list]; [%bin_shape: unit array]; ] (* being lazy does not change the shape *) let%test_unit _ = ensure_all_same [ [%bin_shape: unit]; [%bin_shape: unit lazy_t]; ] (* examples which make use of predefined array *) module Array = struct let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: int array]; [%bin_shape: float array]; [%bin_shape: int array array]; ] type 'a copy_predef_array = 'a array [@@deriving bin_shape] type my_int_predef_array = int array [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: int array]; [%bin_shape: int copy_predef_array]; [%bin_shape: my_int_predef_array]; ] end module Non_regular = struct (* Types [a] and [b] make no `base' use of their polymorphic variable ['a] *) type 'a a = A of 'a a [@@deriving bin_shape] (* But we regard applications to different types as having different shapes *) let%test_unit _ = ensure_all_different [ [%bin_shape: int a]; [%bin_shape: float a]; ] (* This is because of our handling of recursion which is general enough to handle non regular recursion *) let%test_unit _ = ensure_shape [%bin_shape: int a] ~expect:Canonical.(create (apply ( dvariant ["A", [recurse 0 [var 0]]]) [int])) let%test_unit _ = ensure_shape [%bin_shape: float a] ~expect:Canonical.(create (apply ( dvariant ["A", [recurse 0 [var 0]]]) [float])) (* And here is an example of non-regular recursion *) type 'a b = B of 'a list b [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int b]; [%bin_shape: float b]; ] let%test_unit _ = ensure_shape [%bin_shape: int b] ~expect:Canonical.(create (apply ( dvariant ["B", [recurse 0 [list (var 0)]]]) [int])) end module Polymorphism_and_recursion = struct (* example from Valentin *) type 'a t = A of 'a t list [@@deriving bin_shape] type u1 = int t [@@deriving bin_shape] type u2 = A of u2 list [@@deriving bin_shape] let%test_unit _ = ensure_shape [%bin_shape: u1] ~expect:Canonical.(create (apply ( dvariant ["A", [list (recurse 0 [var 0])]]) [int])) let%test_unit _ = ensure_shape [%bin_shape: u2] ~expect:Canonical.(create (apply ( dvariant ["A", [list (recurse 0 [])]]) [])) (* So these types are not equivalent. Which is a shame. *) let%test_unit _ = ensure_all_different [ [%bin_shape: u1]; [%bin_shape: u2]; ] end module Polymorphic_variants = struct type v0 = [ `E1 ] [@@deriving bin_shape] type v1 = [ `E1 | `E2 ] [@@deriving bin_shape] type v2 = [ `E1 | `E2 of int ] [@@deriving bin_shape] type v3 = [ `XE1 | `E2 of int ] [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: v0]; [%bin_shape: v1]; [%bin_shape: v2]; [%bin_shape: v3]; [%bin_shape: Variants.v1]; ] type v4 = [ `E1 | `E2 ] [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: v1]; [%bin_shape: v4]; ] (* Polymorphic_variants allow reordering (unlike normal variants) *) type v5 = [ `E2 | `E1 ] [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: v1]; [%bin_shape: v5]; (* reordered *) ] let%test_unit _ = ensure_shape [%bin_shape: v1] ~expect:Canonical.(create ( poly_variant [ "E1", None; "E2", None; ])) (* Support for [Rinherit] *) type v6 = [ | v1 ] [@@deriving bin_shape] type v7 = [ v0 | `E2 ] [@@deriving bin_shape] type v8 = [ v1 | `E2 ] [@@deriving bin_shape] let%test_unit _ = ensure_shape [%bin_shape: v6] ~expect:Canonical.(create ( poly_variant [ "E1", None; "E2", None; ])) let%test_unit _ = ensure_shape [%bin_shape: v7] ~expect:Canonical.(create ( poly_variant [ "E1", None; "E2", None; ])) let%test_unit _ = ensure_all_same [ [%bin_shape: v1]; [%bin_shape: v6]; [%bin_shape: v7]; [%bin_shape: v8]; ] type q = [ `a | `b | `c ] [@@deriving bin_shape] type q1 = [ `a | `b ] [@@deriving bin_shape] type q2 = [ `b | `c ] [@@deriving bin_shape] type q3 = [ q1 | q2 ] [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: q]; [%bin_shape: q3]; ] end module Parameters_and_orders = struct type a1 = A of a3 and a2 = B of a1 and a3 = C of a2 [@@deriving bin_shape] type b3 = C of b2 and b2 = B of b1 and b1 = A of b3 [@@deriving bin_shape] type ('a, 'b) c1 = 'a * 'b [@@deriving bin_shape] type ('b, 'a) c2 = 'a * 'b [@@deriving bin_shape] type t1 = (b1, b2) c1 [@@deriving bin_shape] type t2 = (b2, b1) c2 [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: t1]; [%bin_shape: t2]; ] end module Recursive_polymorphic_variant = struct type t1 = [ `A | `B of t1 ] [@@deriving bin_shape] let%test_unit _ = let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t1 in () end module Inheriting_from_recursive_polymorphic_variant = struct let%test_unit _ = expect_raise (fun () -> let module M = struct type t1 = [ `A | `B of t1 ] [@@deriving bin_shape] type t2 = [ t1 | `C ] [@@deriving bin_shape] end in let _ = Shape.eval [%bin_shape: M.t2] in ()) end module Inheriting_from_recursive_polymorphic_variant2 = struct let%test_unit _ = expect_raise (fun () -> let module M = struct type t1 = [ `A | `B of t1 ] [@@deriving bin_shape] type t2 = [ `Q | `P of t2 | t1] [@@deriving bin_shape] type t3 = [ t2 | `C ] [@@deriving bin_shape] end in let _ = Shape.eval [%bin_shape: M.t3] in ()) end module Unrolling_bad_0 = struct let%test_unit _ = let module M = struct type t1 = [ `A | `B of t1 ] [@@deriving bin_shape] type t2 = [ `A | `B of [ `A | `B of t2 ] ] [@@deriving bin_shape] let () = ensure_shape [%bin_shape: t1] ~expect:Canonical.(create (apply ( define (poly_variant [ "A", None; "B", Some (recurse 0 []) ])) [])) let () = ensure_shape [%bin_shape: t2] ~expect:Canonical.(create (apply ( define (poly_variant [ "A", None; "B", Some ( poly_variant [ "A", None; "B", Some (recurse 0 []) ])])) [])) let () = ensure_all_different [ [%bin_shape: t1]; [%bin_shape: t2]; ] end in () end let%test_unit _ = let module Unrolling_good_1 = struct type t = [ `A of t ] [@@deriving bin_shape] type u = [ `A of u ] [@@deriving bin_shape] let () = ensure_all_same [ [%bin_shape: t]; [%bin_shape: u]; ] end in () let%test_unit _ = let module Unrolling_bad_1 = struct type t = [ `A of t ] [@@deriving bin_shape] type u = [ `A of t ] [@@deriving bin_shape] (* like good, except: [of u] -> [of t] *) let () = ensure_all_different [ [%bin_shape: t]; [%bin_shape: u]; ] end in () module Unrolling_bad_2 = struct type 'a named = [`A | `B of 'a] [@@deriving bin_shape] type t1 = t1 named [@@deriving bin_shape] type t2 = t2 named named [@@deriving bin_shape] (* We get different shapes for t1 and t2, because we dont regard a type as equivalent to an unrolled version of itself. *) let%test_unit _ = ensure_shape [%bin_shape: t1] ~expect:Canonical.(create (apply ( define ( poly_variant [ "A", None; "B", Some (recurse 0 [])]) ) [])) let%test_unit _ = ensure_shape [%bin_shape: t2] ~expect:Canonical.(create (apply ( define ( poly_variant [ "A", None; "B", Some ( poly_variant [ "A", None; "B", Some (recurse 0 [])])]) ) [])) let%test_unit _ = ensure_all_different [ [%bin_shape: t1]; [%bin_shape: t2]; ] end module Tricky1 = struct type 'a inner = Tight of 'a inner | Loose of 'a [@@deriving bin_shape] type outer = Z | S of outer inner [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: outer]; ] end module Tricky_mutual = struct type 'a inner = Tight of 'a inner | Loose of 'a and outer = Z | S of outer inner [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int]; [%bin_shape: outer]; ] end module Cyclic_app = struct type ('a, 'b) t = | A of ('b, 'a) t | B [@@deriving bin_shape] let%test_unit _ = ensure_shape [%bin_shape: (int, string) t] ~expect:Canonical.(create (apply ( dvariant ["A", [recurse 0 [var 1; var 0]]; "B", []] ) [int; string])) let%test_unit _ = ensure_shape [%bin_shape: (string, int) t] ~expect:Canonical.(create (apply ( dvariant ["A", [recurse 0 [var 1; var 0]]; "B", []] ) [string; int])) (* So these types are not equivalent. *) let%test_unit _ = ensure_all_different [ [%bin_shape: (int, string) t]; [%bin_shape: (string, int) t]; ] end module Non_regular_recursion = struct type 'a mylist = Nil | Cons of 'a * 'a mylist [@@deriving bin_shape] type 'a mylist2 = Nil | Cons of 'a * string mylist2 [@@deriving bin_shape] type 'a mylist3 = Nil | Cons of 'a * float mylist3 [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int mylist]; [%bin_shape: int mylist2]; [%bin_shape: int mylist3]; ] end module Dub = struct type 'a dub = 'a * 'a [@@deriving bin_shape] type t0 = B | Knot of t0 [@@deriving bin_shape] type t1 = B | Knot of t1 dub [@@deriving bin_shape] type t2 = B | Knot of t2 dub dub [@@deriving bin_shape] type t3 = B | Knot of t3 dub dub dub [@@deriving bin_shape] type t4 = B | Knot of t4 dub dub dub dub [@@deriving bin_shape] let r0 = Canonical.(recurse 0 []) let%test_unit _ = ensure_shape [%bin_shape: t2] ~expect:Canonical.(create (apply ( dvariant [ "B", []; "Knot", [ tuple [tuple [r0;r0]; tuple [r0;r0]] ]]) [])) let%test_unit _ = ensure_shape [%bin_shape: t3] ~expect:Canonical.(create (apply ( dvariant [ "B", []; "Knot", [ tuple [ tuple [tuple [r0;r0]; tuple [r0;r0]]; tuple [tuple [r0;r0]; tuple [r0;r0]]; ]]]) [])) (* Testing for specific digest values - fails if the digest scheme is changed *) let%test_unit _ = [%test_result: string] (eval_to_digest [%bin_shape: t3]) ~expect:"e502ebd5fc3a340527fe4aa39b68bee5" let%test_unit _ = [%test_result: string] (eval_to_digest [%bin_shape: t4]) ~expect:"a66734cfcaea50f37e04cd706cf9c7d0" (* Use [bin_digest..] function/extension *) let%test_unit _ = [%test_result: string] [%bin_digest: t4] ~expect:"a66734cfcaea50f37e04cd706cf9c7d0" module By_hand = struct module type Unary_with_shape = sig type 'a t [@@deriving bin_shape] end let add_dub (module M : Unary_with_shape) : (module Unary_with_shape) = (module struct type 'a t = 'a M.t dub [@@deriving bin_shape] end) let dubs n : (module Unary_with_shape) = Fn.apply_n_times ~n add_dub (module struct type 'a t = 'a [@@deriving bin_shape] end) let gen_t' n = let module Dubs = (val dubs n) in let module M = struct type t = B | Knot of t Dubs.t [@@deriving bin_shape] let _f () = Knot (assert false) let _f () = B end in M.bin_shape_t (* [gen_t n] constructs a type-expression for t, which if tricky to express directly in Ocaml. But possible. See [gen_t'] above. *) let gen_t n = assert (n>=0); let open Shape in let name = Tid.of_string "any_name_will_do" in let _group = group (Location.of_string "group") [ name, [], ( variant [ "B", []; "Knot", [ Fn.apply_n_times ~n bin_shape_dub (rec_app name []) ]])] in top_app _group name [] let%test_unit _ = ensure_all_same [ [%bin_shape: t4]; gen_t 4; gen_t' 4; ] end let test_eval_time n allowed = let exp = By_hand.gen_t n in let before = Time.now() in let _res = Shape.eval_to_digest exp in let after = Time.now() in [%test_pred: Time.Span.t] (fun x -> x < allowed) (Time.diff after before) let%test_unit _ = test_eval_time 15 (sec 1.) (* demonstate that we have no exponential blowup *) let%test_unit _ = test_eval_time 10000 (sec 1.) end (* Captures all kinds of shape *) module Complex_type = struct type t0 = A | B of t0 [@@deriving bin_shape] let bin_shape_t0 = Shape.annotate "t0" bin_shape_t0 type 'a t1 = Z | Q of 'a t1 [@@deriving bin_shape] type base_types = { a : unit; b : bool; c : string; d : char; f : float; g : int32; h : int64; i : int64 ref; j : int64 Lazy.t; k : int64 option; l : int64 list; m : int64 array; o : Bigstring.Stable.V1.t; } [@@deriving bin_shape] type 'a all_stuff = [ `Nullary | `Variant of t0 | `Record of base_types | `Big_tuple of (int64 * string * unit * bool) | `List of int64 list | `Application of int64 t1 | `Var of 'a ] [@@deriving bin_shape] let%test_unit _ = [%test_result: string] (eval_to_digest [%bin_shape: bool all_stuff]) ~expect:"23cb21f19c45331a6a0227af4eeb55f5" end module Too_aggressive_memoization_1 = struct type t = A of t [@@deriving bin_shape] type t1 = A of t1 [@@deriving bin_shape] module A = struct type u = A of t [@@deriving bin_shape] type s = T of t | U of u [@@deriving bin_shape] end module B = struct type u = A of t [@@deriving bin_shape] type s = T of t1 | U of u [@@deriving bin_shape] end (* This test fails if we do memoization too aggressively. *) let%test_unit _ = ensure_all_same [ [%bin_shape: A.s]; [%bin_shape: B.s]; ] end module Too_aggressive_memoization_2 = struct type t = A of t [@@deriving bin_shape] type t1 = A of t [@@deriving bin_shape] type u1 = X of v1 and v1 = A of u1 [@@deriving bin_shape] type u2 = X of t [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: u1]; [%bin_shape: u2]; ] module A = struct type s = T of t | U of u1 [@@deriving bin_shape] end module B = struct type s = T of t | U of u2 [@@deriving bin_shape] end (* This test fails if we do memoization too aggressively. *) let%test_unit _ = ensure_all_different [ [%bin_shape: A.s]; [%bin_shape: B.s]; ] end module Example_poly_variants = struct type a = [ `qaz | `bar ] [@@deriving bin_shape] type b = [ `foo | a ] [@@deriving bin_shape] let exp = [%bin_shape: b] let expect : Canonical.t = let open Canonical in create ( poly_variant [ ("bar", None); ("foo", None); ("qaz", None); ]) let%test_unit _ = ensure_shape exp ~expect end module Example_direct_recusion = struct type 'a mylist = Nil | Cons of 'a * 'a mylist [@@deriving bin_shape] let exp = [%bin_shape: int mylist] let expect : Canonical.t = let open Canonical in create (apply ( dvariant [ "Nil", []; "Cons", [var 0; recurse 0 [var 0]] ]) [int]) let%test_unit _ = ensure_shape exp ~expect end module Example_block_of_3 = struct type 'a mylist = Nil | Cons of 'a * 'a mylist and 'a and_string = 'a * string and t = (int*float) mylist and_string [@@deriving bin_shape] let exp = [%bin_shape: t] let expect : Canonical.t = let open Canonical in let def = dvariant [ "Nil", []; "Cons", [var 0; recurse 0 [var 0]] ] in create (tuple [apply def [tuple [int; float]]; string]) let%test_unit _ = ensure_shape exp ~expect end module Example_inner_outer1 = struct (* .. within the same mut-block *) type 'a inner = Tight of 'a inner | Loose of 'a and outer = Z of outer | S of outer inner [@@deriving bin_shape] let exp = [%bin_shape: outer] let expect : Canonical.t = let open Canonical in let inner = dvariant [ "Tight", [recurse 1 [var 0]]; "Loose", [var 0]; ] in let outer = dvariant [ "Z", [recurse 0 []]; "S", [apply inner [recurse 0 []]]; ] in create (apply outer []) let%test_unit _ = ensure_shape exp ~expect end module Example_inner_outer2 = struct (* .. within sequence of mut-blocks *) type 'a inner = Tight of 'a inner | Loose of 'a [@@deriving bin_shape] type outer = Z of outer | S of outer inner [@@deriving bin_shape] let exp = [%bin_shape: outer] let expect : Canonical.t = let open Canonical in let inner = dvariant [ "Tight", [recurse 1 [var 0]]; "Loose", [var 0]; ] in let outer = dvariant [ "Z", [recurse 0 []]; "S", [apply inner [recurse 0 []]] ] in create (apply outer []) let%test_unit _ = ensure_shape exp ~expect end let%test_unit _ = ensure_all_same [ [%bin_shape: Example_inner_outer1.outer]; [%bin_shape: Example_inner_outer2.outer]; ] module Example_mut_recursion_with_extra_aliases = struct type t = A of t1 | B of u and t1 = t and u = C of t1 | D of u [@@deriving bin_shape] let exp = [%bin_shape: t1] let expect : Canonical.t = let open Canonical in let u = dvariant [ "C", [recurse 0 []]; "D", [recurse 1 []]; ] in let t = dvariant [ "A", [recurse 0 []]; "B", [apply u []]; ] in create (apply t []) let%test_unit _ = ensure_shape exp ~expect module Tiny_variation = struct type t = A of t | B of u (* changed [t1] -> [t] ...*) and t1 = t and u = C of t1 | D of u [@@deriving bin_shape] let exp_variation = [%bin_shape: t1] (* happily the shape is unchanged *) let%test_unit _ = ensure_shape exp_variation ~expect end let%test_unit _ = ensure_all_same [ [%bin_shape: t]; [%bin_shape: t1]; [%bin_shape: Tiny_variation.t]; [%bin_shape: Tiny_variation.t1]; ] end module Tricky = struct type 'b u = | Uu of 'b u | Ub of 'b [@@deriving bin_shape] type 'a t = | Tt of 'a t | Ta of 'a | Tu of 'a u [@@deriving bin_shape] type knot = | Base | Knot of knot t [@@deriving bin_shape] let exp = [%bin_shape: knot] let expect : Canonical.t = let open Canonical in let u = dvariant [ "Uu", [recurse 2 [var 0]]; "Ub", [var 0]; ] in let t = dvariant [ "Tt", [recurse 1 [var 0]]; "Ta", [var 0]; "Tu", [apply u [var 0]]; ] in let knot = dvariant [ "Base", []; "Knot", [apply t [recurse 0 []]]; ] in create (apply knot []) let%test_unit _ = ensure_shape exp ~expect end module Test_tid_clash = struct module Other = struct type 'a t = | Tt of 'a t | Ta of 'a [@@deriving bin_shape] end type t = | Base | Knot of t Other.t [@@deriving bin_shape] let exp = [%bin_shape: t] let expect : Canonical.t = let open Canonical in let other = dvariant [ "Tt", [recurse 1 [var 0]]; "Ta", [var 0]; ] in let knot = dvariant [ "Base", []; "Knot", [apply other [recurse 0 []]]; ] in create (apply knot []) let%test_unit _ = ensure_shape exp ~expect end module Test_nested_type_application = struct type 'a pair = 'a * 'a [@@deriving bin_shape] type t = int pair pair [@@deriving bin_shape] let exp = [%bin_shape: int pair pair] let expect = Canonical.(create (tuple [tuple [int;int]; tuple [int;int]])) let%test_unit _ = ensure_shape exp ~expect end module Test_recursive_nested_type_application = struct type 'a mylist = Nil | Cons of 'a * 'a mylist [@@deriving bin_shape] type t = int mylist mylist [@@deriving bin_shape] let exp = [%bin_shape: int mylist mylist] let expect = let open Canonical in let mylist = dvariant [ "Nil", []; "Cons", [var 0; recurse 0 [var 0]] ] in create (apply mylist [apply mylist [int]]) let%test_unit _ = ensure_shape exp ~expect end module Examples_where_shape_exps_are_constructed_by_hand = struct module Example_mut_recursion = struct type t = A of t | B of u and u = C of t | D of u [@@deriving bin_shape] let exp = [%bin_shape: t] let expect : Canonical.t = let open Canonical in let u = dvariant [ "C", [recurse 0 []]; "D", [recurse 1 []]; ] in let t = dvariant [ "A", [recurse 0 []]; "B", [apply u []]; ] in create (apply t []) module By_hand = struct let exp = let open Shape in let t = Tid.of_string "t" in let u = Tid.of_string "u" in let _group = group (Location.of_string "group") [ t, [], ( variant [ "A", [rec_app t []]; "B", [rec_app u []]; ]); u, [], ( variant [ "C", [rec_app t []]; "D", [rec_app u []]; ]); ] in top_app _group t [] let%test_unit _ = ensure_shape exp ~expect end let%test_unit _ = ensure_shape exp ~expect end module Example_bad = struct type 'a t = A of int | B of string t [@@deriving bin_shape] type 'a s = A of 'a | B of string s [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: int t]; [%bin_shape: int s]; ] end module Example_annotation = struct let exp = let open Shape in let foo = Tid.of_string "foo" in let my_int = Tid.of_string "my_int" in let _group = group (Location.of_string "group") [ foo, [], ( annotate "blah" (rec_app my_int []) ); my_int, [], ( bin_shape_int ) ] in top_app _group foo [] let expect : Canonical.t = let open Canonical in create (annotate "blah" int) let%test_unit _ = ensure_shape exp ~expect end module Example_definition_order_1 = struct type t1 = A [@@deriving bin_shape] type t2 = B [@@deriving bin_shape] type t = t1 * t2 [@@deriving bin_shape] let exp = [%bin_shape: t] let expect : Canonical.t = let open Canonical in let t1 = variant ["A", [];] in let t2 = variant ["B", [];] in create (tuple [t1; t2]) let%test_unit _ = ensure_shape exp ~expect end end module Example_definition_order_2 = struct type t1 = A [@@deriving bin_shape] type t2 = B [@@deriving bin_shape] type ('a, 'b) tup = ('b * 'a) [@@deriving bin_shape] type x1 = (t1 * t2) [@@deriving bin_shape] type x2 = (t2, t1) tup [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: x1]; [%bin_shape: x2]; ] end module Example_definition_order_3 = struct type t1 = A [@@deriving bin_shape] type t2 = B [@@deriving bin_shape] type x1 = [`t1 of t1 | `t2 of t2 ] [@@deriving bin_shape] type x2 = [`t2 of t2 | `t1 of t1 ] [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: x1]; [%bin_shape: x2]; ] end module Example_definition_order_4 = struct type t1 = A of t1 [@@deriving bin_shape] type t2 = B of t2 [@@deriving bin_shape] type ('a, 'b) tup = ('b * 'a) [@@deriving bin_shape] type x1 = (t1 * t2) [@@deriving bin_shape] type x2 = (t2, t1) tup [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: x1]; [%bin_shape: x2]; ] end module Annotations = struct module D1 = struct type dollars = float [@@deriving bin_io] let bin_shape_dollars = Shape.annotate "dollars" bin_shape_dollars type dollars2 = float [@@deriving bin_io] let bin_shape_dollars2 = Shape.annotate "dollars2" bin_shape_dollars2 let%test_unit _ = ensure_all_different [ [%bin_shape: float]; [%bin_shape: dollars]; [%bin_shape: dollars2]; ] type dollars_copy = float [@@deriving bin_io] (* Annotations are not generative. A different type with the same annotation has the same shape. *) let bin_shape_dollars_copy = Shape.annotate "dollars" bin_shape_dollars_copy let%test_unit _ = ensure_all_same [ [%bin_shape: dollars]; [%bin_shape: dollars_copy]; ] end module D2 = struct (* Annotations are different from the original un-annotated type. And different from records and new base types. *) module Orig = struct type t = int [@@deriving bin_io] end module Record = struct type t = { qaz : int } [@@deriving bin_io] end module Annotation = struct type t = int [@@deriving bin_io] let bin_shape_t = Shape.annotate "qaz" bin_shape_t end module New_base = struct type t = int [@@deriving bin_io] let bin_shape_t = Shape.basetype "qaz" [bin_shape_t] end let%test_unit _ = ensure_all_different [ [%bin_shape: Orig.t]; [%bin_shape: Record.t]; [%bin_shape: Annotation.t]; [%bin_shape: New_base.t]; ] end end module Annotation_Syntax = struct module Dollars = struct module Without_syntax = struct type t = float [@@deriving bin_shape] let bin_shape_t = Shape.annotate "dollars" bin_shape_t end module With_syntax = struct type t = float [@@deriving bin_shape ~annotate:"dollars"] end let%test_unit _ = ensure_all_same [ [%bin_shape: Without_syntax.t]; [%bin_shape: With_syntax.t]; ] module Bin_io_with_annotated_shape = struct type t = float [@@deriving bin_io ~annotate:"dollars"] let%test_unit _ = ensure_all_same [ [%bin_shape: Without_syntax.t]; [%bin_shape: t]; ] end module Bin_io_with_annotated_shape_broken = struct type t = float [@@deriving bin_shape ~annotate:"dollars", bin_io] let%test_unit _ = ensure_all_different [ (* BUG *) [%bin_shape: Without_syntax.t]; [%bin_shape: t]; ] end end end module Test_nonrec = struct module A = struct type t = int [@@deriving bin_shape] end module B = struct open A type nonrec t = t [@@deriving bin_shape] end let%test_unit _ = ensure_all_same [ [%bin_shape: A.t]; [%bin_shape: B.t]; ] end module Basetype_syntax = struct module Kind0 = struct module Orig = struct type t = int [@@deriving bin_shape] end type shapeless = Orig.t module Without_syntax = struct type t = shapeless let bin_shape_t = Shape.basetype "my-base" [] end let%test_unit _ = ensure_all_different [ [%bin_shape: Orig.t]; [%bin_shape: Without_syntax.t]; ] module With_syntax = struct type t = shapeless [@@deriving bin_shape ~basetype:"my-base"] end let%test_unit _ = ensure_all_same [ [%bin_shape: Without_syntax.t]; [%bin_shape: With_syntax.t]; ] end module Kind1 = struct module Orig = struct type 'a t = 'a list [@@deriving bin_shape] end type 'a shapeless = 'a Orig.t module Without_syntax = struct type 'a t = 'a shapeless let bin_shape_t a = Shape.basetype "my-base1" [a] end let%test_unit _ = ensure_all_different [ [%bin_shape: int Orig.t]; [%bin_shape: int Without_syntax.t]; ] module With_syntax = struct type 'a t = 'a shapeless [@@deriving bin_shape ~basetype:"my-base1"] end let%test_unit _ = ensure_all_same [ [%bin_shape: int Without_syntax.t]; [%bin_shape: int With_syntax.t]; ] end end module Inline_records = struct type r1 = {i:int; s:string;} [@@deriving bin_shape] type t = A of r1 [@@deriving bin_shape] type t_using_inline_record = A of {i:int; s:string;} [@@deriving bin_shape] let%test_unit _ = ensure_all_different [ [%bin_shape: t_using_inline_record]; [%bin_shape: r1]; ] let%test_unit _ = ensure_all_same [ [%bin_shape: t]; [%bin_shape: t_using_inline_record]; ] end module Wildcard : sig type _ abstract [@@deriving bin_shape] type _ concrete [@@deriving bin_shape] end = struct type _ abstract [@@deriving bin_shape] type 'a concrete = 'a list [@@deriving bin_shape] let%test_unit _ = ensure_all_same [ [%bin_shape: int abstract]; [%bin_shape: string abstract]; ] let%test_unit _ = ensure_all_different [ [%bin_shape: int concrete]; [%bin_shape: string concrete]; ] end ppx_bin_prot-0.14.0/src/000077500000000000000000000000001366315055700151015ustar00rootroot00000000000000ppx_bin_prot-0.14.0/src/dune000066400000000000000000000003201366315055700157520ustar00rootroot00000000000000(library (name ppx_bin_prot) (public_name ppx_bin_prot) (kind ppx_deriver) (ppx_runtime_libraries bin_prot) (libraries compiler-libs.common base ppxlib bin_shape_expand) (preprocess (pps ppxlib.metaquot)))ppx_bin_prot-0.14.0/src/ppx_bin_prot.ml000066400000000000000000001467671366315055700201630ustar00rootroot00000000000000(** Ppx_bin_prot: Preprocessing Module for a Type Safe Binary Protocol *) open Base open Ppxlib open Ast_builder.Default let ( @@ ) a b = a b (* +-----------------------------------------------------------------+ | Signature generators | +-----------------------------------------------------------------+ *) module Sig = struct let mk_sig_generator combinators = let mk_sig ~ctxt:_ (_rf, tds) = List.concat_map tds ~f:(fun td -> let td = name_type_params_in_td td in List.map combinators ~f:(fun mk -> mk td)) in Deriving.Generator.V2.make Deriving.Args.empty mk_sig let mk_typ ?(wrap_result=fun ~loc:_ x -> x) type_constr td = let loc = td.ptype_loc in let id = Longident.parse type_constr in let wrap_type ~loc t = ptyp_constr ~loc (Located.mk ~loc id) [t] in let result_type = wrap_type ~loc:td.ptype_name.loc (wrap_result ~loc (core_type_of_type_declaration td)) in List.fold_right td.ptype_params ~init:result_type ~f:(fun (tp, _variance) acc -> let loc = tp.ptyp_loc in ptyp_arrow ~loc Nolabel (wrap_type ~loc tp) acc) ;; let mk name_format type_constr ?wrap_result td = let loc = td.ptype_loc in let name = Loc.map ~f:(Printf.sprintf name_format) td.ptype_name in let typ = mk_typ ?wrap_result type_constr td in psig_value ~loc (value_description ~loc ~name ~type_:typ ~prim:[]) let bin_write = mk_sig_generator [ mk "bin_size_%s" "Bin_prot.Size.sizer" ; mk "bin_write_%s" "Bin_prot.Write.writer" ; mk "bin_writer_%s" "Bin_prot.Type_class.writer" ] let bin_read = mk_sig_generator [ mk "bin_read_%s" "Bin_prot.Read.reader" ; mk "__bin_read_%s__" "Bin_prot.Read.reader" ~wrap_result:(fun ~loc t -> [%type: int -> [%t t]]) ; mk "bin_reader_%s" "Bin_prot.Type_class.reader" ] let bin_type_class = mk_sig_generator [ mk "bin_%s" "Bin_prot.Type_class.t" ] let named = let mk_named_sig ~ctxt (rf, tds) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in match mk_named_sig ~loc ~sg_name:"Bin_prot.Binable.S" ~handle_polymorphic_variant:true tds with | Some incl -> [psig_include ~loc incl] | None -> List.concat_map [ Bin_shape_expand.sig_gen; bin_write; bin_read; bin_type_class ] ~f:(fun gen -> Deriving.Generator.apply ~name:"unused" gen ~ctxt (rf, tds) []) in Deriving.Generator.V2.make Deriving.Args.empty mk_named_sig end (* +-----------------------------------------------------------------+ | Utility functions | +-----------------------------------------------------------------+ *) let atoms_in_row_fields row_fields = List.exists row_fields ~f:(fun row_field -> match row_field.prf_desc with | Rtag (_, is_constant, _) -> is_constant | Rinherit _ -> false) ;; let atoms_in_variant cds = List.filter cds ~f:(fun cds -> match cds.pcd_args with | Pcstr_tuple [] -> true | Pcstr_tuple _ -> false | Pcstr_record _ -> false) let let_ins loc bindings expr = List.fold_right bindings ~init:expr ~f:(fun binding expr -> pexp_let ~loc Nonrecursive [binding] expr) let alias_or_fun expr fct = let is_id = match expr.pexp_desc with | Pexp_ident _ -> true | _ -> false in if is_id then expr else fct ;; let td_is_nil td = match td.ptype_kind, td.ptype_manifest with | Ptype_abstract, None -> true | _ -> false type var = string Located.t let vars_of_params ~prefix td = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in { name with txt = prefix ^ name.txt }) let map_vars vars ~f = List.map vars ~f:(fun (v : var) -> f ~loc:v.loc v.txt) let patts_of_vars = map_vars ~f:pvar let exprs_of_vars = map_vars ~f:evar let project_vars expr vars ~field_name = let field : Longident.t = Ldot (Ldot (Lident "Bin_prot", "Type_class"), field_name) in let args = map_vars vars ~f:(fun ~loc txt -> pexp_field ~loc (evar ~loc txt) (Located.mk ~loc field)) in let loc = expr.pexp_loc in eapply ~loc expr args module Full_type_name : sig type t val make : path:string -> type_declaration -> t val absent : t val get : t -> string option val get_exn : loc:Location.t -> t -> string end = struct type t = string option let make ~path td = Some (Printf.sprintf "%s.%s" path td.ptype_name.txt) let absent = None let get t = t let get_exn ~loc t = match t with | Some n -> n | None -> Location.raise_errorf ~loc "Bug in ppx_bin_prot: full type name needed but not in a type declaration.\n\ Callstack:\n\ %s" (Caml.Printexc.get_callstack 256 |> Caml.Printexc.raw_backtrace_to_string) end let generate_poly_type ?wrap_result ~loc td constructor = ptyp_poly ~loc (List.map td.ptype_params ~f:get_type_param_name) (Sig.mk_typ ?wrap_result constructor td) (* Determines whether or not the generated code associated with a type declaration should include explicit type signatures. In particular, we'd rather not add an explicit type signature when polymorphic variants are involved. As discussed in https://github.com/janestreet/ppx_bin_prot/pull/7 However, if we have mutually recursive type declarations involving polymorphic type constructors where we add a type declaration to one of them, we need it on all of them, otherwise we'll generate ill-typed code. *) let would_rather_omit_type_signatures = let module M = struct exception E end in let has_variant = object inherit Ast_traverse.iter as super method! core_type ct = match ct.ptyp_desc with | Ptyp_variant _ -> Exn.raise_without_backtrace M.E | _ -> super#core_type ct end in fun td -> match td.ptype_kind with | Ptype_variant _ | Ptype_record _ | Ptype_open -> false | Ptype_abstract -> match td.ptype_manifest with | None -> false | Some body -> try has_variant#core_type body; false with M.E -> true (* +-----------------------------------------------------------------+ | Generator for size computation of OCaml-values for bin_prot | +-----------------------------------------------------------------+ *) module Generate_bin_size = struct let mk_abst_call ~loc id args = type_constr_conv ~loc id ~f:(fun s -> "bin_size_" ^ s) args (* Conversion of types *) let rec bin_size_type full_type_name _loc ty = let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) -> `Fun (bin_size_appl_fun full_type_name loc id args) | Ptyp_tuple l -> bin_size_tuple full_type_name loc l | Ptyp_var parm -> `Fun (evar ~loc @@ "_size_of_" ^ parm) | Ptyp_arrow _ -> Location.raise_errorf ~loc "bin_size_type: cannot convert functions to the binary protocol" | Ptyp_variant (row_fields, _, _) -> bin_size_variant full_type_name loc row_fields | Ptyp_poly (parms, ty) -> bin_size_poly full_type_name loc parms ty | _ -> Location.raise_errorf ~loc "bin_size_type: unknown type construct" (* Conversion of polymorphic types *) and bin_size_appl_fun full_type_name loc id args = let loc = { loc with loc_ghost = true } in let sizers = List.map args ~f:(fun ty -> match bin_size_type full_type_name ty.ptyp_loc ty with | `Fun e -> e | `Match cases -> pexp_function ~loc:{ ty.ptyp_loc with loc_ghost = true } cases) in match mk_abst_call ~loc id sizers with | [%expr Bin_prot.Size.bin_size_array Bin_prot.Size.bin_size_float ] -> [%expr Bin_prot.Size.bin_size_float_array ] | e -> e (* Conversion of tuples and records *) and bin_size_args : 'a 'b. Full_type_name.t -> Location.t -> ('a -> core_type) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> 'b list * expression = fun full_type_name loc get_tp mk_patt tps -> let rec loop i = function | el :: rest -> let tp = get_tp el in let v_name = "v" ^ Int.to_string i in let v_expr = let e_name = evar ~loc v_name in let expr = match bin_size_type full_type_name loc tp with | `Fun fun_expr -> eapply ~loc fun_expr [e_name] | `Match cases -> pexp_match ~loc e_name cases in [%expr Bin_prot.Common.(+) size [%e expr] ] in let patt = mk_patt loc v_name el in if List.is_empty rest then [patt], v_expr else let patts, in_expr = loop (i + 1) rest in patt :: patts, [%expr let size = [%e v_expr] in [%e in_expr] ] | [] -> assert false (* impossible *) in loop 1 tps and bin_size_tup_rec : 'a 'b. Full_type_name.t -> Location.t -> ('b list -> pattern) -> ('a -> core_type) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> _ = fun full_type_name loc cnv_patts get_tp mk_patt tp -> let patts, expr = bin_size_args full_type_name loc get_tp mk_patt tp in `Match [ case ~lhs:(cnv_patts patts) ~guard:None ~rhs:[%expr let size = 0 in [%e expr] ] ] (* Conversion of tuples *) and bin_size_tuple full_type_name loc l = let cnv_patts patts = ppat_tuple ~loc patts in let get_tp tp = tp in let mk_patt loc v_name _ = pvar ~loc v_name in bin_size_tup_rec full_type_name loc cnv_patts get_tp mk_patt l (* Conversion of records *) and bin_size_record full_type_name loc tp = let cnv_patts lbls = ppat_record ~loc lbls Closed in let get_tp ld = ld.pld_type in let mk_patt loc v_name ld = (Located.map lident ld.pld_name, pvar ~loc v_name) in bin_size_tup_rec full_type_name loc cnv_patts get_tp mk_patt tp (* Conversion of variant types *) and bin_size_variant full_type_name loc row_fields = let nonatom_matchings = List.fold_left row_fields ~init:[] ~f:(fun acc rf -> match rf.prf_desc with | Rtag (_, true, _) -> acc | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> let size_args = match bin_size_type full_type_name tp.ptyp_loc tp with | `Fun fun_expr -> eapply ~loc fun_expr [ [%expr args ] ] | `Match cases -> pexp_match ~loc [%expr args] cases in case ~lhs:(ppat_variant cnstr ~loc (Some [%pat? args])) ~guard:None ~rhs:[%expr let size_args = [%e size_args] in Bin_prot.Common.(+) size_args 4 ] :: acc | Rtag (_, false, []) -> acc (* Impossible, let the OCaml compiler fail *) | Rinherit ty -> let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) -> let call = bin_size_appl_fun full_type_name loc id args in case ~lhs:(ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc "v")) ~guard:None ~rhs:(eapply ~loc call [ [%expr v] ]) :: acc | _ -> Location.raise_errorf ~loc "bin_size_variant: unknown type" ) in let matchings = if atoms_in_row_fields row_fields then case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:[%expr 4] :: nonatom_matchings else nonatom_matchings in `Match (List.rev matchings) (* Polymorphic record fields *) and bin_size_poly full_type_name loc parms tp = let bindings = let mk_binding parm = let full_type_name = Full_type_name.get_exn ~loc full_type_name in value_binding ~loc ~pat:(pvar ~loc @@ "_size_of_" ^ parm.txt) ~expr:[%expr fun _v -> raise (Bin_prot.Common.Poly_rec_write [%e estring ~loc full_type_name]) ] in List.map parms ~f:mk_binding in match bin_size_type full_type_name loc tp with | `Fun fun_expr -> `Fun (pexp_let ~loc Nonrecursive bindings fun_expr) | `Match matchings -> `Match [ case ~lhs:(pvar ~loc "arg") ~guard:None ~rhs:(pexp_let ~loc Nonrecursive bindings (pexp_match ~loc (evar ~loc "arg") matchings)) ] (* Conversion of sum types *) let bin_size_sum full_type_name loc alts = let n_alts = List.length alts in let size_tag = if n_alts <= 256 then [%expr 1 ] else if n_alts <= 65536 then [%expr 2 ] else Location.raise_errorf ~loc "bin_size_sum: too many alternatives (%d > 65536)" n_alts in let nonatom_matchings = List.fold_left alts ~init:[] ~f:(fun acc cd -> (match cd.pcd_res with | None -> () | Some ty -> Location.raise_errorf ~loc:ty.ptyp_loc "bin_size_sum: GADTs are not supported by bin_prot"); match cd.pcd_args with | Pcstr_tuple [] -> acc | Pcstr_tuple args -> let get_tp tp = tp in let mk_patt loc v_name _ = pvar ~loc v_name in let patts, size_args = bin_size_args full_type_name loc get_tp mk_patt args in let args = match patts with | [patt] -> patt | _ -> ppat_tuple ~loc patts in case ~lhs:(pconstruct cd (Some args)) ~guard:None ~rhs:[%expr let size = [%e size_tag] in [%e size_args] ] :: acc | Pcstr_record fields -> let cnv_patts lbls = ppat_record ~loc lbls Closed in let get_tp ld = ld.pld_type in let mk_patt loc v_name ld = Located.map lident ld.pld_name, pvar ~loc v_name in let patts, size_args = bin_size_args full_type_name loc get_tp mk_patt fields in case ~lhs:(pconstruct cd (Some (cnv_patts patts))) ~guard:None ~rhs:[%expr let size = [%e size_tag] in [%e size_args] ] :: acc ) in let atom_matching init atoms = List.fold_left atoms ~init:(pconstruct init None) ~f:(fun acc atom -> ppat_or ~loc acc (pconstruct atom None)) in let matchings = match atoms_in_variant alts with | [] -> nonatom_matchings | init :: atoms -> case ~lhs:(atom_matching init atoms) ~guard:None ~rhs:size_tag :: nonatom_matchings in `Match (List.rev matchings) (* Empty types *) let bin_size_nil full_type_name loc = let full_type_name = Full_type_name.get_exn ~loc full_type_name in `Fun [%expr fun _v -> raise (Bin_prot.Common.Empty_type [%e estring ~loc full_type_name]) ] let make_fun ~loc ?(don't_expand=false) fun_or_match = match fun_or_match with | `Fun fun_expr when don't_expand -> fun_expr | `Fun fun_expr -> alias_or_fun fun_expr [%expr fun v -> [%e eapply ~loc fun_expr [[%expr v]]]] | `Match matchings -> pexp_function ~loc matchings let sizer_body_of_td ~path td = let full_type_name = Full_type_name.make ~path td in let loc = td.ptype_loc in let res = match td.ptype_kind with | Ptype_variant alts -> bin_size_sum full_type_name loc alts | Ptype_record flds -> bin_size_record full_type_name loc flds | Ptype_open -> Location.raise_errorf ~loc "bin_size_td: open types not yet supported" | Ptype_abstract -> match td.ptype_manifest with | None -> bin_size_nil full_type_name loc | Some ty -> bin_size_type full_type_name loc ty in make_fun ~loc ~don't_expand:(td_is_nil td) res (* Generate code from type definitions *) let bin_size_td ~can_omit_type_annot ~loc ~path td = let body = sizer_body_of_td ~path td in let tparam_patts = vars_of_params td ~prefix:"_size_of_" |> patts_of_vars in let pat = pvar ~loc @@ "bin_size_" ^ td.ptype_name.txt in let pat_with_type = if can_omit_type_annot then pat else ppat_constraint ~loc pat (generate_poly_type ~loc td "Bin_prot.Size.sizer") in value_binding ~loc ~pat:pat_with_type ~expr:(eabstract ~loc tparam_patts body) let bin_size ~loc ~path (rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in let rec_flag = really_recursive rec_flag tds in let can_omit_type_annot = List.for_all ~f:would_rather_omit_type_signatures tds in let bindings = List.map tds ~f:(bin_size_td ~can_omit_type_annot ~loc ~path) in pstr_value ~loc rec_flag bindings end (* +-----------------------------------------------------------------+ | Generator for converters of OCaml-values to the binary protocol | +-----------------------------------------------------------------+ *) module Generate_bin_write = struct let mk_abst_call ~loc id args = type_constr_conv ~loc id ~f:(fun s -> "bin_write_" ^ s) args (* Conversion of types *) let rec bin_write_type full_type_name _loc ty = let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) -> `Fun (bin_write_appl_fun full_type_name loc id args) | Ptyp_tuple l -> bin_write_tuple full_type_name loc l | Ptyp_var parm -> `Fun (evar ~loc @@ "_write_" ^ parm) | Ptyp_arrow _ -> Location.raise_errorf ~loc "bin_write_type: cannot convert functions to the binary protocol" | Ptyp_variant (row_fields, _, _) -> bin_write_variant full_type_name loc row_fields | Ptyp_poly (parms, ty) -> bin_write_poly full_type_name loc parms ty | _ -> Location.raise_errorf ~loc "bin_write_type: unknown type construct" (* Conversion of polymorphic types *) and bin_write_appl_fun full_type_name loc id args = let loc = { loc with loc_ghost = true } in let writers = List.map args ~f:(fun ty -> match bin_write_type full_type_name ty.ptyp_loc ty with | `Fun e -> e | `Match cases -> [%expr fun buf ~pos -> [%e pexp_function ~loc:ty.ptyp_loc cases ] ] ) in let e = match mk_abst_call ~loc id writers with | [%expr Bin_prot.Write.bin_write_array Bin_prot.Write.bin_write_float ] -> [%expr Bin_prot.Write.bin_write_float_array ] | e -> e in e (* Conversion of tuples and records *) and bin_write_args : 'a 'b. Full_type_name.t -> Location.t -> ('a -> core_type) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> 'b list * expression = fun full_type_name loc get_tp mk_patt tp -> let rec loop i = function | el :: rest -> let tp = get_tp el in let v_name = "v" ^ Int.to_string i in let v_expr = let e_name = evar ~loc v_name in match bin_write_type full_type_name loc tp with | `Fun fun_expr -> [%expr [%e fun_expr] buf ~pos [%e e_name] ] | `Match cases -> pexp_match ~loc e_name cases in let patt = mk_patt loc v_name el in if List.is_empty rest then [patt], v_expr else let patts, in_expr = loop (i + 1) rest in patt :: patts, [%expr let pos = [%e v_expr] in [%e in_expr] ] | [] -> assert false (* impossible *) in loop 1 tp and bin_write_tup_rec : 'a 'b. Full_type_name.t -> Location.t -> ('b list -> pattern) -> ('a -> core_type) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> _ = fun full_type_name loc cnv_patts get_tp mk_patt tp -> let patts, expr = bin_write_args full_type_name loc get_tp mk_patt tp in `Match [ case ~lhs:(cnv_patts patts) ~guard:None ~rhs:expr ] (* Conversion of tuples *) and bin_write_tuple full_type_name loc l = let cnv_patts patts = ppat_tuple ~loc patts in let get_tp tp = tp in let mk_patt loc v_name _ = pvar ~loc v_name in bin_write_tup_rec full_type_name loc cnv_patts get_tp mk_patt l (* Conversion of records *) and bin_write_record full_type_name loc tp = let cnv_patts lbls = ppat_record ~loc lbls Closed in let get_tp ld = ld.pld_type in let mk_patt loc v_name ld = (Located.map lident ld.pld_name, pvar ~loc v_name) in bin_write_tup_rec full_type_name loc cnv_patts get_tp mk_patt tp (* Conversion of variant types *) and bin_write_variant full_type_name loc row_fields = let matchings = List.map row_fields ~f:(fun row_field -> match row_field.prf_desc with | Rtag ({txt = cnstr; _ }, true, _) | Rtag ({ txt = cnstr; _ }, false, []) -> case ~lhs:(ppat_variant ~loc cnstr None) ~guard:None ~rhs:[%expr Bin_prot.Write.bin_write_variant_int buf ~pos [%e eint ~loc (Ocaml_common.Btype.hash_variant cnstr) ] ] | Rtag ({ txt = cnstr; _ }, false, tp :: _) -> let write_args = match bin_write_type full_type_name tp.ptyp_loc tp with | `Fun fun_expr -> [%expr [%e fun_expr] buf ~pos args ] | `Match cases -> pexp_match ~loc [%expr args] cases in case ~lhs:(ppat_variant ~loc cnstr (Some [%pat? args])) ~guard:None ~rhs:[%expr let pos = Bin_prot.Write.bin_write_variant_int buf ~pos [%e eint ~loc (Ocaml_common.Btype.hash_variant cnstr)] in [%e write_args] ] | Rinherit ty -> let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) -> let call = bin_write_appl_fun full_type_name loc id args in case ~lhs:(ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc "v")) ~guard:None ~rhs:[%expr [%e call] buf ~pos v] | _ -> Location.raise_errorf ~loc "bin_write_variant: unknown type" ) in `Match matchings (* Polymorphic record fields *) and bin_write_poly full_type_name loc parms tp = let bindings = let mk_binding parm = let full_type_name = Full_type_name.get_exn ~loc full_type_name in value_binding ~loc ~pat:(pvar ~loc @@ "_write_" ^ parm.txt) ~expr:[%expr fun _buf ~pos:_ _v -> raise (Bin_prot.Common.Poly_rec_write [%e estring ~loc full_type_name]) ] in List.map parms ~f:mk_binding in match bin_write_type full_type_name loc tp with | `Fun fun_expr -> `Fun (pexp_let ~loc Nonrecursive bindings fun_expr) | `Match matchings -> `Match [ case ~lhs:(pvar ~loc "arg") ~guard:None ~rhs:(pexp_let ~loc Nonrecursive bindings (pexp_match ~loc (evar ~loc "arg") matchings)) ] (* Conversion of sum types *) let bin_write_sum full_type_name loc alts = let n_alts = List.length alts in let write_tag = if n_alts <= 256 then [%expr Bin_prot.Write.bin_write_int_8bit buf ~pos ] else if n_alts <= 65536 then [%expr Bin_prot.Write.bin_write_int_16bit buf ~pos ] else Location.raise_errorf ~loc "bin_write_sum: too many alternatives (%d > 65536)" n_alts in let matchings = List.mapi alts ~f:(fun i cd -> (match cd.pcd_res with | None -> () | Some ty -> Location.raise_errorf ~loc:ty.ptyp_loc "bin_write_sum: GADTs are not supported by bin_prot"); match cd.pcd_args with | Pcstr_tuple [] -> let loc = cd.pcd_loc in case ~lhs:(pconstruct cd None) ~guard:None ~rhs:(eapply ~loc write_tag [eint ~loc i]) | Pcstr_tuple args -> let get_tp tp = tp in let mk_patt loc v_name _ = pvar ~loc v_name in let patts, write_args = bin_write_args full_type_name loc get_tp mk_patt args in let args = match patts with | [patt] -> patt | _ -> ppat_tuple ~loc patts in case ~lhs:(pconstruct cd (Some args)) ~guard:None ~rhs:[%expr let pos = [%e eapply ~loc write_tag [eint ~loc i]] in [%e write_args] ] | Pcstr_record fields -> let cnv_patts lbls = ppat_record ~loc lbls Closed in let get_tp ld = ld.pld_type in let mk_patt loc v_name ld = Located.map lident ld.pld_name, pvar ~loc v_name in let patts, expr = bin_write_args full_type_name loc get_tp mk_patt fields in case ~lhs:(pconstruct cd (Some (cnv_patts patts))) ~guard:None ~rhs:[%expr let pos = [%e eapply ~loc write_tag [eint ~loc i]] in [%e expr] ] ) in `Match matchings (* Empty types *) let bin_write_nil full_type_name loc = let full_type_name = Full_type_name.get_exn ~loc full_type_name in `Fun [%expr fun _buf ~pos:_ _v -> raise (Bin_prot.Common.Empty_type [%e estring ~loc full_type_name]) ] let make_fun ~loc ?(don't_expand=false) fun_or_match = match fun_or_match with | `Fun fun_expr when don't_expand -> fun_expr | `Fun fun_expr -> alias_or_fun fun_expr [%expr fun buf ~pos v -> [%e fun_expr] buf ~pos v ] | `Match matchings -> [%expr fun buf ~pos -> [%e pexp_function ~loc matchings ] ] let writer_type_class_record ~loc ~size ~write = [%expr { Bin_prot.Type_class. size = [%e size] ; write = [%e write] } ] let writer_body_of_td ~path td = let full_type_name = Full_type_name.make ~path td in let loc = td.ptype_loc in let res = match td.ptype_kind with | Ptype_variant alts -> bin_write_sum full_type_name loc alts | Ptype_record flds -> bin_write_record full_type_name loc flds | Ptype_open -> Location.raise_errorf ~loc "bin_size_td: open types not yet supported" | Ptype_abstract -> match td.ptype_manifest with | None -> bin_write_nil full_type_name loc | Some ty -> bin_write_type full_type_name loc ty in make_fun ~loc ~don't_expand:(td_is_nil td) res let project_vars expr vars ~field_name = let call = project_vars expr vars ~field_name in let loc = call.pexp_loc in alias_or_fun call [%expr fun v -> [%e eapply ~loc call [ [%expr v] ]]] (* Generate code from type definitions *) let bin_write_td ~can_omit_type_annot ~loc ~path td = let body = writer_body_of_td ~path td in let size_name = "bin_size_" ^ td.ptype_name.txt in let write_name = "bin_write_" ^ td.ptype_name.txt in let write_binding = let tparam_patts = vars_of_params td ~prefix:"_write_" |> patts_of_vars in let pat = pvar ~loc write_name in let pat_with_type = if can_omit_type_annot then pat else ppat_constraint ~loc pat (generate_poly_type ~loc td "Bin_prot.Write.writer") in value_binding ~loc ~pat:pat_with_type ~expr:(eabstract ~loc tparam_patts body) in let writer_binding = let vars = vars_of_params td ~prefix:"bin_writer_" in let writer_record = writer_type_class_record ~loc ~size: (project_vars (evar ~loc size_name ) vars ~field_name:"size" ) ~write: (project_vars (evar ~loc write_name) vars ~field_name:"write") in value_binding ~loc ~pat:(pvar ~loc @@ "bin_writer_" ^ td.ptype_name.txt) ~expr:(eabstract ~loc (patts_of_vars vars) writer_record) in (write_binding, writer_binding) let bin_write ~loc ~path (rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in let rec_flag = really_recursive rec_flag tds in let can_omit_type_annot = List.for_all tds ~f:would_rather_omit_type_signatures in let write_bindings, writer_bindings = List.map tds ~f:(bin_write_td ~can_omit_type_annot ~loc ~path) |> List.unzip in Generate_bin_size.bin_size ~loc ~path (rec_flag, tds) :: [ pstr_value ~loc rec_flag write_bindings ; pstr_value ~loc Nonrecursive writer_bindings ] ;; let gen = Deriving.Generator.make Deriving.Args.empty bin_write let extension ~loc ~path:_ ty = let loc = { loc with loc_ghost = true } in let full_type_name = Full_type_name.absent in let size = Generate_bin_size.bin_size_type full_type_name loc ty |> Generate_bin_size.make_fun ~loc in let write = bin_write_type full_type_name loc ty |> make_fun ~loc in writer_type_class_record ~loc ~size ~write ;; end (* +-----------------------------------------------------------------+ | Generator for converters of binary protocol to OCaml-values | +-----------------------------------------------------------------+ *) module Generate_bin_read = struct let full_type_name_or_anonymous full_type_name = match Full_type_name.get full_type_name with | None -> "" | Some s -> s let mk_abst_call loc ?(internal = false) id args = type_constr_conv ~loc id args ~f:(fun s -> let s = "bin_read_" ^ s in if internal then "__" ^ s ^ "__" else s) (* Conversion of type paths *) let bin_read_path_fun loc id args = mk_abst_call { loc with loc_ghost = true } id args let get_closed_expr loc = function | `Open expr -> [%expr fun buf ~pos_ref -> [%e expr] ] | `Closed expr -> expr let get_open_expr loc = function | `Open expr -> expr | `Closed expr -> [%expr [%e expr] buf ~pos_ref ] (* Conversion of arguments *) let rec handle_arg_tp loc full_type_name arg_tp = let args, bindings = let arg_map ai tp = let f = get_open_expr loc (bin_read_type full_type_name loc tp) in let arg_name = "arg_" ^ Int.to_string (ai + 1) in (evar ~loc arg_name, value_binding ~loc ~pat:(pvar ~loc arg_name) ~expr:f) in List.mapi arg_tp ~f:arg_map |> List.unzip in let args_expr = match args with | [expr] -> expr | _ -> pexp_tuple ~loc args in bindings, args_expr (* Conversion of types *) and bin_read_type_internal full_type_name ~full_type _loc ty = let loc = { ty.ptyp_loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) -> let args_expr = List.map args ~f:(fun tp -> get_closed_expr _loc (bin_read_type full_type_name _loc tp)) in let expr = match bin_read_path_fun id.loc id args_expr with | [%expr Bin_prot.Read.bin_read_array Bin_prot.Read.bin_read_float ] -> [%expr Bin_prot.Read.bin_read_float_array ] | expr -> expr in `Closed expr | Ptyp_tuple tp -> bin_read_tuple full_type_name loc tp | Ptyp_var parm -> `Closed (evar ~loc ("_of__" ^ parm)) | Ptyp_arrow _ -> Location.raise_errorf ~loc "bin_read_arrow: cannot convert functions" | Ptyp_variant (row_fields, _, _) -> bin_read_variant full_type_name loc ?full_type row_fields | Ptyp_poly (parms, poly_tp) -> bin_read_poly full_type_name loc parms poly_tp | _ -> Location.raise_errorf ~loc "bin_read_type: unknown type construct" and bin_read_type full_type_name loc ty = bin_read_type_internal full_type_name ~full_type:None loc ty and bin_read_type_toplevel full_type_name ~full_type loc ty = bin_read_type_internal full_type_name ~full_type:(Some full_type) loc ty (* Conversion of tuples *) and bin_read_tuple full_type_name loc tps = let bindings, exprs = let map i tp = let v_name = "v" ^ Int.to_string (i + 1) in let expr = get_open_expr loc (bin_read_type full_type_name loc tp) in (value_binding ~loc ~pat:(pvar ~loc v_name) ~expr, evar ~loc v_name) in List.mapi tps ~f:map |> List.unzip in `Open (let_ins loc bindings (pexp_tuple ~loc exprs)) (* Variant conversions *) (* Generate internal call *) and mk_internal_call full_type_name loc ty = let loc = { loc with loc_ghost = true } in match ty.ptyp_desc with | Ptyp_constr (id, args) | Ptyp_class (id, args) -> let arg_exprs = List.map args ~f:(fun tp -> get_closed_expr loc (bin_read_type full_type_name loc tp)) in mk_abst_call loc ~internal:true id arg_exprs | _ -> Location.raise_errorf ~loc:ty.ptyp_loc "bin_read: unknown type" (* Generate matching code for variants *) and bin_read_variant full_type_name loc ?full_type row_fields = let is_contained, full_type = match full_type with | None -> true, ptyp_variant ~loc row_fields Closed None | Some full_type -> false, full_type in let code = let mk_check_vint mcs = pexp_match ~loc (evar ~loc "vint") mcs in let mk_try_next_expr call next_expr = [%expr try [%e call] with Bin_prot.Common.No_variant_match -> [%e next_expr] ] in let raise_nvm = [%expr raise Bin_prot.Common.No_variant_match ] in let rec loop_many next = function | h :: t -> loop_one next t h | [] -> match next with | `Matches mcs -> mk_check_vint mcs | `Expr expr -> expr | `None -> raise_nvm and loop_one next t = fun row_field -> match row_field.prf_desc with | Rtag ({ txt = cnstr; _ }, is_constant, tps) -> let rhs = match is_constant, tps with | false, arg_tp :: _ -> let bnds, args_expr = handle_arg_tp loc full_type_name [ arg_tp ] in let_ins loc bnds (pexp_variant ~loc cnstr (Some args_expr)) | _ -> pexp_variant ~loc cnstr None in let this_mc = case ~lhs:(pint ~loc (Ocaml_common.Btype.hash_variant cnstr)) ~guard:None ~rhs in add_mc next this_mc t | Rinherit ty -> let call = [%expr ( [%e mk_internal_call full_type_name ty.ptyp_loc ty] buf ~pos_ref vint :> [%t full_type] ) ] in let expr = match next with | `Matches mcs -> mk_try_next_expr call (mk_check_vint mcs) | `Expr expr -> mk_try_next_expr call expr | `None -> call in loop_many (`Expr expr) t and add_mc next this_mc t = let next_mcs = match next with | `Matches mcs -> mcs | `Expr expr -> [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:expr ] | `None -> [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:raise_nvm ] in loop_many (`Matches (this_mc :: next_mcs)) t in loop_many `None (List.rev row_fields) in if is_contained then let full_type_name = full_type_name_or_anonymous full_type_name in `Open [%expr let vint = Bin_prot.Read.bin_read_variant_int buf ~pos_ref in try [%e code] with Bin_prot.Common.No_variant_match -> Bin_prot.Common.raise_variant_wrong_type [%e estring ~loc full_type_name] !pos_ref ] else `Open code (* Polymorphic record field conversion *) and bin_read_poly full_type_name loc parms tp = let bindings = let mk_binding parm = let full_type_name = Full_type_name.get_exn ~loc full_type_name in value_binding ~loc ~pat:(pvar ~loc @@ "_of__" ^ parm.txt) ~expr:[%expr fun _buf ~pos_ref -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Poly_rec_bound [%e estring ~loc full_type_name]) !pos_ref ] in List.map parms ~f:mk_binding in let f = get_open_expr loc (bin_read_type full_type_name loc tp) in `Open (pexp_let ~loc Nonrecursive bindings f) (* Record conversions *) let bin_read_label_declaration_list full_type_name loc fields wrap = let bindings, rec_bindings = let map field = let loc = field.pld_loc in let v_name = "v_" ^ field.pld_name.txt in let f = get_open_expr loc (bin_read_type full_type_name loc field.pld_type) in ( value_binding ~loc ~pat:(pvar ~loc:field.pld_name.loc v_name) ~expr:f, (Located.map lident field.pld_name, evar ~loc:field.pld_name.loc v_name) ) in List.map fields ~f:map |> List.unzip in let_ins loc bindings (wrap (pexp_record ~loc rec_bindings None)) (* Sum type conversions *) let bin_read_sum full_type_name loc alts = let map mi cd = (match cd.pcd_res with | None -> () | Some _ -> Location.raise_errorf ~loc:cd.pcd_loc "bin_read_sum: GADTs are not supported by bin_prot"); match cd.pcd_args with | Pcstr_tuple [] -> let loc = cd.pcd_loc in case ~lhs:(pint ~loc mi) ~guard:None ~rhs:(econstruct cd None) | Pcstr_tuple args -> let bindings, args_expr = handle_arg_tp loc full_type_name args in let rhs = let_ins loc bindings (econstruct cd (Some args_expr)) in case ~lhs:(pint ~loc mi) ~guard:None ~rhs | Pcstr_record fields -> let rhs = bin_read_label_declaration_list full_type_name loc fields (fun e -> econstruct cd (Some e)) in case ~lhs:(pint ~loc mi) ~guard:None ~rhs in let mcs = List.mapi alts ~f:map in let n_alts = List.length alts in let read_fun = if n_alts <= 256 then [%expr Bin_prot.Read.bin_read_int_8bit ] else if n_alts <= 65536 then [%expr Bin_prot.Read.bin_read_int_16bit ] else Location.raise_errorf ~loc "bin_size_sum: too many alternatives (%d > 65536)" n_alts in let full_type_name = Full_type_name.get_exn ~loc full_type_name in `Open (pexp_match ~loc [%expr [%e read_fun] buf ~pos_ref ] (mcs @ [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:[%expr Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag [%e estring ~loc full_type_name]) !pos_ref ] ])) (* Record conversions *) let bin_read_record full_type_name loc fields = let rhs = bin_read_label_declaration_list full_type_name loc fields (fun x -> x) in `Open rhs (* Empty types *) let bin_read_nil full_type_name loc = let full_type_name = Full_type_name.get_exn ~loc full_type_name in `Closed [%expr fun _buf ~pos_ref -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Empty_type [%e estring ~loc full_type_name]) !pos_ref ] (* Generate code from type definitions *) let reader_body_of_td td full_type_name = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_variant cds -> bin_read_sum full_type_name loc cds | Ptype_record lds -> bin_read_record full_type_name loc lds | Ptype_open -> Location.raise_errorf ~loc "bin_size_td: open types not yet supported" | Ptype_abstract -> match td.ptype_manifest with | None -> bin_read_nil full_type_name loc | Some ty -> bin_read_type_toplevel full_type_name loc ty ~full_type:(core_type_of_type_declaration td) (* When the type is a polymorphic variant the main bin_read_NAME function reads an integer and calls the __bin_read_NAME__ function wrapped into a try-with. *) let main_body_for_polymorphic_variant ~loc ~vtag_read_name ~full_type_name ~args = let full_type_name = full_type_name_or_anonymous full_type_name in let vtag_read_expr = evar ~loc vtag_read_name in [%expr fun buf ~pos_ref -> let vint = Bin_prot.Read.bin_read_variant_int buf ~pos_ref in try [%e eapply ~loc vtag_read_expr (exprs_of_vars args)] buf ~pos_ref vint with Bin_prot.Common.No_variant_match -> let err = Bin_prot.Common.ReadError.Variant [%e estring ~loc full_type_name] in Bin_prot.Common.raise_read_error err !pos_ref ] module Td_class = struct type polymorphic_variant = { all_atoms : bool } type t = | Polymorphic_variant of polymorphic_variant | Alias_but_not_polymorphic_variant | Other let of_core_type ty = match ty.ptyp_desc with | Ptyp_variant (row_fields, _, _) -> let all_atoms = List.for_all row_fields ~f:(fun row_field -> match row_field.prf_desc with | Rtag (_, is_constant, _) -> is_constant | Rinherit _ -> false) in Polymorphic_variant { all_atoms } | _ -> Alias_but_not_polymorphic_variant let of_td td = match td.ptype_kind, td.ptype_manifest with | Ptype_abstract, Some ty -> of_core_type ty | _ -> Other end let variant_wrong_type ~loc full_type_name = let full_type_name = full_type_name_or_anonymous full_type_name in [%expr fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type [%e estring ~loc full_type_name] !pos_ref ] let vtag_reader ~loc ~(td_class : Td_class.t) ~full_type_name ~oc_body = match td_class with | Alias_but_not_polymorphic_variant -> begin match oc_body with | `Closed call -> let rec rewrite_call cnv e = let loc = e.pexp_loc in match e.pexp_desc with | Pexp_apply (f,[arg]) -> rewrite_call (fun new_f -> cnv (pexp_apply ~loc new_f [arg])) f | Pexp_ident { txt = Ldot (Ldot (Lident "Bin_prot", "Read"), _); _ } -> variant_wrong_type ~loc full_type_name | Pexp_ident { txt = Lident name; _ } when String.is_prefix name ~prefix:"_o" -> let full_type_name = Full_type_name.get_exn ~loc full_type_name in [%expr fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Silly_type [%e estring ~loc full_type_name]) !pos_ref ] | Pexp_ident id -> let expr = unapplied_type_constr_conv ~loc id ~f:(fun s -> "__" ^ s ^ "__") in let cnv_expr = cnv expr in alias_or_fun cnv_expr [%expr fun buf ~pos_ref vint -> [%e cnv_expr] buf ~pos_ref vint ] | _ -> let s = Pprintast.string_of_expression e in Location.raise_errorf ~loc "ppx_bin_prot: impossible case: %s" s in rewrite_call (fun x -> x) (curry_applications call) | _ -> variant_wrong_type ~loc full_type_name end | Polymorphic_variant { all_atoms } -> begin match oc_body with | `Open body when all_atoms -> [%expr fun _buf ~pos_ref:_ vint -> [%e body] ] | `Open body -> [%expr fun buf ~pos_ref vint -> [%e body] ] | _ -> assert false (* impossible *) end | Other -> variant_wrong_type ~loc full_type_name let read_and_vtag_read_bindings ~loc ~read_name ~read_binding_type ~vtag_read_name ~vtag_read_binding_type ~full_type_name ~(td_class : Td_class.t) ~args ~oc_body = let read_binding = let body = match td_class with | Polymorphic_variant _ -> main_body_for_polymorphic_variant ~loc ~vtag_read_name ~full_type_name ~args | Alias_but_not_polymorphic_variant | Other -> match oc_body with | `Closed expr -> alias_or_fun expr [%expr fun buf ~pos_ref -> [%e expr] buf ~pos_ref ] | `Open body -> [%expr fun buf ~pos_ref -> [%e body] ] in let pat = pvar ~loc read_name in let pat_with_type = match read_binding_type with | None -> pat | Some ty -> ppat_constraint ~loc pat ty in value_binding ~loc ~pat:pat_with_type ~expr:(eabstract ~loc (patts_of_vars args) body) in let vtag_read_binding = let pat = pvar ~loc vtag_read_name in let pat_with_type = match vtag_read_binding_type with | None -> pat | Some ty -> ppat_constraint ~loc pat ty in value_binding ~loc ~pat:pat_with_type ~expr:(eabstract ~loc (patts_of_vars args) (vtag_reader ~loc ~td_class ~full_type_name ~oc_body)) in (read_binding, vtag_read_binding) let reader_type_class_record ~loc ~read ~vtag_read = [%expr { Bin_prot.Type_class. read = [%e read] ; vtag_read = [%e vtag_read] } ] let bin_read_td ~can_omit_type_annot ~loc:_ ~path td = let full_type_name = Full_type_name.make ~path td in let loc = td.ptype_loc in let oc_body = reader_body_of_td td full_type_name in let read_name = "bin_read_" ^ td.ptype_name.txt in let vtag_read_name = "__bin_read_" ^ td.ptype_name.txt ^ "__" in let vtag_read_binding_type, read_binding_type = if can_omit_type_annot then None, None else Some (generate_poly_type ~loc td "Bin_prot.Read.reader" ~wrap_result:(fun ~loc t -> [%type: int -> [%t t]])), Some (generate_poly_type ~loc td "Bin_prot.Read.reader") in let read_binding, vtag_read_binding = let args = vars_of_params td ~prefix:"_of__" in read_and_vtag_read_bindings ~loc ~read_name ~read_binding_type ~vtag_read_name ~vtag_read_binding_type ~full_type_name ~td_class:(Td_class.of_td td) ~args ~oc_body in let vars = vars_of_params td ~prefix:"bin_reader_" in let read = let call = project_vars (evar ~loc read_name) vars ~field_name:"read" in alias_or_fun call [%expr fun buf ~pos_ref -> [%e call] buf ~pos_ref ] in let vtag_read = let call = project_vars (evar ~loc vtag_read_name) vars ~field_name:"read" in alias_or_fun call [%expr fun buf ~pos_ref vtag -> [%e call] buf ~pos_ref vtag ] in let reader = reader_type_class_record ~loc ~read ~vtag_read in let reader_binding = value_binding ~loc ~pat:(pvar ~loc @@ "bin_reader_" ^ td.ptype_name.txt) ~expr:(eabstract ~loc (patts_of_vars vars) reader) in (vtag_read_binding, (read_binding, reader_binding)) (* Generate code from type definitions *) let bin_read ~loc ~path (rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in let rec_flag = really_recursive rec_flag tds in (match rec_flag, tds with | Nonrecursive, _ :: _ :: _ -> (* there can be captures in the generated code if we allow this *) Location.raise_errorf ~loc "bin_prot doesn't support multiple nonrecursive definitions." | _ -> ()); let can_omit_type_annot = List.for_all tds ~f:would_rather_omit_type_signatures in let vtag_read_bindings, read_and_reader_bindings = List.map tds ~f:(bin_read_td ~can_omit_type_annot ~loc ~path) |> List.unzip in let read_bindings, reader_bindings = List.unzip read_and_reader_bindings in let defs = match rec_flag with | Recursive -> [ pstr_value ~loc Recursive (vtag_read_bindings @ read_bindings) ] | Nonrecursive -> let cnv binding = pstr_value ~loc Nonrecursive [binding] in List.map vtag_read_bindings ~f:cnv @ List.map read_bindings ~f:cnv in defs @ [ pstr_value ~loc Nonrecursive reader_bindings ] let gen = Deriving.Generator.make Deriving.Args.empty bin_read let extension ~loc ~path:_ ty = let loc = { loc with loc_ghost = true } in let full_type_name = Full_type_name.absent in let read_name = "read" in let vtag_read_name = "vtag_read" in let read_binding, vtag_read_binding = let oc_body = bin_read_type_toplevel full_type_name loc ty ~full_type:ty in read_and_vtag_read_bindings ~loc ~read_name ~read_binding_type:None ~vtag_read_name ~vtag_read_binding_type:None ~full_type_name ~td_class:(Td_class.of_core_type ty) ~args:[] ~oc_body in pexp_let ~loc Nonrecursive [vtag_read_binding] (pexp_let ~loc Nonrecursive [read_binding] (reader_type_class_record ~loc ~read: (evar ~loc read_name) ~vtag_read:(evar ~loc vtag_read_name))) ;; end (* Generator for binary protocol type classes *) module Generate_tp_class = struct let tp_record ~loc ~writer ~reader ~shape = [%expr { Bin_prot.Type_class. writer = [%e writer] ; reader = [%e reader] ; shape = [%e shape] } ] let bin_tp_class_td td = let loc = td.ptype_loc in let tparam_cnvs = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in "bin_" ^ name.txt) in let mk_pat id = pvar ~loc id in let tparam_patts = List.map tparam_cnvs ~f:mk_pat in let writer = let tparam_exprs = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in [%expr [%e evar ~loc:name.loc @@ "bin_" ^ name.txt] .Bin_prot.Type_class.writer ]) in eapply ~loc (evar ~loc @@ "bin_writer_" ^ td.ptype_name.txt) tparam_exprs in let reader = let tparam_exprs = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in [%expr [%e evar ~loc:name.loc @@ "bin_" ^ name.txt] .Bin_prot.Type_class.reader ]) in eapply ~loc (evar ~loc @@ "bin_reader_" ^ td.ptype_name.txt) tparam_exprs in let shape = let tparam_exprs = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in [%expr [%e evar ~loc:name.loc @@ "bin_" ^ name.txt] .Bin_prot.Type_class.shape ]) in eapply ~loc (evar ~loc @@ "bin_shape_" ^ td.ptype_name.txt) tparam_exprs in let body = tp_record ~loc ~writer ~reader ~shape in value_binding ~loc ~pat:(pvar ~loc @@ "bin_" ^ td.ptype_name.txt) ~expr:(eabstract ~loc tparam_patts body) (* Generate code from type definitions *) let bin_tp_class ~loc ~path:_ (_rec_flag, tds) = let tds = List.map tds ~f:name_type_params_in_td in let bindings = List.map tds ~f:bin_tp_class_td in [ pstr_value ~loc Nonrecursive bindings ] (* Add code generator to the set of known generators *) let gen = Deriving.Generator.make Deriving.Args.empty bin_tp_class let extension ~loc ~path ty = let loc = { loc with loc_ghost = true } in tp_record ~loc ~writer:(Generate_bin_write.extension ~loc ~path ty) ~reader:(Generate_bin_read .extension ~loc ~path ty) ~shape:(Bin_shape_expand.shape_extension ~loc ty) ;; end let bin_shape = Deriving.add "bin_shape" ~str_type_decl:Bin_shape_expand.str_gen ~sig_type_decl:Bin_shape_expand.sig_gen ~extension:(fun ~loc ~path:_ -> Bin_shape_expand.shape_extension ~loc) let () = Deriving.add "bin_digest" ~extension:(fun ~loc ~path:_ -> Bin_shape_expand.digest_extension ~loc) |> Deriving.ignore let bin_write = Deriving.add "bin_write" ~str_type_decl:Generate_bin_write.gen ~sig_type_decl:Sig.bin_write let () = Deriving.add "bin_writer" ~extension:Generate_bin_write.extension |> Deriving.ignore let bin_read = Deriving.add "bin_read" ~str_type_decl:Generate_bin_read.gen ~sig_type_decl:Sig.bin_read let () = Deriving.add "bin_reader" ~extension:Generate_bin_read.extension |> Deriving.ignore let bin_type_class = Deriving.add "bin_type_class" ~str_type_decl:Generate_tp_class.gen ~sig_type_decl:Sig.bin_type_class ~extension:Generate_tp_class.extension let bin_io_named_sig = Deriving.add "bin_io.named_sig.prevent using this in source files" ~sig_type_decl:Sig.named let bin_io = let set = [bin_shape; bin_write; bin_read; bin_type_class] in Deriving.add_alias "bin_io" set ~sig_type_decl:[bin_io_named_sig] ~str_type_decl:(List.rev set) ppx_bin_prot-0.14.0/src/ppx_bin_prot.mli000066400000000000000000000002551366315055700203110ustar00rootroot00000000000000open Ppxlib val bin_shape : Deriving.t val bin_write : Deriving.t val bin_read : Deriving.t val bin_type_class : Deriving.t val bin_io : Deriving.t ppx_bin_prot-0.14.0/test/000077500000000000000000000000001366315055700152715ustar00rootroot00000000000000ppx_bin_prot-0.14.0/test/bin_prot_test.ml000066400000000000000000001127351366315055700205070ustar00rootroot00000000000000open Bigarray open Printf open OUnit open Bin_prot open Common open Utils open ReadError open Type_class open Bin_prot.Std module Bigstring = struct type t = buf let create = create_buf let of_string str = let len = String.length str in let buf = create len in blit_string_buf str buf ~len; buf let length buf = Array1.dim buf end let expect_exc test_exc f = try ignore (f ()); false with | exc -> test_exc exc let expect_bounds_error f = let test_exc = function | Invalid_argument "index out of bounds" -> true | _ -> false in expect_exc test_exc f let expect_buffer_short f = let exc = Buffer_short in expect_exc ((=) exc) f let expect_read_error exp_re exp_pos f = let test_exc = function | Read_error (re, pos) -> exp_re = re && exp_pos = pos | _ -> false in expect_exc test_exc f let expect_no_error f = try ignore (f ()); true with | _ -> false let check_write_bounds_checks name buf write arg = (name ^ ": negative bound") @? expect_bounds_error (fun () -> write buf ~pos:~-1 arg); (name ^ ": positive bound") @? expect_buffer_short (fun () -> write buf ~pos:(Bigstring.length buf) arg) let check_read_bounds_checks name buf read = (name ^ ": negative bound") @? expect_bounds_error (fun () -> read buf ~pos_ref:(ref ~-1)); (name ^ ": positive bound") @? expect_buffer_short (fun () -> read buf ~pos_ref:(ref (Bigstring.length buf))) let check_write_result name buf pos write arg exp_len = let res_pos = write buf ~pos arg in sprintf "%s: returned wrong write position (%d, expected %d)" name res_pos (pos + exp_len) @? (res_pos = pos + exp_len) let check_read_result name buf pos read exp_ret exp_len = let pos_ref = ref pos in (name ^ ": returned wrong result") @? (read buf ~pos_ref = exp_ret); sprintf "%s: returned wrong read position (%d, expected %d)" name !pos_ref (pos + exp_len) @? (!pos_ref - pos = exp_len) let check_all_args tp_name read write buf args = let write_name = "write_" ^ tp_name ^ " " in let read_name = "read_" ^ tp_name ^ " " in let buf_len = Bigstring.length buf in let act (arg, str_arg, arg_len) = let write_name_arg = write_name ^ str_arg in let read_name_arg = read_name ^ str_arg in for pos = 0 to 8 do check_write_bounds_checks write_name buf write arg; check_read_bounds_checks read_name buf read; check_write_result write_name_arg buf pos write arg arg_len; check_read_result read_name_arg buf pos read arg arg_len; done; (write_name_arg ^ ": write failed near bound") @? expect_no_error (fun () -> write buf ~pos:(buf_len - arg_len) arg); (read_name_arg ^ ": read failed near bound") @? expect_no_error (fun () -> if read buf ~pos_ref:(ref (buf_len - arg_len)) <> arg then failwith (read_name_arg ^ ": read near bound returned wrong result")); let small_buf = Array1.sub buf 0 (buf_len - 1) in (write_name_arg ^ ": write exceeds bound") @? expect_buffer_short (fun () -> write small_buf ~pos:(buf_len - arg_len) arg); (read_name_arg ^ ": read exceeds bound") @? expect_buffer_short (fun () -> read small_buf ~pos_ref:(ref (buf_len - arg_len))) in List.iter act args let mk_buf n = let bstr = Bigstring.create n in for i = 0 to n - 1 do bstr.{i} <- '\255' done; bstr let check_all extra_buf_size tp_name read write args = let buf_len = extra_buf_size + 8 in let buf = mk_buf buf_len in match args with | [] -> assert false | (arg, _, _) :: _ -> let write_name = "write_" ^ tp_name in check_write_bounds_checks write_name buf write arg; let read_name = "read_" ^ tp_name in check_read_bounds_checks read_name buf read; check_all_args tp_name read write buf args let random_string n = String.init n (fun _ -> Char.chr (Random.int 256)) let mk_int_test ~n ~len = n, Printf.sprintf "%x" n, len let mk_nat0_test ~n ~len = Nat0.of_int n, Printf.sprintf "%x" n, len let mk_float_test n = n, Printf.sprintf "%g" n, 8 let mk_int32_test ~n ~len = n, Printf.sprintf "%lx" n, len let mk_int64_test ~n ~len = n, Printf.sprintf "%Lx" n, len let mk_nativeint_test ~n ~len = n, Printf.sprintf "%nx" n, len let mk_gen_float_vec tp n = let vec = Array1.create tp fortran_layout n in for i = 1 to n do vec.{i} <- float i done; vec let mk_float32_vec = mk_gen_float_vec float32 let mk_float64_vec = mk_gen_float_vec float64 let mk_bigstring n = let bstr = Array1.create char c_layout n in for i = 0 to n - 1 do bstr.{i} <- Char.chr (Random.int 256) done; bstr let mk_gen_float_mat tp m n = let mat = Array2.create tp fortran_layout m n in let fn = float m in for c = 1 to n do let ofs = float (c - 1) *. fn in for r = 1 to m do mat.{r, c} <- ofs +. float r done; done; mat let mk_float32_mat = mk_gen_float_mat float32 let mk_float64_mat = mk_gen_float_mat float64 let test = "Bin_prot" >::: [ "unit" >:: (fun () -> check_all 1 "unit" Read.bin_read_unit Write.bin_write_unit [ ((), "()", 1); ]; ); "bool" >:: (fun () -> check_all 1 "bool" Read.bin_read_bool Write.bin_write_bool [ (true, "true", 1); (false, "false", 1); ]; ); "string" >:: (fun () -> check_all 66000 "string" Read.bin_read_string Write.bin_write_string [ ("", "\"\"", 1); (random_string 1, "random 1", 1 + 1); (random_string 10, "random 10", 10 + 1); (random_string 127, "random 127", 127 + 1); (random_string 128, "long 128", 128 + 3); (random_string 65535, "long 65535", 65535 + 3); (random_string 65536, "long 65536", 65536 + 5); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\252\255\255\000" in "String_too_long" @? expect_read_error String_too_long 0 (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\251\255\255\000" in "StringMaximimum" @? expect_buffer_short (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\248\255\255\255\255\255\255\001" in "String_too_long" @? expect_read_error String_too_long 0 (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\247\255\255\255\255\255\255\001" in "StringMaximimum" @? expect_buffer_short (fun () -> Read.bin_read_string bad_buf ~pos_ref:(ref 0)) ); "char" >:: (fun () -> check_all 1 "char" Read.bin_read_char Write.bin_write_char [ ('x', "x", 1); ('y', "y", 1); ]; ); "int" >:: (fun () -> let small_int_tests = [ mk_int_test ~n:~-0x01 ~len:2; mk_int_test ~n: 0x00 ~len:1; mk_int_test ~n: 0x01 ~len:1; mk_int_test ~n:0x7e ~len:1; mk_int_test ~n:0x7f ~len:1; mk_int_test ~n:0x80 ~len:3; mk_int_test ~n:0x81 ~len:3; mk_int_test ~n:0x7ffe ~len:3; mk_int_test ~n:0x7fff ~len:3; mk_int_test ~n:0x8000 ~len:5; mk_int_test ~n:0x8001 ~len:5; mk_int_test ~n:0x3ffffffe ~len:5; mk_int_test ~n:0x3fffffff ~len:5; mk_int_test ~n:~-0x7f ~len:2; mk_int_test ~n:~-0x80 ~len:2; mk_int_test ~n:~-0x81 ~len:3; mk_int_test ~n:~-0x82 ~len:3; mk_int_test ~n:~-0x7fff ~len:3; mk_int_test ~n:~-0x8000 ~len:3; mk_int_test ~n:~-0x8001 ~len:5; mk_int_test ~n:~-0x8002 ~len:5; mk_int_test ~n:~-0x40000001 ~len:5; mk_int_test ~n:~-0x40000000 ~len:5; ] in let all_int_tests = if Sys.word_size = 32 then small_int_tests else mk_int_test ~n:(int_of_string "0x7ffffffe") ~len:5 :: mk_int_test ~n:(int_of_string "0x7fffffff") ~len:5 :: mk_int_test ~n:(int_of_string "0x80000000") ~len:9 :: mk_int_test ~n:(int_of_string "0x80000001") ~len:9 :: mk_int_test ~n:max_int ~len:9 :: mk_int_test ~n:(int_of_string "-0x000000007fffffff") ~len:5 :: mk_int_test ~n:(int_of_string "-0x0000000080000000") ~len:5 :: mk_int_test ~n:(int_of_string "-0x0000000080000001") ~len:9 :: mk_int_test ~n:(int_of_string "-0x0000000080000002") ~len:9 :: mk_int_test ~n:min_int ~len:9 :: small_int_tests in check_all 9 "int" Read.bin_read_int Write.bin_write_int all_int_tests; let bad_buf = Bigstring.of_string "\132" in "Int_code" @? expect_read_error Int_code 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\255\255\255\064" in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\255\191" in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\191" in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int bad_buf ~pos_ref:(ref 0)) ); "nat0" >:: (fun () -> let small_int_tests = [ mk_nat0_test ~n:0x00 ~len:1; mk_nat0_test ~n:0x01 ~len:1; mk_nat0_test ~n:0x7e ~len:1; mk_nat0_test ~n:0x7f ~len:1; mk_nat0_test ~n:0x80 ~len:3; mk_nat0_test ~n:0x81 ~len:3; mk_nat0_test ~n:0x7fff ~len:3; mk_nat0_test ~n:0x8000 ~len:3; mk_nat0_test ~n:0xffff ~len:3; mk_nat0_test ~n:0x10000 ~len:5; mk_nat0_test ~n:0x10001 ~len:5; mk_nat0_test ~n:0x3ffffffe ~len:5; mk_nat0_test ~n:0x3fffffff ~len:5; ] in let all_int_tests = if Sys.word_size = 32 then small_int_tests else mk_nat0_test ~n:(int_of_string "0x7fffffff") ~len:5 :: mk_nat0_test ~n:(int_of_string "0x80000000") ~len:5 :: mk_nat0_test ~n:(int_of_string "0xffffffff") ~len:5 :: mk_nat0_test ~n:(int_of_string "0x100000000") ~len:9 :: mk_nat0_test ~n:(int_of_string "0x100000001") ~len:9 :: mk_nat0_test ~n:max_int ~len:9 :: small_int_tests in check_all 9 "nat0" Read.bin_read_nat0 Write.bin_write_nat0 all_int_tests; let bad_buf = Bigstring.of_string "\128" in "Nat0_code" @? expect_read_error Nat0_code 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\255\255\255\064" in "Nat0_overflow" @? expect_read_error Nat0_overflow 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\064" in "Nat0_overflow" @? expect_read_error Nat0_overflow 0 (fun () -> Read.bin_read_nat0 bad_buf ~pos_ref:(ref 0)) ); "float" >:: (fun () -> let float_tests = [ mk_float_test 0.; mk_float_test (-0.); mk_float_test (-1.); mk_float_test 1.; mk_float_test infinity; mk_float_test (-.infinity); mk_float_test 1e-310; (* subnormal *) mk_float_test (-1e-310); (* subnormal *) mk_float_test 3.141595; ] in check_all 8 "float" Read.bin_read_float Write.bin_write_float float_tests ); "int32" >:: (fun () -> let int32_tests = [ mk_int32_test ~n:(-0x01l) ~len:2; mk_int32_test ~n: 0x00l ~len:1; mk_int32_test ~n: 0x01l ~len:1; mk_int32_test ~n:0x7el ~len:1; mk_int32_test ~n:0x7fl ~len:1; mk_int32_test ~n:0x80l ~len:3; mk_int32_test ~n:0x81l ~len:3; mk_int32_test ~n:0x7ffel ~len:3; mk_int32_test ~n:0x7fffl ~len:3; mk_int32_test ~n:0x8000l ~len:5; mk_int32_test ~n:0x8001l ~len:5; mk_int32_test ~n:0x7ffffffel ~len:5; mk_int32_test ~n:0x7fffffffl ~len:5; mk_int32_test ~n:(-0x7fl) ~len:2; mk_int32_test ~n:(-0x80l) ~len:2; mk_int32_test ~n:(-0x81l) ~len:3; mk_int32_test ~n:(-0x82l) ~len:3; mk_int32_test ~n:(-0x7fffl) ~len:3; mk_int32_test ~n:(-0x8000l) ~len:3; mk_int32_test ~n:(-0x8001l) ~len:5; mk_int32_test ~n:(-0x8002l) ~len:5; mk_int32_test ~n:(-0x80000001l) ~len:5; mk_int32_test ~n:(-0x80000000l) ~len:5; ] in check_all 5 "int32" Read.bin_read_int32 Write.bin_write_int32 int32_tests; let bad_buf = Bigstring.of_string "\132" in "Int32_code" @? expect_read_error Int32_code 0 (fun () -> Read.bin_read_int32 bad_buf ~pos_ref:(ref 0)) ); "int64" >:: (fun () -> let int64_tests = [ mk_int64_test ~n:(-0x01L) ~len:2; mk_int64_test ~n: 0x00L ~len:1; mk_int64_test ~n: 0x01L ~len:1; mk_int64_test ~n:0x7eL ~len:1; mk_int64_test ~n:0x7fL ~len:1; mk_int64_test ~n:0x80L ~len:3; mk_int64_test ~n:0x81L ~len:3; mk_int64_test ~n:0x7ffeL ~len:3; mk_int64_test ~n:0x7fffL ~len:3; mk_int64_test ~n:0x8000L ~len:5; mk_int64_test ~n:0x8001L ~len:5; mk_int64_test ~n:0x7ffffffeL ~len:5; mk_int64_test ~n:0x7fffffffL ~len:5; mk_int64_test ~n:0x80000000L ~len:9; mk_int64_test ~n:0x80000001L ~len:9; mk_int64_test ~n:0x7ffffffffffffffeL ~len:9; mk_int64_test ~n:0x7fffffffffffffffL ~len:9; mk_int64_test ~n:(-0x7fL) ~len:2; mk_int64_test ~n:(-0x80L) ~len:2; mk_int64_test ~n:(-0x81L) ~len:3; mk_int64_test ~n:(-0x82L) ~len:3; mk_int64_test ~n:(-0x7fffL) ~len:3; mk_int64_test ~n:(-0x8000L) ~len:3; mk_int64_test ~n:(-0x8001L) ~len:5; mk_int64_test ~n:(-0x8002L) ~len:5; mk_int64_test ~n:(-0x7fffffffL) ~len:5; mk_int64_test ~n:(-0x80000000L) ~len:5; mk_int64_test ~n:(-0x80000001L) ~len:9; mk_int64_test ~n:(-0x80000002L) ~len:9; mk_int64_test ~n:(-0x8000000000000001L) ~len:9; mk_int64_test ~n:(-0x8000000000000000L) ~len:9; ] in check_all 9 "int64" Read.bin_read_int64 Write.bin_write_int64 int64_tests; let bad_buf = Bigstring.of_string "\132" in "Int64_code" @? expect_read_error Int64_code 0 (fun () -> Read.bin_read_int64 bad_buf ~pos_ref:(ref 0)) ); "nativeint" >:: (fun () -> let small_nativeint_tests = [ mk_nativeint_test ~n:(-0x01n) ~len:2; mk_nativeint_test ~n: 0x00n ~len:1; mk_nativeint_test ~n: 0x01n ~len:1; mk_nativeint_test ~n:0x7en ~len:1; mk_nativeint_test ~n:0x7fn ~len:1; mk_nativeint_test ~n:0x80n ~len:3; mk_nativeint_test ~n:0x81n ~len:3; mk_nativeint_test ~n:0x7ffen ~len:3; mk_nativeint_test ~n:0x7fffn ~len:3; mk_nativeint_test ~n:0x8000n ~len:5; mk_nativeint_test ~n:0x8001n ~len:5; mk_nativeint_test ~n:0x7ffffffen ~len:5; mk_nativeint_test ~n:0x7fffffffn ~len:5; mk_nativeint_test ~n:(-0x7fn) ~len:2; mk_nativeint_test ~n:(-0x80n) ~len:2; mk_nativeint_test ~n:(-0x81n) ~len:3; mk_nativeint_test ~n:(-0x82n) ~len:3; mk_nativeint_test ~n:(-0x7fffn) ~len:3; mk_nativeint_test ~n:(-0x8000n) ~len:3; mk_nativeint_test ~n:(-0x8001n) ~len:5; mk_nativeint_test ~n:(-0x8002n) ~len:5; mk_nativeint_test ~n:(-0x7fffffffn) ~len:5; mk_nativeint_test ~n:(-0x80000000n) ~len:5; ] in let nativeint_tests = if Sys.word_size = 32 then small_nativeint_tests else mk_nativeint_test ~n:0x80000000n ~len:9 :: mk_nativeint_test ~n:0x80000001n ~len:9 :: mk_nativeint_test ~n:(-0x80000001n) ~len:9 :: mk_nativeint_test ~n:(-0x80000002n) ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "0x7ffffffffffffffe") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "0x7fffffffffffffff") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000001") ~len:9 :: mk_nativeint_test ~n:(Nativeint.of_string "-0x8000000000000000") ~len:9 :: small_nativeint_tests in let size = if Sys.word_size = 32 then 5 else 9 in check_all size "nativeint" Read.bin_read_nativeint Write.bin_write_nativeint nativeint_tests; let bad_buf = Bigstring.of_string "\251" in "Nativeint_code" @? expect_read_error Nativeint_code 0 (fun () -> Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0)); if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\255\255" in "Nativeint_code (overflow)" @? expect_read_error Nativeint_code 0 (fun () -> Read.bin_read_nativeint bad_buf ~pos_ref:(ref 0)) ); "ref" >:: (fun () -> check_all 1 "ref" (Read.bin_read_ref Read.bin_read_int) (Write.bin_write_ref Write.bin_write_int) [(ref 42, "ref 42", 1)]; ); "option" >:: (fun () -> check_all 2 "option" (Read.bin_read_option Read.bin_read_int) (Write.bin_write_option Write.bin_write_int) [ (Some 42, "Some 42", 2); (None, "None", 1); ]; ); "pair" >:: (fun () -> check_all 9 "pair" (Read.bin_read_pair Read.bin_read_float Read.bin_read_int) (Write.bin_write_pair Write.bin_write_float Write.bin_write_int) [((3.141, 42), "(3.141, 42)", 9)]; ); "triple" >:: (fun () -> check_all 14 "triple" (Read.bin_read_triple Read.bin_read_float Read.bin_read_int Read.bin_read_string) (Write.bin_write_triple Write.bin_write_float Write.bin_write_int Write.bin_write_string) [((3.141, 42, "test"), "(3.141, 42, \"test\")", 14)]; ); "list" >:: (fun () -> check_all 12 "list" (Read.bin_read_list Read.bin_read_int) (Write.bin_write_list Write.bin_write_int) [ ([42; -1; 200; 33000], "[42; -1; 200; 33000]", 12); ([], "[]", 1); ]; ); "array" >:: (fun () -> let bin_read_int_array = Read.bin_read_array Read.bin_read_int in check_all 12 "array" bin_read_int_array (Write.bin_write_array Write.bin_write_int) [ ([| 42; -1; 200; 33000 |], "[|42; -1; 200; 33000|]", 12); ([||], "[||]", 1); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\000\000\064\000" in "Array_too_long" @? expect_read_error Array_too_long 0 (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\063\000" in "ArrayMaximimum" @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in "Array_too_long" @? expect_read_error Array_too_long 0 (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in "ArrayMaximimum" @? expect_buffer_short (fun () -> bin_read_int_array bad_buf ~pos_ref:(ref 0)) ); "float_array" >:: (fun () -> check_all 33 "float_array" Read.bin_read_float_array Write.bin_write_float_array [ ([| 42.; -1.; 200.; 33000. |], "[|42.; -1.; 200.; 33000.|]", 33); ([||], "[||]", 1); ]; if Sys.word_size = 32 then let bad_buf = Bigstring.of_string "\253\000\000\032\000" in "Array_too_long (float)" @? expect_read_error Array_too_long 0 (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\253\255\255\031\000" in "ArrayMaximimum (float)" @? expect_buffer_short (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)) else let bad_buf = Bigstring.of_string "\252\000\000\000\000\000\000\064\000" in "Array_too_long (float)" @? expect_read_error Array_too_long 0 (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)); let bad_buf = Bigstring.of_string "\252\255\255\255\255\255\255\063\000" in "ArrayMaximimum (float)" @? expect_buffer_short (fun () -> Read.bin_read_float_array bad_buf ~pos_ref:(ref 0)); (* Test that the binary forms of [float array] and [float_array] are the same *) let arrays = let rec loop acc len = if len < 0 then acc else let a = Array.init len (fun i -> float_of_int (i + len)) in let txt = Printf.sprintf "float array, len = %d" len in let buf = len * 8 + Size.bin_size_nat0 (Nat0.unsafe_of_int len) in loop ((a, txt, buf) :: acc) (len - 1) in loop [] 255 in let len = 255 * 8 + Size.bin_size_nat0 (Nat0.unsafe_of_int 255) in check_all len "float array -> float_array" Read.bin_read_float_array (Write.bin_write_array Write.bin_write_float) arrays; check_all len "float_array -> float array" (Read.bin_read_array Read.bin_read_float) (Write.bin_write_float_array) arrays; (* Check that the canonical closures used in the short circuit test of float arrays are indeed allocated closures as opposed to [compare] for example which is a primitive. Even if it looks like a tautology, it is not. (for example, [compare == compare] is false. *) assert (bin_write_float == bin_write_float); assert (bin_read_float == bin_read_float); assert (bin_size_float == bin_size_float); ); "hashtbl" >:: (fun () -> let bindings = List.rev [(42, 3.); (17, 2.); (42, 4.)] in let htbl = Hashtbl.create (List.length bindings) in List.iter (fun (k, v) -> Hashtbl.add htbl k v) bindings; check_all 28 "hashtbl" (Read.bin_read_hashtbl Read.bin_read_int Read.bin_read_float) (Write.bin_write_hashtbl Write.bin_write_int Write.bin_write_float) [ (htbl, "[(42, 3.); (17, 2.); (42, 4.)]", 28); (Hashtbl.create 0, "[]", 1) ]; ); "float32_vec" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n * 4 in let vec = mk_float32_vec n in check_all size "float32_vec" Read.bin_read_float32_vec Write.bin_write_float32_vec [ (vec, "[| ... |]", size); (mk_float32_vec 0, "[||]", 1); ] ); "float64_vec" >:: (fun () -> let n = 127 in let header = 1 in let size = header + n * 8 in let vec = mk_float64_vec n in check_all size "float64_vec" Read.bin_read_float64_vec Write.bin_write_float64_vec [ (vec, "[| ... |]", size); (mk_float64_vec 0, "[||]", 1); ] ); "vec" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n * 8 in let vec = mk_float64_vec n in check_all size "vec" Read.bin_read_vec Write.bin_write_vec [ (vec, "[| ... |]", size); (mk_float64_vec 0, "[||]", 1); ] ); "float32_mat" >:: (fun () -> let m = 128 in let n = 127 in let header = 3 + 1 in let size = header + m * n * 4 in let mat = mk_float32_mat m n in check_all size "float32_mat" Read.bin_read_float32_mat Write.bin_write_float32_mat [ (mat, "[| ... |]", size); (mk_float32_mat 0 0, "[||]", 2); ] ); "float64_mat" >:: (fun () -> let m = 10 in let n = 12 in let header = 1 + 1 in let size = header + m * n * 8 in let mat = mk_float64_mat m n in check_all size "float64_mat" Read.bin_read_float64_mat Write.bin_write_float64_mat [ (mat, "[| ... |]", size); (mk_float64_mat 0 0, "[||]", 2); ] ); "mat" >:: (fun () -> let m = 128 in let n = 128 in let header = 3 + 3 in let size = header + m * n * 8 in let mat = mk_float64_mat m n in check_all size "mat" Read.bin_read_mat Write.bin_write_mat [ (mat, "[| ... |]", size); (mk_float64_mat 0 0, "[||]", 2); ] ); "bigstring" >:: (fun () -> let n = 128 in let header = 3 in let size = header + n in let bstr = mk_bigstring n in check_all size "bigstring" Read.bin_read_bigstring Write.bin_write_bigstring [ (bstr, "[| ... |]", size); (mk_bigstring 0, "[||]", 1); ] ); "bigstring (big)" >:: (fun () -> (* [n] is a 16bits integer that will be serialized differently depending on whether it is considered as an integer or an unsigned integer. *) let n = 40_000 in let header = 3 in let size = header + n in let bstr = mk_bigstring n in check_all size "bigstring" Read.bin_read_bigstring Write.bin_write_bigstring [ (bstr, "[| ... |]", size); (mk_bigstring 0, "[||]", 1); ] ); "variant_tag" >:: (fun () -> check_all 4 "variant_tag" Read.bin_read_variant_int Write.bin_write_variant_int [ ((Obj.magic `Foo : int), "`Foo", 4); ((Obj.magic `Bar : int), "`Bar", 4); ]; let bad_buf = Bigstring.of_string "\000\000\000\000" in "Variant_tag" @? expect_read_error Variant_tag 0 (fun () -> Read.bin_read_variant_int bad_buf ~pos_ref:(ref 0)) ); "int64_bits" >:: (fun () -> check_all 8 "int64_bits" Read.bin_read_int64_bits Write.bin_write_int64_bits [ (Int64.min_int, "min_int", 8); (Int64.add Int64.min_int Int64.one, "min_int + 1", 8); (Int64.minus_one, "-1", 8); (Int64.zero, "0", 8); (Int64.one, "1", 8); (Int64.sub Int64.max_int Int64.one, "max_int - 1", 8); (Int64.max_int, "max_int", 8); ]; ); "int_64bit" >:: (fun () -> check_all 8 "int_64bit" Read.bin_read_int_64bit Write.bin_write_int_64bit [ (min_int, "min_int", 8); (min_int + 1, "min_int + 1", 8); (-1, "-1", 8); (0, "0", 8); (1, "1", 8); (max_int - 1, "max_int - 1", 8); (max_int, "max_int", 8); ]; let bad_buf_max = bin_dump bin_int64_bits.writer (Int64.succ (Int64.of_int max_int)) in "Int_overflow (positive)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int_64bit bad_buf_max ~pos_ref:(ref 0)); let bad_buf_min = bin_dump bin_int64_bits.writer (Int64.pred (Int64.of_int min_int)) in "Int_overflow (negative)" @? expect_read_error Int_overflow 0 (fun () -> Read.bin_read_int_64bit bad_buf_min ~pos_ref:(ref 0)); ); "network16_int" >:: (fun () -> check_all 2 "network16_int" Read.bin_read_network16_int Write.bin_write_network16_int [ (* No negative numbers - ambiguous on 64bit platforms *) (0, "0", 2); (1, "1", 2); ]; ); "network32_int" >:: (fun () -> check_all 4 "network32_int" Read.bin_read_network32_int Write.bin_write_network32_int [ (* No negative numbers - ambiguous on 64bit platforms *) (0, "0", 4); (1, "1", 4); ]; ); "network32_int32" >:: (fun () -> check_all 4 "network32_int32" Read.bin_read_network32_int32 Write.bin_write_network32_int32 [ (-1l, "-1", 4); (0l, "0", 4); (1l, "1", 4); ]; ); "network64_int" >:: (fun () -> check_all 8 "network64_int" Read.bin_read_network64_int Write.bin_write_network64_int [ (-1, "-1", 8); (0, "0", 8); (1, "1", 8); ]; ); "network64_int64" >:: (fun () -> check_all 8 "network64_int64" Read.bin_read_network64_int64 Write.bin_write_network64_int64 [ (-1L, "-1", 8); (0L, "0", 8); (1L, "1", 8); ]; ); ] module Common = struct type tuple = float * string * int64 [@@deriving bin_io] type 'a record = { a : int; b : 'a; c : 'a option } [@@deriving bin_io] type 'a singleton_record = { y : 'a } [@@deriving bin_io] type 'a inline_record = | IR of { mutable ir_a : int; ir_b : 'a; ir_c : 'a option } | Other of int [@@deriving bin_io] type 'a sum = Foo | Bar of int | Bla of 'a * string [@@deriving bin_io] type 'a variant = [ `Foo | `Bar of int | `Bla of 'a * string ] [@@deriving bin_io] type 'a poly_app = (tuple * int singleton_record * 'a record * 'a inline_record) variant sum list [@@deriving bin_io] type 'a rec_t1 = RecFoo1 of 'a rec_t2 and 'a rec_t2 = RecFoo2 of 'a poly_app * 'a rec_t1 | RecNone [@@deriving bin_io] type 'a poly_id = 'a rec_t1 [@@deriving bin_io] type el = float poly_id [@@deriving bin_io] type els = el array [@@deriving bin_io] module Wildcard : sig type _ transparent = int [@@deriving bin_io] type _ opaque [@@deriving bin_io] val opaque_examples : int opaque list end = struct type _ transparent = int [@@deriving bin_io] type 'a opaque = 'a option [@@deriving bin_io] let opaque_examples = [None; Some 0; Some 1] end let test = "Bin_prot_common" >::: [ "Utils.bin_dump" >:: (fun () -> let el = let record = { a = 17; b = 2.78; c = None } in let inline_record = IR {ir_a = 18; ir_b = 43210.; ir_c = None} in let arg = (3.1, "foo", 42L), { y = 4321 }, record, inline_record in let variant = `Bla (arg, "fdsa") in let sum = Bla (variant, "asdf") in let poly_app = [ sum ] in RecFoo1 (RecFoo2 (poly_app, RecFoo1 RecNone)) in let els = Array.make 10 el in let buf = bin_dump ~header:true bin_els.writer els in let pos_ref = ref 0 in let els_len = Read.bin_read_int_64bit buf ~pos_ref in "pos_ref for length incorrect" @? (!pos_ref = 8); "els_len disagrees with bin_size" @? (els_len = bin_size_els els); let new_els = bin_read_els buf ~pos_ref in "new_els and els not equal" @? (els = new_els) ); ] end module Inline = struct let compatible xs derived_tc inline_writer inline_reader inline_tc = ListLabels.map xs ~f:(fun x -> "" >:: fun () -> "incorrect size from inline writer" @? (derived_tc.writer.size x = inline_writer.size x); "incorrect size from inline type class" @? (derived_tc.writer.size x = inline_tc.writer.size x); let buf = bin_dump derived_tc.writer x in "incorrect bin dump from inline writer" @? (buf = bin_dump inline_writer x); "incorrect bin dump from inline type class" @? (buf = bin_dump inline_tc.writer x); let val_and_len reader = let pos_ref = ref 0 in let x = reader.read buf ~pos_ref in (x, !pos_ref) in let (_, len) = val_and_len derived_tc.reader in let (x', len') = val_and_len inline_reader in "incorrect value from inline reader" @? (x = x'); "incorrect length from inline reader" @? (len = len'); let (x', len') = val_and_len inline_tc.reader in "incorrect value from inline type class" @? (x = x'); "incorrect length from inline type class" @? (len = len'); ) ;; type variant_extension = [ float Common.variant | `Baz of int * float ] [@@deriving bin_io] let test = "Bin_prot.Inline" >::: [ "simple tuple" >::: compatible [(50.5, "hello", 1234L)] Common.bin_tuple [%bin_writer : Common.tuple] [%bin_reader : Common.tuple] [%bin_type_class : Common.tuple]; "redefine tuple" >::: compatible [(50.5, "hello", 1234L)] Common.bin_tuple [%bin_writer : float * string * int64] [%bin_reader : float * string * int64] [%bin_type_class : float * string * int64]; "simple variant" >::: compatible [`Foo; `Bar 8; `Bla (33.3, "world")] (Common.bin_variant bin_float) [%bin_writer : float Common.variant] [%bin_reader : float Common.variant] [%bin_type_class : float Common.variant]; "redefine variant" >::: compatible [`Foo; `Bar 8; `Bla (33.3, "world")] (Common.bin_variant bin_float) [%bin_writer : [`Foo | `Bar of int | `Bla of float * string]] [%bin_reader : [`Foo | `Bar of int | `Bla of float * string]] [%bin_type_class : [`Foo | `Bar of int | `Bla of float * string]]; "variant_extension" >::: compatible [`Foo; `Bar 8; `Bla (33.3, "world"); `Baz (17, 17.71)] bin_variant_extension [%bin_writer : [ float Common.variant | `Baz of int * float ]] [%bin_reader : [ float Common.variant | `Baz of int * float ]] [%bin_type_class : [ float Common.variant | `Baz of int * float ]]; "sub variant" >::: compatible [ { Common. y = `Foo }; { y = `Bar 42 }; { y = `Bla (42, "world") } ] (Common.bin_singleton_record (Common.bin_variant bin_int)) [%bin_writer : [`Foo | `Bar of int | `Bla of int * string] Common.singleton_record] [%bin_reader : [`Foo | `Bar of int | `Bla of int * string] Common.singleton_record] [%bin_type_class : [`Foo | `Bar of int | `Bla of int * string] Common.singleton_record]; "transparent wildcard" >::: compatible [ 1; 2; 3 ] (Common.Wildcard.bin_transparent bin_string) [%bin_writer : string Common.Wildcard.transparent] [%bin_reader : string Common.Wildcard.transparent] [%bin_type_class : string Common.Wildcard.transparent]; "opaque wildcard" >::: compatible Common.Wildcard.opaque_examples (Common.Wildcard.bin_opaque bin_int) [%bin_writer : int Common.Wildcard.opaque] [%bin_reader : int Common.Wildcard.opaque] [%bin_type_class : int Common.Wildcard.opaque]; ] ;; end ppx_bin_prot-0.14.0/test/bin_prot_test_nonrec.ml000066400000000000000000000010371366315055700220430ustar00rootroot00000000000000open Bin_prot.Std type t = float [@@deriving bin_io] module M : sig type t = float [@@deriving bin_io] end = struct type nonrec t = t [@@deriving bin_io] end module M1 : sig type t = float list [@@deriving bin_io] end = struct type nonrec t = t list [@@deriving bin_io] end module M2 : sig type nonrec t = t list [@@deriving bin_io] end = struct type nonrec t = t list [@@deriving bin_io] end module M3 : sig type nonrec t = [ `A of t ] [@@deriving bin_io] end = struct type nonrec t = [ `A of t ] [@@deriving bin_io] end ppx_bin_prot-0.14.0/test/blob_test.ml000066400000000000000000000057631366315055700176130ustar00rootroot00000000000000open Bin_prot.Std open Bin_prot.Blob module Mystery = struct type t = { name : string ; age : int ; favorite_colors : string list } [@@deriving bin_io] let value = { name = "Drew" ; age = 25 ; favorite_colors = [ "Blue"; "Yellow" ] } end module T = struct type 'a t = { header : string ; mystery : 'a ; footer : string } [@@deriving bin_io] let value mystery = { header = "header" ; mystery ; footer = "footer" } end (* Some Rumsfeldian tests follow... *) module Known = struct type nonrec t = Mystery.t t T.t [@@deriving bin_io] let value = T.value Mystery.value end module Unknown = struct type t = Opaque.Bigstring.t T.t [@@deriving bin_io] let value = T.value (Opaque.Bigstring.to_opaque Mystery.value Mystery.bin_writer_t) end let convert bin_writer bin_reader value = let buffer = Bin_prot.Utils.bin_dump bin_writer value in bin_reader.Bin_prot.Type_class.read buffer ~pos_ref:(ref 0) let roundtrip { Bin_prot.Type_class. reader; writer; shape = _ } value = assert (convert writer reader value = value) module Dropped = struct type t = Ignored.t T.t [@@deriving bin_read] let bin_size_t = T.bin_size_t Ignored.bin_size_t end let bigstring_to_string bigstring = let len = Bigarray.Array1.dim bigstring in String.init len (fun i -> bigstring.{i}) let test = let open OUnit in "Blob_test" >::: [ "roundtrip known" >:: (fun () -> roundtrip Known.bin_t Known.value); "roundtrip unknown" >:: (fun () -> roundtrip Unknown.bin_t Unknown.value); "opaque and wrapped serialize the same way" >:: (fun () -> let known_buffer = Bin_prot.Utils.bin_dump Known.bin_writer_t Known.value in let unknown_buffer = Bin_prot.Utils.bin_dump Unknown.bin_writer_t Unknown.value in let known_s = bigstring_to_string known_buffer in let unknown_s = bigstring_to_string unknown_buffer in if known_s <> unknown_s then failwith (Printf.sprintf "%s <> %s" known_s unknown_s)); "serialized wrapped deserializes to the expected opaque" >:: (fun () -> let unknown_from_known = convert Known.bin_writer_t Unknown.bin_reader_t Known.value in assert (Unknown.value = unknown_from_known)); "serialized opaque deserializes to the expected wrapped" >:: (fun () -> let known_from_unknown = convert Unknown.bin_writer_t Known.bin_reader_t Unknown.value in assert (Known.value = known_from_unknown)); "Dropped" >:: (fun () -> let buffer = Bin_prot.Utils.bin_dump Known.bin_writer_t Known.value in let value = Dropped.bin_reader_t.Bin_prot.Type_class.read buffer ~pos_ref:(ref 0) in let ignored = value.mystery in (* The value deserialized with [Dropped] agrees with the value serialized by [Known], except for the ignored bit. *) assert ({ Known.value with mystery = ignored} = value ); (* [Dropped] remembered the size of the ignored data. *) assert (Dropped.bin_size_t value = Known.bin_size_t Known.value)); ] ppx_bin_prot-0.14.0/test/dune000066400000000000000000000004111366315055700161430ustar00rootroot00000000000000(alias (name runtest) (deps test_runner.exe) (action (bash ./test_runner.exe))) (executables (names example test_runner mac_test microbench bin_prot_test_nonrec) (libraries bin_prot core core_bench oUnit) (preprocess (pps ppx_jane -allow-unannotated-ignores)))ppx_bin_prot-0.14.0/test/example.ml000066400000000000000000000037171366315055700172660ustar00rootroot00000000000000open Bin_prot.Std module type S = sig end include (struct type t = int [@@deriving bin_io] end : S) include (struct type t = int32 [@@deriving bin_io] end : S) include (struct type t = int64 [@@deriving bin_io] end : S) include (struct type t = nativeint [@@deriving bin_io] end : S) include (struct type t = float [@@deriving bin_io] end : S) include (struct type t = char [@@deriving bin_io] end : S) include (struct type t = int list [@@deriving bin_io] end : S) include (struct type t = float array [@@deriving bin_io] end : S) include (struct type t = int64 array [@@deriving bin_io] end : S) include (struct type t = int * float * char [@@deriving bin_io] end : S) include (struct type t = A | B [@@deriving bin_io] type u = C | D | E of t [@@deriving bin_io] end : S) include (struct type t = [ `A | `B ] [@@deriving bin_io] type u = [ `C | `D | `E of t ] [@@deriving bin_io] end : S) include (struct type a = [ `A1 | `A2 ] [@@deriving bin_io] type b = [ `B1 | `B2 ] [@@deriving bin_io] type t = [ a | b ] [@@deriving bin_io] end : S) include (struct type t = { foo : char; bar : int; baz : string; } [@@deriving bin_io] end : S) include (struct type t = | A of { foo : char; bar : int; baz : string; } | B of int | C of char * int * string [@@deriving bin_io] end : S) include (struct type 'a t = 'a [@@deriving bin_io] end : S) include (struct type 'a t = 'a * int [@@deriving bin_io] end : S) include (struct type ('a, 'b) t = 'a * 'b [@@deriving bin_io] end : S) include (struct type 'a t = 'a constraint 'a = [< `A | `B ] [@@deriving bin_io] type 'a u = [`A] t [@@deriving bin_io] end : S) include (struct type 'a t = { foo : 'a; bar : int; } [@@deriving bin_io] end : S) include (struct type 'a t = | A of { foo : 'a; bar : int; } | B of 'a | C [@@deriving bin_io] end : S) ppx_bin_prot-0.14.0/test/mac_test.ml000066400000000000000000000057441366315055700174340ustar00rootroot00000000000000open Printf open Bin_prot open Common open Bin_prot.Std (* Checks correct behavior for empty types *) type empty [@@deriving bin_io] module type S = sig (* Checks correct behavior for type signatures with variance annotations. *) type +'a t [@@deriving bin_io] end module PolyInhTest = struct type x = [ `X1 | `X2 ] [@@deriving bin_io] type y = [ `Y1 | `Y2 ] [@@deriving bin_io] type xy = [ x | `FOO | `Bar of int * float | y ] [@@deriving bin_io] end type tuple = float * string * int64 [@@deriving bin_io] type 'a record = { a : int; b : 'a; c : 'a option } [@@deriving bin_io] type 'a singleton_record = { y : 'a } [@@deriving bin_io] type 'a inline_record = | IR of { ir_a : int; ir_b : 'a; ir_c : 'a option } | Other of int [@@deriving bin_io] type 'a sum = Foo | Bar of int | Bla of 'a * string [@@deriving bin_io] type 'a variant = [ `Foo | `Bar of int | `Bla of 'a * string ] [@@deriving bin_io] type 'a poly_app = (tuple * int singleton_record * 'a record * 'a inline_record) variant sum list [@@deriving bin_io] type 'a rec_t1 = RecFoo1 of 'a rec_t2 and 'a rec_t2 = RecFoo2 of 'a poly_app * 'a rec_t1 | RecNone [@@deriving bin_io] type 'a poly_id = 'a rec_t1 [@@deriving bin_io] type el = float poly_id [@@deriving bin_io] type els = el array [@@deriving bin_io] let mb = 1024. *. 1024. let main () = (* Allocate buffer (= bigstring) *) let buf = create_buf 10000 in (* Define array of dummy elements to be marshalled *) let el = let record = { a = 17; b = 2.78; c = None } in let inline_record = IR {ir_a = 18; ir_b = 43210.; ir_c = None} in let arg = (3.1, "foo", 42L), { y = 4321 }, record, inline_record in let variant = `Bla (arg, "fdsa") in let sum = Bla (variant, "asdf") in let poly_app = [ sum ] in RecFoo1 (RecFoo2 (poly_app, RecFoo1 RecNone)) in let x = Array.make 10 el in let n = 100_000 in (* Write n times *) let t1 = Unix.gettimeofday () in for _ = 1 to n do ignore (bin_write_els buf ~pos:0 x) done; let t2 = Unix.gettimeofday () in let write_time = t2 -. t1 in (* Read n times *) let t1 = Unix.gettimeofday () in for _ = 1 to n do let pos_ref = ref 0 in ignore (bin_read_els buf ~pos_ref) done; let t2 = Unix.gettimeofday () in let read_time = t2 -. t1 in (* Write, read, and verify *) let end_pos = bin_write_els buf ~pos:0 x in let pos_ref = ref 0 in let y = bin_read_els buf ~pos_ref in assert (!pos_ref = end_pos && x = y); (* Print result *) let f_n = float n in let msg_size = float (n * end_pos) in printf "msgs: %d msg length: %d\n\ write time: %.3fs write rate: %9.2f msgs/s write throughput: %.2f MB/s\n\ \ read time: %.3fs read rate: %9.2f msgs/s read throughput: %.2f MB/s\n%!" n end_pos write_time (f_n /. write_time) (msg_size /. write_time /. mb) read_time (f_n /. read_time) (msg_size /. read_time /. mb) let () = try main () with Read_error (err, pos) -> eprintf "Uncaught exception: %s: %d\n%!" (ReadError.to_string err) pos ppx_bin_prot-0.14.0/test/microbench.ml000066400000000000000000000067531366315055700177470ustar00rootroot00000000000000open Core open Core_bench let write_bin_prot writer buf ~pos a = let len = writer.Bin_prot.Type_class.size a in assert(writer.Bin_prot.Type_class.write buf ~pos a = pos + len) let read_bin_prot reader buf ~pos_ref = reader.Bin_prot.Type_class.read buf ~pos_ref let pos_ref = ref 0 let one = if Random.bool () then 1.0 else 1.0 let pi = if Random.bool () then 3.141597 else 3.141597 let read_float x = let buf = Bigstring.create 100 in write_bin_prot Float.bin_writer_t buf x ~pos:0; (fun () -> pos_ref := 0; ignore(read_bin_prot Float.bin_reader_t buf ~pos_ref : float)) let write_float x = let buf = Bigstring.create 100 in (fun () -> write_bin_prot Float.bin_writer_t buf x ~pos:0) module R = struct type t = { x : float; y : float } [@@deriving bin_io] end let read_r x = let buf = Bigstring.create 100 in write_bin_prot R.bin_writer_t buf x ~pos:0; (fun () -> pos_ref := 0; ignore(read_bin_prot R.bin_reader_t buf ~pos_ref : R.t)) let write_r x = let buf = Bigstring.create 100 in (fun () -> write_bin_prot R.bin_writer_t buf x ~pos:0) let r_one : R.t = if Random.bool () then { x = 1.0; y = 1.0 } else { x = 1.0; y = 1.0 } let r_pi : R.t = if Random.bool () then { x = pi ; y = pi } else { x = pi ; y = pi } module IR = struct type t = | A of { x : float; y : float } | B of { u : int ; v : int } [@@deriving bin_io] end let read_ir x = let buf = Bigstring.create 100 in write_bin_prot IR.bin_writer_t buf x ~pos:0; (fun () -> pos_ref := 0; ignore(read_bin_prot IR.bin_reader_t buf ~pos_ref : IR.t)) let write_ir x = let buf = Bigstring.create 100 in (fun () -> write_bin_prot IR.bin_writer_t buf x ~pos:0) let ir_one : IR.t = if Random.bool () then B { u = 1; v = 1 } else B { u = 1; v = 1 } let ir_pi : IR.t = if Random.bool () then A { x = pi ; y = pi } else A { x = pi ; y = pi } let lengths = [0; 1; 10; 100; 1000; 10_000] let write_float_array len = let arr = Array.create ~len 1.0 in let buf = Bigstring.create 1_000_000 in Staged.stage (fun () -> write_bin_prot bin_writer_float_array buf arr ~pos:0) let read_float_array len = let arr = Array.create ~len 1.0 in let buf = Bigstring.create 1_000_000 in write_bin_prot bin_writer_float_array buf arr ~pos:0; Staged.stage (fun () -> pos_ref := 0; let arr = read_bin_prot bin_reader_float_array buf ~pos_ref in if not (Array.length arr = len) then failwithf "got len %d, expected %d" (Array.length arr) len ()) let benchs = [ Bench.Test.create ~name:"write float one" (write_float one) ; Bench.Test.create ~name:"read float one" (read_float one) ; Bench.Test.create ~name:"write float pi" (write_float pi) ; Bench.Test.create ~name:"read float pi" (read_float pi) ; Bench.Test.create ~name:"write record one" (write_r r_one) ; Bench.Test.create ~name:"read record one" (read_r r_one) ; Bench.Test.create ~name:"write record pi" (write_r r_pi) ; Bench.Test.create ~name:"read record pi" (read_r r_pi) ; Bench.Test.create ~name:"write inline record one" (write_ir ir_one) ; Bench.Test.create ~name:"read inline record one" (read_ir ir_one) ; Bench.Test.create ~name:"write inline record pi" (write_ir ir_pi) ; Bench.Test.create ~name:"read inline record pi" (read_ir ir_pi) ; Bench.Test.create_indexed ~name:"write float array" ~args:lengths (write_float_array) ; Bench.Test.create_indexed ~name:"read float array" ~args:lengths (read_float_array) ] let () = Command.run (Bench.make_command benchs) ppx_bin_prot-0.14.0/test/nopervasives/000077500000000000000000000000001366315055700200155ustar00rootroot00000000000000ppx_bin_prot-0.14.0/test/nopervasives/dune000066400000000000000000000002661366315055700206770ustar00rootroot00000000000000(alias (name runtest) (deps ppx_bin_prot_nopervasives.cmxa)) (library (name ppx_bin_prot_nopervasives) (libraries core) (flags :standard -nopervasives) (preprocess (pps ppx_jane)))ppx_bin_prot-0.14.0/test/nopervasives/ppx_bin_prot_nopervasives.ml000066400000000000000000000001441366315055700256550ustar00rootroot00000000000000open Core module M = struct type t = { a: float ; b: float } [@@deriving bin_io] end ppx_bin_prot-0.14.0/test/test.ml000066400000000000000000000002371366315055700166040ustar00rootroot00000000000000open OUnit let all = TestList [ Bin_prot_test.test; Bin_prot_test.Common.test; Bin_prot_test.Inline.test; Blob_test.test; ] ppx_bin_prot-0.14.0/test/test_runner.ml000066400000000000000000000000701366315055700201700ustar00rootroot00000000000000open OUnit let () = ignore (run_test_tt_main Test.all)