pax_global_header00006660000000000000000000000064135645304060014520gustar00rootroot0000000000000052 comment=09669b6421a2bfaf88946ef113a5f8f4c6473ac3 ppx_fields_conv-0.13.0/000077500000000000000000000000001356453040600147635ustar00rootroot00000000000000ppx_fields_conv-0.13.0/.gitignore000066400000000000000000000000411356453040600167460ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_fields_conv-0.13.0/CHANGES.md000066400000000000000000000017551356453040600163650ustar00rootroot00000000000000## 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.13.0/CONTRIBUTING.md000066400000000000000000000044101356453040600172130ustar00rootroot00000000000000This 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.13.0/LICENSE.md000066400000000000000000000021351356453040600163700ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2019 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_fields_conv-0.13.0/Makefile000066400000000000000000000004031356453040600164200ustar00rootroot00000000000000INSTALL_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.13.0/README.md000066400000000000000000000175001356453040600162450ustar00rootroot00000000000000ppx_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`. ppx_fields_conv-0.13.0/bench/000077500000000000000000000000001356453040600160425ustar00rootroot00000000000000ppx_fields_conv-0.13.0/bench/bench_fields.ml000066400000000000000000000102721356453040600210030ustar00rootroot00000000000000(* 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.13.0/bench/dune000066400000000000000000000002071356453040600167170ustar00rootroot00000000000000(library (name field_setting_bench) (preprocess (pps ppx_bench ppx_fields_conv ppx_cold)) (libraries fieldslib compiler-libs.common))ppx_fields_conv-0.13.0/dune000066400000000000000000000000001356453040600156270ustar00rootroot00000000000000ppx_fields_conv-0.13.0/dune-project000066400000000000000000000000171356453040600173030ustar00rootroot00000000000000(lang dune 1.5)ppx_fields_conv-0.13.0/example/000077500000000000000000000000001356453040600164165ustar00rootroot00000000000000ppx_fields_conv-0.13.0/example/dune000066400000000000000000000002071356453040600172730ustar00rootroot00000000000000(executables (names test) (libraries) (preprocess (pps ppxlib ppx_fields_conv))) (alias (name DEFAULT) (deps test.ml.pp test.mli.pp))ppx_fields_conv-0.13.0/example/test.ml000066400000000000000000000011351356453040600177270ustar00rootroot00000000000000 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.13.0/example/test.mli000066400000000000000000000022151356453040600201000ustar00rootroot00000000000000(* 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.13.0/ppx_fields_conv.opam000066400000000000000000000014441356453040600210260ustar00rootroot00000000000000opam-version: "2.0" version: "v0.13.0" maintainer: "opensource@janestreet.com" 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.04.2"} "base" {>= "v0.13" & < "v0.14"} "fieldslib" {>= "v0.13" & < "v0.14"} "dune" {>= "1.5.1"} "ppxlib" {>= "0.9.0"} ] synopsis: "Generation of accessor and iteration functions for ocaml records" description: " Part of the Jane Street's PPX rewriters collection. " ppx_fields_conv-0.13.0/src/000077500000000000000000000000001356453040600155525ustar00rootroot00000000000000ppx_fields_conv-0.13.0/src/dune000066400000000000000000000002601356453040600164260ustar00rootroot00000000000000(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.13.0/src/ppx_fields_conv.ml000066400000000000000000000734141356453040600212770ustar00rootroot00000000000000(* 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 let check_no_collision = let always = [ "make_creator"; "create"; "fold"; "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 exp_string : (loc:Location.t -> string -> expression) = fun ~loc s -> pexp_constant ~loc (Pconst_string (s,None)) let pat_name : (loc:Location.t -> string -> pattern) = fun ~loc name -> ppat_var ~loc (Loc.make name ~loc) let exp_name : (loc:Location.t -> string -> expression) = fun ~loc name -> pexp_ident ~loc (Loc.make (Longident.Lident name) ~loc) let lid_name : (loc:Location.t -> string -> Longident.t loc) = fun ~loc name -> Loc.make (Longident.Lident name) ~loc let exp_true ~loc = pexp_construct ~loc (Located.mk ~loc (Longident.Lident "true")) None let str_item ~loc name body = pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pat_name ~loc name) ~expr:body ] let mod_ ~loc : (string -> structure -> structure_item) = fun name structure -> pstr_module ~loc (module_binding ~loc ~name:(Located.mk ~loc 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 name) ~type_:(pmty_signature ~loc signature)) end module Create = struct let record ~loc pairs = pexp_record ~loc (List.map pairs ~f:(fun (name,exp) -> A.lid_name ~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") ;; module Gen_sig = struct let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (A.lid_name ~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 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 (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 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 = A.sig_item ~loc name [%type: [%t record_ty] -> [%t ty] ] in match m, private_ with | Immutable, _ | Mutable, Private -> [getter] | Mutable, Public -> let setter = 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 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_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 getters_and_setters @ [ A.sig_mod ~loc fields_module ( List.concat [ [A.sig_item ~loc "names" [%type: string list]]; fields; [fold]; begin 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 -> [ create_fun; simple_create_fun; map; ] end; [iter; and_f; or_f; to_list; map_poly; A.sig_mod ~loc "Direct" (List.concat [ [ direct_iter; direct_fold; direct_and_f; direct_or_f; direct_to_list; ]; begin match private_ with | Private -> [] | Public -> [direct_map; set_all_mutable_fields] end; ])]])] let fields_of_td (td:type_declaration) : 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 labdecs | _ -> [] let generate ~loc ~path:_ (rec_flag, tds) = 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 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 : (structure * structure_item) = let {pld_name={txt=name;loc}; pld_type=field_ty; pld_mutable=m; _} = labdec in let getter = A.str_item ~loc name [%expr fun _r__ -> [%e pexp_field ~loc [%expr _r__] (A.lid_name ~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 = A.str_item ~loc ("set_" ^ name) [%expr fun _r__ v__ -> [%e pexp_setfield ~loc [%expr _r__] (A.lid_name ~loc name) [%expr v__] ]] in let setter_field = [%expr Some [%e A.exp_name ~loc ("set_" ^ name)]] in [setter], setter_field | Immutable, _ -> [], [%expr None ] in let field = let e = pexp_record ~loc [A.lid_name ~loc name, A.exp_name ~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 A.exp_string ~loc name]; getter = [%e A.exp_name ~loc name]; setter = [%e setter_field]; fset = [%e fset];}] in 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), A.pat_name ~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, A.exp_name ~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:(A.pat_name ~loc field_name) ~expr:[%expr [%e A.exp_name ~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 [ (A.pat_name ~loc (field_name ^ "_gen__")); [%pat? compile_acc__]; ]) ~expr:[%expr [%e A.exp_name ~loc (field_name ^ "_fun__")] [%e A.exp_name ~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, A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e acc_expr] [%e A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e acc_expr] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~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 and_fun ~loc labdecs = let names = Inspect.field_names labdecs in let field_fold acc_expr field_name = [%expr [%e acc_expr] && [%e A.exp_name ~loc (field_name ^ "_fun__")] [%e A.exp_name ~loc field_name] ] in let body = List.fold_left names ~init:(A.exp_true ~loc) ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~loc field_name)] ] in let body = List.fold_left names ~init:(A.exp_true ~loc) ~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 A.exp_name ~loc (field_name ^ "_fun__")] [%e A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~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 A.exp_name ~loc (field_name ^ "_fun__")] [%e A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__")] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~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 A.exp_name ~loc (field_name ^ "_fun__") ] [%e A.exp_name ~loc field_name] record__ [%e pexp_field ~loc [%expr record__] (A.lid_name ~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 A.exp_name ~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 : structure_item = 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 (A.exp_name ~loc record_name) (A.lid_name ~loc field_name) (A.exp_name ~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. [Caml.Sys.opaque_identity] causes flambda to generate the correct assembly here. *) [%expr let [%p A.pat_name ~loc record_name] = Fieldslib.Field.For_generated_code.opaque_identity [%e A.exp_name ~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 (A.pat_name ~loc field_name) acc) in let body = pexp_fun ~loc Nolabel None (A.pat_name ~loc record_name) function_ in [%stri let[@inline always] set_all_mutable_fields = [%e body]] let record ~private_ ~record_name ~loc (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:(A.exp_string ~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 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_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 getter_and_setters @ [ A.mod_ ~loc fields_module ( List.concat [ [A.str_item ~loc "names" (elist ~loc names)]; fields; begin match private_ with | Private -> [] | Public -> [create; simple_create; map;] end; [iter; fold; map_poly; andf; orf; to_list; ]; [A.mod_ ~loc "Direct" (List.concat [ [ direct_iter; direct_fold; direct_andf; direct_orf; direct_to_list; ]; begin match private_ with | Private -> [] | Public -> [direct_map; set_all_mutable_fields] end; ])]])] let fields_of_td (td:type_declaration) : 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 labdecs | _ -> [] let generate ~loc ~path:_ (rec_flag, tds) = 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 end let fields = Deriving.add "fields" ~str_type_decl:(Deriving.Generator.make Deriving.Args.empty Gen_struct.generate) ~sig_type_decl:(Deriving.Generator.make Deriving.Args.empty Gen_sig.generate) ;; ppx_fields_conv-0.13.0/src/ppx_fields_conv.mli000066400000000000000000000000451356453040600214360ustar00rootroot00000000000000open Ppxlib val fields : Deriving.t ppx_fields_conv-0.13.0/test/000077500000000000000000000000001356453040600157425ustar00rootroot00000000000000ppx_fields_conv-0.13.0/test/dune000066400000000000000000000003741356453040600166240ustar00rootroot00000000000000(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.13.0/test/fields_test.ml000066400000000000000000000116321356453040600206040ustar00rootroot00000000000000module Simple : sig type t = { x : int; w : int } [@@deriving fields] end = struct type t = { x : int; w : int } [@@deriving fields] 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 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 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 ppx_fields_conv-0.13.0/test/gen_test_from_doc.sh000077500000000000000000000020751356453040600217650ustar00rootroot00000000000000#!/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;/^