pax_global_header00006660000000000000000000000064146164733610014525gustar00rootroot0000000000000052 comment=0199e0d4cb3d736c7ee87f886c25af4fb19c107e ppx_bin_prot-0.17.0/000077500000000000000000000000001461647336100143155ustar00rootroot00000000000000ppx_bin_prot-0.17.0/.gitignore000066400000000000000000000000411461647336100163000ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_bin_prot-0.17.0/.ocamlformat000066400000000000000000000000231461647336100166150ustar00rootroot00000000000000profile=janestreet ppx_bin_prot-0.17.0/CHANGES.md000066400000000000000000000016641461647336100157160ustar00rootroot00000000000000## Release v0.17.0 * Support sizing and writing locally-allocated values. This can be enabled by passing a flag to the deriver: `[@@deriving bin_io ~localize]`. * Hide source code locations in test output to avoid noise when restyling etc. ## Release v0.16.0 - Several new expression forms are supported to derive the individual values defined by `ppx_bin_prot`. * `[%bin_shape: t]` * `[%bin_digest: t]` * `[%bin_size: t]` * `[%bin_write: t]` * `[%bin_read: t]` * `[%bin_writer: t]` * `[%bin_reader: t]` * `[%bin_type_class: t]` ## Old pre-v0.15 changelogs (very likely stale and incomplete) ## 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.17.0/CONTRIBUTING.md000066400000000000000000000044101461647336100165450ustar00rootroot00000000000000This 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.17.0/LICENSE.md000066400000000000000000000021461461647336100157240ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2024 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_bin_prot-0.17.0/Makefile000066400000000000000000000004031461647336100157520ustar00rootroot00000000000000INSTALL_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.17.0/README.md000066400000000000000000000104541461647336100156000ustar00rootroot00000000000000ppx_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. ## Expression extensions Several new expression forms are supported to derive the individual values defined by `ppx_bin_prot`. Each of the following extensions can be used, with arbitrary type expressions in place of `t`, to produce values of the corresponding types on the right: ```ocaml [%bin_shape: t] : Bin_prot.Shape.t [%bin_digest: t] : string [%bin_size: t] : t Bin_prot.Size.sizer [%bin_write: t] : t Bin_prot.Write.writer [%bin_read: t] : t Bin_prot.Read.reader [%bin_writer: t] : t Bin_prot.Type_class.writer [%bin_reader: t] : t Bin_prot.Type_class.reader [%bin_type_class: t] : t Bin_prot.Type_class.t ``` ### 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. ## Local-accepting bin_io functions This ppx includes the option to support local allocation, a nonstandard OCaml extension available at: https://github.com/ocaml-flambda/ocaml-jst In both structures and signatures, `[@@deriving bin_io ~localize]` (and similarly for `bin_write` and `bin_size`) additionally generates definitions for `bin_write_t__local` and `bin_size_t__local` which accept locally allocated `t`s. As well, the following extension points are available: ```ocaml [%bin_size_local: t] : t Bin_prot.Size.sizer_local [%bin_write_local: t] : t Bin_prot.Write.writer_local ``` No other values from this ppx currently support local allocations. ppx_bin_prot-0.17.0/bench/000077500000000000000000000000001461647336100153745ustar00rootroot00000000000000ppx_bin_prot-0.17.0/bench/dune000066400000000000000000000001751461647336100162550ustar00rootroot00000000000000(library (name ppx_bin_prot_bench) (libraries bin_prot core) (modules ppx_bin_prot_bench) (preprocess (pps ppx_jane))) ppx_bin_prot-0.17.0/bench/ppx_bin_prot_bench.ml000066400000000000000000000065261461647336100216010ustar00rootroot00000000000000open Core 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_array bin_writer_float) 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_array bin_writer_float) buf arr ~pos:0; Staged.stage (fun () -> pos_ref := 0; let arr = read_bin_prot (bin_reader_array bin_reader_float) buf ~pos_ref in if not (Array.length arr = len) then failwithf "got len %d, expected %d" (Array.length arr) len ()) ;; let%bench_fun "write float one" = write_float one let%bench_fun "read float one" = read_float one let%bench_fun "write float pi" = write_float pi let%bench_fun "read float pi" = read_float pi let%bench_fun "write record one" = write_r r_one let%bench_fun "read record one" = read_r r_one let%bench_fun "write record pi" = write_r r_pi let%bench_fun "read record pi" = read_r r_pi let%bench_fun "write inline record one" = write_ir ir_one let%bench_fun "read inline record one" = read_ir ir_one let%bench_fun "write inline record pi" = write_ir ir_pi let%bench_fun "read inline record pi" = read_ir ir_pi let%bench_fun ("write float array" [@indexed len = lengths]) = Staged.unstage (write_float_array len) ;; let%bench_fun ("read float array" [@indexed len = lengths]) = Staged.unstage (read_float_array len) ;; ppx_bin_prot-0.17.0/bench/ppx_bin_prot_bench.mli000066400000000000000000000000551461647336100217410ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_bin_prot-0.17.0/dune000066400000000000000000000000001461647336100151610ustar00rootroot00000000000000ppx_bin_prot-0.17.0/dune-project000066400000000000000000000000211461647336100166300ustar00rootroot00000000000000(lang dune 3.11) ppx_bin_prot-0.17.0/ppx_bin_prot.opam000066400000000000000000000015711461647336100177020ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.0" maintainer: "Jane Street developers" 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" {>= "5.1.0"} "base" {>= "v0.17" & < "v0.18"} "bin_prot" {>= "v0.17" & < "v0.18"} "ppx_here" {>= "v0.17" & < "v0.18"} "ppxlib_jane" {>= "v0.17" & < "v0.18"} "dune" {>= "3.11.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Generation of bin_prot readers and writers from types" description: " Part of the Jane Street's PPX rewriters collection. " ppx_bin_prot-0.17.0/shape/000077500000000000000000000000001461647336100154155ustar00rootroot00000000000000ppx_bin_prot-0.17.0/shape/example0/000077500000000000000000000000001461647336100171305ustar00rootroot00000000000000ppx_bin_prot-0.17.0/shape/example0/dune000066400000000000000000000002071461647336100200050ustar00rootroot00000000000000(library (name bin_shape_gen_example) (libraries) (preprocess (pps ppx_bin_prot))) (alias (name DEFAULT) (deps example.ml.pp)) ppx_bin_prot-0.17.0/shape/example0/example.ml000066400000000000000000000012241461647336100211140ustar00rootroot00000000000000type 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.17.0/shape/src/000077500000000000000000000000001461647336100162045ustar00rootroot00000000000000ppx_bin_prot-0.17.0/shape/src/bin_shape_expand.ml000066400000000000000000000311371461647336100220320ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default let raise_errorf ~loc fmt = Location.raise_errorf ~loc (Stdlib.( ^^ ) "ppx_bin_shape: " fmt) ;; let loc_string loc ~hide_loc = let loc_expr = if hide_loc then [%expr ""] else Ppx_here_expander.lift_position_as_string ~loc in [%expr Bin_prot.Shape.Location.of_string [%e loc_expr]] ;; 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 ~hide_loc (xs : expression list) = [%expr Bin_prot.Shape.poly_variant [%e loc_string loc ~hide_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 expr_error ~loc msg = pexp_extension ~loc (Location.Error.to_extension (Location.Error.createf ~loc "ppx_bin_shape: %s" msg)) ;; let expr_errorf ~loc = Printf.ksprintf (fun msg -> expr_error ~loc msg) let of_type : allow_free_vars:bool -> hide_loc:bool -> context:Context.t -> core_type -> expression = fun ~allow_free_vars ~hide_loc ~context -> let rec traverse_row ~loc ~typ_for_error (row : row_field) : expression = match row.prf_desc with | Rtag (_, true, _ :: _) | Rtag (_, false, _ :: _ :: _) -> expr_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, []) -> expr_error ~loc "impossible row_type: Rtag (_,_,false,[])" | Rinherit t -> [%expr Bin_prot.Shape.inherit_ [%e loc_string { t.ptyp_loc with loc_ghost = true } ~hide_loc] [%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 (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) | 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 ~hide_loc] [%e shape_vid ~loc ~tvar]] else expr_errorf ~loc "unexpected free type variable: '%s" tvar | Ptyp_variant (rows, _, None) -> shape_poly_variant ~loc ~hide_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 _ -> expr_errorf ~loc "unsupported type: %s" (string_of_core_type typ) in traverse ;; let tvars_of_def (td : type_declaration) : (string list, [ `Non_tvar of location ]) Result.t = let tvars, non_tvars = List.partition_map td.ptype_params ~f:(fun (typ, _variance) -> let loc = typ.ptyp_loc in match typ with | { ptyp_desc = Ptyp_var tvar; _ } -> First tvar | _ -> Second (`Non_tvar loc)) in match non_tvars with | `Non_tvar loc :: _ -> Error (`Non_tvar loc) | [] -> Ok tvars ;; 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 ~hide_loc ~context lds = shape_record ~loc (List.map lds ~f:(fun ld -> ld.pld_name.txt, of_type ~hide_loc ~context ld.pld_type)) ;; let of_kind ~loc ~hide_loc ~context (k : type_kind) : expression option = match k with | Ptype_record lds -> Some (of_label_decs ~loc ~hide_loc ~context lds) | Ptype_variant cds -> Some (shape_variant ~loc (List.map cds ~f:(fun cd -> ( cd.pcd_name.txt , match cd.pcd_args with | Pcstr_tuple args -> List.map args ~f:(of_type ~hide_loc ~context) | Pcstr_record lds -> [ of_label_decs ~loc ~hide_loc ~context lds ] )))) | Ptype_abstract -> None | Ptype_open -> Some (expr_errorf ~loc "open types not supported") ;; let expr_of_td ~loc ~hide_loc ~context (td : type_declaration) : expression option = let expr = match of_kind ~loc ~hide_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 ~hide_loc ~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 __) +> flag "hide_locations") (fun ~loc ~path:_ (rec_flag, tds) annotation_opt annotation_provisionally_opt basetype_opt hide_loc -> 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 annotate_f : expression -> expression = match annotation_opt with | None -> fun e -> e | Some name -> (match tds with | [] | _ :: _ :: _ -> fun _e -> expr_errorf ~loc "unexpected [~annotate] on multi type-declaration" | [ _ ] -> 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 ~hide_loc ~context td in match body_opt with | None -> None | Some body -> (match tvars_of_def td with | Error (`Non_tvar loc) -> Some (expr_errorf ~loc "unexpected non-tvar in type params") | Ok tvars -> 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 match tvars_of_def td with | Error (`Non_tvar loc) -> expr_errorf ~loc "unexpected non-tvar in type params" | Ok tvars -> 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 -> (match tds with | [] | _ :: _ :: _ -> expr_errorf ~loc "unexpected [~basetype] on multi type-declaration" | [ _ ] -> mk_exprs (fun ~tname:_ ~args -> shape_basetype ~loc ~uuid args)) | None -> [%expr let _group = Bin_prot.Shape.group [%e loc_string loc ~hide_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 match tvars_of_def td with | Error (`Non_tvar loc) -> psig_extension ~loc (Location.Error.to_extension (Location.Error.createf ~loc "%s" "unexpected non-tvar in type params")) [] | Ok tvars -> 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:_ ~hide_loc typ = let context = Context.create [] in let allow_free_vars = false in of_type ~allow_free_vars ~hide_loc ~context typ ;; let digest_extension ~loc ~hide_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 ~hide_loc typ])] ;; ppx_bin_prot-0.17.0/shape/src/bin_shape_expand.mli000066400000000000000000000005161461647336100222000ustar00rootroot00000000000000open 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 -> hide_loc:bool -> core_type -> expression val digest_extension : loc:Location.t -> hide_loc:bool -> core_type -> expression ppx_bin_prot-0.17.0/shape/src/dune000066400000000000000000000002371461647336100170640ustar00rootroot00000000000000(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.17.0/shape/test/000077500000000000000000000000001461647336100163745ustar00rootroot00000000000000ppx_bin_prot-0.17.0/shape/test/dune000066400000000000000000000002751461647336100172560ustar00rootroot00000000000000(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.17.0/shape/test/examples.mlt000066400000000000000000000143651461647336100207410ustar00rootroot00000000000000open 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 ~hide_locations] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2 end [%%expect {| Exception: (Failure ": 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 ~hide_locations] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2 end [%%expect {| Exception: (Failure ": 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 ~hide_locations] let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t end [%%expect {| Exception: (Failure ": 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.17.0/shape/test/test.ml000066400000000000000000001277731461647336100177260ustar00rootroot00000000000000open 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 _ = 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 _ = 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 _ = 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_float.now () in let _res = Shape.eval_to_digest exp in let after = Time_float.now () in [%test_pred: Time_float.Span.t] (fun x -> x < allowed) (Time_float.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.17.0/src/000077500000000000000000000000001461647336100151045ustar00rootroot00000000000000ppx_bin_prot-0.17.0/src/dune000066400000000000000000000003421461647336100157610ustar00rootroot00000000000000(library (name ppx_bin_prot) (public_name ppx_bin_prot) (kind ppx_deriver) (ppx_runtime_libraries bin_prot) (libraries compiler-libs.common base ppxlib ppxlib_jane bin_shape_expand) (preprocess (pps ppxlib.metaquot))) ppx_bin_prot-0.17.0/src/ppx_bin_prot.ml000066400000000000000000002067351461647336100201560ustar00rootroot00000000000000(** Ppx_bin_prot: Preprocessing Module for a Type Safe Binary Protocol *) open Base open Ppxlib open Ast_builder.Default (* +-----------------------------------------------------------------+ | Name mangling | +-----------------------------------------------------------------+ *) module Locality_mode = struct type t = Ppxlib_jane.Ast_builder.Default.mode option end (* Bring the name [Local] into scope *) type mode = Ppxlib_jane.Ast_builder.Default.mode = Local module Locality_modality = struct type t = Ppxlib_jane.Ast_builder.Default.modality option let of_ld ld = let modality, _ = Ppxlib_jane.Ast_builder.Default.get_label_declaration_modality ld in match modality, ld.pld_mutable with | Some _, _ -> modality | None, Mutable -> Some Global | None, Immutable -> None ;; let of_cstr_tuple_field core_type = let modality, _ = Ppxlib_jane.Ast_builder.Default.get_tuple_field_modality core_type in modality ;; let of_tuple_field _ = None let apply modality locality = match (modality : t) with | None -> locality | Some Global -> None ;; end (* type_name is for types like Bin_prot.Size.sizer *) let type_name string ~locality = match locality with | Some Local -> string ^ "_local" | None -> string ;; let signature_name = type_name let value_name ~prefix ~locality string = let suffix = match locality with | Some Local -> "__local" | None -> "" in prefix ^ string ^ suffix ;; let bin_read_name = value_name ~prefix:"bin_read_" let bin_vtag_read_name ~locality string = "__" ^ bin_read_name string ~locality ^ "__" let bin_reader_name = value_name ~prefix:"bin_reader_" let bin_size_name = value_name ~prefix:"bin_size_" let bin_write_name = value_name ~prefix:"bin_write_" let bin_writer_name = value_name ~prefix:"bin_writer_" let bin_shape_name = value_name ~prefix:"bin_shape_" let bin_name = value_name ~prefix:"bin_" let bin_size_arg = value_name ~prefix:"_size_of_" let bin_write_arg = value_name ~prefix:"_write_" let conv_name = value_name ~prefix:"_of__" module Typ = struct type t = { type_constr : string ; wrap_result : loc:Location.t -> core_type -> core_type } let vtag_reader ~locality = { type_constr = type_name "Bin_prot.Read.reader" ~locality ; wrap_result = (fun ~loc t -> [%type: int -> [%t t]]) } ;; let create type_constr ~locality = { type_constr = type_name type_constr ~locality; wrap_result = (fun ~loc:_ x -> x) } ;; end (* +-----------------------------------------------------------------+ | Signature generators | +-----------------------------------------------------------------+ *) module Sig = struct let mk_sig_generator combinators ~with_localize = let mk_sig ~ctxt:_ (_rf, tds) localize = List.concat_map tds ~f:(fun td -> let td = name_type_params_in_td td in List.concat_map combinators ~f:(fun mk -> Staged.unstage mk td ~localize)) in if with_localize then ( let flags = Deriving.Args.(empty +> flag "localize") in Deriving.Generator.V2.make flags mk_sig) else ( let flags = Deriving.Args.empty in Deriving.Generator.V2.make flags (fun ~ctxt x -> mk_sig ~ctxt x false)) ;; let mk_typ ~hide_params { Typ.type_constr; wrap_result } 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) [ (if hide_params then ptyp_any ~loc:td.ptype_name.loc else 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 ~can_generate_local name_format type_constr = Staged.stage (fun td ~localize:localize_requested -> let generate ~locality = let loc = td.ptype_loc in let name = Loc.map ~f:(name_format ~locality) td.ptype_name in let typ = mk_typ ~hide_params:false (type_constr ~locality) td in psig_value ~loc (value_description ~loc ~name ~type_:typ ~prim:[]) in if can_generate_local && localize_requested then [ generate ~locality:None; generate ~locality:(Some Local) ] else [ generate ~locality:None ]) ;; let bin_write = mk_sig_generator ~with_localize:true [ mk bin_size_name (Typ.create "Bin_prot.Size.sizer") ~can_generate_local:true ; mk bin_write_name (Typ.create "Bin_prot.Write.writer") ~can_generate_local:true ; mk bin_writer_name (Typ.create "Bin_prot.Type_class.writer") ~can_generate_local:false ] ;; let bin_read = mk_sig_generator ~with_localize:false [ mk bin_read_name (Typ.create "Bin_prot.Read.reader") ~can_generate_local:false ; mk bin_vtag_read_name Typ.vtag_reader ~can_generate_local:false ; mk bin_reader_name (Typ.create "Bin_prot.Type_class.reader") ~can_generate_local:false ] ;; let bin_type_class = mk_sig_generator ~with_localize:false [ mk bin_name (Typ.create "Bin_prot.Type_class.t") ~can_generate_local:false ] ;; let named = let mk_named_sig ~ctxt (rf, tds) localize = let loc = Expansion_context.Deriver.derived_item_loc ctxt in match mk_named_sig ~loc ~sg_name: (signature_name "Bin_prot.Binable.S" ~locality:(if localize then Some Local else None)) ~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) (if localize then [ "localize", [%expr localize] ] else [])) in let flags = Deriving.Args.(empty +> flag "localize") in Deriving.Generator.V2.make flags 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 ~f ~locality td = List.map td.ptype_params ~f:(fun tp -> let name = get_type_param_name tp in { name with txt = f ~locality 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 args = map_vars vars ~f:(fun ~loc txt -> let record = evar ~loc txt in pexp_field ~loc record (Located.mk ~loc (Lident field_name))) 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" (Stdlib.Printexc.get_callstack 256 |> Stdlib.Printexc.raw_backtrace_to_string) ;; end let generate_poly_type ~loc constructor td = ptyp_poly ~loc (List.map td.ptype_params ~f:get_type_param_name) (Sig.mk_typ ~hide_params:false constructor td) ;; let make_value ~locality ~loc ~type_constr ~hide_params ~make_value_name ~make_arg_name ~body td = let vars = vars_of_params td ~f:make_arg_name ~locality in let pat = pvar ~loc (make_value_name ~locality td.ptype_name.txt) in let expr = eabstract ~loc (patts_of_vars vars) body in let constraint_ = if hide_params then Sig.mk_typ ~hide_params (type_constr ~locality) td else generate_poly_type ~loc (type_constr ~locality) td in let pat, expr = (* When [constraint_] has universally quantified type variables, we need to put the constraint on the pattern: {[ let f : 'a. 'a sizer -> 'a t sizer = ... ]} When we generate F# code, however, we can't put a constraint on the pattern in the case of [let rec] declarations, so we instead have to put it on the expression: {[ let rec f = (... : _ sizer -> _ sizer) ]} We use the [hide_params] value as a differentiator between these two cases, as it is always [false] when we need universally quantified type variables, and always [true] when generating F#-compatible code. *) if hide_params then pat, pexp_constraint ~loc expr constraint_ else ppat_constraint ~loc pat constraint_, expr in value_binding ~loc ~pat ~expr ;; (* 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)) ;; let should_omit_type_params ~f_sharp_compatible tds = (* Universal quantifier annotations are not supported in F#. By not generating type params, we remove the need for any quantifiers. *) f_sharp_compatible || List.for_all ~f:would_rather_omit_type_signatures tds ;; let aliases_of_tds tds ~function_name ~function_type_name = (* So that ~localize doesn't double the size of the generated code, we define the non @local function as an alias to the @local function. This only works for ground types, as [(buf -> pos:pos -> 'a -> pos) -> buf -> pos:pos -> 'a list -> pos] is a type that is neither stronger nor weaker than the same type with local_ on the 'a and 'a list. If the compiler supports polymorphism over locality one day, we may be able to only generate one version of the code, the local version. *) if List.for_all tds ~f:(fun td -> List.is_empty td.ptype_params) then Some (List.map tds ~f:(fun td -> let loc = td.ptype_name.loc in let expr = pexp_coerce ~loc (evar ~loc (function_name ~locality:(Some Local) td.ptype_name.txt)) None (ptyp_constr ~loc (Located.mk ~loc (Longident.parse (function_type_name ~locality:None))) [ ptyp_any ~loc ]) in let pat = pvar ~loc (function_name ~locality:None td.ptype_name.txt) in value_binding ~loc ~pat ~expr)) else None ;; let alias_local_binding_if_possible ~loc ~localize ~function_name ~function_type_name rec_flag bindings tds = let rec_flag = really_recursive rec_flag tds in if localize then [ pstr_value ~loc rec_flag (bindings ~locality:(Some Local)) ; (match aliases_of_tds ~function_name ~function_type_name:(type_name function_type_name) tds with | Some values -> pstr_value ~loc Nonrecursive values | None -> pstr_value ~loc rec_flag (bindings ~locality:None)) ] else [ pstr_value ~loc rec_flag (bindings ~locality:None) ] ;; (* +-----------------------------------------------------------------+ | Generator for size computation of OCaml-values for bin_prot | +-----------------------------------------------------------------+ *) module Generate_bin_size = struct let mk_abst_call ~loc id args ~locality = type_constr_conv ~loc id ~f:(bin_size_name ~locality) args ;; (* Conversion of types *) let rec bin_size_type full_type_name _loc ty ~locality = let loc = { ty.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with | Some (Jtyp_tuple alist, (_ : attributes)) -> bin_size_labeled_tuple full_type_name loc alist ~locality | Some (Jtyp_layout _, _) | None -> (match ty.ptyp_desc with | Ptyp_constr (id, args) -> `Fun (bin_size_appl_fun full_type_name loc id args ~locality) | Ptyp_tuple l -> bin_size_tuple full_type_name loc l ~locality | Ptyp_var parm -> `Fun (evar ~loc (bin_size_arg parm ~locality)) | 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 ~locality | Ptyp_poly (parms, ty) -> bin_size_poly full_type_name loc parms ty ~locality | _ -> 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 ~locality = 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 ~locality with | `Fun e -> e | `Match cases -> pexp_function ~loc:{ ty.ptyp_loc with loc_ghost = true } cases) in mk_abst_call ~loc id sizers ~locality (* Conversion of tuples and records *) and bin_size_args : 'a 'b. Full_type_name.t -> Location.t -> ('a -> core_type) -> ('a -> Locality_modality.t) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> locality:Locality_mode.t -> 'b list * expression = fun full_type_name loc get_tp get_locality_modality mk_patt tps ~locality -> let rec loop i = function | el :: rest -> let tp = get_tp el in let locality = Locality_modality.apply (get_locality_modality el) locality 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 ~locality 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) -> ('a -> Locality_modality.t) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> locality:Locality_mode.t -> _ = fun full_type_name loc cnv_patts get_tp get_locality_modality mk_patt tp ~locality -> let patts, expr = bin_size_args full_type_name loc get_tp get_locality_modality mk_patt tp ~locality 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 ~locality = 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 Locality_modality.of_tuple_field mk_patt l ~locality (* Conversion of labeled tuples *) and bin_size_labeled_tuple full_type_name loc l ~locality = let cnv_patts patts = Ppxlib_jane.Jane_syntax.Labeled_tuples.pat_of ~loc (patts, Closed) in let get_tp (_, tp) = tp in let mk_patt loc v_name (label, _) = label, pvar ~loc v_name in bin_size_tup_rec full_type_name loc cnv_patts get_tp Locality_modality.of_tuple_field mk_patt l ~locality (* Conversion of records *) and bin_size_record full_type_name loc tp ~locality = 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 Locality_modality.of_ld mk_patt tp ~locality (* Conversion of variant types *) and bin_size_variant full_type_name loc row_fields ~locality = 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 ~locality 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 ~locality 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 ~locality = 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 (bin_size_arg parm.txt ~locality)) ~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 ~locality 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 ~locality = 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 Locality_modality.of_cstr_tuple_field mk_patt args ~locality 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 Locality_modality.of_ld mk_patt fields ~locality 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 ~locality = 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 ~locality | Ptype_record flds -> bin_size_record full_type_name loc flds ~locality | 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 ~locality) in make_fun ~loc ~don't_expand:(td_is_nil td) res ;; (* Generate code from type definitions *) let bin_size_td ~should_omit_type_params ~loc ~path td ~locality = let body = sizer_body_of_td ~path td ~locality in make_value ~locality ~loc ~type_constr:(Typ.create "Bin_prot.Size.sizer") ~hide_params:should_omit_type_params ~make_value_name:bin_size_name ~make_arg_name:bin_size_arg ~body td ;; let bin_size ~f_sharp_compatible ~loc ~path (rec_flag, tds) localize = let tds = List.map tds ~f:name_type_params_in_td in let should_omit_type_params = should_omit_type_params ~f_sharp_compatible tds in let bindings ~locality = List.map tds ~f:(bin_size_td ~should_omit_type_params ~loc ~path ~locality) in alias_local_binding_if_possible ~loc ~localize ~function_name:bin_size_name ~function_type_name:"Bin_prot.Size.sizer" rec_flag bindings tds ;; let extension ~loc ~path:_ ty ~locality = bin_size_type Full_type_name.absent loc ty ~locality |> make_fun ~loc:{ loc with loc_ghost = true } ;; end (* +-----------------------------------------------------------------+ | Generator for converters of OCaml-values to the binary protocol | +-----------------------------------------------------------------+ *) module Generate_bin_write = struct let mk_abst_call ~loc id args ~locality = type_constr_conv ~loc id ~f:(bin_write_name ~locality) args ;; let mk_buf_pos_call ~loc e v = let args = [ Nolabel, [%expr buf]; Labelled "pos", [%expr pos]; Nolabel, v ] in pexp_apply ~loc e args ;; (* Conversion of types *) let rec bin_write_type full_type_name _loc ty ~locality = let loc = { ty.ptyp_loc with loc_ghost = true } in match Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with | Some (Jtyp_tuple alist, (_ : attributes)) -> bin_write_labeled_tuple full_type_name loc alist ~locality | Some (Jtyp_layout _, _) | None -> (match ty.ptyp_desc with | Ptyp_constr (id, args) -> `Fun (bin_write_appl_fun full_type_name loc id args ~locality) | Ptyp_tuple l -> bin_write_tuple full_type_name loc l ~locality | Ptyp_var parm -> `Fun (evar ~loc (bin_write_arg parm ~locality)) | 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 ~locality | Ptyp_poly (parms, ty) -> bin_write_poly full_type_name loc parms ty ~locality | _ -> 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 ~locality = 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 ~locality with | `Fun e -> e | `Match cases -> [%expr fun buf ~pos -> [%e pexp_function ~loc:ty.ptyp_loc cases]]) in mk_abst_call ~loc id writers ~locality (* Conversion of tuples and records *) and bin_write_args : 'a 'b. Full_type_name.t -> Location.t -> ('a -> core_type) -> ('a -> Locality_modality.t) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> locality:Locality_mode.t -> 'b list * expression = fun full_type_name loc get_tp get_locality_modality mk_patt tp ~locality -> let rec loop i = function | el :: rest -> let tp = get_tp el in let locality = Locality_modality.apply (get_locality_modality el) locality 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 ~locality with | `Fun fun_expr -> mk_buf_pos_call ~loc fun_expr 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) -> ('a -> Locality_modality.t) -> (Location.t -> string -> 'a -> 'b) -> 'a list -> locality:Locality_mode.t -> _ = fun full_type_name loc cnv_patts get_tp get_locality_modality mk_patt tp ~locality -> let patts, expr = bin_write_args full_type_name loc get_tp get_locality_modality mk_patt tp ~locality in `Match [ case ~lhs:(cnv_patts patts) ~guard:None ~rhs:expr ] (* Conversion of tuples *) and bin_write_tuple full_type_name loc l ~locality = 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 Locality_modality.of_tuple_field mk_patt l ~locality (* Conversion of labeled tuples *) and bin_write_labeled_tuple full_type_name loc l ~locality = let cnv_patts patts = Ppxlib_jane.Jane_syntax.Labeled_tuples.pat_of ~loc (patts, Closed) in let get_tp (_, tp) = tp in let mk_patt loc v_name (label, _) = label, pvar ~loc v_name in bin_write_tup_rec full_type_name loc cnv_patts get_tp Locality_modality.of_tuple_field mk_patt l ~locality (* Conversion of records *) and bin_write_record full_type_name loc tp ~locality = 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 Locality_modality.of_ld mk_patt tp ~locality (* Conversion of variant types *) and bin_write_variant full_type_name loc row_fields ~locality = 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 ~locality with | `Fun fun_expr -> mk_buf_pos_call fun_expr ~loc [%expr 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 ~locality in case ~lhs:(ppat_alias ~loc (ppat_type ~loc id) (Located.mk ~loc "v")) ~guard:None ~rhs:(mk_buf_pos_call call ~loc [%expr 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 ~locality = 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 (bin_write_arg parm.txt ~locality)) ~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 ~locality 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 ~locality = 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 Locality_modality.of_cstr_tuple_field mk_patt args ~locality 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 Locality_modality.of_ld mk_patt fields ~locality 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 mk_buf_pos_call fun_expr ~loc [%expr v]]] | `Match matchings -> [%expr fun buf ~pos -> [%e pexp_function ~loc matchings]] ;; let writer_type_class_record ~loc ~size ~write = [%expr { size = [%e size]; write = [%e write] }] ;; let writer_body_of_td ~path td ~locality = 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 ~locality | Ptype_record flds -> bin_write_record full_type_name loc flds ~locality | 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 ~locality) in make_fun ~loc ~don't_expand:(td_is_nil td) res ;; let project_vars expr vars ~field_name = let loc = expr.pexp_loc in let call = project_vars expr vars ~field_name in alias_or_fun call [%expr fun v -> [%e eapply ~loc call [ [%expr v] ]]] ;; (* Generate code from type definitions *) let bin_write_td ~should_omit_type_params ~loc ~path ~locality td = let body = writer_body_of_td ~path ~locality td in make_value ~locality ~loc ~type_constr:(Typ.create "Bin_prot.Write.writer") ~hide_params:should_omit_type_params ~make_value_name:bin_write_name ~make_arg_name:bin_write_arg ~body td ;; let bin_writer_td ~loc td ~locality = let body = let vars = vars_of_params td ~f:bin_writer_name ~locality in writer_type_class_record ~loc ~size: (project_vars (evar ~loc (bin_size_name td.ptype_name.txt ~locality)) vars ~field_name:"size") ~write: (project_vars (evar ~loc (bin_write_name td.ptype_name.txt ~locality)) vars ~field_name:"write") in make_value ~locality ~loc ~type_constr:(Typ.create "Bin_prot.Type_class.writer") ~hide_params:true ~make_value_name:bin_writer_name ~make_arg_name:bin_writer_name ~body td ;; let bin_write ~f_sharp_compatible ~loc ~path (rec_flag, tds) localize = let tds = List.map tds ~f:name_type_params_in_td in let should_omit_type_params = should_omit_type_params ~f_sharp_compatible tds in let write_bindings = let write_bindings ~locality = List.map tds ~f:(bin_write_td ~should_omit_type_params ~loc ~path ~locality) in alias_local_binding_if_possible ~loc ~localize ~function_name:bin_write_name ~function_type_name:"Bin_prot.Write.writer" rec_flag write_bindings tds in let writer_bindings = let writer_bindings ~locality = List.map tds ~f:(bin_writer_td ~loc ~locality) in [ writer_bindings ~locality:None ] in List.concat [ Generate_bin_size.bin_size ~f_sharp_compatible ~loc ~path (rec_flag, tds) localize ; write_bindings ; List.map writer_bindings ~f:(pstr_value ~loc Nonrecursive) ] ;; let gen = let flags = Deriving.Args.(empty +> flag "localize") in Deriving.Generator.make flags (bin_write ~f_sharp_compatible:false) ;; let function_extension ~loc ~path:_ ty ~locality = bin_write_type Full_type_name.absent loc ty ~locality |> make_fun ~loc:{ loc with loc_ghost = true } ;; let type_class_extension ~loc ~path:_ ty = let locality = None in 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 ~locality |> Generate_bin_size.make_fun ~loc in let write = bin_write_type full_type_name loc ty ~locality |> make_fun ~loc in [%expr ([%e writer_type_class_record ~loc ~size ~write] : _ Bin_prot.Type_class.writer)] ;; end (* +-----------------------------------------------------------------+ | Generator for converters of binary protocol to OCaml-values | +-----------------------------------------------------------------+ *) module Generate_bin_read = struct let locality = None 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:((if internal then bin_vtag_read_name else bin_read_name) ~locality) ;; (* 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 Ppxlib_jane.Jane_syntax.Core_type.of_ast ty with | Some (Jtyp_tuple alist, (_ : attributes)) -> bin_read_labeled_tuple full_type_name loc alist | Some (Jtyp_layout _, _) | None -> (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 = bin_read_path_fun id.loc id args_expr in `Closed expr | Ptyp_tuple tp -> bin_read_tuple full_type_name loc tp | Ptyp_var parm -> `Closed (evar ~loc (conv_name parm ~locality)) | 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)) (* Conversion of labeled tuples *) and bin_read_labeled_tuple full_type_name loc alist = let bindings, exprs = let map i (label, 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, (label, evar ~loc v_name) in List.mapi alist ~f:map |> List.unzip in `Open (let_ins loc bindings (Ppxlib_jane.Jane_syntax.Labeled_tuples.expr_of ~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 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 (conv_name parm.txt ~locality)) ~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 -> (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) | Polymorphic_variant { all_atoms } -> (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 *)) | 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 { read = [%e read]; vtag_read = [%e vtag_read] }] ;; let bin_read_td ~should_omit_type_params ~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_name td.ptype_name.txt ~locality in let vtag_read_name = bin_vtag_read_name td.ptype_name.txt ~locality in let vtag_read_binding_type, read_binding_type = (* It seems like that we could simplify this code if we used [make_value] here and in read_and_vtag_read_bindings. That requires more refactoring, as read_and_vtag_read_bindings is also used for [%bin_read: ..], which we'd need to change, similar to what bin_write is doing. *) if should_omit_type_params then None, None else ( Some (generate_poly_type ~loc (Typ.vtag_reader ~locality) td) , Some (generate_poly_type ~loc (Typ.create "Bin_prot.Read.reader" ~locality) td) ) in let read_binding, vtag_read_binding = let args = vars_of_params td ~f:conv_name ~locality 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 ~f:bin_reader_name ~locality 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_binding = let body = reader_type_class_record ~loc ~read ~vtag_read in make_value ~locality ~loc ~type_constr:(Typ.create "Bin_prot.Type_class.reader") ~hide_params:true ~make_value_name:bin_reader_name ~make_arg_name:bin_reader_name ~body td in vtag_read_binding, (read_binding, reader_binding) ;; (* Generate code from type definitions *) let bin_read ~f_sharp_compatible ~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 should_omit_type_params = should_omit_type_params ~f_sharp_compatible tds in let vtag_read_bindings, read_and_reader_bindings = List.map tds ~f:(bin_read_td ~should_omit_type_params ~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 ~f_sharp_compatible:false) ;; let function_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 = (* The vtag reader is used for polymorphic variants, and not for other types. We bind it with an underscore so the resulting code compiles either way. This seems less error-prone than adding logic here to keep it or not, mirroring the logic elsewhere of whether to refer to it or not. *) "_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 ] read_binding.pvb_expr ;; let type_class_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 ] [%expr ([%e reader_type_class_record ~loc ~read:(evar ~loc read_name) ~vtag_read:(evar ~loc vtag_read_name)] : _ Bin_prot.Type_class.reader)]) ;; end (* Generator for binary protocol type classes *) module Generate_tp_class = struct let locality = None let tp_record ~loc ~writer ~reader ~shape = [%expr { writer = [%e writer]; reader = [%e reader]; shape = [%e shape] }] ;; let bin_tp_class_td td = let loc = td.ptype_loc in let body = let vars = vars_of_params ~f:bin_name ~locality td in let writer = project_vars (evar ~loc (bin_writer_name td.ptype_name.txt ~locality)) vars ~field_name:"writer" in let reader = project_vars (evar ~loc (bin_reader_name td.ptype_name.txt ~locality)) vars ~field_name:"reader" in let shape = project_vars (evar ~loc (bin_shape_name td.ptype_name.txt ~locality)) vars ~field_name:"shape" in tp_record ~loc ~writer ~reader ~shape in make_value ~locality ~loc ~type_constr:(Typ.create "Bin_prot.Type_class.t") ~hide_params:true ~make_value_name:bin_name ~make_arg_name:bin_name ~body td ;; (* 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 ~hide_loc ~path ty = let loc = { loc with loc_ghost = true } in [%expr ([%e tp_record ~loc ~writer:(Generate_bin_write.type_class_extension ~loc ~path ty) ~reader:(Generate_bin_read.type_class_extension ~loc ~path ty) ~shape:(Bin_shape_expand.shape_extension ~loc ~hide_loc ty)] : _ Bin_prot.Type_class.t)] ;; 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 ~hide_loc:false) ;; let () = Deriving.add "bin_digest" ~extension:(fun ~loc ~path:_ -> Bin_shape_expand.digest_extension ~loc ~hide_loc:false) |> Deriving.ignore ;; let bin_size = Deriving.add "bin_size" ~extension:(Generate_bin_size.extension ~locality:None) ;; let () = Deriving.add "bin_size_local" ~extension:(Generate_bin_size.extension ~locality:(Some Local)) |> Deriving.ignore ;; let bin_write = Deriving.add "bin_write" ~str_type_decl:Generate_bin_write.gen ~sig_type_decl:Sig.bin_write ~extension:(Generate_bin_write.function_extension ~locality:None) ;; let () = Deriving.add "bin_write_local" ~extension:(Generate_bin_write.function_extension ~locality:(Some Local)) |> Deriving.ignore ;; let () = Deriving.add "bin_writer" ~extension:Generate_bin_write.type_class_extension |> Deriving.ignore ;; let bin_read = Deriving.add "bin_read" ~str_type_decl:Generate_bin_read.gen ~sig_type_decl:Sig.bin_read ~extension:Generate_bin_read.function_extension ;; let () = Deriving.add "bin_reader" ~extension:Generate_bin_read.type_class_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 ~hide_loc:false) ;; 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] is used in dotnet libraries to generate code that is compatible with F#. OCaml and F# have largely overlapping syntaxes, but some minor differences need to be taken into account: 1. F# doesn't have labeled arguments so all labeled arguments are changed into not labeled in [For_f_sharp.remove_labeled_arguments] below. This means we have to be careful when writing the ppx code to generate arguments to functions in the correct order (even if they are named) so that they are in the correct order for F# code after names are removed. 2. Accessing fields with a qualified path [record.M.field] doesn't work in F#, so we use type-directed disambiguation everywhere instead. We also use type-directed disambiguation for record construction. 3. Universal quantifier annotations (e.g. [let f : 'a. ...]) are not supported in F#. These are only necessary for polymorphic recursion, so we always avoid it when [f_sharp_compatible = true]. In fact, when [f_sharp_compatible = true], we hide all type parameters using an underscore, since they are not necessary for type-directed disambiguation. 4. Type annotations on the pattern of [let rec] bindings are not supported in F# (e.g. this doesn't work: [let rec (a : unit -> unit) = ...]), so whenever [f_sharp_compatible = true], we put the type annotation as a constraint on the expression rather than the pattern. *) module For_f_sharp = struct let remove_labeled_arguments = object inherit Ast_traverse.map method! arg_label (_ : arg_label) = Nolabel end ;; let bin_write ~loc ~path (rec_flag, tds) = let localize = false in let structure = Generate_bin_write.bin_write ~f_sharp_compatible:true ~loc ~path (rec_flag, tds) localize in remove_labeled_arguments#structure structure ;; let bin_read ~loc ~path (rec_flag, tds) = let structure = Generate_bin_read.bin_read ~f_sharp_compatible:true ~loc ~path (rec_flag, tds) in remove_labeled_arguments#structure structure ;; end ppx_bin_prot-0.17.0/src/ppx_bin_prot.mli000066400000000000000000000007051461647336100203140ustar00rootroot00000000000000open Ppxlib val bin_shape : Deriving.t val bin_size : Deriving.t val bin_write : Deriving.t val bin_read : Deriving.t val bin_type_class : Deriving.t val bin_io : Deriving.t module For_f_sharp : sig val bin_write : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure_item list val bin_read : loc:Location.t -> path:string -> rec_flag * type_declaration list -> structure_item list end ppx_bin_prot-0.17.0/test/000077500000000000000000000000001461647336100152745ustar00rootroot00000000000000ppx_bin_prot-0.17.0/test/allocation_tests.ml000066400000000000000000000025101461647336100211730ustar00rootroot00000000000000open! Core 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.17.0/test/allocation_tests.mli000066400000000000000000000000561461647336100213470ustar00rootroot00000000000000(*_ This file is intentionally left blank. *) ppx_bin_prot-0.17.0/test/compatibility.ml000066400000000000000000000322151461647336100205020ustar00rootroot00000000000000open! Core open Bigarray open Bin_prot open Common open Utils open Type_class open Bin_prot.Std module Array1_extras (M : Expect_test_helpers_base.With_equal) = struct let to_list : type a b c. (a, b, c) Array1.t -> a list = fun t -> let get i = match Array1.layout t with | C_layout -> Array1.get t i | Fortran_layout -> Array1.get t (i + 1) in List.init (Array1.dim t) ~f:get ;; let equal t1 t2 = Comparable.lift (List.equal M.equal) ~f:to_list t1 t2 let sexp_of_t t = List.sexp_of_t M.sexp_of_t (to_list t) end module Common = struct type tuple = float * string * int64 [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a record = { a : int ; b : 'a ; c : 'a option } [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a singleton_record = { y : 'a } [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a inline_record = | IR of { mutable ir_a : int ; ir_b : 'a ; ir_c : 'a option } | Other of int [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a sum = | Foo | Bar of int | Bla of 'a * string [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a variant = [ `Foo | `Bar of int | `Bla of 'a * string ] [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type variant_extension = [ float variant | `Baz of int * float ] [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a poly_app = (tuple * int singleton_record * 'a record * 'a inline_record) variant sum list [@@deriving bin_io ~localize, bin_io, equal, sexp_of] 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 ~localize, bin_io, equal, sexp_of] type 'a poly_id = 'a rec_t1 [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type el = float poly_id [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type els = el array [@@deriving bin_io ~localize, bin_io, equal, sexp_of] module Wildcard : sig type _ transparent = int [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type _ opaque [@@deriving bin_io ~localize, bin_io, equal, sexp_of] val opaque_examples : int opaque list end = struct type _ transparent = int [@@deriving bin_io ~localize, bin_io, equal, sexp_of] type 'a opaque = 'a option [@@deriving bin_io ~localize, bin_io, equal, sexp_of] let opaque_examples = [ None; Some 0; Some 1 ] end let%expect_test "Utils.bin_dump" = 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.create ~len: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 Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"pos_ref for length incorrect" !pos_ref 8; Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"els_len disagrees with bin_size" els_len (bin_size_els els); let new_els = bin_read_els buf ~pos_ref in Expect_test_helpers_base.require_equal [%here] (module struct type t = float poly_id Array.t [@@deriving equal, sexp_of] end) ~message:"new_els and els not equal" els new_els ;; end let%test_module "Inline" = (module struct let check_compatible m xs derived_tc inline_writer inline_reader inline_tc = List.iter xs ~f:(fun x -> Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"incorrect size from inline writer" (derived_tc.writer.size x) (inline_writer.size x); Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"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 Expect_test_helpers_base.require_equal [%here] (module struct type t = buf include Array1_extras (Char) end) ~message:"incorrect bin dump from inline writer" buf (bin_dump inline_writer x); Expect_test_helpers_base.require_equal [%here] (module struct type t = buf include Array1_extras (Char) end) ~message:"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 Expect_test_helpers_base.require_equal [%here] m ~message:"incorrect value from inline reader" x x'; Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"incorrect length from inline reader" len len'; let x', len' = val_and_len inline_tc.reader in Expect_test_helpers_base.require_equal [%here] m ~message:"incorrect value from inline type class" x x'; Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"incorrect length from inline type class" len len') ;; let%expect_test "simple tuple" = check_compatible (module struct type t = Common.tuple [@@deriving equal, sexp_of] end) [ 50.5, "hello", 1234L ] Common.bin_tuple [%bin_writer: Common.tuple] [%bin_reader: Common.tuple] [%bin_type_class: Common.tuple] ;; let%expect_test "redefine tuple" = check_compatible (module struct type t = Common.tuple [@@deriving equal, sexp_of] end) [ 50.5, "hello", 1234L ] Common.bin_tuple [%bin_writer: float * string * int64] [%bin_reader: float * string * int64] [%bin_type_class: float * string * int64] ;; let%expect_test "simple variant" = check_compatible (module struct type t = float Common.variant [@@deriving equal, sexp_of] end) [ `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] ;; let%expect_test "redefine variant" = check_compatible (module struct type t = [ `Foo | `Bar of int | `Bla of float * string ] [@@deriving equal, sexp_of] end) [ `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 ]] ;; let%expect_test "variant_extension" = check_compatible (module struct type t = [ float Common.variant | `Baz of int * float ] [@@deriving equal, sexp_of] end) [ `Foo; `Bar 8; `Bla (33.3, "world"); `Baz (17, 17.71) ] Common.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 ]] ;; let%expect_test "sub variant" = check_compatible (module struct type t = [ `Foo | `Bar of int | `Bla of int * string ] Common.singleton_record [@@deriving equal, sexp_of] end) [ { 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] ;; let%expect_test "transparent wildcard" = check_compatible (module struct type t = string Common.Wildcard.transparent [@@deriving equal, sexp_of] end) [ 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] ;; let%expect_test "opaque wildcard" = check_compatible (module struct type t = int Common.Wildcard.opaque [@@deriving equal, sexp_of] end) 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) ;; let%test_module "Local" = (module struct module type S = sig type t [@@deriving bin_io ~localize] include Expect_test_helpers_base.With_equal with type t := t end let check_compatible : type a. (module S with type t = a) -> a list -> unit = fun (module M) xs -> List.iter xs ~f:(fun x -> if phys_equal M.bin_write_t (M.bin_write_t__local :> _ Write.writer) then print_endline "bin_write_t = bin_write_t__local" else ( Expect_test_helpers_base.require_equal [%here] (module Int) ~message:"bin_size differs from bin_size_local" (M.bin_size_t x) (M.bin_size_t__local x); let buf = bin_dump M.bin_writer_t x in Expect_test_helpers_base.require_equal [%here] (module struct type t = buf include Array1_extras (Char) end) ~message:"incorrect bin dump from local writer" (bin_dump { size = (M.bin_size_t__local :> _ Size.sizer) ; write = (M.bin_write_t__local :> _ Write.writer) } x) buf; let x' = M.bin_read_t buf ~pos_ref:(ref 0) in Expect_test_helpers_base.require_equal [%here] (module M) ~message:"bin_write_local -> bin_read roundtrip failed" x x')) ;; let%expect_test "tuple" = check_compatible (module struct type t = Common.tuple [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ 1., "hi", 2L; Float.infinity, "", 0L ] ;; let%expect_test "variant" = check_compatible (module struct type t = float Common.variant [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ `Foo; `Bar 8; `Bla (33.3, "world") ] ;; let%expect_test "variant_extension" = check_compatible (module struct type t = Common.variant_extension [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ `Foo; `Bar 8; `Bla (33.3, "world"); `Baz (17, 17.71) ] ;; let%expect_test "sub variant" = check_compatible (module struct type t = int Common.variant Common.singleton_record [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ { Common.y = `Foo }; { y = `Bar 42 }; { y = `Bla (42, "world") } ] ;; let%expect_test "transparent wildcard" = check_compatible (module struct type t = string Common.Wildcard.transparent [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ 1; 2; 3 ] ;; let%expect_test "opaque wildcard" = check_compatible (module struct type t = int Common.Wildcard.opaque [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) Common.Wildcard.opaque_examples ;; let%expect_test "complicated type" = let el = let open Common in 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.create ~len:10 el in check_compatible (module struct type t = Common.els [@@deriving bin_io ~localize, bin_io, equal, sexp_of] end) [ els ] ;; end) ;; ppx_bin_prot-0.17.0/test/compatibility.mli000066400000000000000000000000561461647336100206510ustar00rootroot00000000000000(*_ This file is intentionally left blank. *) ppx_bin_prot-0.17.0/test/deriving_inline.ml000066400000000000000000000610441461647336100210000ustar00rootroot00000000000000open! Bin_prot.Std [@@@warning "-60"] module T : sig type t [@@deriving_inline bin_io, bin_io ~localize] include sig [@@@ocaml.warning "-32"] include Bin_prot.Binable.S with type t := t include Bin_prot.Binable.S_local with type t := t end [@@ocaml.doc "@inline"] [@@@end] end = struct type t = A [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ Bin_prot.Shape.Tid.of_string "t", [], Bin_prot.Shape.variant [ "A", [] ] ] in (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] ;; let _ = bin_shape_t let (bin_size_t__local : t Bin_prot.Size.sizer_local) = function | A -> 1 ;; let _ = bin_size_t__local let bin_size_t = (bin_size_t__local :> _ Bin_prot.Size.sizer) let _ = bin_size_t let (bin_write_t__local : t Bin_prot.Write.writer_local) = fun buf ~pos -> function | A -> Bin_prot.Write.bin_write_int_8bit buf ~pos 0 ;; let _ = bin_write_t__local let bin_write_t = (bin_write_t__local :> _ Bin_prot.Write.writer) let _ = bin_write_t let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.T.t" !pos_ref ;; let _ = __bin_read_t__ let (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> A | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.T.t") !pos_ref ;; let _ = bin_read_t let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end module T1 : sig type 'a t [@@deriving_inline bin_io, bin_io ~localize] include sig [@@@ocaml.warning "-32"] include Bin_prot.Binable.S1 with type 'a t := 'a t include Bin_prot.Binable.S_local1 with type 'a t := 'a t end [@@ocaml.doc "@inline"] [@@@end] end = struct type 'a t = A of 'a [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : 'a t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [ Bin_prot.Shape.Vid.of_string "a" ] , Bin_prot.Shape.variant [ ( "A" , [ Bin_prot.Shape.var (Bin_prot.Shape.Location.of_string "") (Bin_prot.Shape.Vid.of_string "a") ] ) ] ) ] in fun a -> (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [ a ] ;; let _ = bin_shape_t let bin_size_t__local : 'a. 'a Bin_prot.Size.sizer_local -> 'a t Bin_prot.Size.sizer_local = fun _size_of_a__local -> function | A v1 -> let size = 1 in Bin_prot.Common.( + ) size (_size_of_a__local v1) ;; let _ = bin_size_t__local let bin_size_t : 'a. 'a Bin_prot.Size.sizer -> 'a t Bin_prot.Size.sizer = fun _size_of_a -> function | A v1 -> let size = 1 in Bin_prot.Common.( + ) size (_size_of_a v1) ;; let _ = bin_size_t let bin_write_t__local : 'a. 'a Bin_prot.Write.writer_local -> 'a t Bin_prot.Write.writer_local = fun _write_a__local buf ~pos -> function | A v1 -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in _write_a__local buf ~pos v1 ;; let _ = bin_write_t__local let bin_write_t : 'a. 'a Bin_prot.Write.writer -> 'a t Bin_prot.Write.writer = fun _write_a buf ~pos -> function | A v1 -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in _write_a buf ~pos v1 ;; let _ = bin_write_t let bin_writer_t = (fun bin_writer_a -> { size = (fun v -> bin_size_t bin_writer_a.size v) ; write = (fun v -> bin_write_t bin_writer_a.write v) } : _ Bin_prot.Type_class.writer -> _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let __bin_read_t__ : 'a. 'a Bin_prot.Read.reader -> (int -> 'a t) Bin_prot.Read.reader = fun _of__a _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.T1.t" !pos_ref ;; let _ = __bin_read_t__ let bin_read_t : 'a. 'a Bin_prot.Read.reader -> 'a t Bin_prot.Read.reader = fun _of__a buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> let arg_1 = _of__a buf ~pos_ref in A arg_1 | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.T1.t") !pos_ref ;; let _ = bin_read_t let bin_reader_t = (fun bin_reader_a -> { read = (fun buf ~pos_ref -> (bin_read_t bin_reader_a.read) buf ~pos_ref) ; vtag_read = (fun buf ~pos_ref vtag -> (__bin_read_t__ bin_reader_a.read) buf ~pos_ref vtag) } : _ Bin_prot.Type_class.reader -> _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = (fun bin_a -> { writer = bin_writer_t bin_a.writer ; reader = bin_reader_t bin_a.reader ; shape = bin_shape_t bin_a.shape } : _ Bin_prot.Type_class.t -> _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end module T_write : sig type t [@@deriving_inline bin_write, bin_write ~localize] include sig [@@@ocaml.warning "-32"] val bin_size_t : t Bin_prot.Size.sizer val bin_write_t : t Bin_prot.Write.writer val bin_writer_t : t Bin_prot.Type_class.writer val bin_size_t : t Bin_prot.Size.sizer val bin_size_t__local : t Bin_prot.Size.sizer_local val bin_write_t : t Bin_prot.Write.writer val bin_write_t__local : t Bin_prot.Write.writer_local val bin_writer_t : t Bin_prot.Type_class.writer end [@@ocaml.doc "@inline"] [@@@end] end = struct type t [@@deriving bin_write ~localize] end module T_read : sig type t [@@deriving_inline bin_read] include sig [@@@ocaml.warning "-32"] val bin_read_t : t Bin_prot.Read.reader val __bin_read_t__ : (int -> t) Bin_prot.Read.reader val bin_reader_t : t Bin_prot.Type_class.reader end [@@ocaml.doc "@inline"] [@@@end] end = struct type t [@@deriving bin_read] end module T_type_class : sig type t [@@deriving_inline bin_type_class] include sig [@@@ocaml.warning "-32"] val bin_t : t Bin_prot.Type_class.t end [@@ocaml.doc "@inline"] [@@@end] end = struct type t [@@deriving bin_io] end module Mutual_recursion : sig type t = | Int of int | Add of u * u and u = Mul of t * t [@@deriving bin_io ~localize] end = struct type t = | Int of int | Add of u * u and u = Mul of t * t [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : t) -> () let _ = fun (_ : u) -> () let bin_shape_t, bin_shape_u = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [] , Bin_prot.Shape.variant [ "Int", [ bin_shape_int ] ; ( "Add" , [ (Bin_prot.Shape.rec_app (Bin_prot.Shape.Tid.of_string "u")) [] ; (Bin_prot.Shape.rec_app (Bin_prot.Shape.Tid.of_string "u")) [] ] ) ] ) ; ( Bin_prot.Shape.Tid.of_string "u" , [] , Bin_prot.Shape.variant [ ( "Mul" , [ (Bin_prot.Shape.rec_app (Bin_prot.Shape.Tid.of_string "t")) [] ; (Bin_prot.Shape.rec_app (Bin_prot.Shape.Tid.of_string "t")) [] ] ) ] ) ] in ( (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] , (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "u")) [] ) ;; let _ = bin_shape_t and _ = bin_shape_u let rec (bin_size_t__local : t Bin_prot.Size.sizer_local) = function | Int v1 -> let size = 1 in Bin_prot.Common.( + ) size (bin_size_int__local v1) | Add (v1, v2) -> let size = 1 in let size = Bin_prot.Common.( + ) size (bin_size_u__local v1) in Bin_prot.Common.( + ) size (bin_size_u__local v2) and (bin_size_u__local : u Bin_prot.Size.sizer_local) = function | Mul (v1, v2) -> let size = 1 in let size = Bin_prot.Common.( + ) size (bin_size_t__local v1) in Bin_prot.Common.( + ) size (bin_size_t__local v2) ;; let _ = bin_size_t__local and _ = bin_size_u__local let bin_size_t = (bin_size_t__local :> _ Bin_prot.Size.sizer) and bin_size_u = (bin_size_u__local :> _ Bin_prot.Size.sizer) let _ = bin_size_t and _ = bin_size_u let rec (bin_write_t__local : t Bin_prot.Write.writer_local) = fun buf ~pos -> function | Int v1 -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in bin_write_int__local buf ~pos v1 | Add (v1, v2) -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 1 in let pos = bin_write_u__local buf ~pos v1 in bin_write_u__local buf ~pos v2 and (bin_write_u__local : u Bin_prot.Write.writer_local) = fun buf ~pos -> function | Mul (v1, v2) -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in let pos = bin_write_t__local buf ~pos v1 in bin_write_t__local buf ~pos v2 ;; let _ = bin_write_t__local and _ = bin_write_u__local let bin_write_t = (bin_write_t__local :> _ Bin_prot.Write.writer) and bin_write_u = (bin_write_u__local :> _ Bin_prot.Write.writer) let _ = bin_write_t and _ = bin_write_u let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) and bin_writer_u = ({ size = bin_size_u; write = bin_write_u } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t and _ = bin_writer_u let rec (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Mutual_recursion.t" !pos_ref and (__bin_read_u__ : (int -> u) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Mutual_recursion.u" !pos_ref and (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> let arg_1 = bin_read_int buf ~pos_ref in Int arg_1 | 1 -> let arg_1 = bin_read_u buf ~pos_ref in let arg_2 = bin_read_u buf ~pos_ref in Add (arg_1, arg_2) | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.Mutual_recursion.t") !pos_ref and (bin_read_u : u Bin_prot.Read.reader) = fun buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> let arg_1 = bin_read_t buf ~pos_ref in let arg_2 = bin_read_t buf ~pos_ref in Mul (arg_1, arg_2) | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.Mutual_recursion.u") !pos_ref ;; let _ = __bin_read_t__ and _ = __bin_read_u__ and _ = bin_read_t and _ = bin_read_u let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) and bin_reader_u = ({ read = bin_read_u; vtag_read = __bin_read_u__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t and _ = bin_reader_u let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) and bin_u = ({ writer = bin_writer_u; reader = bin_reader_u; shape = bin_shape_u } : _ Bin_prot.Type_class.t) ;; let _ = bin_t and _ = bin_u [@@@end] end module Float_array : sig type t = float array * int list [@@deriving_inline bin_io] include sig [@@@ocaml.warning "-32"] include Bin_prot.Binable.S with type t := t end [@@ocaml.doc "@inline"] [@@@end] end = struct type t = float array * int list [@@deriving_inline bin_io ~hide_locations] let _ = fun (_ : t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [] , Bin_prot.Shape.tuple [ bin_shape_array bin_shape_float; bin_shape_list bin_shape_int ] ) ] in (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] ;; let _ = bin_shape_t let (bin_size_t : t Bin_prot.Size.sizer) = function | v1, v2 -> let size = 0 in let size = Bin_prot.Common.( + ) size (bin_size_array bin_size_float v1) in Bin_prot.Common.( + ) size (bin_size_list bin_size_int v2) ;; let _ = bin_size_t let (bin_write_t : t Bin_prot.Write.writer) = fun buf ~pos -> function | v1, v2 -> let pos = bin_write_array bin_write_float buf ~pos v1 in bin_write_list bin_write_int buf ~pos v2 ;; let _ = bin_write_t let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Float_array.t" !pos_ref ;; let _ = __bin_read_t__ let (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> let v1 = (bin_read_array bin_read_float) buf ~pos_ref in let v2 = (bin_read_list bin_read_int) buf ~pos_ref in v1, v2 ;; let _ = bin_read_t let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end module Global_fields_with_localize : sig module Record : sig type t [@@deriving bin_io ~localize] end module Record_constructor : sig type t [@@deriving bin_io ~localize] end module Tuple_constructor : sig type t [@@deriving bin_io ~localize] end end = struct module T = struct type t [@@deriving bin_io ~localize] end module Normal = T module Mutable = T module Global = T module Ocaml_global = T module Extension_global = T module Record = struct type t = { a : Normal.t ; mutable b : Mutable.t ; c : Global.t ; d : Ocaml_global.t ; e : Extension_global.t } [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [] , Bin_prot.Shape.record [ "a", Normal.bin_shape_t ; "b", Mutable.bin_shape_t ; "c", Global.bin_shape_t ; "d", Ocaml_global.bin_shape_t ; "e", Extension_global.bin_shape_t ] ) ] in (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] ;; let _ = bin_shape_t let (bin_size_t__local : t Bin_prot.Size.sizer_local) = function | { a = v1; b = v2; c = v3; d = v4; e = v5 } -> let size = 0 in let size = Bin_prot.Common.( + ) size (Normal.bin_size_t__local v1) in let size = Bin_prot.Common.( + ) size (Mutable.bin_size_t v2) in let size = Bin_prot.Common.( + ) size (Global.bin_size_t v3) in let size = Bin_prot.Common.( + ) size (Ocaml_global.bin_size_t v4) in Bin_prot.Common.( + ) size (Extension_global.bin_size_t v5) ;; let _ = bin_size_t__local let bin_size_t = (bin_size_t__local :> _ Bin_prot.Size.sizer) let _ = bin_size_t let (bin_write_t__local : t Bin_prot.Write.writer_local) = fun buf ~pos -> function | { a = v1; b = v2; c = v3; d = v4; e = v5 } -> let pos = Normal.bin_write_t__local buf ~pos v1 in let pos = Mutable.bin_write_t buf ~pos v2 in let pos = Global.bin_write_t buf ~pos v3 in let pos = Ocaml_global.bin_write_t buf ~pos v4 in Extension_global.bin_write_t buf ~pos v5 ;; let _ = bin_write_t__local let bin_write_t = (bin_write_t__local :> _ Bin_prot.Write.writer) let _ = bin_write_t let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Global_fields_with_localize.Record.t" !pos_ref ;; let _ = __bin_read_t__ let (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> let v_a = Normal.bin_read_t buf ~pos_ref in let v_b = Mutable.bin_read_t buf ~pos_ref in let v_c = Global.bin_read_t buf ~pos_ref in let v_d = Ocaml_global.bin_read_t buf ~pos_ref in let v_e = Extension_global.bin_read_t buf ~pos_ref in { a = v_a; b = v_b; c = v_c; d = v_d; e = v_e } ;; let _ = bin_read_t let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end module Record_constructor = struct type t = | T of { a : Normal.t ; mutable b : Mutable.t ; c : Global.t ; d : Ocaml_global.t ; e : Extension_global.t } [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [] , Bin_prot.Shape.variant [ ( "T" , [ Bin_prot.Shape.record [ "a", Normal.bin_shape_t ; "b", Mutable.bin_shape_t ; "c", Global.bin_shape_t ; "d", Ocaml_global.bin_shape_t ; "e", Extension_global.bin_shape_t ] ] ) ] ) ] in (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] ;; let _ = bin_shape_t let (bin_size_t__local : t Bin_prot.Size.sizer_local) = function | T { a = v1; b = v2; c = v3; d = v4; e = v5 } -> let size = 1 in let size = Bin_prot.Common.( + ) size (Normal.bin_size_t__local v1) in let size = Bin_prot.Common.( + ) size (Mutable.bin_size_t v2) in let size = Bin_prot.Common.( + ) size (Global.bin_size_t v3) in let size = Bin_prot.Common.( + ) size (Ocaml_global.bin_size_t v4) in Bin_prot.Common.( + ) size (Extension_global.bin_size_t v5) ;; let _ = bin_size_t__local let bin_size_t = (bin_size_t__local :> _ Bin_prot.Size.sizer) let _ = bin_size_t let (bin_write_t__local : t Bin_prot.Write.writer_local) = fun buf ~pos -> function | T { a = v1; b = v2; c = v3; d = v4; e = v5 } -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in let pos = Normal.bin_write_t__local buf ~pos v1 in let pos = Mutable.bin_write_t buf ~pos v2 in let pos = Global.bin_write_t buf ~pos v3 in let pos = Ocaml_global.bin_write_t buf ~pos v4 in Extension_global.bin_write_t buf ~pos v5 ;; let _ = bin_write_t__local let bin_write_t = (bin_write_t__local :> _ Bin_prot.Write.writer) let _ = bin_write_t let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Global_fields_with_localize.Record_constructor.t" !pos_ref ;; let _ = __bin_read_t__ let (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> let v_a = Normal.bin_read_t buf ~pos_ref in let v_b = Mutable.bin_read_t buf ~pos_ref in let v_c = Global.bin_read_t buf ~pos_ref in let v_d = Ocaml_global.bin_read_t buf ~pos_ref in let v_e = Extension_global.bin_read_t buf ~pos_ref in T { a = v_a; b = v_b; c = v_c; d = v_d; e = v_e } | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.Global_fields_with_localize.Record_constructor.t") !pos_ref ;; let _ = bin_read_t let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end module Tuple_constructor = struct type t = T of Normal.t * Global.t * Ocaml_global.t * Extension_global.t [@@deriving_inline bin_io ~localize ~hide_locations] let _ = fun (_ : t) -> () let bin_shape_t = let _group = Bin_prot.Shape.group (Bin_prot.Shape.Location.of_string "") [ ( Bin_prot.Shape.Tid.of_string "t" , [] , Bin_prot.Shape.variant [ ( "T" , [ Normal.bin_shape_t ; Global.bin_shape_t ; Ocaml_global.bin_shape_t ; Extension_global.bin_shape_t ] ) ] ) ] in (Bin_prot.Shape.top_app _group (Bin_prot.Shape.Tid.of_string "t")) [] ;; let _ = bin_shape_t let (bin_size_t__local : t Bin_prot.Size.sizer_local) = function | T (v1, v2, v3, v4) -> let size = 1 in let size = Bin_prot.Common.( + ) size (Normal.bin_size_t__local v1) in let size = Bin_prot.Common.( + ) size (Global.bin_size_t v2) in let size = Bin_prot.Common.( + ) size (Ocaml_global.bin_size_t v3) in Bin_prot.Common.( + ) size (Extension_global.bin_size_t v4) ;; let _ = bin_size_t__local let bin_size_t = (bin_size_t__local :> _ Bin_prot.Size.sizer) let _ = bin_size_t let (bin_write_t__local : t Bin_prot.Write.writer_local) = fun buf ~pos -> function | T (v1, v2, v3, v4) -> let pos = Bin_prot.Write.bin_write_int_8bit buf ~pos 0 in let pos = Normal.bin_write_t__local buf ~pos v1 in let pos = Global.bin_write_t buf ~pos v2 in let pos = Ocaml_global.bin_write_t buf ~pos v3 in Extension_global.bin_write_t buf ~pos v4 ;; let _ = bin_write_t__local let bin_write_t = (bin_write_t__local :> _ Bin_prot.Write.writer) let _ = bin_write_t let bin_writer_t = ({ size = bin_size_t; write = bin_write_t } : _ Bin_prot.Type_class.writer) ;; let _ = bin_writer_t let (__bin_read_t__ : (int -> t) Bin_prot.Read.reader) = fun _buf ~pos_ref _vint -> Bin_prot.Common.raise_variant_wrong_type "deriving_inline.ml.Global_fields_with_localize.Tuple_constructor.t" !pos_ref ;; let _ = __bin_read_t__ let (bin_read_t : t Bin_prot.Read.reader) = fun buf ~pos_ref -> match Bin_prot.Read.bin_read_int_8bit buf ~pos_ref with | 0 -> let arg_1 = Normal.bin_read_t buf ~pos_ref in let arg_2 = Global.bin_read_t buf ~pos_ref in let arg_3 = Ocaml_global.bin_read_t buf ~pos_ref in let arg_4 = Extension_global.bin_read_t buf ~pos_ref in T (arg_1, arg_2, arg_3, arg_4) | _ -> Bin_prot.Common.raise_read_error (Bin_prot.Common.ReadError.Sum_tag "deriving_inline.ml.Global_fields_with_localize.Tuple_constructor.t") !pos_ref ;; let _ = bin_read_t let bin_reader_t = ({ read = bin_read_t; vtag_read = __bin_read_t__ } : _ Bin_prot.Type_class.reader) ;; let _ = bin_reader_t let bin_t = ({ writer = bin_writer_t; reader = bin_reader_t; shape = bin_shape_t } : _ Bin_prot.Type_class.t) ;; let _ = bin_t [@@@end] end end ppx_bin_prot-0.17.0/test/deriving_inline.mli000066400000000000000000000000561461647336100211450ustar00rootroot00000000000000(*_ This file is intentionally left blank. *) ppx_bin_prot-0.17.0/test/dune000066400000000000000000000001571461647336100161550ustar00rootroot00000000000000(library (name ppx_bin_prot_tests) (libraries core expect_test_helpers_core) (preprocess (pps ppx_jane))) ppx_bin_prot-0.17.0/test/example.ml000066400000000000000000000054771461647336100172760ustar00rootroot00000000000000open Bin_prot.Std module type S = sig type t [@@deriving bin_io ~localize] end module type S1 = sig type 'a t [@@deriving bin_io ~localize] end module type S2 = sig type ('a, 'b) t [@@deriving bin_io ~localize] end include ( struct type t = int [@@deriving bin_io ~localize] end : S) include ( struct type t = int32 [@@deriving bin_io ~localize] end : S) include ( struct type t = int64 [@@deriving bin_io ~localize] end : S) include ( struct type t = nativeint [@@deriving bin_io ~localize] end : S) include ( struct type t = float [@@deriving bin_io ~localize] end : S) include ( struct type t = char [@@deriving bin_io ~localize] end : S) include ( struct type t = int list [@@deriving bin_io ~localize] end : S) include ( struct type t = float array [@@deriving bin_io ~localize] end : S) include ( struct type t = int64 array [@@deriving bin_io ~localize] end : S) include ( struct type t = int * float * char [@@deriving bin_io ~localize] end : S) include ( struct type u = | A | B [@@deriving bin_io ~localize] type t = | C | D | E of u [@@deriving bin_io ~localize] end : S) include ( struct type u = [ `A | `B ] [@@deriving bin_io ~localize] type t = [ `C | `D | `E of u ] [@@deriving bin_io ~localize] end : S) include ( struct type a = [ `A1 | `A2 ] [@@deriving bin_io ~localize] type b = [ `B1 | `B2 ] [@@deriving bin_io ~localize] type t = [ a | b ] [@@deriving bin_io ~localize] end : S) include ( struct type t = { foo : char ; bar : int ; baz : string } [@@deriving bin_io ~localize] 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 ~localize] end : S) include ( struct type 'a t = 'a [@@deriving bin_io ~localize] end : S1) include ( struct type 'a t = 'a * int [@@deriving bin_io ~localize] end : S1) include ( struct type ('a, 'b) t = 'a * 'b [@@deriving bin_io ~localize] end : S2) include ( struct type 'a u = 'a constraint 'a = [< `A | `B ] [@@deriving bin_io ~localize] type 'a t = [ `A ] u [@@deriving bin_io ~localize] end : S1) include ( struct type 'a t = { foo : 'a ; bar : int } [@@deriving bin_io ~localize] end : S1) include ( struct type 'a t = | A of { foo : 'a ; bar : int } | B of 'a | C [@@deriving bin_io ~localize] end : S1) ppx_bin_prot-0.17.0/test/example.mli000066400000000000000000000000561461647336100174330ustar00rootroot00000000000000(*_ This file is intentionally left blank. *) ppx_bin_prot-0.17.0/test/extension_tests.ml000066400000000000000000000104711461647336100210670ustar00rootroot00000000000000(* Ensure that all of the extension points expand without causing compiler errors. *) module _ = struct module T' = struct open Bin_prot.Std type t = { a : int ; b : string } [@@deriving bin_io] end open T' (* [Bin_prot.Std] doesn't need to be included in namespace. *) let _ = [%bin_shape: t] let (_ : string) = [%bin_digest: t] let _ = [%bin_size: t] let _ = [%bin_write: t] let _ = [%bin_writer: t] let (_ : t Bin_prot.Read.reader) = [%bin_read: t] let (_ : t Bin_prot.Type_class.reader) = [%bin_reader: t] let _ = [%bin_type_class: t] end (* Check extension points on polymorphic variants. *) module _ = struct type t = [ `A | `B of int ] open Bin_prot.Std let (_ : Bin_shape.t) = [%bin_shape: [ `A | `B of int ]] let (_ : string) = [%bin_digest: [ `A | `B of int ]] let _ = [%bin_size: [ `A | `B of int ]] let _ = [%bin_write: [ `A | `B of int ]] let _ = [%bin_writer: [ `A | `B of int ]] let (_ : t Bin_prot.Read.reader) = [%bin_read: [ `A | `B of int ]] let (_ : t Bin_prot.Type_class.reader) = [%bin_reader: [ `A | `B of int ]] let _ = [%bin_type_class: [ `A | `B of int ]] end open! Core open Expect_test_helpers_core module type S = sig type t [@@deriving equal, quickcheck, sexp_of] end (* Testing [%bin_size{,_local}], [%bin_write{,_local}], and [%bin_read] extension points behave the same as the derived functions. *) let test (type a) bin_size bin_size_local bin_write bin_write_local bin_read (module M : S with type t = a) = quickcheck_m [%here] (module M) ~f:(fun t -> let computed_size = bin_size t in let computed_size_local = bin_size_local t in require [%here] (computed_size = computed_size_local) ~if_false_then_print_s: [%lazy_message "bin_size differs from bin_size_local" (computed_size : int) (computed_size_local : int)]; let message = Bigstring.create computed_size in let written_size = bin_write message ~pos:0 t in require [%here] (computed_size = written_size) ~if_false_then_print_s: [%lazy_message "did not write entire message" (computed_size : int) (written_size : int) ~written:(Bigstring.sub message ~pos:0 ~len:written_size : Bigstring.t)]; let pos_ref = ref 0 in let round_trip = bin_read message ~pos_ref in let read_size = !pos_ref in require [%here] (computed_size = read_size) ~if_false_then_print_s: [%lazy_message "did not read entire message" (computed_size : int) (read_size : int) (message : Bigstring.t)]; require [%here] (M.equal t round_trip) ~if_false_then_print_s: [%lazy_message "value did not round-trip" (t : M.t) (round_trip : M.t)]; let message_local = Bigstring.create computed_size in let (_ : int) = bin_write_local message_local ~pos:0 t in require [%here] (Bigstring.equal message message_local) ~if_false_then_print_s: [%lazy_message "bin_write differs from bin_write_local" ~output:(message : Bigstring.t) ~local_output:(message_local : Bigstring.t)]) ;; let%expect_test _ = test [%bin_size: int] [%bin_size_local: int] [%bin_write: int] [%bin_write_local: int] [%bin_read: int] (module Int); [%expect {| |}] ;; let%expect_test _ = test [%bin_size: string list] [%bin_size_local: string list] [%bin_write: string list] [%bin_write_local: string list] [%bin_read: string list] (module struct type t = string list [@@deriving equal, quickcheck, sexp_of] end); [%expect {| |}] ;; let%expect_test _ = let open struct type c = [ `C of string ] [@@deriving bin_io ~localize, equal, quickcheck, sexp_of] end in test [%bin_size: [ `A | `B of int | c ]] [%bin_size_local: [ `A | `B of int | c ]] [%bin_write: [ `A | `B of int | c ]] [%bin_write_local: [ `A | `B of int | c ]] [%bin_read: [ `A | `B of int | c ]] (module struct type t = [ `A | `B of int | c ] [@@deriving equal, quickcheck, sexp_of] end); [%expect {| |}] ;; ppx_bin_prot-0.17.0/test/extension_tests.mli000066400000000000000000000000551461647336100212350ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) ppx_bin_prot-0.17.0/test/mutually_recursive.mlt000066400000000000000000000061401461647336100217560ustar00rootroot00000000000000open 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 ~localize] 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_shape.t -> Bin_shape.t -> Bin_shape.t val bin_shape_t' : Bin_shape.t -> Bin_shape.t -> Bin_shape.t val bin_size_branch__local : 'a Bin_prot.Size.sizer_local -> 'm Bin_prot.Size.sizer_local -> ('a, 'm) branch Bin_prot.Size.sizer_local val bin_size_t'__local : 'a Bin_prot.Size.sizer_local -> 'm Bin_prot.Size.sizer_local -> ('a, 'm) t' Bin_prot.Size.sizer_local 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__local : 'a Bin_prot.Write.writer_local -> 'm Bin_prot.Write.writer_local -> ('a, 'm) branch Bin_prot.Write.writer_local val bin_write_t'__local : 'a Bin_prot.Write.writer_local -> 'm Bin_prot.Write.writer_local -> ('a, 'm) t' Bin_prot.Write.writer_local 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.writer -> 'b Bin_prot.Type_class.writer -> ('a, 'b) branch Bin_prot.Type_class.writer val bin_writer_t' : 'a Bin_prot.Type_class.writer -> 'b Bin_prot.Type_class.writer -> ('a, 'b) t' Bin_prot.Type_class.writer 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.reader -> 'b Bin_prot.Type_class.reader -> ('a, 'b) branch Bin_prot.Type_class.reader val bin_reader_t' : 'a Bin_prot.Type_class.reader -> 'b Bin_prot.Type_class.reader -> ('a, 'b) t' Bin_prot.Type_class.reader val bin_branch : 'a Bin_prot.Type_class.t -> 'b Bin_prot.Type_class.t -> ('a, 'b) branch Bin_prot.Type_class.t val bin_t' : 'a Bin_prot.Type_class.t -> 'b Bin_prot.Type_class.t -> ('a, 'b) t' Bin_prot.Type_class.t end |}] ppx_bin_prot-0.17.0/test/nonrec_test.ml000066400000000000000000000012301461647336100201450ustar00rootroot00000000000000open Bin_prot.Std [@@@warning "-unused-module"] type t = float [@@deriving bin_io ~localize] module M : sig type t = float [@@deriving bin_io ~localize] end = struct type nonrec t = t [@@deriving bin_io ~localize] end module M1 : sig type t = float list [@@deriving bin_io ~localize] end = struct type nonrec t = t list [@@deriving bin_io ~localize] end module M2 : sig type nonrec t = t list [@@deriving bin_io ~localize] end = struct type nonrec t = t list [@@deriving bin_io ~localize] end module M3 : sig type nonrec t = [ `A of t ] [@@deriving bin_io ~localize] end = struct type nonrec t = [ `A of t ] [@@deriving bin_io ~localize] end ppx_bin_prot-0.17.0/test/nonrec_test.mli000066400000000000000000000000561461647336100203230ustar00rootroot00000000000000(*_ This file is intentionally left blank. *) ppx_bin_prot-0.17.0/test/nopervasives/000077500000000000000000000000001461647336100200205ustar00rootroot00000000000000ppx_bin_prot-0.17.0/test/nopervasives/dune000066400000000000000000000002761461647336100207030ustar00rootroot00000000000000(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.17.0/test/nopervasives/ppx_bin_prot_nopervasives.ml000066400000000000000000000001501461647336100256550ustar00rootroot00000000000000open Core module M = struct type t = { a : float ; b : float } [@@deriving bin_io] end ppx_bin_prot-0.17.0/test/polymorphic_recursion.mlt000066400000000000000000000020261461647336100224500ustar00rootroot00000000000000open Bin_prot.Std;; #verbose true module Simple = struct type 'a t = C of 'a list t * string t [@@deriving bin_io ~localize] end [%%expect {| module Simple : sig type 'a t = C of 'a list t * string t val bin_shape_t : Bin_shape.t -> Bin_shape.t val bin_size_t__local : 'a Bin_prot.Size.sizer_local -> 'a t Bin_prot.Size.sizer_local val bin_size_t : 'a Bin_prot.Size.sizer -> 'a t Bin_prot.Size.sizer val bin_write_t__local : 'a Bin_prot.Write.writer_local -> 'a t Bin_prot.Write.writer_local 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_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.reader -> 'a t Bin_prot.Type_class.reader val bin_t : 'a Bin_prot.Type_class.t -> 'a t Bin_prot.Type_class.t end |}]