pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=0363459dca9e8d1e91b36bf1993ed9540b109995 ppx_fields_conv-0.16.0/000077500000000000000000000000001442175067100147675ustar00rootroot00000000000000ppx_fields_conv-0.16.0/.gitignore000066400000000000000000000000411442175067100167520ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_fields_conv-0.16.0/CHANGES.md000066400000000000000000000024361442175067100163660ustar00rootroot00000000000000## Release v0.16.0 * Added options to `[@@deriving fields]` for selecting a subset of definitions. For example, `[@@deriving fields ~getters ~setters]` derives getter and setter functions only, and omits the entire `Fields` submodule. ## Old pre-v0.15 changelogs (very likely stale and incomplete) ## v0.11 - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, ppx\_metaquot and ppx\_type\_conv. ## 113.33.00 - Fix errors in `ppx_fields_conv` documentation - Add unit tests for `ppx_fields_conv` functions - Fix some idiosyncracies where the implementations in `ppx_fields_conv.ml` differed (ex: a variable would be called one thing when implementing one function but would be called something different when implementing every other function). ## 113.24.00 - The `iter` function generated by ppx\_variants\_conv and ppx\_fields\_conv allowed one to give function which returned values of arbitrary types as iter function. This release constraint these functions to return unit. N.B. the signature generated by the use of `@@deriving variants` (resp. fields) in interface already constrained the type to unit. - Update to follow type\_conv's evolution. - Add `Fields.make_creator` to ppx\_fields\_conv's readme, since it appears to not be all that deprecated. ppx_fields_conv-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100172170ustar00rootroot00000000000000This 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_fields_conv-0.16.0/LICENSE.md000066400000000000000000000021461442175067100163760ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_fields_conv-0.16.0/Makefile000066400000000000000000000004031442175067100164240ustar00rootroot00000000000000INSTALL_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_fields_conv-0.16.0/README.md000066400000000000000000000230171442175067100162510ustar00rootroot00000000000000ppx_fields_conv =============== Generation of accessor and iteration functions for ocaml records. `ppx_fields_conv` is a ppx rewriter that can be used to define first class values representing record fields, and additional routines, to get and set record fields, iterate and fold over all fields of a record and create new record values. # Basic Usage If you define a type as follows: ```ocaml type t = { dir : [ `Buy | `Sell ]; quantity : int; price : float; mutable cancelled : bool; } [@@deriving fields] ``` then code will be generated for functions of the following type: ```ocaml (* getters *) val cancelled : t -> bool val price : t -> float val quantity : t -> int val dir : t -> [ `Buy | `Sell ] (* setters *) val set_cancelled : t -> bool -> unit (* higher order fields and functions over all fields *) module Fields : sig val names : string list val cancelled : (t, bool ) Field.t val price : (t, float ) Field.t val quantity : (t, int ) Field.t val dir : (t, [ `Buy | `Sell ]) Field.t val create : dir:[ `Buy | `Sell ] -> quantity : int -> price : float -> cancelled : bool -> t val make_creator : dir: ((t, [ `Buy | `Sell ]) Field.t -> 'a -> ('arg -> [ `Buy | `Sell ]) * 'b) -> quantity: ((t, int ) Field.t -> 'b -> ('arg -> int ) * 'c) -> price: ((t, float ) Field.t -> 'c -> ('arg -> float ) * 'd) -> cancelled:((t, bool ) Field.t -> 'd -> ('arg -> bool ) * 'e) -> 'a -> ('arg -> t) * 'e val fold : init:'a -> dir :('a -> (t, [ `Buy | `Sell ]) Field.t -> 'b) -> quantity :('b -> (t, int ) Field.t -> 'c) -> price :('c -> (t, float ) Field.t -> 'd) -> cancelled:('d -> (t, bool ) Field.t -> 'e) -> 'e val map : dir :((t, [ `Buy | `Sell ]) Field.t -> [ `Buy | `Sell ]) -> quantity :((t, int ) Field.t -> int) -> price :((t, float ) Field.t -> float) -> cancelled:((t, bool ) Field.t -> bool) -> t val iter : dir :((t, [ `Buy | `Sell ]) Field.t -> unit) -> quantity :((t, int ) Field.t -> unit) -> price :((t, float ) Field.t -> unit) -> cancelled:((t, bool ) Field.t -> unit) -> unit val for_all : dir :((t, [ `Buy | `Sell ]) Field.t -> bool) -> quantity :((t, int ) Field.t -> bool) -> price :((t, float ) Field.t -> bool) -> cancelled:((t, bool ) Field.t -> bool) -> bool val exists : dir :((t, [ `Buy | `Sell ]) Field.t -> bool) -> quantity :((t, int ) Field.t -> bool) -> price :((t, float ) Field.t -> bool) -> cancelled:((t, bool ) Field.t -> bool) -> bool val to_list : dir :((t, [ `Buy | `Sell ]) Field.t -> 'a) -> quantity :((t, int ) Field.t -> 'a) -> price :((t, float ) Field.t -> 'a) -> cancelled:((t, bool ) Field.t -> 'a) -> 'a list val map_poly : ([< `Read | `Set_and_create ], t, 'a) Field.user -> 'a list (** Functions that take a record directly *) module Direct : sig val fold : t -> init:'a -> dir :('a -> (t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'b) -> quantity :('b -> (t, int ) Field.t -> t -> int -> 'c) -> price :('c -> (t, float ) Field.t -> t -> float -> 'd) -> cancelled:('d -> (t, bool ) Field.t -> t -> bool -> 'e) -> 'e val map : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> [ `Buy | `Sell ]) -> quantity :((t, int ) Field.t -> t -> int -> int) -> price :((t, float ) Field.t -> t -> float -> float) -> cancelled:((t, bool ) Field.t -> t -> bool -> bool) -> t val iter : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> unit) -> quantity :((t, int ) Field.t -> t -> int -> unit) -> price :((t, float ) Field.t -> t -> float -> unit) -> cancelled:((t, bool ) Field.t -> t -> bool -> unit) -> unit val for_all : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) -> quantity :((t, int ) Field.t -> t -> int -> bool) -> price :((t, float ) Field.t -> t -> float -> bool) -> cancelled:((t, bool ) Field.t -> t -> bool -> bool) -> bool val exists : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) -> quantity :((t, int ) Field.t -> t -> int -> bool) -> price :((t, float ) Field.t -> t -> float -> bool) -> cancelled:((t, bool ) Field.t -> t -> bool -> bool) -> bool val to_list : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'a) -> quantity :((t, int ) Field.t -> t -> int -> 'a) -> price :((t, float ) Field.t -> t -> float -> 'a) -> cancelled:((t, bool ) Field.t -> t -> bool -> 'a) -> 'a list val set_all_mutable_fields : t -> cancelled:bool -> unit end end ``` Use of `[@@deriving fields]` in an .mli will extend the signature for functions with the above types; In an .ml, definitions will be generated. Field.t is defined in Fieldslib, including: ```ocaml type ('perm, 'record, 'field) t_with_perm type ('record, 'field) t = ([ `Read | `Set_and_create], 'record, 'field) t_with_perm val name : (_, _, _) t_with_perm -> string val get : (_, 'r, 'a) t_with_perm -> 'r -> 'a ``` # Functions over all fields Use of the generated functions together with `Fieldslib` allow us to define functions over t which check exhaustiveness w.r.t record fields, avoiding common semantic errors which can occur when a record is extended with new fields but we forget to update functions. For example if you are writing a custom equality operator to ignore small price differences: ```ocaml let ( = ) a b : bool = let use op = fun field -> op (Field.get field a) (Field.get field b) in let price_equal p1 p2 = Float.abs (p1 -. p2) < 0.001 in Fields.for_all ~dir:(use (=)) ~quantity:(use (=)) ~price:(use price_equal) ~cancelled:(use (=)) ;; ``` A type error would occur if you were to add a new field and not change the definition of `( = )`: ```ocaml type t = { dir : [ `Buy | `Sell ]; quantity : int; price : float; mutable cancelled : bool; symbol : string; } [@@deriving fields] ... Error: This expression has type symbol:(([< `Read | `Set_and_create ], t, string) Field.t_with_perm -> bool) -> bool but an expression was expected of type bool ``` Or similarly you could use `fold` to create `to_string` function: ```ocaml let to_string t = let conv to_s = fun acc f -> (sprintf "%s: %s" (Field.name f) (to_s (Field.get f t))) :: acc in let fs = Fields.fold ~init:[] ~dir:(conv (function `Buy -> "Buy" | `Sell -> "Sell")) ~quantity:(conv Int.to_string) ~price:(conv Float.to_string) ~cancelled:(conv Bool.to_string) in String.concat fs ~sep:", " ;; ``` Addition of a new field would cause a type error reminding you to update the definition of `to_string`. # Selecting definitions The `[@@deriving fields]` clause allows options to specify which definitions it provides. Use `~getters` and `~setters` to explicitly select toplevel accessors, `fields` to select `Field.t` values, and `~names` to select `Fields.names`. Use `~iterators` with a tuple containing names chosen from `create`, `make_creator`, and so on, to select elements of `Fields`. Use `~direct_iterators` with a tuple of names to select elements of `Fields.Direct`. For example: ```ocaml type t = { x : int; y : int } [@@deriving fields ~getters ~fields ~iterators:(fold, iter) ``` The above defines the accessors `x` and `y`, the field values `Fields.x` and `Fields.y`, `Fields.fold`, and `Fields.iter`. # Opt-in function: `fold_right` By default, `[@@deriving fields]` derives all available functions except `Fields.fold_right` and `Fields.Direct.fold_right`. These functions can be selected via `~iterators:fold_right` and `~direct_iterators:fold_right`. Their signatures (when selected) are as follows. ```ocaml module Fields : sig val fold_right : dir :((t, [ `Buy | `Sell ]) Field.t -> 'd -> 'e) -> quantity :((t, int ) Field.t -> 'c -> 'd) -> price :((t, float ) Field.t -> 'b -> 'c) -> cancelled:((t, bool ) Field.t -> 'a -> 'b) -> init:'a -> 'e module Direct : sig val fold_right : t -> dir :((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'd -> 'e) -> quantity :((t, int ) Field.t -> t -> int -> 'c -> 'd) -> price :((t, float ) Field.t -> t -> float -> 'b -> 'c) -> cancelled:((t, bool ) Field.t -> t -> bool -> 'a -> 'b) -> init:'a -> 'e end end ``` ppx_fields_conv-0.16.0/bench/000077500000000000000000000000001442175067100160465ustar00rootroot00000000000000ppx_fields_conv-0.16.0/bench/bench_fields.ml000066400000000000000000000073771442175067100210230ustar00rootroot00000000000000(* Current results: ┌───────────────────────────────────────────────────────────────────────────────────────┬──────────┬────────────┐ │ Name │ Time/Run │ Percentage │ ├───────────────────────────────────────────────────────────────────────────────────────┼──────────┼────────────┤ │ [bench_fields.ml:field_setting] manual field setting │ 2.93ns │ 92.92% │ │ [bench_fields.ml:field_setting] Fields.Direct inlined │ 2.71ns │ 86.01% │ │ [bench_fields.ml:field_setting] Fields.Direct NOT inlined │ 3.15ns │ 100.00% │ │ [bench_fields.ml:shorter_record_field_setting] manual field setting │ 2.68ns │ 84.91% │ │ [bench_fields.ml:shorter_record_field_setting] [Fields.Direct.set_all_mutable_fields] │ 2.53ns │ 80.10% │ └───────────────────────────────────────────────────────────────────────────────────────┴──────────┴────────────┘ *) type a_or_b = | A | B let%bench_module "field_setting" = (module struct type t = { mutable a : int ; b : int ; mutable c : a_or_b ; mutable d : int ; mutable e : int ; mutable f : int ; mutable g : int } [@@deriving fields] let set_manual t ~a ~c ~d ~e ~f ~g = t.a <- a; t.c <- c; t.d <- d; t.e <- e; t.f <- f; t.g <- g ;; let[@inline] set_via_fields t ~a ~c ~d ~e ~f ~g = Fields.Direct.set_all_mutable_fields t ~a ~c ~d ~e ~f ~g ;; let[@cold] set_via_fields_not_inlined t ~a ~c ~d ~e ~f ~g = Fields.Direct.set_all_mutable_fields t ~a ~c ~d ~e ~f ~g ;; let init () = { a = 0; b = 0; c = A; d = 0; e = 0; f = 0; g = 0 } let%bench_fun "manual field setting" = let t = init () in fun () -> set_manual t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 ;; let%bench_fun "Fields.Direct inlined" = let t = init () in fun () -> set_via_fields t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 ;; let%bench_fun "Fields.Direct NOT inlined" = let t = init () in fun () -> set_via_fields_not_inlined t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 ;; end) ;; let%bench_module "shorter_record_field_setting" = (module struct type t = { mutable a : int ; b : int ; mutable c : a_or_b ; mutable d : int ; e : int ; f : int ; g : int } [@@deriving fields] let set_manual t ~a ~c ~d = t.a <- a; t.c <- c; t.d <- d ;; let set_via_fields t ~a ~c ~d = Fields.Direct.set_all_mutable_fields t ~a ~c ~d let init () = { a = 0; b = 0; c = B; d = 0; e = 0; f = 0; g = 0 } let%bench_fun "manual field setting" = let t = init () in fun () -> set_manual t ~a:1234567 ~c:B ~d:1000 ;; let%bench_fun "[Fields.Direct.set_all_mutable_fields]" = let t = init () in fun () -> set_via_fields t ~a:1234567 ~c:B ~d:1000 ;; end) ;; ppx_fields_conv-0.16.0/bench/dune000066400000000000000000000002071442175067100167230ustar00rootroot00000000000000(library (name field_setting_bench) (preprocess (pps ppx_bench ppx_fields_conv ppx_cold)) (libraries fieldslib compiler-libs.common))ppx_fields_conv-0.16.0/dune000066400000000000000000000000001442175067100156330ustar00rootroot00000000000000ppx_fields_conv-0.16.0/dune-project000066400000000000000000000000201442175067100173010ustar00rootroot00000000000000(lang dune 1.10)ppx_fields_conv-0.16.0/example/000077500000000000000000000000001442175067100164225ustar00rootroot00000000000000ppx_fields_conv-0.16.0/example/dune000066400000000000000000000002071442175067100172770ustar00rootroot00000000000000(executables (names test) (libraries) (preprocess (pps ppxlib ppx_fields_conv))) (alias (name DEFAULT) (deps test.ml.pp test.mli.pp))ppx_fields_conv-0.16.0/example/test.ml000066400000000000000000000011621442175067100177330ustar00rootroot00000000000000 type ('a, 'b) t = { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool } [@@deriving fields] type foo = { a : [ `Bar | `Baz of string ] ; b : int } [@@deriving fields] module Private_in_mli = struct type ('a, 'b) t = { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool } [@@deriving fields] end module Private_in_ml = struct type ('a, 'b) t = ('a, 'b) Private_in_mli.t = private { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool } [@@deriving fields] end ppx_fields_conv-0.16.0/example/test.mli000066400000000000000000000022211442175067100201010ustar00rootroot00000000000000(* sample mli showing everything that 'with fields' introduces *) (* NOTES: - (1) this file was hand generated and can therefore get out of sync with the actual interface of the generated code. - (2) The file generated_test.mli does not have this problem as it is generated by ocamlp4o from the file test.mli - (3) The types we list here are actually more general than those in generated_test.mli (see make_creator, for example) *) type ('a, 'b) t = { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool (* symbol : string; *) } [@@deriving fields] type foo = { a : [ `Bar | `Baz of string ] ; b : int } [@@deriving fields] module Private_in_mli : sig type ('a, 'b) t = private { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool (* symbol : string; *) } [@@deriving fields] end module Private_in_ml : sig type ('a, 'b) t = ('a, 'b) Private_in_mli.t = private { dir : 'a * 'b ; quantity : ('a, 'b) t ; price : int * 'a ; mutable cancelled : bool (* symbol : string; *) } [@@deriving fields] end ppx_fields_conv-0.16.0/ppx_fields_conv.opam000066400000000000000000000014641442175067100210340ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_fields_conv" bug-reports: "https://github.com/janestreet/ppx_fields_conv/issues" dev-repo: "git+https://github.com/janestreet/ppx_fields_conv.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_fields_conv/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "base" {>= "v0.16" & < "v0.17"} "fieldslib" {>= "v0.16" & < "v0.17"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Generation of accessor and iteration functions for ocaml records" description: " Part of the Jane Street's PPX rewriters collection. " ppx_fields_conv-0.16.0/src/000077500000000000000000000000001442175067100155565ustar00rootroot00000000000000ppx_fields_conv-0.16.0/src/dune000066400000000000000000000002601442175067100164320ustar00rootroot00000000000000(library (name ppx_fields_conv) (public_name ppx_fields_conv) (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries base ppxlib) (preprocess (pps ppxlib.metaquot)))ppx_fields_conv-0.16.0/src/ppx_fields_conv.ml000066400000000000000000001073211442175067100212760ustar00rootroot00000000000000(* Generated code should depend on the environment in scope as little as possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the use of [=]. It is especially important to not use polymorphic comparisons, since we are moving more and more to code that doesn't have them in scope. *) open Base open Printf open Ppxlib open Ast_builder.Default module Selector = Selector let check_no_collision = let always = [ "make_creator" ; "create" ; "fold" ; "fold_right" ; "iter" ; "to_list" ; "map" ; "map_poly" ; "for_all" ; "exists" ; "names" ] in fun (lbls : label_declaration list) -> let generated_funs = let extra_forbidden_names = List.filter_map lbls ~f:(function | { pld_mutable = Mutable; pld_name; _ } -> Some ("set_" ^ pld_name.txt) | _ -> None) in ("set_all_mutable_fields" :: extra_forbidden_names) @ always in List.iter lbls ~f:(fun { pld_name; pld_loc; _ } -> if List.mem generated_funs pld_name.txt ~equal:String.equal then Location.raise_errorf ~loc:pld_loc "ppx_fields_conv: field name %S conflicts with one of the generated functions" pld_name.txt) ;; module A = struct (* Additional AST construction helpers *) let str_item ~loc name body = pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] ;; let mod_ ~loc : string -> structure -> structure_item = fun name structure -> pstr_module ~loc (module_binding ~loc ~name:(Located.mk ~loc (Some name)) ~expr:(pmod_structure ~loc structure)) ;; let sig_item ~loc name typ = psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) ;; let sig_mod ~loc : string -> signature -> signature_item = fun name signature -> psig_module ~loc (module_declaration ~loc ~name:(Located.mk ~loc (Some name)) ~type_:(pmty_signature ~loc signature)) ;; end module Create = struct let record ~loc pairs = pexp_record ~loc (List.map pairs ~f:(fun (name, exp) -> Located.lident ~loc name, exp)) None ;; let lambda ~loc patterns body = List.fold_right patterns ~init:body ~f:(fun (lab, pat) acc -> pexp_fun ~loc lab None pat acc) ;; let lambda_sig ~loc arg_tys body_ty = List.fold_right arg_tys ~init:body_ty ~f:(fun (lab, arg_ty) acc -> ptyp_arrow ~loc lab arg_ty acc) ;; end module Inspect = struct let field_names labdecs = List.map labdecs ~f:(fun labdec -> labdec.pld_name.txt) end let perm ~loc private_ = match private_ with | Private -> [%type: [< `Read ]] | Public -> [%type: [< `Read | `Set_and_create ]] ;; let field_t ~loc private_ tps = let id = match private_ with | Private -> Longident.parse "Fieldslib.Field.readonly_t" | Public -> Longident.parse "Fieldslib.Field.t" in ptyp_constr ~loc (Located.mk ~loc id) tps ;; let check_at_least_one_record ~loc rec_flag tds = (match rec_flag with | Nonrecursive -> Location.raise_errorf ~loc "nonrec is not compatible with the `fields' preprocessor" | _ -> ()); let is_record td = match td.ptype_kind with | Ptype_record _ -> true | _ -> false in if not (List.exists tds ~f:is_record) then Location.raise_errorf ~loc (match tds with | [ _ ] -> "Unsupported use of fields (you can only use it on records)." | _ -> "'with fields' can only be applied on type definitions in which at least one \ type definition is a record") ;; let module_defn defns ~name ~loc ~make_module = if List.is_empty defns then [] else [ make_module ~loc name defns ] ;; let assemble ~loc ~selection ~fields_module ~make_module ~make_error alist = let alist = List.filter alist ~f:(fun (selector, _) -> Set.mem selection selector) in match List.is_empty alist with | true -> [ make_error (Location.Error.createf ~loc "[@@deriving fields]: no definitions generated") ] | false -> let inline, fields, direct = List.partition3_map alist ~f:(fun (selector, defn) -> match (selector : Selector.t) with | Per_field (Getters | Setters) -> `Fst defn | Per_field (Names | Fields) | Iterator _ -> `Snd defn | Direct_iterator _ -> `Trd defn) in List.concat [ inline ; module_defn ~loc ~make_module ~name:fields_module (List.concat [ fields; module_defn ~loc ~make_module ~name:"Direct" direct ]) ] ;; module Gen_sig = struct let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps let label_arg name ty = Labelled name, ty let field_arg ~loc ~private_ ~record (f : field:core_type -> ty:core_type -> 'a) labdec : arg_label * 'a = let { pld_name = name; pld_type = ty; _ } = labdec in label_arg name.txt (f ~field:(field_t ~loc private_ [ record; ty ]) ~ty) ;; let create_fun ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let f i = field_arg ~loc ~private_:Public ~record (fun ~field ~ty -> let create_f = [%type: 'input__ -> [%t ty]] in [%type: [%t field] -> [%t acc i] -> [%t create_f] * [%t acc (i + 1)]]) in let types = List.mapi labdecs ~f in let create_record_f = [%type: 'input__ -> [%t record]] in let t = Create.lambda_sig ~loc (types @ [ Nolabel, acc 0 ]) [%type: [%t create_record_f] * [%t acc (List.length labdecs)]] in A.sig_item ~loc "make_creator" t ;; let simple_create_fun ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f labdec = let { pld_name = name; pld_type = ty; _ } = labdec in label_arg name.txt ty in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types record in A.sig_item ~loc "create" t ;; let fold_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let f i arg : arg_label * core_type = field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t acc i] -> [%t field] -> [%t acc (i + 1)]]) arg in let types = List.mapi labdecs ~f in let init_ty = label_arg "init" (acc 0) in let t = Create.lambda_sig ~loc (init_ty :: types) (acc (List.length labdecs)) in A.sig_item ~loc "fold" t ;; let direct_fold_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let f i arg = field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> [%type: [%t acc i] -> [%t field] -> [%t record] -> [%t field_ty] -> [%t acc (i + 1)]]) arg in let types = List.mapi labdecs ~f in let init_ty = label_arg "init" (acc 0) in let t = Create.lambda_sig ~loc ((Nolabel, record) :: init_ty :: types) (acc (List.length labdecs)) in A.sig_item ~loc "fold" t ;; let fold_right_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let numlabs = List.length labdecs in let f i arg : arg_label * core_type = field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> [%t acc (numlabs - i - 1)] -> [%t acc (numlabs - i)]]) arg in let types = List.mapi labdecs ~f in let init_ty = label_arg "init" (acc 0) in let t = Create.lambda_sig ~loc (types @ [ init_ty ]) (acc numlabs) in A.sig_item ~loc "fold_right" t ;; let direct_fold_right_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in let numlabs = List.length labdecs in let f i arg = field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t record] -> [%t field_ty] -> [%t acc (numlabs - i - 1)] -> [%t acc (numlabs - i)]]) arg in let types = List.mapi labdecs ~f in let init_ty = label_arg "init" (acc 0) in let t = Create.lambda_sig ~loc (((Nolabel, record) :: types) @ [ init_ty ]) (acc numlabs) in A.sig_item ~loc "fold_right" t ;; let bool_fun fun_name ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> bool]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types [%type: bool] in A.sig_item ~loc fun_name t ;; let direct_bool_fun fun_name ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t record] -> [%t field_ty] -> bool]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc ((Nolabel, record) :: types) [%type: bool] in A.sig_item ~loc fun_name t ;; let iter_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> unit]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types [%type: unit] in A.sig_item ~loc "iter" t ;; let direct_iter_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t record] -> [%t field_ty] -> unit]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc ((Nolabel, record) :: types) [%type: unit] in A.sig_item ~loc "iter" t ;; let to_list_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> 'elem__]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types [%type: 'elem__ list] in A.sig_item ~loc "to_list" t ;; let direct_to_list_fun ~private_ ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t record] -> [%t field_ty] -> 'elem__]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc ((Nolabel, record) :: types) [%type: 'elem__ list] in A.sig_item ~loc "to_list" t ;; let map_fun ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_:Public ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t field_ty]]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types record in A.sig_item ~loc "map" t ;; let direct_map_fun ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f = field_arg ~loc ~private_:Public ~record (fun ~field ~ty:field_ty -> [%type: [%t field] -> [%t record] -> [%t field_ty] -> [%t field_ty]]) in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc ((Nolabel, record) :: types) record in A.sig_item ~loc "map" t ;; let map_poly ~private_ ~ty_name ~tps ~loc _ = let record = apply_type ~loc ~ty_name ~tps in let tps_names = List.map tps ~f:(fun tp -> match tp.ptyp_desc with | Ptyp_var var -> var | _ -> assert false) in let fresh_variable = let rec loop i = let ret = sprintf "x%i" i in if List.mem ~equal:String.equal tps_names ret then loop (i + 1) else ret in ptyp_var ~loc (loop 0) in let perm = perm ~loc private_ in let t = [%type: [%t ptyp_constr ~loc (Located.mk ~loc (Longident.parse "Fieldslib.Field.user")) [ perm; record; fresh_variable ]] -> [%t fresh_variable] list] in A.sig_item ~loc "map_poly" t ;; let set_all_mutable_fields ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let labels = List.fold_right labdecs ~init:[%type: unit] ~f:(fun labdec acc -> match labdec.pld_mutable with | Immutable -> acc | Mutable -> ptyp_arrow ~loc (Labelled labdec.pld_name.txt) labdec.pld_type acc) in A.sig_item ~loc "set_all_mutable_fields" [%type: [%t record] -> [%t labels]] ;; let record ~private_ ~ty_name ~tps ~loc ~selection (labdecs : label_declaration list) : signature = let fields = List.rev_map labdecs ~f:(fun labdec -> let { pld_name = { txt = name; loc }; pld_type = ty; _ } = labdec in let record_ty = apply_type ~loc ~ty_name ~tps in let field = A.sig_item ~loc name (field_t ~loc private_ [ record_ty; ty ]) in Selector.Per_field Fields, field) in let getters_and_setters = List.concat (List.rev_map labdecs ~f:(fun labdec -> let { pld_name = { txt = name; loc }; pld_type = ty; pld_mutable = m; _ } = labdec in let record_ty = apply_type ~loc ~ty_name ~tps in let getter = ( Selector.Per_field Getters , A.sig_item ~loc name [%type: [%t record_ty] -> [%t ty]] ) in match m, private_ with | Immutable, _ | Mutable, Private -> [ getter ] | Mutable, Public -> let setter = ( Selector.Per_field Setters , A.sig_item ~loc ("set_" ^ name) [%type: [%t record_ty] -> [%t ty] -> unit] ) in [ getter; setter ])) in let create_fun = create_fun ~ty_name ~tps ~loc labdecs in let simple_create_fun = simple_create_fun ~ty_name ~tps ~loc labdecs in let fields_module = if String.equal ty_name "t" then "Fields" else "Fields_of_" ^ ty_name in let iter = iter_fun ~private_ ~ty_name ~tps ~loc labdecs in let fold = fold_fun ~private_ ~ty_name ~tps ~loc labdecs in let fold_right = fold_right_fun ~private_ ~ty_name ~tps ~loc labdecs in let map = map_fun ~ty_name ~tps ~loc labdecs in let map_poly = map_poly ~private_ ~ty_name ~tps ~loc labdecs in let and_f = bool_fun "for_all" ~private_ ~ty_name ~tps ~loc labdecs in let or_f = bool_fun "exists" ~private_ ~ty_name ~tps ~loc labdecs in let to_list = to_list_fun ~private_ ~ty_name ~tps ~loc labdecs in let direct_iter = direct_iter_fun ~private_ ~ty_name ~tps ~loc labdecs in let direct_fold = direct_fold_fun ~private_ ~ty_name ~tps ~loc labdecs in let direct_fold_right = direct_fold_right_fun ~private_ ~ty_name ~tps ~loc labdecs in let direct_map = direct_map_fun ~ty_name ~tps ~loc labdecs in let direct_and_f = direct_bool_fun "for_all" ~private_ ~ty_name ~tps ~loc labdecs in let direct_or_f = direct_bool_fun "exists" ~private_ ~ty_name ~tps ~loc labdecs in let direct_to_list = direct_to_list_fun ~private_ ~ty_name ~tps ~loc labdecs in let set_all_mutable_fields = set_all_mutable_fields ~ty_name ~tps ~loc labdecs in List.concat [ getters_and_setters ; [ Per_field Names, A.sig_item ~loc "names" [%type: string list] ] ; fields ; [ Iterator Fold, fold; Iterator Fold_right, fold_right ] ; (match private_ with (* The ['perm] phantom type prohibits first-class fields from mutating or creating private records, so we can expose them (and fold, etc.). However, we still can't expose functions that explicitly create private records. *) | Private -> [] | Public -> [ Iterator Make_creator, create_fun ; Iterator Create, simple_create_fun ; Iterator Map, map ]) ; [ Iterator Iter, iter ; Iterator For_all, and_f ; Iterator Exists, or_f ; Iterator To_list, to_list ; Iterator Map_poly, map_poly ; Direct_iterator Iter, direct_iter ; Direct_iterator Fold, direct_fold ; Direct_iterator For_all, direct_and_f ; Direct_iterator Exists, direct_or_f ; Direct_iterator To_list, direct_to_list ; Direct_iterator Fold_right, direct_fold_right ] ; (match private_ with | Private -> [] | Public -> [ Direct_iterator Map, direct_map ; Direct_iterator Set_all_mutable_fields, set_all_mutable_fields ]) ] |> assemble ~loc ~selection ~fields_module ~make_module:A.sig_mod ~make_error:(fun error -> psig_extension ~loc (Location.Error.to_extension error) []) ;; let fields_of_td (td : type_declaration) ~selection : signature = let { ptype_name = { txt = ty_name; loc } ; ptype_private = private_ ; ptype_params ; ptype_kind ; _ } = td in let tps = List.map ptype_params ~f:(fun (tp, _variance) -> tp) in match ptype_kind with | Ptype_record labdecs -> check_no_collision labdecs; record ~private_ ~ty_name ~tps ~loc ~selection labdecs | _ -> [] ;; let generate ~ctxt (rec_flag, tds) selection = let loc = Expansion_context.Deriver.derived_item_loc ctxt in match selection with | Error error -> [ psig_extension ~loc (Location.Error.to_extension error) [] ] | Ok selection -> let tds = List.map tds ~f:name_type_params_in_td in check_at_least_one_record ~loc rec_flag tds; List.concat_map tds ~f:(fields_of_td ~selection) ;; end module Gen_struct = struct let gen_fields ~private_ ~loc (labdecs : label_declaration list) = let rec_id = match labdecs with | [] -> assert false | [ _ ] -> None | _ :: _ :: _ -> Some [%expr _r__] in let conv_field labdec = let { pld_name = { txt = name; loc }; pld_type = field_ty; pld_mutable = m; _ } = labdec in let getter = ( Selector.Per_field Getters , A.str_item ~loc name [%expr fun _r__ -> [%e pexp_field ~loc [%expr _r__] (Located.lident ~loc name)]] ) in let setter, setter_field = match m, private_ with | Mutable, Private -> ( [] , [%expr Some (fun _ _ -> failwith "invalid call to a setter of a private type")] ) | Mutable, Public -> let setter = ( Selector.Per_field Setters , A.str_item ~loc ("set_" ^ name) [%expr fun _r__ v__ -> [%e pexp_setfield ~loc [%expr _r__] (Located.lident ~loc name) [%expr v__]]] ) in let setter_field = [%expr Some [%e evar ~loc ("set_" ^ name)]] in [ setter ], setter_field | Immutable, _ -> [], [%expr None] in let field = let e = pexp_record ~loc [ Located.lident ~loc name, evar ~loc "v__" ] rec_id in let fset = match private_ with | Private -> [%expr fun _ _ -> failwith "Invalid call to an fsetter of a private type"] | Public -> [%expr fun _r__ v__ -> [%e e]] in let perm = perm ~loc private_ in let annot = [%type: ([%t perm], _, [%t field_ty]) Fieldslib.Field.t_with_perm] in let body = [%expr Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.force_variance = (fun (_ : [%t perm]) -> ()) ; name = [%e estring ~loc name] ; getter = [%e evar ~loc name] ; setter = [%e setter_field] ; fset = [%e fset] }] in Selector.Per_field Fields, A.str_item ~loc name (pexp_constraint ~loc body annot) in getter :: setter, field in let xss, ys = List.unzip (List.rev (List.map labdecs ~f:conv_field)) in List.concat xss, ys ;; let label_arg ?label ~loc name = let l = match label with | None -> name | Some n -> n in Labelled l, pvar ~loc name ;; let label_arg_fun ~loc name = label_arg ~label:name ~loc (name ^ "_fun__") let creation_fun ~loc _record_name labdecs = let names = Inspect.field_names labdecs in let f = let body_record = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in let body = List.fold_right names ~init:[%expr [%e body_record]] ~f:(fun field_name acc -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc field_name) ~expr:[%expr [%e evar ~loc (field_name ^ "_gen__")] acc__] ] acc) in Create.lambda ~loc [ Nolabel, [%pat? acc__] ] body in let patterns = List.map names ~f:(label_arg_fun ~loc) in let body0 = [%expr [%e f], compile_acc__] in let body = List.fold_right names ~init:body0 ~f:(fun field_name acc -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat: (ppat_tuple ~loc [ pvar ~loc (field_name ^ "_gen__"); [%pat? compile_acc__] ]) ~expr: [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] compile_acc__] ] acc) in let f = Create.lambda ~loc (patterns @ [ Nolabel, [%pat? compile_acc__] ]) body in A.str_item ~loc "make_creator" f ;; let simple_creation_fun ~loc _record_name labdecs = let names = Inspect.field_names labdecs in let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in let f = Create.lambda ~loc patterns f in A.str_item ~loc "create" f ;; let fold_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e acc_expr] [%e evar ~loc field_name]] in let body = List.fold_left names ~init:[%expr init__] ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let init = label_arg ~label:"init" ~loc "init__" in let lambda = Create.lambda ~loc (init :: patterns) body in A.str_item ~loc "fold" lambda ;; let direct_fold_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e acc_expr] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] in let body = List.fold_left names ~init:[%expr init__] ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let init = label_arg ~label:"init" ~loc "init__" in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: init :: patterns) body in A.str_item ~loc "fold" lambda ;; let fold_right_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold_right field_name acc_expr = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] [%e acc_expr]] in let body = List.fold_right names ~f:field_fold_right ~init:[%expr init__] in let patterns = List.map names ~f:(label_arg_fun ~loc) in let init = label_arg ~label:"init" ~loc "init__" in let lambda = Create.lambda ~loc (patterns @ [ init ]) body in A.str_item ~loc "fold_right" lambda ;; let direct_fold_right_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold_right field_name acc_expr = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)] [%e acc_expr]] in let body = List.fold_right names ~f:field_fold_right ~init:[%expr init__] in let patterns = List.map names ~f:(label_arg_fun ~loc) in let init = label_arg ~label:"init" ~loc "init__" in let lambda = Create.lambda ~loc (((Nolabel, [%pat? record__]) :: patterns) @ [ init ]) body in A.str_item ~loc "fold_right" lambda ;; let and_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e acc_expr] && [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]] in let body = List.fold_left names ~init:(ebool ~loc true) ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc patterns body in A.str_item ~loc "for_all" lambda ;; let direct_and_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e acc_expr] && [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] in let body = List.fold_left names ~init:(ebool ~loc true) ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in A.str_item ~loc "for_all" lambda ;; let or_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e acc_expr] || [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]] in let body = List.fold_left names ~init:[%expr false] ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc patterns body in A.str_item ~loc "exists" lambda ;; let direct_or_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e acc_expr] || [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] in let body = List.fold_left names ~init:[%expr false] ~f:field_fold in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in A.str_item ~loc "exists" lambda ;; let iter_fun ~loc labdecs = let names = Inspect.field_names labdecs in let iter_field field_name = [%expr ([%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] : unit)] in let body = List.fold_left (List.tl_exn names) ~init:(iter_field (List.hd_exn names)) ~f:(fun acc n -> [%expr [%e acc]; [%e iter_field n]]) in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc patterns body in A.str_item ~loc "iter" lambda ;; let direct_iter_fun ~loc labdecs = let names = Inspect.field_names labdecs in let iter_field field_name = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] in let body = List.fold_left (List.tl_exn names) ~init:(iter_field (List.hd_exn names)) ~f:(fun acc n -> [%expr [%e acc]; [%e iter_field n]]) in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in A.str_item ~loc "iter" lambda ;; let map_fun ~loc labdecs = let names = Inspect.field_names labdecs in let body = Create.record ~loc (List.map names ~f:(fun field_name -> let e = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]] in field_name, e)) in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc patterns body in A.str_item ~loc "map" lambda ;; let direct_map_fun ~loc labdecs = let names = Inspect.field_names labdecs in let body = Create.record ~loc (List.map names ~f:(fun field_name -> let e = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] in field_name, e)) in let patterns = List.map names ~f:(label_arg_fun ~loc) in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in A.str_item ~loc "map" lambda ;; let to_list_fun ~loc labdecs = let names = Inspect.field_names labdecs in let patterns = List.map names ~f:(label_arg_fun ~loc) in let fold field_name tail = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] :: [%e tail]] in let body = List.fold_right names ~init:[%expr []] ~f:fold in let lambda = Create.lambda ~loc patterns body in A.str_item ~loc "to_list" lambda ;; let direct_to_list_fun ~loc labdecs = let names = Inspect.field_names labdecs in let patterns = List.map names ~f:(label_arg_fun ~loc) in let fold field_name tail = [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)] :: [%e tail]] in let body = List.fold_right names ~init:[%expr []] ~f:fold in let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in A.str_item ~loc "to_list" lambda ;; let map_poly ~loc labdecs = let names = Inspect.field_names labdecs in let fold name acc = [%expr record__.Fieldslib.Field.f [%e evar ~loc name] :: [%e acc]] in let body = List.fold_right names ~init:[%expr []] ~f:fold in A.str_item ~loc "map_poly" (pexp_fun ~loc Nolabel None [%pat? record__] body) ;; let sequence_ ~loc xs = match List.rev xs with | [] -> [%expr ()] | x :: xs -> List.fold_left ~init:x xs ~f:(fun x y -> pexp_sequence ~loc y x) ;; let set_all_mutable_fields ~loc labdecs = let record_name = "_record__" in let body = let exprs = List.fold_right labdecs ~init:[] ~f:(fun labdec acc -> match labdec.pld_mutable with | Immutable -> acc | Mutable -> let field_name = labdec.pld_name.txt in pexp_setfield ~loc (evar ~loc record_name) (Located.lident ~loc field_name) (evar ~loc field_name) :: acc) in (* As of 2019-06-25, flambda generates extra mov instructions when calling [Fields.Direct.set_all_mutable_fields] on a top-level record. [Stdlib.Sys.opaque_identity] causes flambda to generate the correct assembly here. *) [%expr let [%p pvar ~loc record_name] = Fieldslib.Field.For_generated_code.opaque_identity [%e evar ~loc record_name] in [%e sequence_ ~loc exprs]] in let function_ = List.fold_right labdecs ~init:body ~f:(fun labdec acc -> match labdec.pld_mutable with | Immutable -> acc | Mutable -> let field_name = labdec.pld_name.txt in pexp_fun ~loc (Labelled field_name) None (pvar ~loc field_name) acc) in let body = pexp_fun ~loc Nolabel None (pvar ~loc record_name) function_ in [%stri let[@inline always] set_all_mutable_fields = [%e body]] ;; let record ~private_ ~record_name ~loc ~selection (labdecs : label_declaration list) : structure = let getter_and_setters, fields = gen_fields ~private_ ~loc labdecs in let create = creation_fun ~loc record_name labdecs in let simple_create = simple_creation_fun ~loc record_name labdecs in let names = List.map (Inspect.field_names labdecs) ~f:(estring ~loc) in let fields_module = if String.equal record_name "t" then "Fields" else "Fields_of_" ^ record_name in let iter = iter_fun ~loc labdecs in let fold = fold_fun ~loc labdecs in let fold_right = fold_right_fun ~loc labdecs in let map = map_fun ~loc labdecs in let map_poly = map_poly ~loc labdecs in let andf = and_fun ~loc labdecs in let orf = or_fun ~loc labdecs in let to_list = to_list_fun ~loc labdecs in let direct_iter = direct_iter_fun ~loc labdecs in let direct_fold = direct_fold_fun ~loc labdecs in let direct_fold_right = direct_fold_right_fun ~loc labdecs in let direct_andf = direct_and_fun ~loc labdecs in let direct_orf = direct_or_fun ~loc labdecs in let direct_map = direct_map_fun ~loc labdecs in let direct_to_list = direct_to_list_fun ~loc labdecs in let set_all_mutable_fields = set_all_mutable_fields ~loc labdecs in List.concat [ getter_and_setters ; [ Per_field Names, A.str_item ~loc "names" (elist ~loc names) ] ; fields ; (match private_ with | Private -> [] | Public -> [ Iterator Make_creator, create ; Iterator Create, simple_create ; Iterator Map, map ]) ; [ Iterator Iter, iter ; Iterator Fold, fold ; Iterator Map_poly, map_poly ; Iterator For_all, andf ; Iterator Exists, orf ; Iterator To_list, to_list ; Iterator Fold_right, fold_right ; Direct_iterator Iter, direct_iter ; Direct_iterator Fold, direct_fold ; Direct_iterator For_all, direct_andf ; Direct_iterator Exists, direct_orf ; Direct_iterator To_list, direct_to_list ; Direct_iterator Fold_right, direct_fold_right ] ; (match private_ with | Private -> [] | Public -> [ Direct_iterator Map, direct_map ; Direct_iterator Set_all_mutable_fields, set_all_mutable_fields ]) ] |> assemble ~loc ~selection ~fields_module ~make_module:A.mod_ ~make_error:(fun error -> pstr_extension ~loc (Location.Error.to_extension error) []) ;; let fields_of_td (td : type_declaration) ~selection : structure = let { ptype_name = { txt = record_name; loc } ; ptype_private = private_ ; ptype_kind ; _ } = td in match ptype_kind with | Ptype_record labdecs -> check_no_collision labdecs; record ~private_ ~record_name ~loc ~selection labdecs | _ -> [] ;; let generate ~ctxt (rec_flag, tds) selection = let loc = Expansion_context.Deriver.derived_item_loc ctxt in match selection with | Error error -> [ pstr_extension ~loc (Location.Error.to_extension error) [] ] | Ok selection -> let tds = List.map tds ~f:name_type_params_in_td in check_at_least_one_record ~loc rec_flag tds; List.concat_map tds ~f:(fields_of_td ~selection) ;; end let fields = Deriving.add "fields" ~str_type_decl:(Selector.generator Gen_struct.generate ~add_dependencies:true) ~sig_type_decl:(Selector.generator Gen_sig.generate ~add_dependencies:false) ;; ppx_fields_conv-0.16.0/src/ppx_fields_conv.mli000066400000000000000000000001131442175067100214360ustar00rootroot00000000000000open! Base open Ppxlib module Selector = Selector val fields : Deriving.t ppx_fields_conv-0.16.0/src/selector.ml000066400000000000000000000214041442175067100177310ustar00rootroot00000000000000open! Base open Ppxlib module Per_field = struct type t = | Getters | Setters | Names | Fields let all = [ Getters; Setters; Names; Fields ] let to_flag_name = function | Getters -> "getters" | Setters -> "setters" | Names -> "names" | Fields -> "fields" ;; let to_expression t ~loc = match t with | Getters -> [%expr Getters] | Setters -> [%expr Setters] | Names -> [%expr Names] | Fields -> [%expr Fields] ;; end module Iterator = struct type t = | Create | Make_creator | Exists | Fold | Fold_right | For_all | Iter | Map | To_list | Map_poly let all = [ Create ; Make_creator ; Exists ; Fold ; Fold_right ; For_all ; Iter ; Map ; To_list ; Map_poly ] ;; let to_variable_name = function | Create -> "create" | Make_creator -> "make_creator" | Exists -> "exists" | Fold -> "fold" | Fold_right -> "fold_right" | For_all -> "for_all" | Iter -> "iter" | Map -> "map" | To_list -> "to_list" | Map_poly -> "map_poly" ;; let to_expression t ~loc = match t with | Create -> [%expr Create] | Make_creator -> [%expr Make_creator] | Exists -> [%expr Exists] | Fold -> [%expr Fold] | Fold_right -> [%expr Fold_right] | For_all -> [%expr For_all] | Iter -> [%expr Iter] | Map -> [%expr Map] | To_list -> [%expr To_list] | Map_poly -> [%expr Map_poly] ;; end module Direct_iterator = struct type t = | Exists | Fold | Fold_right | For_all | Iter | Map | To_list | Set_all_mutable_fields let all = [ Exists; Fold; Fold_right; For_all; Iter; Map; To_list; Set_all_mutable_fields ] ;; let to_variable_name = function | Exists -> "exists" | Fold -> "fold" | Fold_right -> "fold_right" | For_all -> "for_all" | Iter -> "iter" | Map -> "map" | To_list -> "to_list" | Set_all_mutable_fields -> "set_all_mutable_fields" ;; let to_expression t ~loc = match t with | Exists -> [%expr Exists] | Fold -> [%expr Fold] | Fold_right -> [%expr Fold_right] | For_all -> [%expr For_all] | Iter -> [%expr Iter] | Map -> [%expr Map] | To_list -> [%expr To_list] | Set_all_mutable_fields -> [%expr Set_all_mutable_fields] ;; end type t = | Per_field of Per_field.t | Iterator of Iterator.t | Direct_iterator of Direct_iterator.t let all = List.concat [ List.map Per_field.all ~f:(fun x -> Per_field x) ; List.map Iterator.all ~f:(fun x -> Iterator x) ; List.map Direct_iterator.all ~f:(fun x -> Direct_iterator x) ] ;; let to_string = function | Per_field x -> "~" ^ Per_field.to_flag_name x | Iterator x -> "~iterators:" ^ Iterator.to_variable_name x | Direct_iterator x -> "~direct_iterators:" ^ Direct_iterator.to_variable_name x ;; let sexp_of_t t = Sexp.Atom (to_string t) let compare = (Poly.compare : t -> t -> int) include (val Comparator.make ~compare ~sexp_of_t) let to_expression t ~loc = match t with | Per_field x -> [%expr Ppx_fields_conv.Selector.Per_field [%e Per_field.to_expression x ~loc]] | Iterator x -> [%expr Ppx_fields_conv.Selector.Iterator [%e Iterator.to_expression x ~loc]] | Direct_iterator x -> [%expr Ppx_fields_conv.Selector.Direct_iterator [%e Direct_iterator.to_expression x ~loc]] ;; let direct_dependencies = function | Per_field (Getters | Setters | Names) -> [] | Per_field Fields -> [ Per_field Getters; Per_field Setters ] | Iterator _ | Direct_iterator _ -> [ Per_field Fields ] ;; let rec with_dependencies selector = selector :: List.concat_map ~f:with_dependencies (direct_dependencies selector) ;; module type S = sig type t val all : t list val to_variable_name : t -> string end let select_id (type a) (module M : S with type t = a) ~arg_name ~f expr = match expr.pexp_desc with | Pexp_ident { loc; txt = Lident txt } -> (match List.find M.all ~f:(fun x -> String.equal txt (M.to_variable_name x)) with | Some x -> Ok (f x) | None -> Error ( loc , Printf.sprintf "[~%s] %s" arg_name (if String.equal txt arg_name then Printf.sprintf "requires an argument" else Printf.sprintf "does not accept [%s] as an argument, valid arguments are: %s" (Longident.name (Lident txt)) (String.concat ~sep:", " (List.map M.all ~f:(fun x -> Printf.sprintf "[%s]" (M.to_variable_name x))))) )) | _ -> Error (expr.pexp_loc, "expected a variable name") ;; let select_id_tuple m ~arg_name ~f expr = Result.bind (match expr.pexp_desc with | Pexp_tuple tuple -> Ok tuple | Pexp_ident _ -> Ok [ expr ] | _ -> Error [ expr.pexp_loc, "expected a variable name or a tuple of variable names" ]) ~f:(fun exprs -> List.map exprs ~f:(select_id m ~arg_name ~f) |> Result.combine_errors) ;; let select_iterators = select_id_tuple ~arg_name:"iterators" ~f:(fun x -> Iterator x) (module Iterator) ;; let select_direct_iterators = select_id_tuple ~arg_name:"direct_iterators" ~f:(fun x -> Direct_iterator x) (module Direct_iterator) ;; let select_fold_right expr = Error [ ( expr.pexp_loc , "[~fold_right] is no longer supported; use [~iterators:fold_right] and/or \ [~direct_iterators:fold_right]" ) ] ;; let select_one x expr = match expr.pexp_desc with | Pexp_ident { txt = Lident txt; _ } when String.equal txt (Per_field.to_flag_name x) -> Ok [ Per_field x ] | _ -> Error [ ( expr.pexp_loc , Printf.sprintf "expected no explicit argument to [~%s]" (Per_field.to_flag_name x) ) ] ;; let select_getters = select_one Getters let select_setters = select_one Setters let select_names = select_one Names let select_fields = select_one Fields let default_selectors = List.filter all ~f:(function | Iterator Fold_right | Direct_iterator Fold_right -> false | _ -> true) ;; let selection list ~add_dependencies = let list = if add_dependencies then List.concat_map list ~f:with_dependencies else list in Set.Using_comparator.of_list ~comparator list ;; let error_of_alists ~loc alists = match List.map (List.concat alists) ~f:(fun (loc, message) -> loc, "deriving fields: " ^ message) with | [ (loc, message) ] -> Location.Error.make ~loc message ~sub:[] | sub -> Location.Error.make ~loc "deriving fields: multiple syntax errors" ~sub ;; let generator ~add_dependencies f = Deriving.Generator.V2.make (let open Deriving.Args in empty +> arg "fold_right" (map1 __ ~f:select_fold_right) +> arg "getters" (map1 __ ~f:select_getters) +> arg "setters" (map1 __ ~f:select_setters) +> arg "names" (map1 __ ~f:select_names) +> arg "fields" (map1 __ ~f:select_fields) +> arg "iterators" (map1 __ ~f:select_iterators) +> arg "direct_iterators" (map1 __ ~f:select_direct_iterators)) (fun ~ctxt ast arg1 arg2 arg3 arg4 arg5 arg6 arg7 -> let loc = Expansion_context.Deriver.derived_item_loc ctxt in let results = match List.filter_opt [ arg1; arg2; arg3; arg4; arg5; arg6; arg7 ] with | [] -> [ Ok default_selectors ] | _ :: _ as non_empty -> non_empty in let selection = Result.combine_errors results |> Result.map ~f:List.concat |> Result.map ~f:(selection ~add_dependencies) |> Result.map_error ~f:(error_of_alists ~loc) in f ~ctxt ast selection) ;; let deriving_clause ~loc list = let open Ast_builder.Default in if List.is_empty list then None else ( let per_field, iterators, direct_iterators = List.dedup_and_sort list ~compare |> List.partition3_map ~f:(function | Per_field x -> `Fst x | Iterator x -> `Snd x | Direct_iterator x -> `Trd x) in let per_field = List.map per_field ~f:(fun x -> let s = Per_field.to_flag_name x in Labelled s, evar ~loc s) in let iterators = if List.is_empty iterators then [] else [ ( Labelled "iterators" , pexp_tuple ~loc (List.map iterators ~f:(fun f -> evar ~loc (Iterator.to_variable_name f))) ) ] in let direct_iterators = if List.is_empty direct_iterators then [] else [ ( Labelled "direct_iterators" , pexp_tuple ~loc (List.map direct_iterators ~f:(fun f -> evar ~loc (Direct_iterator.to_variable_name f))) ) ] in Some (pexp_apply ~loc [%expr fields] (List.concat [ per_field; iterators; direct_iterators ]))) ;; ppx_fields_conv-0.16.0/src/selector.mli000066400000000000000000000027011442175067100201010ustar00rootroot00000000000000open! Base open Ppxlib module Per_field : sig type t = | Getters | Setters | Names | Fields end module Iterator : sig type t = | Create | Make_creator | Exists | Fold | Fold_right | For_all | Iter | Map | To_list | Map_poly end module Direct_iterator : sig type t = | Exists | Fold | Fold_right | For_all | Iter | Map | To_list | Set_all_mutable_fields end type t = | Per_field of Per_field.t | Iterator of Iterator.t | Direct_iterator of Direct_iterator.t val all : t list val compare : t -> t -> int val sexp_of_t : t -> Sexp.t include Comparator.S with type t := t (** Creates a [@@deriving] generator that determines a set of selectors from optional flags, or reports a syntax error. *) val generator : add_dependencies:bool (** in the .ml we must define dependencies; in the mli we don't need to export them *) -> (ctxt:Expansion_context.Deriver.t -> 'input -> ((t, comparator_witness) Set.t, Location.Error.t) Result.t -> 'output) -> ('output, 'input) Deriving.Generator.t (** Creates a [fields] expression for a [@@deriving] attribute, with appropriate arguments to define the given selectors. Returns [None] if no selectors are chosen. *) val deriving_clause : loc:location -> t list -> expression option (** Produces an expression that reconstructs [t] at runtime. *) val to_expression : t -> loc:location -> expression ppx_fields_conv-0.16.0/test/000077500000000000000000000000001442175067100157465ustar00rootroot00000000000000ppx_fields_conv-0.16.0/test/arguments.mlt000066400000000000000000000047161442175067100205010ustar00rootroot00000000000000#print_line_numbers true type t = { x : int ; y : int } [@@deriving fields ~fold_right] [%%expect {| Line 7, characters 20-30: Error: deriving fields: [~fold_right] is no longer supported; use [~iterators:fold_right] and/or [~direct_iterators:fold_right] |}] type t = { x : int ; y : int } [@@deriving fields ~iterators:(1, 2) ~direct_iterators:3] [%%expect {| Line 16, characters 0-94: Error: deriving fields: multiple syntax errors Line 20, characters 31-32: deriving fields: expected a variable name Line 20, characters 34-35: deriving fields: expected a variable name Line 20, characters 55-56: deriving fields: expected a variable name or a tuple of variable names |}] type t = { x : int ; y : int } [@@deriving fields ~iterators:x ~direct_iterators:(y, z)] [%%expect {| Line 34, characters 0-94: Error: deriving fields: multiple syntax errors Line 38, characters 30-31: deriving fields: [~iterators] does not accept [x] as an argument, valid arguments are: [create], [make_creator], [exists], [fold], [fold_right], [for_all], [iter], [map], [to_list], [map_poly] Line 38, characters 51-52: deriving fields: [~direct_iterators] does not accept [y] as an argument, valid arguments are: [exists], [fold], [fold_right], [for_all], [iter], [map], [to_list], [set_all_mutable_fields] Line 38, characters 54-55: deriving fields: [~direct_iterators] does not accept [z] as an argument, valid arguments are: [exists], [fold], [fold_right], [for_all], [iter], [map], [to_list], [set_all_mutable_fields] |}] type t = { x : int ; y : int } [@@deriving fields ~getters:true ~setters:false] [%%expect {| Line 58, characters 0-85: Error: deriving fields: multiple syntax errors Line 62, characters 28-32: deriving fields: expected no explicit argument to [~getters] Line 62, characters 42-47: deriving fields: expected no explicit argument to [~setters] |}] module _ = struct type t = { x : int ; y : int } [@@deriving fields ~getters] let _ = Fields.iter end [%%expect {| Line 81, characters 10-21: Error: Unbound module Fields |}] module _ (M : sig type t = { x : int ; y : int } [@@deriving fields ~getters] end) = struct let _ = M.Fields.iter end [%%expect {| Line 97, characters 10-23: Error: Unbound module M.Fields |}] type t = { x : int ; y : int } [@@deriving fields ~setters] [%%expect {| Line 105, characters 5-6: Error: [@deriving fields]: no definitions generated |}] ppx_fields_conv-0.16.0/test/deriving_clause.mlt000066400000000000000000000106151442175067100216320ustar00rootroot00000000000000(** This file tests the argument parsing/constructing functions from [Selectors]. *) open Base open Ppxlib open Ast_builder.Default module Selector = Ppx_fields_conv.Selector (** We define a ppx to simulate our argument-parsing. {[ type t [@@deriving fields_clause ......] ]} produces {[ let selectors = [ ...... ] ]} where [] are the selectors that [@@deriving fields] would use if given the same [.] *) let () = let str_type_decl = Selector.generator ~add_dependencies:false (fun ~ctxt _ selectors -> let loc = Expansion_context.Deriver.derived_item_loc ctxt in let selectors_expr = match selectors with | Error error -> Location.Error.raise error | Ok set -> List.map (Set.to_list set) ~f:(Selector.to_expression ~loc) |> elist ~loc in [%str let (selectors : Selector.t list) = [%e selectors_expr]]) in Deriving.add "fields_clause" ~str_type_decl |> Deriving.ignore ;; [%%expect {| |}] (** We write an extension to test our argument-construction. {[ expect := [ ...... ] ;; [%%test_fields_clause] ]} produces {[ expect := [ ...... ] ;; type t [@@deriving fields_clause ......] ;; test "fields_clause ... ..." selectors ]} This tests that the selectors list in [expect] round-trips through [[@@deriving fields_clause]] to produce the same selectors at the end. *) let expect = ref [] let test deriving actual = let expect = List.sort !expect ~compare:Selector.compare in if Poly.equal expect actual then Stdio.print_s (Sexp.message "Ok" [ "deriving", String.sexp_of_t deriving ; "selectors", List.sexp_of_t Selector.sexp_of_t actual ]) else Stdio.print_s (Sexp.message "Error" [ "deriving", String.sexp_of_t deriving ; "actual", List.sexp_of_t Selector.sexp_of_t actual ; "expect", List.sexp_of_t Selector.sexp_of_t expect ]) ;; let () = let extension = Extension.V3.declare_inline "test_fields_clause" Structure_item Ast_pattern.(pstr nil) (fun ~ctxt -> let loc = Expansion_context.Extension.extension_point_loc ctxt in let loc = { loc with loc_ghost = true } in let fields = Selector.deriving_clause ~loc !expect |> Option.value_exn in let fields_clause = match fields with | [%expr fields] -> [%expr fields_clause] | { pexp_desc = Pexp_apply ([%expr fields], args); _ } -> pexp_apply ~loc [%expr fields_clause] args | _ -> assert false in let expr = estring ~loc (Pprintast.string_of_expression fields) in [%str type t [@@deriving [%e fields_clause]] let () = test [%e expr] selectors]) in Driver.register_transformation ~extensions:[ extension ] "test_fields_clause" ;; [%%expect {| |}] let () = expect := [ Per_field Fields ] [%%test_fields_clause] [%%expect {| (Ok (deriving "fields ~fields") (selectors (~fields))) |}] let () = expect := [ Iterator Create ] [%%test_fields_clause] [%%expect {| (Ok (deriving "fields ~iterators:create") (selectors (~iterators:create))) |}] let () = expect := [ Per_field Names; Direct_iterator Iter; Direct_iterator Fold_right ] [%%test_fields_clause] [%%expect {| (Ok (deriving "fields ~names ~direct_iterators:(fold_right, iter)") (selectors (~names ~direct_iterators:fold_right ~direct_iterators:iter))) |}] let () = expect := Selector.all [%%test_fields_clause] [%%expect {| (Ok (deriving "fields ~getters ~setters ~names ~fields\ \n ~iterators:(create, make_creator, exists, fold, fold_right, for_all, iter,\ \n map, to_list, map_poly)\ \n ~direct_iterators:(exists, fold, fold_right, for_all, iter, map, to_list,\ \n set_all_mutable_fields)") (selectors (~getters ~setters ~names ~fields ~iterators:create ~iterators:make_creator ~iterators:exists ~iterators:fold ~iterators:fold_right ~iterators:for_all ~iterators:iter ~iterators:map ~iterators:to_list ~iterators:map_poly ~direct_iterators:exists ~direct_iterators:fold ~direct_iterators:fold_right ~direct_iterators:for_all ~direct_iterators:iter ~direct_iterators:map ~direct_iterators:to_list ~direct_iterators:set_all_mutable_fields))) |}] ppx_fields_conv-0.16.0/test/deriving_inline.ml000066400000000000000000000203541442175067100214510ustar00rootroot00000000000000module Default = struct type t = { x : int ; mutable y : bool } [@@deriving_inline fields] include struct [@@@ocaml.warning "-60"] let _ = fun (_ : t) -> () let y _r__ = _r__.y let _ = y let set_y _r__ v__ = _r__.y <- v__ let _ = set_y let x _r__ = _r__.x let _ = x module Fields = struct let names = [ "x"; "y" ] let _ = names let y = (Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.force_variance = (fun (_ : [< `Read | `Set_and_create ]) -> ()) ; name = "y" ; getter = y ; setter = Some set_y ; fset = (fun _r__ v__ -> { _r__ with y = v__ }) } : ([< `Read | `Set_and_create ], _, bool) Fieldslib.Field.t_with_perm) ;; let _ = y let x = (Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.force_variance = (fun (_ : [< `Read | `Set_and_create ]) -> ()) ; name = "x" ; getter = x ; setter = None ; fset = (fun _r__ v__ -> { _r__ with x = v__ }) } : ([< `Read | `Set_and_create ], _, int) Fieldslib.Field.t_with_perm) ;; let _ = x let make_creator ~x:x_fun__ ~y:y_fun__ compile_acc__ = let x_gen__, compile_acc__ = x_fun__ x compile_acc__ in let y_gen__, compile_acc__ = y_fun__ y compile_acc__ in ( (fun acc__ -> let x = x_gen__ acc__ in let y = y_gen__ acc__ in { x; y }) , compile_acc__ ) ;; let _ = make_creator let create ~x ~y = { x; y } let _ = create let map ~x:x_fun__ ~y:y_fun__ = { x = x_fun__ x; y = y_fun__ y } let _ = map let iter ~x:x_fun__ ~y:y_fun__ = (x_fun__ x : unit); (y_fun__ y : unit) ;; let _ = iter let fold ~init:init__ ~x:x_fun__ ~y:y_fun__ = y_fun__ (x_fun__ init__ x) y let _ = fold let map_poly record__ = [ record__.Fieldslib.Field.f x; record__.Fieldslib.Field.f y ] ;; let _ = map_poly let for_all ~x:x_fun__ ~y:y_fun__ = (true && x_fun__ x) && y_fun__ y let _ = for_all let exists ~x:x_fun__ ~y:y_fun__ = (false || x_fun__ x) || y_fun__ y let _ = exists let to_list ~x:x_fun__ ~y:y_fun__ = [ x_fun__ x; y_fun__ y ] let _ = to_list module Direct = struct let iter record__ ~x:x_fun__ ~y:y_fun__ = x_fun__ x record__ record__.x; y_fun__ y record__ record__.y ;; let _ = iter let fold record__ ~init:init__ ~x:x_fun__ ~y:y_fun__ = y_fun__ (x_fun__ init__ x record__ record__.x) y record__ record__.y ;; let _ = fold let for_all record__ ~x:x_fun__ ~y:y_fun__ = (true && x_fun__ x record__ record__.x) && y_fun__ y record__ record__.y ;; let _ = for_all let exists record__ ~x:x_fun__ ~y:y_fun__ = (false || x_fun__ x record__ record__.x) || y_fun__ y record__ record__.y ;; let _ = exists let to_list record__ ~x:x_fun__ ~y:y_fun__ = [ x_fun__ x record__ record__.x; y_fun__ y record__ record__.y ] ;; let _ = to_list let map record__ ~x:x_fun__ ~y:y_fun__ = { x = x_fun__ x record__ record__.x; y = y_fun__ y record__ record__.y } ;; let _ = map let set_all_mutable_fields _record__ ~y = let _record__ = Fieldslib.Field.For_generated_code.opaque_identity _record__ in _record__.y <- y [@@inline always] ;; let _ = set_all_mutable_fields end end end [@@ocaml.doc "@inline"] [@@@end] end module One_thing = struct type t = { x : int ; mutable y : bool } [@@deriving_inline fields ~setters] let _ = fun (_ : t) -> () let set_y _r__ v__ = _r__.y <- v__ let _ = set_y [@@@end] end module Everything = struct type t = { x : int ; mutable y : bool } [@@deriving_inline fields ~getters ~setters ~names ~fields ~iterators: ( create , make_creator , exists , fold , fold_right , for_all , iter , map , to_list , map_poly ) ~direct_iterators: (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] include struct [@@@ocaml.warning "-60"] let _ = fun (_ : t) -> () let y _r__ = _r__.y let _ = y let set_y _r__ v__ = _r__.y <- v__ let _ = set_y let x _r__ = _r__.x let _ = x module Fields = struct let names = [ "x"; "y" ] let _ = names let y = (Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.force_variance = (fun (_ : [< `Read | `Set_and_create ]) -> ()) ; name = "y" ; getter = y ; setter = Some set_y ; fset = (fun _r__ v__ -> { _r__ with y = v__ }) } : ([< `Read | `Set_and_create ], _, bool) Fieldslib.Field.t_with_perm) ;; let _ = y let x = (Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.force_variance = (fun (_ : [< `Read | `Set_and_create ]) -> ()) ; name = "x" ; getter = x ; setter = None ; fset = (fun _r__ v__ -> { _r__ with x = v__ }) } : ([< `Read | `Set_and_create ], _, int) Fieldslib.Field.t_with_perm) ;; let _ = x let make_creator ~x:x_fun__ ~y:y_fun__ compile_acc__ = let x_gen__, compile_acc__ = x_fun__ x compile_acc__ in let y_gen__, compile_acc__ = y_fun__ y compile_acc__ in ( (fun acc__ -> let x = x_gen__ acc__ in let y = y_gen__ acc__ in { x; y }) , compile_acc__ ) ;; let _ = make_creator let create ~x ~y = { x; y } let _ = create let map ~x:x_fun__ ~y:y_fun__ = { x = x_fun__ x; y = y_fun__ y } let _ = map let iter ~x:x_fun__ ~y:y_fun__ = (x_fun__ x : unit); (y_fun__ y : unit) ;; let _ = iter let fold ~init:init__ ~x:x_fun__ ~y:y_fun__ = y_fun__ (x_fun__ init__ x) y let _ = fold let map_poly record__ = [ record__.Fieldslib.Field.f x; record__.Fieldslib.Field.f y ] ;; let _ = map_poly let for_all ~x:x_fun__ ~y:y_fun__ = (true && x_fun__ x) && y_fun__ y let _ = for_all let exists ~x:x_fun__ ~y:y_fun__ = (false || x_fun__ x) || y_fun__ y let _ = exists let to_list ~x:x_fun__ ~y:y_fun__ = [ x_fun__ x; y_fun__ y ] let _ = to_list let fold_right ~x:x_fun__ ~y:y_fun__ ~init:init__ = x_fun__ x (y_fun__ y init__) let _ = fold_right module Direct = struct let iter record__ ~x:x_fun__ ~y:y_fun__ = x_fun__ x record__ record__.x; y_fun__ y record__ record__.y ;; let _ = iter let fold record__ ~init:init__ ~x:x_fun__ ~y:y_fun__ = y_fun__ (x_fun__ init__ x record__ record__.x) y record__ record__.y ;; let _ = fold let for_all record__ ~x:x_fun__ ~y:y_fun__ = (true && x_fun__ x record__ record__.x) && y_fun__ y record__ record__.y ;; let _ = for_all let exists record__ ~x:x_fun__ ~y:y_fun__ = (false || x_fun__ x record__ record__.x) || y_fun__ y record__ record__.y ;; let _ = exists let to_list record__ ~x:x_fun__ ~y:y_fun__ = [ x_fun__ x record__ record__.x; y_fun__ y record__ record__.y ] ;; let _ = to_list let fold_right record__ ~x:x_fun__ ~y:y_fun__ ~init:init__ = x_fun__ x record__ record__.x (y_fun__ y record__ record__.y init__) ;; let _ = fold_right let map record__ ~x:x_fun__ ~y:y_fun__ = { x = x_fun__ x record__ record__.x; y = y_fun__ y record__ record__.y } ;; let _ = map let set_all_mutable_fields _record__ ~y = let _record__ = Fieldslib.Field.For_generated_code.opaque_identity _record__ in _record__.y <- y [@@inline always] ;; let _ = set_all_mutable_fields end end end [@@ocaml.doc "@inline"] [@@@end] end ppx_fields_conv-0.16.0/test/deriving_inline.mli000066400000000000000000000145441442175067100216260ustar00rootroot00000000000000module Default : sig type t = { x : int ; mutable y : bool } [@@deriving_inline fields] include sig [@@@ocaml.warning "-32-60"] val y : t -> bool val set_y : t -> bool -> unit val x : t -> int module Fields : sig val names : string list val y : (t, bool) Fieldslib.Field.t val x : (t, int) Fieldslib.Field.t val fold : init:'acc__0 -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> 'acc__1) -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> 'acc__2) -> 'acc__2 val make_creator : x:((t, int) Fieldslib.Field.t -> 'acc__0 -> ('input__ -> int) * 'acc__1) -> y:((t, bool) Fieldslib.Field.t -> 'acc__1 -> ('input__ -> bool) * 'acc__2) -> 'acc__0 -> ('input__ -> t) * 'acc__2 val create : x:int -> y:bool -> t val map : x:((t, int) Fieldslib.Field.t -> int) -> y:((t, bool) Fieldslib.Field.t -> bool) -> t val iter : x:((t, int) Fieldslib.Field.t -> unit) -> y:((t, bool) Fieldslib.Field.t -> unit) -> unit val for_all : x:((t, int) Fieldslib.Field.t -> bool) -> y:((t, bool) Fieldslib.Field.t -> bool) -> bool val exists : x:((t, int) Fieldslib.Field.t -> bool) -> y:((t, bool) Fieldslib.Field.t -> bool) -> bool val to_list : x:((t, int) Fieldslib.Field.t -> 'elem__) -> y:((t, bool) Fieldslib.Field.t -> 'elem__) -> 'elem__ list val map_poly : ([< `Read | `Set_and_create ], t, 'x0) Fieldslib.Field.user -> 'x0 list module Direct : sig val iter : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> unit) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> unit) -> unit val fold : t -> init:'acc__0 -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> t -> int -> 'acc__1) -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> t -> bool -> 'acc__2) -> 'acc__2 val for_all : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> bool val exists : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> bool val to_list : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> 'elem__) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> 'elem__) -> 'elem__ list val map : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> int) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> t val set_all_mutable_fields : t -> y:bool -> unit end end end [@@ocaml.doc "@inline"] [@@@end] end module One_thing : sig type t = { x : int ; mutable y : bool } [@@deriving_inline fields ~setters] include sig [@@@ocaml.warning "-32"] val set_y : t -> bool -> unit end [@@ocaml.doc "@inline"] [@@@end] end module Everything : sig type t = { x : int ; mutable y : bool } [@@deriving_inline fields ~getters ~setters ~names ~fields ~iterators: ( create , make_creator , exists , fold , fold_right , for_all , iter , map , to_list , map_poly ) ~direct_iterators: (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] include sig [@@@ocaml.warning "-32-60"] val y : t -> bool val set_y : t -> bool -> unit val x : t -> int module Fields : sig val names : string list val y : (t, bool) Fieldslib.Field.t val x : (t, int) Fieldslib.Field.t val fold : init:'acc__0 -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> 'acc__1) -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> 'acc__2) -> 'acc__2 val fold_right : x:((t, int) Fieldslib.Field.t -> 'acc__1 -> 'acc__2) -> y:((t, bool) Fieldslib.Field.t -> 'acc__0 -> 'acc__1) -> init:'acc__0 -> 'acc__2 val make_creator : x:((t, int) Fieldslib.Field.t -> 'acc__0 -> ('input__ -> int) * 'acc__1) -> y:((t, bool) Fieldslib.Field.t -> 'acc__1 -> ('input__ -> bool) * 'acc__2) -> 'acc__0 -> ('input__ -> t) * 'acc__2 val create : x:int -> y:bool -> t val map : x:((t, int) Fieldslib.Field.t -> int) -> y:((t, bool) Fieldslib.Field.t -> bool) -> t val iter : x:((t, int) Fieldslib.Field.t -> unit) -> y:((t, bool) Fieldslib.Field.t -> unit) -> unit val for_all : x:((t, int) Fieldslib.Field.t -> bool) -> y:((t, bool) Fieldslib.Field.t -> bool) -> bool val exists : x:((t, int) Fieldslib.Field.t -> bool) -> y:((t, bool) Fieldslib.Field.t -> bool) -> bool val to_list : x:((t, int) Fieldslib.Field.t -> 'elem__) -> y:((t, bool) Fieldslib.Field.t -> 'elem__) -> 'elem__ list val map_poly : ([< `Read | `Set_and_create ], t, 'x0) Fieldslib.Field.user -> 'x0 list module Direct : sig val iter : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> unit) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> unit) -> unit val fold : t -> init:'acc__0 -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> t -> int -> 'acc__1) -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> t -> bool -> 'acc__2) -> 'acc__2 val for_all : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> bool val exists : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> bool val to_list : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> 'elem__) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> 'elem__) -> 'elem__ list val fold_right : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> 'acc__1 -> 'acc__2) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> 'acc__0 -> 'acc__1) -> init:'acc__0 -> 'acc__2 val map : t -> x:((t, int) Fieldslib.Field.t -> t -> int -> int) -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) -> t val set_all_mutable_fields : t -> y:bool -> unit end end end [@@ocaml.doc "@inline"] [@@@end] end ppx_fields_conv-0.16.0/test/dune000066400000000000000000000003741442175067100166300ustar00rootroot00000000000000(library (name fieldslib_test) (libraries fieldslib) (preprocess (pps ppx_fields_conv ppx_inline_test))) (rule (targets example_from_doc.ml) (deps ../README.md gen_test_from_doc.sh) (action (bash "./gen_test_from_doc.sh ../README.md > %{targets}")))ppx_fields_conv-0.16.0/test/fields_test.ml000066400000000000000000000143261442175067100206130ustar00rootroot00000000000000module Simple : sig type t = { x : int ; w : int } [@@deriving fields ~iterators:(create, fold_right, for_all, exists, map, to_list, fold, iter) ~direct_iterators:(for_all, exists, map, to_list, fold, fold_right, iter)] end = struct type t = { x : int ; w : int } [@@deriving fields ~iterators:(create, fold_right, for_all, exists, map, to_list, fold, iter) ~direct_iterators:(for_all, exists, map, to_list, fold, fold_right, iter)] let%test _ = Fields.create ~x:2 ~w:4 = { x = 2; w = 4 } let all_even = { x = 2; w = 4 } let some_even = { x = 1; w = 4 } let none_even = { x = 1; w = 3 } let is_even t field = Fieldslib.Field.get field t mod 2 = 0 let%test _ = Fields.for_all ~x:(is_even all_even) ~w:(is_even all_even) = true let%test _ = Fields.for_all ~x:(is_even some_even) ~w:(is_even some_even) = false let%test _ = Fields.exists ~x:(is_even some_even) ~w:(is_even some_even) = true let%test _ = Fields.exists ~x:(is_even none_even) ~w:(is_even none_even) = false let is_even field t n = assert (Fieldslib.Field.get field t = n); n mod 2 = 0 ;; let%test _ = Fields.Direct.for_all all_even ~x:is_even ~w:is_even = true let%test _ = Fields.Direct.for_all some_even ~x:is_even ~w:is_even = false let%test _ = Fields.Direct.exists some_even ~x:is_even ~w:is_even = true let%test _ = Fields.Direct.exists none_even ~x:is_even ~w:is_even = false let t = { x = 1; w = 3 } let add_one t field = Fieldslib.Field.get field t + 1 let%test _ = Fields.map ~x:(add_one t) ~w:(add_one t) = { x = 2; w = 4 } let%test _ = Fields.to_list ~x:(add_one t) ~w:(add_one t) = [ 2; 4 ] let add_one field t n = assert (Fieldslib.Field.get field t = n); n + 1 ;; let%test _ = Fields.Direct.map t ~x:add_one ~w:add_one = { x = 2; w = 4 } let%test _ = Fields.Direct.to_list t ~x:add_one ~w:add_one = [ 2; 4 ] let fold_one t acc field = (Fieldslib.Field.get field t + 1) :: acc let%test _ = Fields.fold ~init:[] ~x:(fold_one t) ~w:(fold_one t) = [ 4; 2 ] let fold_one t field acc = (Fieldslib.Field.get field t + 1) :: acc let%test _ = Fields.fold_right ~x:(fold_one t) ~w:(fold_one t) ~init:[] = [ 2; 4 ] let fold_one acc field t n = assert (Fieldslib.Field.get field t = n); (n + 1) :: acc ;; let%test _ = Fields.Direct.fold t ~init:[] ~x:fold_one ~w:fold_one = [ 4; 2 ] let fold_one field t n acc = assert (Fieldslib.Field.get field t = n); (n + 1) :: acc ;; let%test _ = Fields.Direct.fold_right t ~x:fold_one ~w:fold_one ~init:[] = [ 2; 4 ] let iter_one t buf field = buf := (Fieldslib.Field.get field t + 1) :: !buf let%test _ = let buf = ref [] in Fields.iter ~x:(iter_one t buf) ~w:(iter_one t buf); !buf = [ 4; 2 ] ;; let iter_one buf field t n = assert (Fieldslib.Field.get field t = n); buf := (n + 1) :: !buf ;; let%test _ = let buf = ref [] in Fields.Direct.iter t ~x:(iter_one buf) ~w:(iter_one buf); !buf = [ 4; 2 ] ;; end module Rec = struct type a = { something1 : b } and b = A of a [@@deriving fields] let _ = something1 end module Multiple_names = struct type a = { a : int } and b = { b : int } [@@deriving fields] let%test _ = b { b = 1 } = 1 let%test _ = a { a = 1 } = 1 let _ = Fields_of_a.a let _ = Fields_of_b.b let _ = (Fields_of_a.a : (_, _) Fieldslib.Field.t :> (_, _) Fieldslib.Field.readonly_t) end module Private : sig type t = private { a : int ; mutable b : int } [@@deriving fields] end = struct type u = { a : int ; mutable b : int } type t = u = private { a : int ; mutable b : int } [@@deriving fields] (* let _ = Fieldslib.Field.setter Fields.a *) end (* let _ = Fieldslib.Field.setter Private.Fields.a *) let _ = Private.Fields.fold let _ = Private.Fields.a let _ = Fieldslib.Field.name Private.Fields.a let (_ : Private.t -> int) = Fieldslib.Field.get Private.Fields.a let _ = Private.Fields.map_poly { Fieldslib.Field.f = (fun f -> let (_ : Private.t -> _) = Fieldslib.Field.get f in ()) } ;; module Warnings : sig (* could generate an unused warning but for crazy reasons, only when the type is private *) type t = private { foo : int } [@@deriving fields] val foo : string end = struct type t = { foo : int } [@@deriving fields] let foo = "a" end module Wildcard : sig type _ t = { x : int ; y : string } [@@deriving fields] end = struct type _ t = { x : int ; y : string } [@@deriving fields] let _ = x let _ = y end let%test_module "set_all_mutable_fields" = (module struct module M : sig type 'a t = { mutable a : int ; b : string ; mutable c : 'a } [@@deriving fields] end = struct type 'a t = { mutable a : int ; b : string ; mutable c : 'a } [@@deriving fields] end open M let%test_unit _ = let t : _ t = { a = 0; b = ""; c = nan } in let final_t : _ t = { a = 12; b = t.b; c = 12. } in Fields.Direct.set_all_mutable_fields t ~a:final_t.a ~c:final_t.c; assert (t = final_t) ;; end) ;; (* Sometimes it's convenient for the type of the accumulator to change as you handle the individual fields. *) module M (F1 : sig type t = { a : int ; b : string ; c : bool } [@@deriving fields] end) (F2 : sig type t = { a : int ; b : string } [@@deriving fields] end) = struct let convert : F1.t -> F2.t = F1.Fields.Direct.fold ~init:F2.Fields.create ~a:(fun acc field x _ -> acc ~a:(Fieldslib.Field.get field x)) ~b:(fun acc field x _ -> acc ~b:(Fieldslib.Field.get field x)) ~c:(fun acc _field _x _ -> acc) ;; let construct () : F1.t = F1.Fields.fold ~init:F1.Fields.create ~a:(fun f _ -> f ~a:8) ~b:(fun f _ -> f ~b:"foo") ~c:(fun f _ -> f ~c:true) ;; end (* We expect no unused value, unused type, unused module warnings, as only a part of the generated code is used in normal circumstances. *) module Unused_warnings : sig end = struct [@@@ocaml.warning "+60"] type t = { a : int ; b : int } [@@deriving fields] end ppx_fields_conv-0.16.0/test/gen_test_from_doc.sh000077500000000000000000000020751442175067100217710ustar00rootroot00000000000000#!/bin/bash set -e -o pipefail INPUT=$1 function dump { local INDENT=$(printf "%*s" $1 "") local TAG=$2 local BEGIN="^$" local END="^$" if [[ $3 = -remove-deriving ]]; then local REMOVE_DERIVING=';s/\[@@deriving.**\]//' else local REMOVE_DERIVING='' fi sed -nr "/$BEGIN/,/$END/p" $INPUT | \ sed -r "/^\`\`\`/d;/^