├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── README.md.orig ├── bench ├── bench_fields.ml ├── dune └── field_setting_bench.ml ├── dune ├── dune-project ├── example ├── dune ├── test.ml └── test.mli ├── ppx_fields_conv.opam ├── src ├── dune ├── ppx_fields_conv.ml ├── ppx_fields_conv.mli ├── selector.ml └── selector.mli └── test ├── arguments.mlt ├── deriving_clause.mlt ├── deriving_inline_with_mli.ml ├── deriving_inline_with_mli.mli ├── deriving_inline_without_mli.ml ├── dune ├── fields_test.ml ├── fieldslib_test.ml ├── gen_test_from_doc.sh ├── private.mlt ├── selector_tests.ml ├── selector_tests.mli ├── shadow.mlt ├── test_do_not_require_specifiers ├── dune ├── fieldslib_test_do_not_require_specifiers.ml ├── no_specifiers.ml └── no_specifiers.mli ├── zero_alloc_test.ml ├── zero_alloc_test.mli └── zero_alloc_test.mlt /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Unreleased 2 | 3 | * Added the `-deriving-fields-require-selectors` command-line flag, which can be used to 4 | make writing `[@@derving fields]` with no selectors produce an error during 5 | preprocessing. 6 | 7 | ## Release v0.16.0 8 | 9 | * Added options to `[@@deriving fields]` for selecting a subset of definitions. 10 | For example, `[@@deriving fields ~getters ~setters]` derives getter and setter 11 | functions only, and omits the entire `Fields` submodule. 12 | 13 | ## Old pre-v0.15 changelogs (very likely stale and incomplete) 14 | 15 | ## v0.11 16 | 17 | - Depend on ppxlib instead of (now deprecated) ppx\_core, ppx\_driver, 18 | ppx\_metaquot and ppx\_type\_conv. 19 | 20 | ## 113.33.00 21 | 22 | - Fix errors in `ppx_fields_conv` documentation 23 | 24 | - Add unit tests for `ppx_fields_conv` functions 25 | 26 | - Fix some idiosyncracies where the implementations in `ppx_fields_conv.ml` differed 27 | (ex: a variable would be called one thing when implementing one function but 28 | would be called something different when implementing every other function). 29 | 30 | ## 113.24.00 31 | 32 | - The `iter` function generated by ppx\_variants\_conv and ppx\_fields\_conv allowed 33 | one to give function which returned values of arbitrary types as iter function. 34 | This release constraint these functions to return unit. 35 | 36 | N.B. the signature generated by the use of `@@deriving variants` (resp. fields) 37 | in interface already constrained the type to unit. 38 | 39 | - Update to follow type\_conv's evolution. 40 | 41 | - Add `Fields.make_creator` to ppx\_fields\_conv's readme, since it appears 42 | to not be all that deprecated. 43 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2015--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_fields_conv 2 | =============== 3 | 4 | 5 | Generation of accessor and iteration functions for ocaml records. 6 | 7 | `ppx_fields_conv` is a ppx rewriter that can be used to define: 8 | 9 | * first-class values representing record fields 10 | * additional functions to: 11 | - get and set record fields 12 | - iterate and fold over all fields of a record 13 | - create new record values 14 | 15 | # Basic Usage 16 | 17 | One common use of `ppx_fields_conv` is to derive accessor functions on record types. 18 | For example, one can derive `getters` on the following simple record type: 19 | 20 | ```ocaml 21 | type t = { 22 | dir : [ `Buy | `Sell ]; 23 | quantity : int; 24 | price : float; 25 | mutable cancelled : bool; 26 | } [@@deriving fields ~getters] 27 | ``` 28 | 29 | Which produces functions with the following signatures: 30 | 31 | ```ocaml 32 | val cancelled : t -> bool @@ portable 33 | val price : t -> float @@ portable 34 | val quantity : t -> int @@ portable 35 | val dir : t -> [ `Buy | `Sell ] @@ portable 36 | ``` 37 | 38 | # Selecting definitions 39 | 40 | The `[@@deriving fields]` clause accepts _selectors_ specifying which definitions it 41 | should provide. Use `~getters` and `~setters` to explicitly select toplevel accessors, 42 | `~fields` to select `Field.t` values, and `~names` to select `Fields.names`. Use 43 | `~iterators` with a tuple containing names chosen from `create`, `make_creator`, and so 44 | on, to select elements of `Fields`. Use `~direct_iterators` with a tuple of names to 45 | select elements of `Fields.Direct`. For example: 46 | 47 | ```ocaml 48 | type t = { x : int; y : int } 49 | [@@deriving fields ~getters ~fields ~iterators:(fold, iter)] 50 | ``` 51 | 52 | The above defines the accessors `x` and `y`, the field values 53 | `Fields.x` and `Fields.y`, `Fields.fold`, and `Fields.iter`. 54 | 55 | By default, `[@@deriving fields]` with no selectors derives all of the functions below 56 | except `Fields.fold_right` and `Direct_iterator.fold_right`. This behavior can be changed 57 | with the `-deriving-fields-require-selectors` command-line argument, which currently 58 | defaults to `false`. Passing `true` instead causes `[@@derving fields]` with no selectors 59 | to produce an error during preprocessing. 60 | 61 | ## Implicitly-selected definitions 62 | 63 | The definitions of several of these functions depend on the `getters`, `setters`, and 64 | `fields` definitions. As a result, some of their dependencies might be derived in `*.ml` 65 | files, even if they were not explicitly indicated in the selector list. Specifically, in 66 | structures (and in the toplevel of `*.ml` files): 67 | 68 | - `[@@deriving fields ~fields]` also derives the functions under `~getters` and `~setters` 69 | - `[@@deriving fields ~iterators:_]` and `[@@deriving fields ~direct_iterators:_]` (for 70 | any legal arguments to `iterators` and `direct_iterators`; see below) also derives 71 | `~fields` (which transitively derives `~getters` and `~setters`) 72 | 73 | It's fine to use these "free" derived functions in the `*.ml`. However, to expose them in 74 | `*.mli`s, one must explicitly include them in the selector list, since 75 | `[@@deriving fields]`, when used in signatures, only derives declarations for exactly the 76 | requested functions (and not their dependencies). 77 | 78 | ## Full list of selectors 79 | 80 | The full list of permitted selectors and the signatures of the corresponding functions 81 | follows: 82 | 83 | 84 | ```ocaml 85 | type t = { 86 | dir : [ `Buy | `Sell ]; 87 | quantity : int; 88 | price : float; 89 | mutable cancelled : bool; 90 | } [@@deriving 91 | fields 92 | ~getters 93 | ~local_getters 94 | ~setters 95 | ~names 96 | ~fields 97 | ~iterators: 98 | ( create 99 | , make_creator 100 | , exists 101 | , fold 102 | , fold_right 103 | , for_all 104 | , iter 105 | , map 106 | , to_list 107 | , map_poly ) 108 | ~direct_iterators: 109 | (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] 110 | ``` 111 | 112 | 113 | then code will be generated for functions of the following type (note that the `@@ 114 | portable` annotations are for OxCaml only, and are converted to ignored attributes in 115 | regular OCaml): 116 | 117 | 118 | ```ocaml 119 | (* getters *) 120 | val cancelled : t -> bool @@ portable [@@zero_alloc] 121 | val price : t -> float @@ portable [@@zero_alloc] 122 | val quantity : t -> int @@ portable [@@zero_alloc] 123 | val dir : t -> [ `Buy | `Sell ] @@ portable [@@zero_alloc] 124 | 125 | (* local getters *) 126 | val cancelled__local : local_ t -> bool @@ portable [@@zero_alloc] 127 | val price__local : local_ t -> local_ float @@ portable [@@zero_alloc] 128 | val quantity__local : local_ t -> local_ int @@ portable [@@zero_alloc] 129 | val dir__local : local_ t -> local_ [ `Buy | `Sell ] @@ portable [@@zero_alloc] 130 | 131 | (* setters *) 132 | val set_cancelled : t -> bool -> unit @@ portable [@@zero_alloc] 133 | 134 | (* higher order fields and functions over all fields *) 135 | module Fields : sig 136 | 137 | val names : string list @@ portable 138 | 139 | val cancelled : (t, bool ) Field.t @@ portable 140 | val price : (t, float ) Field.t @@ portable 141 | val quantity : (t, int ) Field.t @@ portable 142 | val dir : (t, [ `Buy | `Sell ]) Field.t @@ portable 143 | 144 | val create 145 | : dir : [ `Buy | `Sell ] 146 | -> quantity : int 147 | -> price : float 148 | -> cancelled : bool 149 | -> t 150 | @@ portable 151 | 152 | val make_creator 153 | : dir : ((t, [ `Buy | `Sell ]) Field.t -> 'a -> ('arg -> [ `Buy | `Sell ]) * 'b) 154 | -> quantity : ((t, int ) Field.t -> 'b -> ('arg -> int ) * 'c) 155 | -> price : ((t, float ) Field.t -> 'c -> ('arg -> float ) * 'd) 156 | -> cancelled : ((t, bool ) Field.t -> 'd -> ('arg -> bool ) * 'e) 157 | -> 'a -> ('arg -> t) * 'e 158 | @@ portable 159 | 160 | val fold 161 | : init : 'a 162 | -> dir : local_ ('a -> (t, [ `Buy | `Sell ]) Field.t -> 'b) 163 | -> quantity : local_ ('b -> (t, int ) Field.t -> 'c) 164 | -> price : local_ ('c -> (t, float ) Field.t -> 'd) 165 | -> cancelled : local_ ('d -> (t, bool ) Field.t -> 'e) 166 | -> 'e 167 | @@ portable 168 | 169 | val fold_right 170 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> 'd -> 'e) 171 | -> quantity : local_ ((t, int ) Field.t -> 'c -> 'd) 172 | -> price : local_ ((t, float ) Field.t -> 'b -> 'c) 173 | -> cancelled : local_ ((t, bool ) Field.t -> 'a -> 'b) 174 | -> init : 'a 175 | -> 'e 176 | @@ portable 177 | 178 | val map 179 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> [ `Buy | `Sell ]) 180 | -> quantity : local_ ((t, int ) Field.t -> int) 181 | -> price : local_ ((t, float ) Field.t -> float) 182 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 183 | -> t 184 | @@ portable 185 | 186 | val iter 187 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> unit) 188 | -> quantity : local_ ((t, int ) Field.t -> unit) 189 | -> price : local_ ((t, float ) Field.t -> unit) 190 | -> cancelled : local_ ((t, bool ) Field.t -> unit) 191 | -> unit 192 | @@ portable 193 | 194 | val for_all 195 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> bool) 196 | -> quantity : local_ ((t, int ) Field.t -> bool) 197 | -> price : local_ ((t, float ) Field.t -> bool) 198 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 199 | -> bool 200 | @@ portable 201 | 202 | val exists 203 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> bool) 204 | -> quantity : local_ ((t, int ) Field.t -> bool) 205 | -> price : local_ ((t, float ) Field.t -> bool) 206 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 207 | -> bool 208 | @@ portable 209 | 210 | val to_list 211 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> 'a) 212 | -> quantity : local_ ((t, int ) Field.t -> 'a) 213 | -> price : local_ ((t, float ) Field.t -> 'a) 214 | -> cancelled : local_ ((t, bool ) Field.t -> 'a) 215 | -> 'a list 216 | @@ portable 217 | 218 | val map_poly : local_ ([< `Read | `Set_and_create ], t, 'a) Field.user -> 'a list @@ portable 219 | 220 | (** Functions that take a record directly *) 221 | module Direct : sig 222 | 223 | val fold 224 | : t 225 | -> init : 'a 226 | -> dir : local_ ('a -> (t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'b) 227 | -> quantity : local_ ('b -> (t, int ) Field.t -> t -> int -> 'c) 228 | -> price : local_ ('c -> (t, float ) Field.t -> t -> float -> 'd) 229 | -> cancelled : local_ ('d -> (t, bool ) Field.t -> t -> bool -> 'e) 230 | -> 'e 231 | @@ portable 232 | 233 | val fold_right 234 | : t 235 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'd -> 'e) 236 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> 'c -> 'd) 237 | -> price : local_ ((t, float ) Field.t -> t -> float -> 'b -> 'c) 238 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> 'a -> 'b) 239 | -> init:'a 240 | -> 'e 241 | @@ portable 242 | 243 | val map 244 | : t 245 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> [ `Buy | `Sell ]) 246 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> int) 247 | -> price : local_ ((t, float ) Field.t -> t -> float -> float) 248 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 249 | -> t 250 | @@ portable 251 | 252 | val iter 253 | : t 254 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> unit) 255 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> unit) 256 | -> price : local_ ((t, float ) Field.t -> t -> float -> unit) 257 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> unit) 258 | -> unit 259 | @@ portable 260 | 261 | val for_all 262 | : t 263 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) 264 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> bool) 265 | -> price : local_ ((t, float ) Field.t -> t -> float -> bool) 266 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 267 | -> bool 268 | @@ portable 269 | 270 | val exists 271 | : t 272 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) 273 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> bool) 274 | -> price : local_ ((t, float ) Field.t -> t -> float -> bool) 275 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 276 | -> bool 277 | @@ portable 278 | 279 | val to_list 280 | : t 281 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'a) 282 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> 'a) 283 | -> price : local_ ((t, float ) Field.t -> t -> float -> 'a) 284 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> 'a) 285 | -> 'a list 286 | @@ portable 287 | 288 | val set_all_mutable_fields : local_ t -> cancelled:bool -> unit @@ portable [@@zero_alloc] 289 | end 290 | 291 | end 292 | ``` 293 | 294 | 295 | Use of `[@@deriving fields]` in an `*.mli` will extend the signature for functions with 296 | the above types; In an `*.ml`, definitions will be generated. 297 | 298 | `Field.t` is defined in `Fieldslib`, including: 299 | 300 | ```ocaml 301 | type ('perm, 'record, 'field) t_with_perm 302 | 303 | type ('record, 'field) t = ([ `Read | `Set_and_create], 'record, 'field) t_with_perm 304 | 305 | val name : (_, _, _) t_with_perm -> string 306 | val get : (_, 'r, 'a) t_with_perm -> 'r -> 'a 307 | ``` 308 | 309 | ## Zero_alloc attribute 310 | 311 | By default, `ppx_fields_conv` will generate `[@@zero_alloc]` attributes for all getters, 312 | setters, and `set_all_mutable_fields`. It is possible, however, that the generated 313 | implementations for a given record may actually allocate, causing the compiler to complain 314 | (this can happen e.g. if your record contains all float fields, or you mask the generated 315 | code with custom definitions). In these instance you can tag your record with an 316 | additional attribute `[@@fields.no_zero_alloc]` to disable adding the `[@@zero_alloc]` 317 | attribute: 318 | 319 | ```ocaml 320 | type t = { x : Some_float_type.t } 321 | [@@fields.no_zero_alloc] 322 | [@@deriving fields ~getters] 323 | ``` 324 | 325 | # Functions over all fields 326 | 327 | Use of the generated functions together with `Fieldslib` allow us to 328 | define functions over t which check exhaustiveness w.r.t record 329 | fields, avoiding common semantic errors which can occur when a record 330 | is extended with new fields but we forget to update functions. 331 | 332 | For example if you are writing a custom equality operator to ignore 333 | small price differences: 334 | 335 | ```ocaml 336 | let ( = ) a b : bool = 337 | let use op = fun field -> 338 | op (Field.get field a) (Field.get field b) 339 | in 340 | let price_equal p1 p2 = Float.abs (p1 -. p2) < 0.001 in 341 | Fields.for_all 342 | ~dir:(use (=)) ~quantity:(use (=)) 343 | ~price:(use price_equal) ~cancelled:(use (=)) 344 | ;; 345 | ``` 346 | 347 | A type error would occur if you were to add a new field and not change 348 | the definition of `( = )`: 349 | 350 | ```ocaml 351 | type t = { 352 | dir : [ `Buy | `Sell ]; 353 | quantity : int; 354 | price : float; 355 | mutable cancelled : bool; 356 | symbol : string; 357 | } [@@deriving fields ~iterators:(for_all, fold)] 358 | 359 | ... 360 | Error: This expression has type 361 | symbol:(([< `Read | `Set_and_create ], t, string) Field.t_with_perm -> 362 | bool) -> 363 | bool 364 | but an expression was expected of type bool 365 | ``` 366 | 367 | Or similarly you could use `fold` to create `to_string` function: 368 | 369 | ```ocaml 370 | let to_string t = 371 | let conv to_s = fun acc f -> 372 | (sprintf "%s: %s" (Field.name f) (to_s (Field.get f t))) :: acc 373 | in 374 | let fs = 375 | Fields.fold ~init:[] 376 | ~dir:(conv (function `Buy -> "Buy" | `Sell -> "Sell")) 377 | ~quantity:(conv Int.to_string) 378 | ~price:(conv Float.to_string) 379 | ~cancelled:(conv Bool.to_string) 380 | in 381 | String.concat fs ~sep:", " 382 | ;; 383 | ``` 384 | 385 | Addition of a new field would cause a type error reminding you to 386 | update the definition of `to_string`. 387 | -------------------------------------------------------------------------------- /README.md.orig: -------------------------------------------------------------------------------- 1 | ppx_fields_conv 2 | =============== 3 | 4 | 5 | Generation of accessor and iteration functions for ocaml records. 6 | 7 | `ppx_fields_conv` is a ppx rewriter that can be used to define: 8 | 9 | * first-class values representing record fields 10 | * additional functions to: 11 | - get and set record fields 12 | - iterate and fold over all fields of a record 13 | - create new record values 14 | 15 | # Basic Usage 16 | 17 | One common use of `ppx_fields_conv` is to derive accessor functions on record types. 18 | For example, one can derive `getters` on the following simple record type: 19 | 20 | ```ocaml 21 | type t = { 22 | dir : [ `Buy | `Sell ]; 23 | quantity : int; 24 | price : float; 25 | mutable cancelled : bool; 26 | } [@@deriving fields ~getters] 27 | ``` 28 | 29 | Which produces functions with the following signatures: 30 | 31 | ```ocaml 32 | val cancelled : t -> bool @@ portable 33 | val price : t -> float @@ portable 34 | val quantity : t -> int @@ portable 35 | val dir : t -> [ `Buy | `Sell ] @@ portable 36 | ``` 37 | 38 | # Selecting definitions 39 | 40 | The `[@@deriving fields]` clause requires _selectors_ specifying which definitions it 41 | should provide. Use `~getters` and `~setters` to explicitly select toplevel accessors, 42 | `~fields` to select `Field.t` values, and `~names` to select `Fields.names`. Use 43 | `~iterators` with a tuple containing names chosen from `create`, `make_creator`, and so 44 | on, to select elements of `Fields`. Use `~direct_iterators` with a tuple of names to 45 | select elements of `Fields.Direct`. For example: 46 | 47 | ```ocaml 48 | type t = { x : int; y : int } 49 | [@@deriving fields ~getters ~fields ~iterators:(fold, iter)] 50 | ``` 51 | 52 | The above defines the accessors `x` and `y`, the field values 53 | `Fields.x` and `Fields.y`, `Fields.fold`, and `Fields.iter`. 54 | 55 | Writing `[@@deriving fields]` with no selectors will produce an error during 56 | preprocessing. Passing the command-line argument 57 | `-deriving-fields-require-selectors=false` restores the legacy behavior of deriving all of 58 | the below functions except `Fields.fold_right` and `Direct_iterator.fold_right`. This flag 59 | should only be used with external code. 60 | 61 | ## Implicitly-selected definitions 62 | 63 | The definitions of several of these functions depend on the `getters`, `setters`, and 64 | `fields` definitions. As a result, some of their dependencies might be derived in `*.ml` 65 | files, even if they were not explicitly indicated in the selector list. Specifically, in 66 | structures (and in the toplevel of `*.ml` files): 67 | 68 | - `[@@deriving fields ~fields]` also derives the functions under `~getters` and `~setters` 69 | - `[@@deriving fields ~iterators:_]` and `[@@deriving fields ~direct_iterators:_]` (for 70 | any legal arguments to `iterators` and `direct_iterators`; see below) also derives 71 | `~fields` (which transitively derives `~getters` and `~setters`) 72 | 73 | It's fine to use these "free" derived functions in the `*.ml`. However, to expose them in 74 | `*.mli`s, one must explicitly include them in the selector list, since 75 | `[@@deriving fields]`, when used in signatures, only derives declarations for exactly the 76 | requested functions (and not their dependencies). 77 | 78 | ## Full list of selectors 79 | 80 | The full list of permitted selectors and the signatures of the corresponding functions 81 | follows: 82 | 83 | 84 | ```ocaml 85 | type t = { 86 | dir : [ `Buy | `Sell ]; 87 | quantity : int; 88 | price : float; 89 | mutable cancelled : bool; 90 | } [@@deriving 91 | fields 92 | ~getters 93 | ~local_getters 94 | ~setters 95 | ~names 96 | ~fields 97 | ~iterators: 98 | ( create 99 | , make_creator 100 | , exists 101 | , fold 102 | , fold_right 103 | , for_all 104 | , iter 105 | , map 106 | , to_list 107 | , map_poly ) 108 | ~direct_iterators: 109 | (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] 110 | ``` 111 | 112 | 113 | then code will be generated for functions of the following type (note that the `@@ 114 | portable` annotations are for OxCaml only, and are converted to ignored attributes in 115 | regular OCaml): 116 | 117 | 118 | ```ocaml 119 | (* getters *) 120 | val cancelled : t -> bool @@ portable [@@zero_alloc] 121 | val price : t -> float @@ portable [@@zero_alloc] 122 | val quantity : t -> int @@ portable [@@zero_alloc] 123 | val dir : t -> [ `Buy | `Sell ] @@ portable [@@zero_alloc] 124 | 125 | (* local getters *) 126 | val cancelled__local : local_ t -> bool @@ portable [@@zero_alloc] 127 | val price__local : local_ t -> local_ float @@ portable [@@zero_alloc] 128 | val quantity__local : local_ t -> local_ int @@ portable [@@zero_alloc] 129 | val dir__local : local_ t -> local_ [ `Buy | `Sell ] @@ portable [@@zero_alloc] 130 | 131 | (* setters *) 132 | val set_cancelled : t -> bool -> unit @@ portable [@@zero_alloc] 133 | 134 | (* higher order fields and functions over all fields *) 135 | module Fields : sig 136 | 137 | val names : string list @@ portable 138 | 139 | val cancelled : (t, bool ) Field.t @@ portable 140 | val price : (t, float ) Field.t @@ portable 141 | val quantity : (t, int ) Field.t @@ portable 142 | val dir : (t, [ `Buy | `Sell ]) Field.t @@ portable 143 | 144 | val create 145 | : dir : [ `Buy | `Sell ] 146 | -> quantity : int 147 | -> price : float 148 | -> cancelled : bool 149 | -> t 150 | @@ portable 151 | 152 | val make_creator 153 | : dir : ((t, [ `Buy | `Sell ]) Field.t -> 'a -> ('arg -> [ `Buy | `Sell ]) * 'b) 154 | -> quantity : ((t, int ) Field.t -> 'b -> ('arg -> int ) * 'c) 155 | -> price : ((t, float ) Field.t -> 'c -> ('arg -> float ) * 'd) 156 | -> cancelled : ((t, bool ) Field.t -> 'd -> ('arg -> bool ) * 'e) 157 | -> 'a -> ('arg -> t) * 'e 158 | @@ portable 159 | 160 | val fold 161 | : init : 'a 162 | -> dir : local_ ('a -> (t, [ `Buy | `Sell ]) Field.t -> 'b) 163 | -> quantity : local_ ('b -> (t, int ) Field.t -> 'c) 164 | -> price : local_ ('c -> (t, float ) Field.t -> 'd) 165 | -> cancelled : local_ ('d -> (t, bool ) Field.t -> 'e) 166 | -> 'e 167 | @@ portable 168 | 169 | val fold_right 170 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> 'd -> 'e) 171 | -> quantity : local_ ((t, int ) Field.t -> 'c -> 'd) 172 | -> price : local_ ((t, float ) Field.t -> 'b -> 'c) 173 | -> cancelled : local_ ((t, bool ) Field.t -> 'a -> 'b) 174 | -> init : 'a 175 | -> 'e 176 | @@ portable 177 | 178 | val map 179 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> [ `Buy | `Sell ]) 180 | -> quantity : local_ ((t, int ) Field.t -> int) 181 | -> price : local_ ((t, float ) Field.t -> float) 182 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 183 | -> t 184 | @@ portable 185 | 186 | val iter 187 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> unit) 188 | -> quantity : local_ ((t, int ) Field.t -> unit) 189 | -> price : local_ ((t, float ) Field.t -> unit) 190 | -> cancelled : local_ ((t, bool ) Field.t -> unit) 191 | -> unit 192 | @@ portable 193 | 194 | val for_all 195 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> bool) 196 | -> quantity : local_ ((t, int ) Field.t -> bool) 197 | -> price : local_ ((t, float ) Field.t -> bool) 198 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 199 | -> bool 200 | @@ portable 201 | 202 | val exists 203 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> bool) 204 | -> quantity : local_ ((t, int ) Field.t -> bool) 205 | -> price : local_ ((t, float ) Field.t -> bool) 206 | -> cancelled : local_ ((t, bool ) Field.t -> bool) 207 | -> bool 208 | @@ portable 209 | 210 | val to_list 211 | : dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> 'a) 212 | -> quantity : local_ ((t, int ) Field.t -> 'a) 213 | -> price : local_ ((t, float ) Field.t -> 'a) 214 | -> cancelled : local_ ((t, bool ) Field.t -> 'a) 215 | -> 'a list 216 | @@ portable 217 | 218 | val map_poly : local_ ([< `Read | `Set_and_create ], t, 'a) Field.user -> 'a list @@ portable 219 | 220 | (** Functions that take a record directly *) 221 | module Direct : sig 222 | 223 | val fold 224 | : t 225 | -> init : 'a 226 | -> dir : local_ ('a -> (t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'b) 227 | -> quantity : local_ ('b -> (t, int ) Field.t -> t -> int -> 'c) 228 | -> price : local_ ('c -> (t, float ) Field.t -> t -> float -> 'd) 229 | -> cancelled : local_ ('d -> (t, bool ) Field.t -> t -> bool -> 'e) 230 | -> 'e 231 | @@ portable 232 | 233 | val fold_right 234 | : t 235 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'd -> 'e) 236 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> 'c -> 'd) 237 | -> price : local_ ((t, float ) Field.t -> t -> float -> 'b -> 'c) 238 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> 'a -> 'b) 239 | -> init:'a 240 | -> 'e 241 | @@ portable 242 | 243 | val map 244 | : t 245 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> [ `Buy | `Sell ]) 246 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> int) 247 | -> price : local_ ((t, float ) Field.t -> t -> float -> float) 248 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 249 | -> t 250 | @@ portable 251 | 252 | val iter 253 | : t 254 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> unit) 255 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> unit) 256 | -> price : local_ ((t, float ) Field.t -> t -> float -> unit) 257 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> unit) 258 | -> unit 259 | @@ portable 260 | 261 | val for_all 262 | : t 263 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) 264 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> bool) 265 | -> price : local_ ((t, float ) Field.t -> t -> float -> bool) 266 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 267 | -> bool 268 | @@ portable 269 | 270 | val exists 271 | : t 272 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> bool) 273 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> bool) 274 | -> price : local_ ((t, float ) Field.t -> t -> float -> bool) 275 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> bool) 276 | -> bool 277 | @@ portable 278 | 279 | val to_list 280 | : t 281 | -> dir : local_ ((t, [ `Buy | `Sell ]) Field.t -> t -> [ `Buy | `Sell ] -> 'a) 282 | -> quantity : local_ ((t, int ) Field.t -> t -> int -> 'a) 283 | -> price : local_ ((t, float ) Field.t -> t -> float -> 'a) 284 | -> cancelled : local_ ((t, bool ) Field.t -> t -> bool -> 'a) 285 | -> 'a list 286 | @@ portable 287 | 288 | val set_all_mutable_fields : local_ t -> cancelled:bool -> unit @@ portable [@@zero_alloc] 289 | end 290 | 291 | end 292 | ``` 293 | 294 | 295 | Use of `[@@deriving fields]` in an `*.mli` will extend the signature for functions with 296 | the above types; In an `*.ml`, definitions will be generated. 297 | 298 | `Field.t` is defined in `Fieldslib`, including: 299 | 300 | ```ocaml 301 | type ('perm, 'record, 'field) t_with_perm 302 | 303 | type ('record, 'field) t = ([ `Read | `Set_and_create], 'record, 'field) t_with_perm 304 | 305 | val name : (_, _, _) t_with_perm -> string 306 | val get : (_, 'r, 'a) t_with_perm -> 'r -> 'a 307 | ``` 308 | 309 | ## Zero_alloc attribute 310 | 311 | By default, `ppx_fields_conv` will generate `[@@zero_alloc]` attributes for all getters, 312 | setters, and `set_all_mutable_fields`. It is possible, however, that the generated 313 | implementations for a given record may actually allocate, causing the compiler to complain 314 | (this can happen e.g. if your record contains all float fields, or you mask the generated 315 | code with custom definitions). In these instance you can tag your record with an 316 | additional attribute `[@@fields.no_zero_alloc]` to disable adding the `[@@zero_alloc]` 317 | attribute: 318 | 319 | ```ocaml 320 | type t = { x : Some_float_type.t } 321 | [@@fields.no_zero_alloc] 322 | [@@deriving fields ~getters] 323 | ``` 324 | 325 | # Functions over all fields 326 | 327 | Use of the generated functions together with `Fieldslib` allow us to 328 | define functions over t which check exhaustiveness w.r.t record 329 | fields, avoiding common semantic errors which can occur when a record 330 | is extended with new fields but we forget to update functions. 331 | 332 | For example if you are writing a custom equality operator to ignore 333 | small price differences: 334 | 335 | ```ocaml 336 | let ( = ) a b : bool = 337 | let use op = fun field -> 338 | op (Field.get field a) (Field.get field b) 339 | in 340 | let price_equal p1 p2 = Float.abs (p1 -. p2) < 0.001 in 341 | Fields.for_all 342 | ~dir:(use (=)) ~quantity:(use (=)) 343 | ~price:(use price_equal) ~cancelled:(use (=)) 344 | ;; 345 | ``` 346 | 347 | A type error would occur if you were to add a new field and not change 348 | the definition of `( = )`: 349 | 350 | ```ocaml 351 | type t = { 352 | dir : [ `Buy | `Sell ]; 353 | quantity : int; 354 | price : float; 355 | mutable cancelled : bool; 356 | symbol : string; 357 | } [@@deriving fields ~iterators:(for_all, fold)] 358 | 359 | ... 360 | Error: This expression has type 361 | symbol:(([< `Read | `Set_and_create ], t, string) Field.t_with_perm -> 362 | bool) -> 363 | bool 364 | but an expression was expected of type bool 365 | ``` 366 | 367 | Or similarly you could use `fold` to create `to_string` function: 368 | 369 | ```ocaml 370 | let to_string t = 371 | let conv to_s = fun acc f -> 372 | (sprintf "%s: %s" (Field.name f) (to_s (Field.get f t))) :: acc 373 | in 374 | let fs = 375 | Fields.fold ~init:[] 376 | ~dir:(conv (function `Buy -> "Buy" | `Sell -> "Sell")) 377 | ~quantity:(conv Int.to_string) 378 | ~price:(conv Float.to_string) 379 | ~cancelled:(conv Bool.to_string) 380 | in 381 | String.concat fs ~sep:", " 382 | ;; 383 | ``` 384 | 385 | Addition of a new field would cause a type error reminding you to 386 | update the definition of `to_string`. 387 | -------------------------------------------------------------------------------- /bench/bench_fields.ml: -------------------------------------------------------------------------------- 1 | (* Current results: 2 | ┌───────────────────────────────────────────────────────────────────────────────────────┬──────────┬────────────┐ 3 | │ Name │ Time/Run │ Percentage │ 4 | ├───────────────────────────────────────────────────────────────────────────────────────┼──────────┼────────────┤ 5 | │ [bench_fields.ml:field_setting] manual field setting │ 2.93ns │ 92.92% │ 6 | │ [bench_fields.ml:field_setting] Fields.Direct inlined │ 2.71ns │ 86.01% │ 7 | │ [bench_fields.ml:field_setting] Fields.Direct NOT inlined │ 3.15ns │ 100.00% │ 8 | │ [bench_fields.ml:shorter_record_field_setting] manual field setting │ 2.68ns │ 84.91% │ 9 | │ [bench_fields.ml:shorter_record_field_setting] [Fields.Direct.set_all_mutable_fields] │ 2.53ns │ 80.10% │ 10 | └───────────────────────────────────────────────────────────────────────────────────────┴──────────┴────────────┘ 11 | *) 12 | 13 | type a_or_b = 14 | | A 15 | | B 16 | 17 | module%bench [@name "field_setting"] _ = struct 18 | type t = 19 | { mutable a : int 20 | ; b : int 21 | ; mutable c : a_or_b 22 | ; mutable d : int 23 | ; mutable e : int 24 | ; mutable f : int 25 | ; mutable g : int 26 | } 27 | [@@deriving fields ~direct_iterators:set_all_mutable_fields] 28 | 29 | let set_manual t ~a ~c ~d ~e ~f ~g = 30 | t.a <- a; 31 | t.c <- c; 32 | t.d <- d; 33 | t.e <- e; 34 | t.f <- f; 35 | t.g <- g 36 | ;; 37 | 38 | let[@inline] set_via_fields t ~a ~c ~d ~e ~f ~g = 39 | Fields.Direct.set_all_mutable_fields t ~a ~c ~d ~e ~f ~g 40 | ;; 41 | 42 | let[@cold] set_via_fields_not_inlined t ~a ~c ~d ~e ~f ~g = 43 | Fields.Direct.set_all_mutable_fields t ~a ~c ~d ~e ~f ~g 44 | ;; 45 | 46 | let init () = { a = 0; b = 0; c = A; d = 0; e = 0; f = 0; g = 0 } 47 | 48 | let%bench_fun "manual field setting" = 49 | let t = init () in 50 | fun () -> set_manual t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 51 | ;; 52 | 53 | let%bench_fun "Fields.Direct inlined" = 54 | let t = init () in 55 | fun () -> set_via_fields t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 56 | ;; 57 | 58 | let%bench_fun "Fields.Direct NOT inlined" = 59 | let t = init () in 60 | fun () -> set_via_fields_not_inlined t ~a:1234567 ~c:B ~d:1000 ~e:99999 ~f:42 ~g:987 61 | ;; 62 | end 63 | 64 | module%bench [@name "shorter_record_field_setting"] _ = struct 65 | type t = 66 | { mutable a : int 67 | ; b : int 68 | ; mutable c : a_or_b 69 | ; mutable d : int 70 | ; e : int 71 | ; f : int 72 | ; g : int 73 | } 74 | [@@deriving fields ~direct_iterators:set_all_mutable_fields] 75 | 76 | let set_manual t ~a ~c ~d = 77 | t.a <- a; 78 | t.c <- c; 79 | t.d <- d 80 | ;; 81 | 82 | let set_via_fields t ~a ~c ~d = Fields.Direct.set_all_mutable_fields t ~a ~c ~d 83 | let init () = { a = 0; b = 0; c = B; d = 0; e = 0; f = 0; g = 0 } 84 | 85 | let%bench_fun "manual field setting" = 86 | let t = init () in 87 | fun () -> set_manual t ~a:1234567 ~c:B ~d:1000 88 | ;; 89 | 90 | let%bench_fun "[Fields.Direct.set_all_mutable_fields]" = 91 | let t = init () in 92 | fun () -> set_via_fields t ~a:1234567 ~c:B ~d:1000 93 | ;; 94 | end 95 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name field_setting_bench) 3 | (preprocess 4 | (pps ppx_bench ppx_fields_conv ppx_cold)) 5 | (libraries fieldslib compiler-libs.common)) 6 | -------------------------------------------------------------------------------- /bench/field_setting_bench.ml: -------------------------------------------------------------------------------- 1 | module Bench_fields = Bench_fields 2 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/janestreet/ppx_fields_conv/c51218f9d5eceb5401b0824d9057dc8e9ac148c6/dune -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names test) 4 | (libraries) 5 | (preprocess 6 | (pps ppxlib ppx_fields_conv))) 7 | 8 | (alias 9 | (name DEFAULT) 10 | (deps test.ml.pp test.mli.pp)) 11 | -------------------------------------------------------------------------------- /example/test.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) t = 2 | { dir : 'a * 'b 3 | ; quantity : ('a, 'b) t 4 | ; price : int * 'a 5 | ; mutable cancelled : bool 6 | } 7 | [@@deriving fields ~getters ~setters] 8 | 9 | type foo = 10 | { a : [ `Bar | `Baz of string ] 11 | ; b : int 12 | } 13 | [@@deriving fields ~getters ~setters] 14 | 15 | module Private_in_mli = struct 16 | type ('a, 'b) t = 17 | { dir : 'a * 'b 18 | ; quantity : ('a, 'b) t 19 | ; price : int * 'a 20 | ; mutable cancelled : bool 21 | } 22 | [@@deriving fields ~getters ~setters] 23 | end 24 | 25 | module Private_in_ml = struct 26 | type ('a, 'b) t = ('a, 'b) Private_in_mli.t = private 27 | { dir : 'a * 'b 28 | ; quantity : ('a, 'b) t 29 | ; price : int * 'a 30 | ; mutable cancelled : bool 31 | } 32 | [@@deriving fields ~getters ~setters] 33 | end 34 | -------------------------------------------------------------------------------- /example/test.mli: -------------------------------------------------------------------------------- 1 | (* sample mli showing everything that 'with fields' introduces *) 2 | 3 | (* 4 | NOTES: 5 | - (1) this file was hand generated and can therefore get out of sync with 6 | the actual interface of the generated code. 7 | - (2) The file generated_test.mli does not have this problem as it is 8 | generated by ocamlp4o from the file test.mli 9 | - (3) The types we list here are actually more general than those in 10 | generated_test.mli (see make_creator, for example) 11 | *) 12 | 13 | type ('a, 'b) t = 14 | { dir : 'a * 'b 15 | ; quantity : ('a, 'b) t 16 | ; price : int * 'a 17 | ; mutable cancelled : bool (* symbol : string; *) 18 | } 19 | [@@deriving fields ~getters ~setters] 20 | 21 | type foo = 22 | { a : [ `Bar | `Baz of string ] 23 | ; b : int 24 | } 25 | [@@deriving fields ~getters ~setters] 26 | 27 | module Private_in_mli : sig 28 | type ('a, 'b) t = private 29 | { dir : 'a * 'b 30 | ; quantity : ('a, 'b) t 31 | ; price : int * 'a 32 | ; mutable cancelled : bool (* symbol : string; *) 33 | } 34 | [@@deriving fields ~getters ~setters] 35 | end 36 | 37 | module Private_in_ml : sig 38 | type ('a, 'b) t = ('a, 'b) Private_in_mli.t = private 39 | { dir : 'a * 'b 40 | ; quantity : ('a, 'b) t 41 | ; price : int * 'a 42 | ; mutable cancelled : bool (* symbol : string; *) 43 | } 44 | [@@deriving fields ~getters ~setters] 45 | end 46 | -------------------------------------------------------------------------------- /ppx_fields_conv.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ppx_fields_conv" 5 | bug-reports: "https://github.com/janestreet/ppx_fields_conv/issues" 6 | dev-repo: "git+https://github.com/janestreet/ppx_fields_conv.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_fields_conv/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "base" 15 | "fieldslib" 16 | "ppxlib_jane" 17 | "dune" {>= "3.17.0"} 18 | "ppxlib" {>= "0.33.0" & < "0.36.0"} 19 | ] 20 | available: arch != "arm32" & arch != "x86_32" 21 | synopsis: "Generation of accessor and iteration functions for ocaml records" 22 | description: " 23 | Part of the Jane Street's PPX rewriters collection. 24 | " 25 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_fields_conv) 3 | (public_name ppx_fields_conv) 4 | (kind ppx_deriver) 5 | (ppx_runtime_libraries fieldslib) 6 | (libraries base compiler-libs.common ppxlib ppxlib_jane) 7 | (preprocess 8 | (pps ppxlib.metaquot))) 9 | -------------------------------------------------------------------------------- /src/ppx_fields_conv.ml: -------------------------------------------------------------------------------- 1 | (* Generated code should depend on the environment in scope as little as 2 | possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the 3 | use of [=]. It is especially important to not use polymorphic comparisons, since we 4 | are moving more and more to code that doesn't have them in scope. *) 5 | 6 | open Base 7 | open Printf 8 | open Ppxlib 9 | open Ast_builder.Default 10 | open Ppxlib_jane.Ast_builder.Default 11 | module Selector = Selector 12 | module Modes = Ppxlib_jane.Shim.Modes 13 | 14 | let check_no_collision = 15 | let always = 16 | [ "make_creator" 17 | ; "create" 18 | ; "fold" 19 | ; "fold_right" 20 | ; "iter" 21 | ; "to_list" 22 | ; "map" 23 | ; "map_poly" 24 | ; "for_all" 25 | ; "exists" 26 | ; "names" 27 | ] 28 | in 29 | fun (lbls : label_declaration list) -> 30 | let generated_funs = 31 | let extra_forbidden_names = 32 | List.filter_map lbls ~f:(function 33 | | { pld_mutable = Mutable; pld_name; _ } -> Some ("set_" ^ pld_name.txt) 34 | | _ -> None) 35 | in 36 | ("set_all_mutable_fields" :: extra_forbidden_names) @ always 37 | in 38 | List.iter lbls ~f:(fun { pld_name; pld_loc; _ } -> 39 | if List.mem generated_funs pld_name.txt ~equal:String.equal 40 | then 41 | Location.raise_errorf 42 | ~loc:pld_loc 43 | "ppx_fields_conv: field name %S conflicts with one of the generated functions" 44 | pld_name.txt) 45 | ;; 46 | 47 | let no_zero_alloc_type_attr = 48 | Attribute.declare_flag "fields.no_zero_alloc" Attribute.Context.type_declaration 49 | ;; 50 | 51 | let nonportable_type_attr = 52 | Attribute.declare_flag "fields.nonportable" Attribute.Context.type_declaration 53 | ;; 54 | 55 | let has_fields_no_zero_alloc_attr td = 56 | match Attribute.get no_zero_alloc_type_attr td with 57 | | Some () -> true 58 | | None -> false 59 | ;; 60 | 61 | let has_fields_nonportable_attr td = 62 | match Attribute.get nonportable_type_attr td with 63 | | Some () -> true 64 | | None -> false 65 | ;; 66 | 67 | let attribute_is_allowlisted_or_reserved attr = 68 | let name = attr.attr_name.txt in 69 | Reserved_namespaces.is_in_reserved_namespaces name 70 | || Ppxlib_private.Name.Allowlisted.is_allowlisted name ~kind:`Attribute 71 | ;; 72 | 73 | let strip_attributes = 74 | object 75 | inherit Ast_traverse.map 76 | method! attributes list = List.filter list ~f:attribute_is_allowlisted_or_reserved 77 | end 78 | ;; 79 | 80 | module A = struct 81 | (* Additional AST construction helpers *) 82 | 83 | let value_binding ~loc ~pat ~expr ~modes = 84 | let expr = 85 | (* Up/down conversion of [value_binding] containing [Pexp_function] can copy modes 86 | from [pvb_constraint] to [mode_annotations]. We need to do this copy before 87 | emitting syntax so that [deriving_inline] works properly. *) 88 | if List.is_empty modes 89 | then expr 90 | else ( 91 | match 92 | Ppxlib_jane.Shim.Pexp_function.of_parsetree ~loc:expr.pexp_loc expr.pexp_desc 93 | with 94 | | None -> expr 95 | | Some (params, constraint_, body) -> 96 | { expr with 97 | pexp_desc = 98 | Ppxlib_jane.Shim.Pexp_function.to_parsetree 99 | ~params 100 | ~constraint_: 101 | { constraint_ with 102 | mode_annotations = modes @ constraint_.mode_annotations 103 | } 104 | ~body 105 | }) 106 | in 107 | value_binding ~loc ~pat ~expr ~modes 108 | ;; 109 | 110 | let str_item ?(attrs = []) ~loc ~portable name body = 111 | let val_binding = 112 | value_binding 113 | ~loc 114 | ~pat:(pvar ~loc name) 115 | ~expr:body 116 | ~modes:(if portable then [ { loc; txt = Mode "portable" } ] else []) 117 | in 118 | pstr_value ~loc Nonrecursive [ { val_binding with pvb_attributes = attrs } ] 119 | ;; 120 | 121 | let mod_ ~loc : string -> structure -> structure_item = 122 | fun name structure -> 123 | pstr_module 124 | ~loc 125 | (module_binding 126 | ~loc 127 | ~name:(Located.mk ~loc (Some name)) 128 | ~expr:(pmod_structure ~loc structure)) 129 | ;; 130 | 131 | let sig_item ?(attrs = []) ~loc ~portable ~univars name typ = 132 | let typ = 133 | match univars with 134 | | [] -> typ 135 | | _ -> 136 | let univars = 137 | List.map univars ~f:Ppxlib_jane.get_type_param_name_and_jkind_of_core_type 138 | in 139 | Ppxlib_jane.Ast_builder.Default.ptyp_poly ~loc univars typ 140 | in 141 | let val_desc = 142 | value_description 143 | ~loc 144 | ~name:(Located.mk ~loc name) 145 | ~type_:typ 146 | ~prim:[] 147 | ~modalities:(if portable then [ Modality "portable" ] else []) 148 | in 149 | psig_value ~loc { val_desc with pval_attributes = attrs } 150 | ;; 151 | 152 | let sig_mod ~loc : string -> signature_item list -> signature_item = 153 | fun name items -> 154 | psig_module 155 | ~loc 156 | (module_declaration 157 | ~loc 158 | (Located.mk ~loc (Some name)) 159 | (pmty_signature ~loc (signature ~loc items))) 160 | ;; 161 | 162 | let sigitems_mod ~loc : string -> signature_item list -> signature_item = 163 | fun name items -> sig_mod ~loc name items 164 | ;; 165 | 166 | let zero_alloc_attr ~arity ~loc = 167 | let custom_error_message = 168 | estring 169 | {|Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that [@@deriving fields] tries to make by default.|} 170 | ~loc 171 | in 172 | let payload : payload = 173 | match arity with 174 | | None -> PStr [ [%stri custom_error_message [%e custom_error_message]] ] 175 | | Some arity -> 176 | PStr 177 | [ [%stri 178 | arity [%e eint ~loc arity] custom_error_message [%e custom_error_message]] 179 | ] 180 | in 181 | attribute ~loc ~name:{ txt = "zero_alloc"; loc } ~payload 182 | ;; 183 | 184 | let inline_always_attr ~loc = 185 | let payload : payload = PStr [ [%stri always] ] in 186 | attribute ~loc ~name:{ txt = "inline"; loc } ~payload 187 | ;; 188 | end 189 | 190 | module Create = struct 191 | let record ~loc pairs = 192 | pexp_record 193 | ~loc 194 | (List.map pairs ~f:(fun (name, exp) -> Located.lident ~loc name, exp)) 195 | None 196 | ;; 197 | 198 | let curry ~loc ty = 199 | match ty.ptyp_desc with 200 | | Ptyp_arrow _ -> [%type: [%t ty] [@extension.curry]] [@ocamlformat "disable"] 201 | | _ -> ty 202 | ;; 203 | 204 | let with_modes ~loc ~modes pat = 205 | if List.is_empty modes 206 | then pat 207 | else Ppxlib_jane.Ast_builder.Default.ppat_constraint ~loc pat None modes 208 | ;; 209 | 210 | let lambda ~loc ?(modes = []) patterns body = 211 | List.fold_right patterns ~init:body ~f:(fun (lab, pat) acc -> 212 | let pat = with_modes ~loc ~modes pat in 213 | pexp_fun ~loc lab None pat acc) 214 | ;; 215 | 216 | let lambda_sig ~loc ?(modes = []) arg_tys body_ty = 217 | Ppxlib_jane.Ast_builder.Default.tarrow_maybe 218 | ~loc 219 | (List.map arg_tys ~f:(fun (lab, arg_ty) : Ppxlib_jane.arrow_argument -> 220 | { arg_label = lab; arg_type = arg_ty; arg_modes = modes })) 221 | body_ty 222 | ;; 223 | end 224 | 225 | module Inspect = struct 226 | let field_names labdecs = List.map labdecs ~f:(fun labdec -> labdec.pld_name.txt) 227 | end 228 | 229 | let perm ~loc private_ = 230 | match private_ with 231 | | Private -> [%type: [< `Read ]] 232 | | Public -> [%type: [< `Read | `Set_and_create ]] 233 | ;; 234 | 235 | let field_t ~loc private_ tps = 236 | let id = 237 | match private_ with 238 | | Private -> Longident.parse "Fieldslib.Field.readonly_t" 239 | | Public -> Longident.parse "Fieldslib.Field.t" 240 | in 241 | ptyp_constr ~loc (Located.mk ~loc id) tps 242 | ;; 243 | 244 | let check_at_least_one_record ~loc rec_flag tds = 245 | (match rec_flag with 246 | | Nonrecursive -> 247 | Location.raise_errorf ~loc "nonrec is not compatible with the `fields' preprocessor" 248 | | _ -> ()); 249 | let is_record td = 250 | match td.ptype_kind with 251 | | Ptype_record _ -> true 252 | | _ -> false 253 | in 254 | if not (List.exists tds ~f:is_record) 255 | then 256 | Location.raise_errorf 257 | ~loc 258 | (match tds with 259 | | [ _ ] -> "Unsupported use of fields (you can only use it on records)." 260 | | _ -> 261 | "'with fields' can only be applied on type definitions in which at least one \ 262 | type definition is a record") 263 | ;; 264 | 265 | let module_defn defns ~name ~loc ~make_module = 266 | if List.is_empty defns then [] else [ make_module ~loc name defns ] 267 | ;; 268 | 269 | let assemble ~loc ~selection ~fields_module ~make_module ~make_error alist = 270 | let alist = List.filter alist ~f:(fun (selector, _) -> Set.mem selection selector) in 271 | match List.is_empty alist with 272 | | true -> 273 | [ make_error 274 | (Location.Error.createf ~loc "[@@deriving fields]: no definitions generated") 275 | ] 276 | | false -> 277 | let inline, fields, direct = 278 | List.partition3_map alist ~f:(fun (selector, defn) -> 279 | match (selector : Selector.t) with 280 | | Per_field (Getters | Local_getters | Setters) -> `Fst defn 281 | | Per_field (Names | Fields) | Iterator _ -> `Snd defn 282 | | Direct_iterator _ -> `Trd defn) 283 | in 284 | List.concat 285 | [ inline 286 | ; module_defn 287 | ~loc 288 | ~make_module 289 | ~name:fields_module 290 | (List.concat [ fields; module_defn ~loc ~make_module ~name:"Direct" direct ]) 291 | ] 292 | ;; 293 | 294 | let is_no_mutable_implied_modalities attr = 295 | match attr.attr_name.txt with 296 | | "ocaml.no_mutable_implied_modalities" | "no_mutable_implied_modalities" -> true 297 | | _ -> false 298 | ;; 299 | 300 | let is_global_field = 301 | let has_explicit_global_modality ld = 302 | List.exists 303 | (fst (Ppxlib_jane.Ast_builder.Default.get_label_declaration_modalities ld)) 304 | ~f:(function 305 | | Modality "global" -> true 306 | | Modality _ -> false) 307 | in 308 | let is_mutable_field_with_implied_modalities ld = 309 | match ld.pld_mutable with 310 | | Immutable -> false 311 | | Mutable -> not (List.exists ld.pld_attributes ~f:is_no_mutable_implied_modalities) 312 | in 313 | fun ld -> has_explicit_global_modality ld || is_mutable_field_with_implied_modalities ld 314 | ;; 315 | 316 | module Gen_sig = struct 317 | let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps 318 | let label_arg name ty = Labelled name, ty 319 | 320 | let field_arg ~loc ~private_ ~record (f : field:core_type -> ty:core_type -> 'a) labdec 321 | : arg_label * 'a 322 | = 323 | let { pld_name = name; pld_type = ty; _ } = labdec in 324 | label_arg name.txt (f ~field:(field_t ~loc private_ [ record; ty ]) ~ty) 325 | ;; 326 | 327 | let create_fun ~ty_name ~tps ~portable ~loc labdecs = 328 | let record = apply_type ~loc ~ty_name ~tps in 329 | let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in 330 | let f i = 331 | field_arg ~loc ~private_:Public ~record (fun ~field ~ty -> 332 | let create_f = [%type: 'input__ -> [%t ty]] in 333 | [%type: [%t field] -> [%t acc i] -> [%t create_f] * [%t acc (i + 1)]]) 334 | in 335 | let types = List.mapi labdecs ~f in 336 | let create_record_f = [%type: 'input__ -> [%t record]] in 337 | let t = 338 | [%type: [%t create_record_f] * [%t acc (List.length labdecs)]] 339 | |> Create.lambda_sig ~loc [ Nolabel, acc 0 ] 340 | |> Create.lambda_sig ~loc types 341 | in 342 | let univars = 343 | ([%type: 'input__] :: List.init (List.length labdecs + 1) ~f:acc) @ tps 344 | in 345 | A.sig_item ~loc ~portable ~univars "make_creator" t 346 | ;; 347 | 348 | let simple_create_fun ~ty_name ~tps ~portable ~loc labdecs = 349 | let record = apply_type ~loc ~ty_name ~tps in 350 | let f labdec = 351 | let { pld_name = name; pld_type = ty; _ } = labdec in 352 | label_arg name.txt ty 353 | in 354 | let types = List.map labdecs ~f in 355 | let t = Create.lambda_sig ~loc types record in 356 | A.sig_item ~loc ~portable ~univars:tps "create" t 357 | ;; 358 | 359 | let fold_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 360 | let record = apply_type ~loc ~ty_name ~tps in 361 | let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in 362 | let f i arg : arg_label * core_type = 363 | field_arg 364 | ~loc 365 | ~private_ 366 | ~record 367 | (fun ~field ~ty:_ -> [%type: [%t acc i] -> [%t field] -> [%t acc (i + 1)]]) 368 | arg 369 | in 370 | let types = List.mapi labdecs ~f in 371 | let init_ty = label_arg "init" (acc 0) in 372 | let t = 373 | acc (List.length labdecs) 374 | |> Create.lambda_sig ~modes:Modes.local ~loc types 375 | |> Create.lambda_sig ~loc [ init_ty ] 376 | in 377 | let univars = List.init (List.length labdecs + 1) ~f:acc @ tps in 378 | A.sig_item ~loc ~portable ~univars "fold" t 379 | ;; 380 | 381 | let direct_fold_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 382 | let record = apply_type ~loc ~ty_name ~tps in 383 | let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in 384 | let f i arg = 385 | field_arg 386 | ~loc 387 | ~private_ 388 | ~record 389 | (fun ~field ~ty:field_ty -> 390 | [%type: 391 | [%t acc i] -> [%t field] -> [%t record] -> [%t field_ty] -> [%t acc (i + 1)]]) 392 | arg 393 | in 394 | let types = List.mapi labdecs ~f in 395 | let init_ty = label_arg "init" (acc 0) in 396 | let t = 397 | acc (List.length labdecs) 398 | |> Create.lambda_sig ~modes:Modes.local ~loc types 399 | |> Create.lambda_sig ~loc [ Nolabel, record; init_ty ] 400 | in 401 | let univars = List.init (List.length labdecs + 1) ~f:acc @ tps in 402 | A.sig_item ~loc ~portable ~univars "fold" t 403 | ;; 404 | 405 | let fold_right_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 406 | let record = apply_type ~loc ~ty_name ~tps in 407 | let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in 408 | let numlabs = List.length labdecs in 409 | let f i arg : arg_label * core_type = 410 | field_arg 411 | ~loc 412 | ~private_ 413 | ~record 414 | (fun ~field ~ty:_ -> 415 | [%type: [%t field] -> [%t acc (numlabs - i - 1)] -> [%t acc (numlabs - i)]]) 416 | arg 417 | in 418 | let types = List.mapi labdecs ~f in 419 | let init_ty = label_arg "init" (acc 0) in 420 | let t = 421 | acc numlabs 422 | |> Create.lambda_sig ~loc [ init_ty ] 423 | |> Create.lambda_sig ~modes:Modes.local ~loc types 424 | in 425 | let univars = List.init (numlabs + 1) ~f:acc @ tps in 426 | A.sig_item ~loc ~portable ~univars "fold_right" t 427 | ;; 428 | 429 | let direct_fold_right_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 430 | let record = apply_type ~loc ~ty_name ~tps in 431 | let acc i = ptyp_var ~loc ("acc__" ^ Int.to_string i) in 432 | let numlabs = List.length labdecs in 433 | let f i arg = 434 | field_arg 435 | ~loc 436 | ~private_ 437 | ~record 438 | (fun ~field ~ty:field_ty -> 439 | [%type: 440 | [%t field] 441 | -> [%t record] 442 | -> [%t field_ty] 443 | -> [%t acc (numlabs - i - 1)] 444 | -> [%t acc (numlabs - i)]]) 445 | arg 446 | in 447 | let types = List.mapi labdecs ~f in 448 | let init_ty = label_arg "init" (acc 0) in 449 | let t = 450 | acc numlabs 451 | |> Create.lambda_sig ~loc [ init_ty ] 452 | |> Create.lambda_sig ~modes:Modes.local ~loc types 453 | |> Create.lambda_sig ~loc [ Nolabel, record ] 454 | in 455 | let univars = List.init (numlabs + 1) ~f:acc @ tps in 456 | A.sig_item ~loc ~portable ~univars "fold_right" t 457 | ;; 458 | 459 | let bool_fun fun_name ~private_ ~ty_name ~tps ~portable ~loc labdecs = 460 | let record = apply_type ~loc ~ty_name ~tps in 461 | let f = 462 | field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> bool]) 463 | in 464 | let types = List.map labdecs ~f in 465 | let t = Create.lambda_sig ~modes:Modes.local ~loc types [%type: bool] in 466 | A.sig_item ~loc ~portable ~univars:tps fun_name t 467 | ;; 468 | 469 | let direct_bool_fun fun_name ~private_ ~ty_name ~tps ~portable ~loc labdecs = 470 | let record = apply_type ~loc ~ty_name ~tps in 471 | let f = 472 | field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> 473 | [%type: [%t field] -> [%t record] -> [%t field_ty] -> bool]) 474 | in 475 | let types = List.map labdecs ~f in 476 | let t = 477 | [%type: bool] 478 | |> Create.lambda_sig ~modes:Modes.local ~loc types 479 | |> Create.lambda_sig ~loc [ Nolabel, record ] 480 | in 481 | A.sig_item ~loc ~portable ~univars:tps fun_name t 482 | ;; 483 | 484 | let iter_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 485 | let record = apply_type ~loc ~ty_name ~tps in 486 | let f = 487 | field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> [%type: [%t field] -> unit]) 488 | in 489 | let types = List.map labdecs ~f in 490 | let t = Create.lambda_sig ~modes:Modes.local ~loc types [%type: unit] in 491 | A.sig_item ~loc ~portable ~univars:tps "iter" t 492 | ;; 493 | 494 | let direct_iter_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 495 | let record = apply_type ~loc ~ty_name ~tps in 496 | let f = 497 | field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> 498 | [%type: [%t field] -> [%t record] -> [%t field_ty] -> unit]) 499 | in 500 | let types = List.map labdecs ~f in 501 | let t = 502 | [%type: unit] 503 | |> Create.lambda_sig ~modes:Modes.local ~loc types 504 | |> Create.lambda_sig ~loc [ Nolabel, record ] 505 | in 506 | A.sig_item ~loc ~portable ~univars:tps "iter" t 507 | ;; 508 | 509 | let to_list_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 510 | let record = apply_type ~loc ~ty_name ~tps in 511 | let f = 512 | field_arg ~loc ~private_ ~record (fun ~field ~ty:_ -> 513 | [%type: [%t field] -> 'elem__]) 514 | in 515 | let types = List.map labdecs ~f in 516 | let t = Create.lambda_sig ~modes:Modes.local ~loc types [%type: 'elem__ list] in 517 | let univars = [%type: 'elem__] :: tps in 518 | A.sig_item ~loc ~portable ~univars "to_list" t 519 | ;; 520 | 521 | let direct_to_list_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs = 522 | let record = apply_type ~loc ~ty_name ~tps in 523 | let f = 524 | field_arg ~loc ~private_ ~record (fun ~field ~ty:field_ty -> 525 | [%type: [%t field] -> [%t record] -> [%t field_ty] -> 'elem__]) 526 | in 527 | let types = List.map labdecs ~f in 528 | let t = 529 | [%type: 'elem__ list] 530 | |> Create.lambda_sig ~modes:Modes.local ~loc types 531 | |> Create.lambda_sig ~loc [ Nolabel, record ] 532 | in 533 | let univars = [%type: 'elem__] :: tps in 534 | A.sig_item ~loc ~portable ~univars "to_list" t 535 | ;; 536 | 537 | let map_fun ~ty_name ~tps ~loc ~portable labdecs = 538 | let record = apply_type ~loc ~ty_name ~tps in 539 | let f = 540 | field_arg ~loc ~private_:Public ~record (fun ~field ~ty:field_ty -> 541 | [%type: [%t field] -> [%t Create.curry ~loc field_ty]]) 542 | in 543 | let types = List.map labdecs ~f in 544 | let t = Create.lambda_sig ~modes:Modes.local ~loc types record in 545 | A.sig_item ~loc ~portable ~univars:tps "map" t 546 | ;; 547 | 548 | let direct_map_fun ~ty_name ~tps ~portable ~loc labdecs = 549 | let record = apply_type ~loc ~ty_name ~tps in 550 | let f = 551 | field_arg ~loc ~private_:Public ~record (fun ~field ~ty:field_ty -> 552 | [%type: 553 | [%t field] -> [%t record] -> [%t field_ty] -> [%t Create.curry ~loc field_ty]]) 554 | in 555 | let types = List.map labdecs ~f in 556 | let t = 557 | record 558 | |> Create.lambda_sig ~modes:Modes.local ~loc types 559 | |> Create.lambda_sig ~loc [ Nolabel, record ] 560 | in 561 | A.sig_item ~loc ~portable ~univars:tps "map" t 562 | ;; 563 | 564 | let map_poly ~private_ ~ty_name ~portable ~tps ~loc _ = 565 | let record = apply_type ~loc ~ty_name ~tps in 566 | let tps_names = 567 | List.map tps ~f:(fun tp -> 568 | match Ppxlib_jane.Shim.Core_type_desc.of_parsetree tp.ptyp_desc with 569 | | Ptyp_var (var, _) -> var 570 | | _ -> assert false) 571 | in 572 | let fresh_variable = 573 | let rec loop i = 574 | let ret = sprintf "x%i" i in 575 | if List.mem ~equal:String.equal tps_names ret then loop (i + 1) else ret 576 | in 577 | ptyp_var ~loc (loop 0) 578 | in 579 | let perm = perm ~loc private_ in 580 | let t = 581 | [%type: 582 | [%t 583 | ptyp_constr 584 | ~loc 585 | (Located.mk ~loc (Longident.parse "Fieldslib.Field.user")) 586 | [ perm; record; fresh_variable ]] 587 | -> [%t fresh_variable] list] 588 | in 589 | let univars = fresh_variable :: tps in 590 | A.sig_item ~loc ~portable ~univars "map_poly" t 591 | ;; 592 | 593 | let set_all_mutable_fields ~ty_name ~tps ~portable ~loc ~gen_zero_alloc_attrs labdecs = 594 | let record = apply_type ~loc ~ty_name ~tps in 595 | let labels = 596 | List.fold_right labdecs ~init:[%type: unit] ~f:(fun labdec acc -> 597 | match labdec.pld_mutable with 598 | | Immutable -> acc 599 | | Mutable -> 600 | ptyp_arrow 601 | ~loc 602 | { arg_label = Labelled labdec.pld_name.txt 603 | ; arg_type = labdec.pld_type 604 | ; arg_modes = [] 605 | } 606 | { result_type = acc; result_modes = [] }) 607 | in 608 | let attrs = 609 | Option.some_if gen_zero_alloc_attrs (A.zero_alloc_attr ~arity:None ~loc) 610 | |> Option.to_list 611 | in 612 | A.sig_item 613 | ~attrs 614 | ~loc 615 | ~portable 616 | ~univars:tps 617 | "set_all_mutable_fields" 618 | [%type: [%t record] -> [%t labels]] 619 | ;; 620 | 621 | let record 622 | ~private_ 623 | ~ty_name 624 | ~tps 625 | ~loc 626 | ~portable 627 | ~selection 628 | ~gen_zero_alloc_attrs 629 | (labdecs : label_declaration list) 630 | : signature_item list 631 | = 632 | let fields = 633 | List.rev_map labdecs ~f:(fun labdec -> 634 | let { pld_name = { txt = name; loc }; pld_type = ty; _ } = labdec in 635 | let record_ty = apply_type ~loc ~ty_name ~tps in 636 | let field = 637 | A.sig_item 638 | ~loc 639 | ~portable 640 | ~univars:tps 641 | name 642 | (field_t ~loc private_ [ record_ty; ty ]) 643 | in 644 | Selector.Per_field Fields, field) 645 | in 646 | let getters_and_setters = 647 | List.concat 648 | (List.rev_map labdecs ~f:(fun labdec -> 649 | let { pld_name = { txt = name; loc }; pld_type = ty; pld_mutable = m; _ } = 650 | labdec 651 | in 652 | let record_ty = apply_type ~loc ~ty_name ~tps in 653 | let getters = 654 | let attrs = 655 | let attr = 656 | (* fields of functions are only guaranteed to be zero-alloc on the field 657 | access. Ppx_fields cannot assume that applying the function is also 658 | zero-alloc, so we add the [arity 1] payload to all getters. *) 659 | A.zero_alloc_attr ~arity:(Some 1) ~loc 660 | in 661 | Option.some_if gen_zero_alloc_attrs attr |> Option.to_list 662 | in 663 | let getter_sig suffix arrow = 664 | A.sig_item 665 | ~attrs 666 | ~loc 667 | ~portable 668 | ~univars:tps 669 | (name ^ suffix) 670 | (arrow record_ty ty) 671 | in 672 | [ ( Selector.Per_field Getters 673 | , getter_sig "" (fun a b -> [%type: [%t a] -> [%t b]]) ) 674 | ; ( Selector.Per_field Local_getters 675 | , getter_sig "__local" (fun a b -> 676 | if is_global_field labdec 677 | then [%type: [%t a] -> [%t b]] 678 | else [%type: [%t a] -> [%t b]]) ) 679 | ] 680 | in 681 | match m, private_ with 682 | | Immutable, _ | Mutable, Private -> getters 683 | | Mutable, Public -> 684 | let attrs = 685 | A.zero_alloc_attr ~arity:None ~loc 686 | |> Option.some_if gen_zero_alloc_attrs 687 | |> Option.to_list 688 | in 689 | let setter = 690 | ( Selector.Per_field Setters 691 | , A.sig_item 692 | ~attrs 693 | ~loc 694 | ~portable 695 | ~univars:tps 696 | ("set_" ^ name) 697 | [%type: [%t record_ty] -> [%t ty] -> unit] ) 698 | in 699 | getters @ [ setter ])) 700 | in 701 | let create_fun = create_fun ~ty_name ~tps ~portable ~loc labdecs in 702 | let simple_create_fun = simple_create_fun ~ty_name ~tps ~portable ~loc labdecs in 703 | let fields_module = 704 | if String.equal ty_name "t" then "Fields" else "Fields_of_" ^ ty_name 705 | in 706 | let iter = iter_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 707 | let fold = fold_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 708 | let fold_right = fold_right_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 709 | let map = map_fun ~ty_name ~tps ~portable ~loc labdecs in 710 | let map_poly = map_poly ~private_ ~ty_name ~tps ~portable ~loc labdecs in 711 | let and_f = bool_fun "for_all" ~private_ ~ty_name ~tps ~portable ~loc labdecs in 712 | let or_f = bool_fun "exists" ~private_ ~ty_name ~tps ~portable ~loc labdecs in 713 | let to_list = to_list_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 714 | let direct_iter = direct_iter_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 715 | let direct_fold = direct_fold_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs in 716 | let direct_fold_right = 717 | direct_fold_right_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs 718 | in 719 | let direct_map = direct_map_fun ~ty_name ~tps ~portable ~loc labdecs in 720 | let direct_and_f = 721 | direct_bool_fun "for_all" ~private_ ~ty_name ~tps ~portable ~loc labdecs 722 | in 723 | let direct_or_f = 724 | direct_bool_fun "exists" ~private_ ~ty_name ~tps ~portable ~loc labdecs 725 | in 726 | let direct_to_list = 727 | direct_to_list_fun ~private_ ~ty_name ~tps ~portable ~loc labdecs 728 | in 729 | let set_all_mutable_fields = 730 | set_all_mutable_fields ~ty_name ~tps ~portable ~loc ~gen_zero_alloc_attrs labdecs 731 | in 732 | List.concat 733 | [ getters_and_setters 734 | ; [ ( Per_field Names 735 | , A.sig_item ~loc ~portable ~univars:tps "names" [%type: string list] ) 736 | ] 737 | ; fields 738 | ; [ Iterator Fold, fold; Iterator Fold_right, fold_right ] 739 | ; (match private_ with 740 | (* The ['perm] phantom type prohibits first-class fields from mutating or 741 | creating private records, so we can expose them (and fold, etc.). 742 | 743 | However, we still can't expose functions that explicitly create private 744 | records. *) 745 | | Private -> [] 746 | | Public -> 747 | [ Iterator Make_creator, create_fun 748 | ; Iterator Create, simple_create_fun 749 | ; Iterator Map, map 750 | ]) 751 | ; [ Iterator Iter, iter 752 | ; Iterator For_all, and_f 753 | ; Iterator Exists, or_f 754 | ; Iterator To_list, to_list 755 | ; Iterator Map_poly, map_poly 756 | ; Direct_iterator Iter, direct_iter 757 | ; Direct_iterator Fold, direct_fold 758 | ; Direct_iterator For_all, direct_and_f 759 | ; Direct_iterator Exists, direct_or_f 760 | ; Direct_iterator To_list, direct_to_list 761 | ; Direct_iterator Fold_right, direct_fold_right 762 | ] 763 | ; (match private_ with 764 | | Private -> [] 765 | | Public -> 766 | [ Direct_iterator Map, direct_map 767 | ; Direct_iterator Set_all_mutable_fields, set_all_mutable_fields 768 | ]) 769 | ] 770 | |> assemble 771 | ~loc 772 | ~selection 773 | ~fields_module 774 | ~make_module:A.sigitems_mod 775 | ~make_error:(fun error -> 776 | psig_extension ~loc (Location.Error.to_extension error) []) 777 | ;; 778 | 779 | let fields_of_td (td : type_declaration) ~selection : signature_item list = 780 | let { ptype_name = { txt = ty_name; loc } 781 | ; ptype_private = private_ 782 | ; ptype_params 783 | ; ptype_kind 784 | ; _ 785 | } 786 | = 787 | td 788 | in 789 | let tps = List.map ptype_params ~f:(fun (tp, _variance) -> tp) in 790 | match ptype_kind with 791 | | Ptype_record labdecs -> 792 | check_no_collision labdecs; 793 | let gen_zero_alloc_attrs = not (has_fields_no_zero_alloc_attr td) in 794 | let portable = not (has_fields_nonportable_attr td) in 795 | record 796 | ~private_ 797 | ~ty_name 798 | ~tps 799 | ~portable 800 | ~loc 801 | ~selection 802 | ~gen_zero_alloc_attrs 803 | labdecs 804 | | _ -> [] 805 | ;; 806 | 807 | let generate ~ctxt (rec_flag, tds) selection = 808 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 809 | match selection with 810 | | Error error -> [ psig_extension ~loc (Location.Error.to_extension error) [] ] 811 | | Ok selection -> 812 | let tds = List.map tds ~f:name_type_params_in_td in 813 | check_at_least_one_record ~loc rec_flag tds; 814 | List.concat_map tds ~f:(fields_of_td ~selection) 815 | ;; 816 | end 817 | 818 | module Gen_struct = struct 819 | let gen_fields 820 | ~private_ 821 | ~portable 822 | ~loc 823 | ~gen_zero_alloc_attrs 824 | (labdecs : label_declaration list) 825 | = 826 | let rec_id = 827 | match labdecs with 828 | | [] -> assert false 829 | | [ _ ] -> None 830 | | _ :: _ :: _ -> Some [%expr _r__] 831 | in 832 | let conv_field labdec = 833 | let { pld_name = { txt = name; loc }; pld_type = field_ty; pld_mutable = m; _ } = 834 | labdec 835 | in 836 | let field_ty = strip_attributes#core_type field_ty in 837 | let zero_alloc_attr = 838 | (* structs don't need to specify the arity since any function fields will appear 839 | as a single arg *) 840 | A.zero_alloc_attr ~arity:None ~loc 841 | in 842 | let getters = 843 | let attrs = 844 | Option.some_if gen_zero_alloc_attrs zero_alloc_attr |> Option.to_list 845 | in 846 | let getter_code suffix wrap_arrow wrap_body = 847 | A.str_item 848 | ~portable 849 | ~attrs 850 | ~loc 851 | (name ^ suffix) 852 | (wrap_arrow 853 | [%pat? _r__] 854 | (wrap_body (pexp_field ~loc [%expr _r__] (Located.lident ~loc name)))) 855 | in 856 | [ ( Selector.Per_field Getters 857 | , getter_code "" (fun a b -> [%expr fun [%p a] -> [%e b]]) Fn.id ) 858 | ; ( Selector.Per_field Local_getters 859 | , getter_code 860 | "__local" 861 | (fun a b -> [%expr fun [%p a] -> [%e b]]) 862 | (if is_global_field labdec then Fn.id else fun b -> [%expr [%e b]]) ) 863 | ] 864 | in 865 | let setter, setter_field = 866 | match m, private_ with 867 | | Mutable, Private -> 868 | ( [] 869 | , [%expr 870 | Some (fun _ _ -> failwith "invalid call to a setter of a private type")] ) 871 | | Mutable, Public -> 872 | let setter = 873 | let attrs = 874 | (* Setters are zero-alloc even for packed float records, so we don't need to 875 | check whether this looks like an array of all-floats. *) 876 | Option.some_if gen_zero_alloc_attrs zero_alloc_attr |> Option.to_list 877 | in 878 | ( Selector.Per_field Setters 879 | , A.str_item 880 | ~portable 881 | ~attrs 882 | ~loc 883 | ("set_" ^ name) 884 | [%expr 885 | fun _r__ v__ -> 886 | [%e 887 | pexp_setfield 888 | ~loc 889 | [%expr _r__] 890 | (Located.lident ~loc name) 891 | [%expr v__]]] ) 892 | in 893 | let setter_field = [%expr Some [%e evar ~loc ("set_" ^ name)]] in 894 | [ setter ], setter_field 895 | | Immutable, _ -> [], [%expr None] 896 | in 897 | let field = 898 | let e = pexp_record ~loc [ Located.lident ~loc name, evar ~loc "v__" ] rec_id in 899 | let fset = 900 | match private_ with 901 | | Private -> 902 | [%expr fun _ _ -> failwith "Invalid call to an fsetter of a private type"] 903 | | Public -> [%expr fun _r__ v__ -> [%e e]] 904 | in 905 | let perm = perm ~loc private_ in 906 | let annot = [%type: ([%t perm], _, [%t field_ty]) Fieldslib.Field.t_with_perm] in 907 | let body = 908 | [%expr 909 | Fieldslib.Field.Field 910 | { Fieldslib.Field.For_generated_code.force_variance = 911 | (fun (_ : [%t perm]) -> ()) 912 | ; name = [%e estring ~loc name] 913 | ; getter = [%e evar ~loc name] 914 | ; setter = [%e setter_field] 915 | ; fset = [%e fset] 916 | }] 917 | in 918 | ( Selector.Per_field Fields 919 | , A.str_item ~portable ~loc name (pexp_constraint ~loc body (Some annot) []) ) 920 | in 921 | getters @ setter, field 922 | in 923 | let xss, ys = List.unzip (List.rev (List.map labdecs ~f:conv_field)) in 924 | List.concat xss, ys 925 | ;; 926 | 927 | let label_arg ?label ?(modes = []) ~loc name = 928 | let l = 929 | match label with 930 | | None -> name 931 | | Some n -> n 932 | in 933 | Labelled l, Create.with_modes ~loc ~modes (pvar ~loc name) 934 | ;; 935 | 936 | let label_arg_fun ?modes ~loc name = label_arg ?modes ~label:name ~loc (name ^ "_fun__") 937 | let nontail ~loc e = [%expr [%e e] [@nontail]] 938 | 939 | let creation_fun ~loc ~portable _record_name labdecs = 940 | let names = Inspect.field_names labdecs in 941 | let f = 942 | let body_record = 943 | Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) 944 | in 945 | let body = 946 | List.fold_right names ~init:[%expr [%e body_record]] ~f:(fun field_name acc -> 947 | pexp_let 948 | ~loc 949 | Nonrecursive 950 | [ value_binding 951 | ~loc 952 | ~pat:(pvar ~loc field_name) 953 | ~expr:[%expr [%e evar ~loc (field_name ^ "_gen__")] acc__] 954 | ~modes:[] 955 | ] 956 | acc) 957 | in 958 | Create.lambda ~loc [ Nolabel, [%pat? acc__] ] body 959 | in 960 | let patterns = List.map names ~f:(label_arg_fun ~loc) in 961 | let body0 = [%expr [%e f], compile_acc__] in 962 | let body = 963 | List.fold_right names ~init:body0 ~f:(fun field_name acc -> 964 | pexp_let 965 | ~loc 966 | Nonrecursive 967 | [ value_binding 968 | ~loc 969 | ~pat: 970 | (ppat_tuple 971 | ~loc 972 | [ None, pvar ~loc (field_name ^ "_gen__") 973 | ; None, [%pat? compile_acc__] 974 | ] 975 | Closed) 976 | ~expr: 977 | [%expr 978 | [%e evar ~loc (field_name ^ "_fun__")] 979 | [%e evar ~loc field_name] 980 | compile_acc__] 981 | ~modes:[] 982 | ] 983 | acc) 984 | in 985 | let f = 986 | body 987 | |> Create.lambda ~loc [ Nolabel, [%pat? compile_acc__] ] 988 | |> Create.lambda ~loc patterns 989 | in 990 | A.str_item ~portable ~loc "make_creator" f 991 | ;; 992 | 993 | let simple_creation_fun ~loc ~portable _record_name labdecs = 994 | let names = Inspect.field_names labdecs in 995 | let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in 996 | let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in 997 | let f = Create.lambda ~loc patterns f in 998 | A.str_item ~portable ~loc "create" f 999 | ;; 1000 | 1001 | let fold_fun ~loc ~portable labdecs = 1002 | let names = Inspect.field_names labdecs in 1003 | let field_fold acc_expr field_name = 1004 | [%expr 1005 | [%e evar ~loc (field_name ^ "_fun__")] [%e acc_expr] [%e evar ~loc field_name]] 1006 | in 1007 | let body = List.fold_left names ~init:[%expr init__] ~f:field_fold in 1008 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1009 | let init = label_arg ~label:"init" ~loc "init__" in 1010 | let lambda = Create.lambda ~loc (init :: patterns) (nontail ~loc body) in 1011 | A.str_item ~portable ~loc "fold" lambda 1012 | ;; 1013 | 1014 | let direct_fold_fun ~loc ~portable labdecs = 1015 | let names = Inspect.field_names labdecs in 1016 | let field_fold acc_expr field_name = 1017 | [%expr 1018 | [%e evar ~loc (field_name ^ "_fun__")] 1019 | [%e acc_expr] 1020 | [%e evar ~loc field_name] 1021 | record__ 1022 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] 1023 | in 1024 | let body = List.fold_left names ~init:[%expr init__] ~f:field_fold in 1025 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1026 | let init = label_arg ~label:"init" ~loc "init__" in 1027 | let lambda = 1028 | Create.lambda 1029 | ~loc 1030 | ((Nolabel, [%pat? record__]) :: init :: patterns) 1031 | (nontail ~loc body) 1032 | in 1033 | A.str_item ~portable ~loc "fold" lambda 1034 | ;; 1035 | 1036 | let fold_right_fun ~loc ~portable labdecs = 1037 | let names = Inspect.field_names labdecs in 1038 | let field_fold_right field_name acc_expr = 1039 | [%expr 1040 | [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] [%e acc_expr]] 1041 | in 1042 | let body = List.fold_right names ~f:field_fold_right ~init:[%expr init__] in 1043 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1044 | let init = label_arg ~label:"init" ~loc "init__" in 1045 | let lambda = Create.lambda ~loc (patterns @ [ init ]) (nontail ~loc body) in 1046 | A.str_item ~portable ~loc "fold_right" lambda 1047 | ;; 1048 | 1049 | let direct_fold_right_fun ~loc ~portable labdecs = 1050 | let names = Inspect.field_names labdecs in 1051 | let field_fold_right field_name acc_expr = 1052 | [%expr 1053 | [%e evar ~loc (field_name ^ "_fun__")] 1054 | [%e evar ~loc field_name] 1055 | record__ 1056 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)] 1057 | [%e acc_expr]] 1058 | in 1059 | let body = List.fold_right names ~f:field_fold_right ~init:[%expr init__] in 1060 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1061 | let init = label_arg ~label:"init" ~loc "init__" in 1062 | let lambda = 1063 | Create.lambda 1064 | ~loc 1065 | (((Nolabel, [%pat? record__]) :: patterns) @ [ init ]) 1066 | (nontail ~loc body) 1067 | in 1068 | A.str_item ~portable ~loc "fold_right" lambda 1069 | ;; 1070 | 1071 | let binop list ~default ~loc ~op = 1072 | match List.rev list with 1073 | | [] -> default 1074 | | last :: prev -> 1075 | List.fold_left ~init:last ~f:(fun acc expr -> eapply ~loc op [ expr; acc ]) prev 1076 | ;; 1077 | 1078 | let and_ ~loc exprs = binop exprs ~default:(ebool ~loc true) ~loc ~op:[%expr ( && )] 1079 | let or_ ~loc exprs = binop exprs ~default:(ebool ~loc false) ~loc ~op:[%expr ( || )] 1080 | 1081 | let and_fun ~loc ~portable labdecs = 1082 | let names = Inspect.field_names labdecs in 1083 | let body = 1084 | List.map names ~f:(fun field_name -> 1085 | [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]]) 1086 | |> and_ ~loc 1087 | in 1088 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1089 | let lambda = Create.lambda ~loc patterns (nontail ~loc body) in 1090 | A.str_item ~portable ~loc "for_all" lambda 1091 | ;; 1092 | 1093 | let direct_and_fun ~loc ~portable labdecs = 1094 | let names = Inspect.field_names labdecs in 1095 | let body = 1096 | List.map names ~f:(fun field_name -> 1097 | [%expr 1098 | [%e evar ~loc (field_name ^ "_fun__")] 1099 | [%e evar ~loc field_name] 1100 | record__ 1101 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]]) 1102 | |> and_ ~loc 1103 | in 1104 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1105 | let lambda = 1106 | Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) (nontail ~loc body) 1107 | in 1108 | A.str_item ~portable ~loc "for_all" lambda 1109 | ;; 1110 | 1111 | let or_fun ~loc ~portable labdecs = 1112 | let names = Inspect.field_names labdecs in 1113 | let body = 1114 | List.map names ~f:(fun field_name -> 1115 | [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]]) 1116 | |> or_ ~loc 1117 | in 1118 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1119 | let lambda = Create.lambda ~loc patterns (nontail ~loc body) in 1120 | A.str_item ~portable ~loc "exists" lambda 1121 | ;; 1122 | 1123 | let direct_or_fun ~loc ~portable labdecs = 1124 | let names = Inspect.field_names labdecs in 1125 | let body = 1126 | List.map names ~f:(fun field_name -> 1127 | [%expr 1128 | [%e evar ~loc (field_name ^ "_fun__")] 1129 | [%e evar ~loc field_name] 1130 | record__ 1131 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]]) 1132 | |> or_ ~loc 1133 | in 1134 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1135 | let lambda = 1136 | Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) (nontail ~loc body) 1137 | in 1138 | A.str_item ~portable ~loc "exists" lambda 1139 | ;; 1140 | 1141 | let iter_fun ~loc ~portable labdecs = 1142 | let names = Inspect.field_names labdecs in 1143 | let iter_field field_name = 1144 | [%expr ([%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] : unit)] 1145 | in 1146 | let body = List.map names ~f:iter_field |> esequence ~loc in 1147 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1148 | let lambda = Create.lambda ~loc patterns body in 1149 | A.str_item ~portable ~loc "iter" lambda 1150 | ;; 1151 | 1152 | let direct_iter_fun ~loc ~portable labdecs = 1153 | let names = Inspect.field_names labdecs in 1154 | let iter_field field_name = 1155 | [%expr 1156 | [%e evar ~loc (field_name ^ "_fun__")] 1157 | [%e evar ~loc field_name] 1158 | record__ 1159 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] 1160 | in 1161 | let body = List.map names ~f:iter_field |> esequence ~loc in 1162 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1163 | let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in 1164 | A.str_item ~portable ~loc "iter" lambda 1165 | ;; 1166 | 1167 | let map_fun ~loc ~portable labdecs = 1168 | let names = Inspect.field_names labdecs in 1169 | let body = 1170 | Create.record 1171 | ~loc 1172 | (List.map names ~f:(fun field_name -> 1173 | let e = 1174 | [%expr [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name]] 1175 | in 1176 | field_name, e)) 1177 | in 1178 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1179 | let lambda = Create.lambda ~loc patterns body in 1180 | A.str_item ~portable ~loc "map" lambda 1181 | ;; 1182 | 1183 | let direct_map_fun ~loc ~portable labdecs = 1184 | let names = Inspect.field_names labdecs in 1185 | let body = 1186 | Create.record 1187 | ~loc 1188 | (List.map names ~f:(fun field_name -> 1189 | let e = 1190 | [%expr 1191 | [%e evar ~loc (field_name ^ "_fun__")] 1192 | [%e evar ~loc field_name] 1193 | record__ 1194 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)]] 1195 | in 1196 | field_name, e)) 1197 | in 1198 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1199 | let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in 1200 | A.str_item ~portable ~loc "map" lambda 1201 | ;; 1202 | 1203 | let to_list_fun ~loc ~portable labdecs = 1204 | let names = Inspect.field_names labdecs in 1205 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1206 | let fold field_name tail = 1207 | [%expr 1208 | [%e evar ~loc (field_name ^ "_fun__")] [%e evar ~loc field_name] :: [%e tail]] 1209 | in 1210 | let body = List.fold_right names ~init:[%expr []] ~f:fold in 1211 | let lambda = Create.lambda ~loc patterns body in 1212 | A.str_item ~portable ~loc "to_list" lambda 1213 | ;; 1214 | 1215 | let direct_to_list_fun ~loc ~portable labdecs = 1216 | let names = Inspect.field_names labdecs in 1217 | let patterns = List.map names ~f:(label_arg_fun ~loc ~modes:Modes.local) in 1218 | let fold field_name tail = 1219 | [%expr 1220 | [%e evar ~loc (field_name ^ "_fun__")] 1221 | [%e evar ~loc field_name] 1222 | record__ 1223 | [%e pexp_field ~loc [%expr record__] (Located.lident ~loc field_name)] 1224 | :: [%e tail]] 1225 | in 1226 | let body = List.fold_right names ~init:[%expr []] ~f:fold in 1227 | let lambda = Create.lambda ~loc ((Nolabel, [%pat? record__]) :: patterns) body in 1228 | A.str_item ~portable ~loc "to_list" lambda 1229 | ;; 1230 | 1231 | let map_poly ~loc ~portable labdecs = 1232 | let names = Inspect.field_names labdecs in 1233 | let fold name acc = 1234 | [%expr record__.Fieldslib.Field.f [%e evar ~loc name] :: [%e acc]] 1235 | in 1236 | let body = List.fold_right names ~init:[%expr []] ~f:fold in 1237 | A.str_item 1238 | ~portable 1239 | ~loc 1240 | "map_poly" 1241 | (pexp_fun 1242 | ~loc 1243 | Nolabel 1244 | None 1245 | (Create.with_modes ~loc ~modes:Modes.local [%pat? record__]) 1246 | body) 1247 | ;; 1248 | 1249 | let sequence_ ~loc xs = esequence ~loc xs 1250 | 1251 | let set_all_mutable_fields ~loc ~gen_zero_alloc_attrs ~portable labdecs = 1252 | let record_name = "_record__" in 1253 | let body = 1254 | let exprs = 1255 | List.fold_right labdecs ~init:[] ~f:(fun labdec acc -> 1256 | match labdec.pld_mutable with 1257 | | Immutable -> acc 1258 | | Mutable -> 1259 | let field_name = labdec.pld_name.txt in 1260 | pexp_setfield 1261 | ~loc 1262 | (evar ~loc record_name) 1263 | (Located.lident ~loc field_name) 1264 | (evar ~loc field_name) 1265 | :: acc) 1266 | in 1267 | (* As of 2019-06-25, flambda generates extra mov instructions when calling 1268 | [Fields.Direct.set_all_mutable_fields] on a top-level record. 1269 | [Stdlib.Sys.opaque_identity] causes flambda to generate the correct assembly here. 1270 | *) 1271 | [%expr 1272 | let [%p pvar ~loc record_name] = 1273 | Fieldslib.Field.For_generated_code.opaque_identity [%e evar ~loc record_name] 1274 | in 1275 | [%e sequence_ ~loc exprs]] 1276 | in 1277 | let function_ = 1278 | List.fold_right labdecs ~init:body ~f:(fun labdec acc -> 1279 | match labdec.pld_mutable with 1280 | | Immutable -> acc 1281 | | Mutable -> 1282 | let field_name = labdec.pld_name.txt in 1283 | pexp_fun ~loc (Labelled field_name) None (pvar ~loc field_name) acc) 1284 | in 1285 | let body = 1286 | pexp_fun 1287 | ~loc 1288 | Nolabel 1289 | None 1290 | (Create.with_modes ~loc ~modes:Modes.local (pvar ~loc record_name)) 1291 | function_ 1292 | in 1293 | let attrs = 1294 | let zero_alloc_attr = 1295 | Option.some_if gen_zero_alloc_attrs (A.zero_alloc_attr ~arity:None ~loc) 1296 | |> Option.to_list 1297 | in 1298 | A.inline_always_attr ~loc :: zero_alloc_attr 1299 | in 1300 | A.str_item ~portable ~attrs ~loc "set_all_mutable_fields" body 1301 | ;; 1302 | 1303 | let record 1304 | ~private_ 1305 | ~record_name 1306 | ~loc 1307 | ~portable 1308 | ~selection 1309 | ~gen_zero_alloc_attrs 1310 | (labdecs : label_declaration list) 1311 | : structure 1312 | = 1313 | let getter_and_setters, fields = 1314 | gen_fields ~private_ ~loc ~gen_zero_alloc_attrs ~portable labdecs 1315 | in 1316 | let create = creation_fun ~loc ~portable record_name labdecs in 1317 | let simple_create = simple_creation_fun ~loc ~portable record_name labdecs in 1318 | let names = List.map (Inspect.field_names labdecs) ~f:(estring ~loc) in 1319 | let fields_module = 1320 | if String.equal record_name "t" then "Fields" else "Fields_of_" ^ record_name 1321 | in 1322 | let iter = iter_fun ~loc ~portable labdecs in 1323 | let fold = fold_fun ~loc ~portable labdecs in 1324 | let fold_right = fold_right_fun ~loc ~portable labdecs in 1325 | let map = map_fun ~loc ~portable labdecs in 1326 | let map_poly = map_poly ~loc ~portable labdecs in 1327 | let andf = and_fun ~loc ~portable labdecs in 1328 | let orf = or_fun ~loc ~portable labdecs in 1329 | let to_list = to_list_fun ~loc ~portable labdecs in 1330 | let direct_iter = direct_iter_fun ~loc ~portable labdecs in 1331 | let direct_fold = direct_fold_fun ~loc ~portable labdecs in 1332 | let direct_fold_right = direct_fold_right_fun ~loc ~portable labdecs in 1333 | let direct_andf = direct_and_fun ~loc ~portable labdecs in 1334 | let direct_orf = direct_or_fun ~loc ~portable labdecs in 1335 | let direct_map = direct_map_fun ~loc ~portable labdecs in 1336 | let direct_to_list = direct_to_list_fun ~loc ~portable labdecs in 1337 | let set_all_mutable_fields = 1338 | set_all_mutable_fields ~loc ~gen_zero_alloc_attrs ~portable labdecs 1339 | in 1340 | List.concat 1341 | [ getter_and_setters 1342 | ; [ Per_field Names, A.str_item ~portable ~loc "names" (elist ~loc names) ] 1343 | ; fields 1344 | ; (match private_ with 1345 | | Private -> [] 1346 | | Public -> 1347 | [ Iterator Make_creator, create 1348 | ; Iterator Create, simple_create 1349 | ; Iterator Map, map 1350 | ]) 1351 | ; [ Iterator Iter, iter 1352 | ; Iterator Fold, fold 1353 | ; Iterator Map_poly, map_poly 1354 | ; Iterator For_all, andf 1355 | ; Iterator Exists, orf 1356 | ; Iterator To_list, to_list 1357 | ; Iterator Fold_right, fold_right 1358 | ; Direct_iterator Iter, direct_iter 1359 | ; Direct_iterator Fold, direct_fold 1360 | ; Direct_iterator For_all, direct_andf 1361 | ; Direct_iterator Exists, direct_orf 1362 | ; Direct_iterator To_list, direct_to_list 1363 | ; Direct_iterator Fold_right, direct_fold_right 1364 | ] 1365 | ; (match private_ with 1366 | | Private -> [] 1367 | | Public -> 1368 | [ Direct_iterator Map, direct_map 1369 | ; Direct_iterator Set_all_mutable_fields, set_all_mutable_fields 1370 | ]) 1371 | ] 1372 | |> assemble 1373 | ~loc 1374 | ~selection 1375 | ~fields_module 1376 | ~make_module:A.mod_ 1377 | ~make_error:(fun error -> 1378 | pstr_extension ~loc (Location.Error.to_extension error) []) 1379 | ;; 1380 | 1381 | let fields_of_td (td : type_declaration) ~selection : structure = 1382 | let { ptype_name = { txt = record_name; loc } 1383 | ; ptype_private = private_ 1384 | ; ptype_kind 1385 | ; _ 1386 | } 1387 | = 1388 | td 1389 | in 1390 | match ptype_kind with 1391 | | Ptype_record labdecs -> 1392 | check_no_collision labdecs; 1393 | let gen_zero_alloc_attrs = not (has_fields_no_zero_alloc_attr td) in 1394 | let portable = not (has_fields_nonportable_attr td) in 1395 | record 1396 | ~private_ 1397 | ~record_name 1398 | ~loc 1399 | ~portable 1400 | ~selection 1401 | ~gen_zero_alloc_attrs 1402 | labdecs 1403 | | _ -> [] 1404 | ;; 1405 | 1406 | let generate ~ctxt (rec_flag, tds) selection = 1407 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 1408 | match selection with 1409 | | Error error -> [ pstr_extension ~loc (Location.Error.to_extension error) [] ] 1410 | | Ok selection -> 1411 | let tds = List.map tds ~f:name_type_params_in_td in 1412 | check_at_least_one_record ~loc rec_flag tds; 1413 | List.concat_map tds ~f:(fields_of_td ~selection) 1414 | ;; 1415 | end 1416 | 1417 | let fields = 1418 | Deriving.add 1419 | "fields" 1420 | ~str_type_decl:(Selector.generator Gen_struct.generate ~add_dependencies:true) 1421 | ~sig_type_decl:(Selector.generator Gen_sig.generate ~add_dependencies:false) 1422 | ;; 1423 | -------------------------------------------------------------------------------- /src/ppx_fields_conv.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | module Selector = Selector 4 | 5 | val fields : Deriving.t 6 | -------------------------------------------------------------------------------- /src/selector.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | let selectors_are_mandatory = ref false 5 | 6 | module Per_field = struct 7 | type t = 8 | | Local_getters 9 | | Getters 10 | | Setters 11 | | Names 12 | | Fields 13 | 14 | let all = [ Local_getters; Getters; Setters; Names; Fields ] 15 | 16 | let to_flag_name = function 17 | | Local_getters -> "local_getters" 18 | | Getters -> "getters" 19 | | Setters -> "setters" 20 | | Names -> "names" 21 | | Fields -> "fields" 22 | ;; 23 | 24 | let to_expression t ~loc = 25 | match t with 26 | | Local_getters -> [%expr Local_getters] 27 | | Getters -> [%expr Getters] 28 | | Setters -> [%expr Setters] 29 | | Names -> [%expr Names] 30 | | Fields -> [%expr Fields] 31 | ;; 32 | end 33 | 34 | module Iterator = struct 35 | type t = 36 | | Create 37 | | Make_creator 38 | | Exists 39 | | Fold 40 | | Fold_right 41 | | For_all 42 | | Iter 43 | | Map 44 | | To_list 45 | | Map_poly 46 | 47 | let all = 48 | [ Create 49 | ; Make_creator 50 | ; Exists 51 | ; Fold 52 | ; Fold_right 53 | ; For_all 54 | ; Iter 55 | ; Map 56 | ; To_list 57 | ; Map_poly 58 | ] 59 | ;; 60 | 61 | let to_variable_name = function 62 | | Create -> "create" 63 | | Make_creator -> "make_creator" 64 | | Exists -> "exists" 65 | | Fold -> "fold" 66 | | Fold_right -> "fold_right" 67 | | For_all -> "for_all" 68 | | Iter -> "iter" 69 | | Map -> "map" 70 | | To_list -> "to_list" 71 | | Map_poly -> "map_poly" 72 | ;; 73 | 74 | let to_expression t ~loc = 75 | match t with 76 | | Create -> [%expr Create] 77 | | Make_creator -> [%expr Make_creator] 78 | | Exists -> [%expr Exists] 79 | | Fold -> [%expr Fold] 80 | | Fold_right -> [%expr Fold_right] 81 | | For_all -> [%expr For_all] 82 | | Iter -> [%expr Iter] 83 | | Map -> [%expr Map] 84 | | To_list -> [%expr To_list] 85 | | Map_poly -> [%expr Map_poly] 86 | ;; 87 | end 88 | 89 | module Direct_iterator = struct 90 | type t = 91 | | Exists 92 | | Fold 93 | | Fold_right 94 | | For_all 95 | | Iter 96 | | Map 97 | | To_list 98 | | Set_all_mutable_fields 99 | 100 | let all = 101 | [ Exists; Fold; Fold_right; For_all; Iter; Map; To_list; Set_all_mutable_fields ] 102 | ;; 103 | 104 | let to_variable_name = function 105 | | Exists -> "exists" 106 | | Fold -> "fold" 107 | | Fold_right -> "fold_right" 108 | | For_all -> "for_all" 109 | | Iter -> "iter" 110 | | Map -> "map" 111 | | To_list -> "to_list" 112 | | Set_all_mutable_fields -> "set_all_mutable_fields" 113 | ;; 114 | 115 | let to_expression t ~loc = 116 | match t with 117 | | Exists -> [%expr Exists] 118 | | Fold -> [%expr Fold] 119 | | Fold_right -> [%expr Fold_right] 120 | | For_all -> [%expr For_all] 121 | | Iter -> [%expr Iter] 122 | | Map -> [%expr Map] 123 | | To_list -> [%expr To_list] 124 | | Set_all_mutable_fields -> [%expr Set_all_mutable_fields] 125 | ;; 126 | end 127 | 128 | type t = 129 | | Per_field of Per_field.t 130 | | Iterator of Iterator.t 131 | | Direct_iterator of Direct_iterator.t 132 | 133 | let all = 134 | List.concat 135 | [ List.map Per_field.all ~f:(fun x -> Per_field x) 136 | ; List.map Iterator.all ~f:(fun x -> Iterator x) 137 | ; List.map Direct_iterator.all ~f:(fun x -> Direct_iterator x) 138 | ] 139 | ;; 140 | 141 | let to_string = function 142 | | Per_field x -> "~" ^ Per_field.to_flag_name x 143 | | Iterator x -> "~iterators:" ^ Iterator.to_variable_name x 144 | | Direct_iterator x -> "~direct_iterators:" ^ Direct_iterator.to_variable_name x 145 | ;; 146 | 147 | let of_string string = 148 | match List.find all ~f:(fun t -> String.equal string (to_string t)) with 149 | | Some t -> t 150 | | None -> raise_s (Atom (Printf.sprintf "unknown flag [%s]" string)) 151 | ;; 152 | 153 | include Sexpable.Of_stringable (struct 154 | type nonrec t = t 155 | 156 | let of_string = of_string 157 | let to_string = to_string 158 | end) 159 | 160 | let compare = (Poly.compare : t -> t -> int) 161 | let equal = (Poly.equal : t -> t -> bool) 162 | 163 | include (val Comparator.make ~compare ~sexp_of_t) 164 | 165 | let to_expression t ~loc = 166 | match t with 167 | | Per_field x -> 168 | [%expr Ppx_fields_conv.Selector.Per_field [%e Per_field.to_expression x ~loc]] 169 | | Iterator x -> 170 | [%expr Ppx_fields_conv.Selector.Iterator [%e Iterator.to_expression x ~loc]] 171 | | Direct_iterator x -> 172 | [%expr 173 | Ppx_fields_conv.Selector.Direct_iterator [%e Direct_iterator.to_expression x ~loc]] 174 | ;; 175 | 176 | let direct_dependencies = function 177 | | Per_field (Local_getters | Getters | Setters | Names) -> [] 178 | | Per_field Fields -> [ Per_field Getters; Per_field Setters ] 179 | | Iterator _ | Direct_iterator _ -> [ Per_field Fields ] 180 | ;; 181 | 182 | let rec with_dependencies selector = 183 | selector :: List.concat_map ~f:with_dependencies (direct_dependencies selector) 184 | ;; 185 | 186 | module type S = sig 187 | type t 188 | 189 | val all : t list 190 | val to_variable_name : t -> string 191 | end 192 | 193 | let select_id (type a) (module M : S with type t = a) ~arg_name ~f expr = 194 | match expr.pexp_desc with 195 | | Pexp_ident { loc; txt = Lident txt } -> 196 | (match List.find M.all ~f:(fun x -> String.equal txt (M.to_variable_name x)) with 197 | | Some x -> Ok (f x) 198 | | None -> 199 | Error 200 | ( loc 201 | , Printf.sprintf 202 | "[~%s] %s" 203 | arg_name 204 | (if String.equal txt arg_name 205 | then Printf.sprintf "requires an argument" 206 | else 207 | Printf.sprintf 208 | "does not accept [%s] as an argument, valid arguments are: %s" 209 | (Longident.name (Lident txt)) 210 | (String.concat 211 | ~sep:", " 212 | (List.map M.all ~f:(fun x -> 213 | Printf.sprintf "[%s]" (M.to_variable_name x))))) )) 214 | | _ -> Error (expr.pexp_loc, "expected a variable name") 215 | ;; 216 | 217 | let select_id_tuple m ~arg_name ~f expr = 218 | Result.bind 219 | (match 220 | Ppxlib_jane.Shim.Expression_desc.of_parsetree expr.pexp_desc ~loc:expr.pexp_loc 221 | with 222 | | Pexp_tuple labeled_exprs -> 223 | (match Ppxlib_jane.as_unlabeled_tuple labeled_exprs with 224 | | Some exprs -> Ok exprs 225 | | None -> Error [ expr.pexp_loc, "does not accept labeled tuples" ]) 226 | | Pexp_ident _ -> Ok [ expr ] 227 | | _ -> 228 | Error [ expr.pexp_loc, "expected a variable name or a tuple of variable names" ]) 229 | ~f:(fun exprs -> 230 | List.map exprs ~f:(select_id m ~arg_name ~f) |> Result.combine_errors) 231 | ;; 232 | 233 | let select_iterators = 234 | select_id_tuple ~arg_name:"iterators" ~f:(fun x -> Iterator x) (module Iterator) 235 | ;; 236 | 237 | let select_direct_iterators = 238 | select_id_tuple 239 | ~arg_name:"direct_iterators" 240 | ~f:(fun x -> Direct_iterator x) 241 | (module Direct_iterator) 242 | ;; 243 | 244 | let select_fold_right expr = 245 | Error 246 | [ ( expr.pexp_loc 247 | , "[~fold_right] is no longer supported; use [~iterators:fold_right] and/or \ 248 | [~direct_iterators:fold_right]" ) 249 | ] 250 | ;; 251 | 252 | let select_one x expr = 253 | match expr.pexp_desc with 254 | | Pexp_ident { txt = Lident txt; _ } when String.equal txt (Per_field.to_flag_name x) -> 255 | Ok [ Per_field x ] 256 | | _ -> 257 | Error 258 | [ ( expr.pexp_loc 259 | , Printf.sprintf 260 | "expected no explicit argument to [~%s]" 261 | (Per_field.to_flag_name x) ) 262 | ] 263 | ;; 264 | 265 | let select_getters = select_one Getters 266 | let select_local_getters = select_one Local_getters 267 | let select_setters = select_one Setters 268 | let select_names = select_one Names 269 | let select_fields = select_one Fields 270 | 271 | let default_selectors = 272 | List.filter all ~f:(function 273 | | Iterator Fold_right | Direct_iterator Fold_right -> false 274 | | _ -> true) 275 | ;; 276 | 277 | let selection list ~add_dependencies = 278 | let list = 279 | if add_dependencies then List.concat_map list ~f:with_dependencies else list 280 | in 281 | Set.Using_comparator.of_list ~comparator list 282 | ;; 283 | 284 | let error_of_alists ~loc alists = 285 | match 286 | List.map (List.concat alists) ~f:(fun (loc, message) -> 287 | loc, "deriving fields: " ^ message) 288 | with 289 | | [ (loc, message) ] -> Location.Error.make ~loc message ~sub:[] 290 | | sub -> Location.Error.make ~loc "deriving fields: multiple syntax errors" ~sub 291 | ;; 292 | 293 | let docs_url = 294 | "https://github.com/janestreet/ppx_fields_conv/blob/master/README.md#selecting-definitions" 295 | ;; 296 | 297 | let no_definitions_error_message = 298 | String.concat 299 | ~sep:" " 300 | [ "No definitions selected." 301 | ; "See the \"Selecting definitions\" section of the documentation:" 302 | ; docs_url 303 | ] 304 | ;; 305 | 306 | let generator ~add_dependencies f = 307 | Deriving.Generator.V2.make 308 | (let open Deriving.Args in 309 | empty 310 | +> arg "fold_right" (map1 __ ~f:select_fold_right) 311 | +> arg "getters" (map1 __ ~f:select_getters) 312 | +> arg "local_getters" (map1 __ ~f:select_local_getters) 313 | +> arg "setters" (map1 __ ~f:select_setters) 314 | +> arg "names" (map1 __ ~f:select_names) 315 | +> arg "fields" (map1 __ ~f:select_fields) 316 | +> arg "iterators" (map1 __ ~f:select_iterators) 317 | +> arg "direct_iterators" (map1 __ ~f:select_direct_iterators)) 318 | (fun ~ctxt ast arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 -> 319 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 320 | let results = 321 | match List.filter_opt [ arg1; arg2; arg3; arg4; arg5; arg6; arg7; arg8 ] with 322 | | [] -> 323 | [ (if !selectors_are_mandatory 324 | then Error [ loc, no_definitions_error_message ] 325 | else Ok default_selectors) 326 | ] 327 | | _ :: _ as non_empty -> non_empty 328 | in 329 | let selection = 330 | Result.combine_errors results 331 | |> Result.map ~f:List.concat 332 | |> Result.map ~f:(selection ~add_dependencies) 333 | |> Result.map_error ~f:(error_of_alists ~loc) 334 | in 335 | f ~ctxt ast selection) 336 | ;; 337 | 338 | let deriving_clause ~loc list = 339 | let open Ast_builder.Default in 340 | if List.is_empty list 341 | then None 342 | else ( 343 | let per_field, iterators, direct_iterators = 344 | List.dedup_and_sort list ~compare 345 | |> List.partition3_map ~f:(function 346 | | Per_field x -> `Fst x 347 | | Iterator x -> `Snd x 348 | | Direct_iterator x -> `Trd x) 349 | in 350 | let per_field = 351 | List.map per_field ~f:(fun x -> 352 | let s = Per_field.to_flag_name x in 353 | Labelled s, evar ~loc s) 354 | in 355 | let iterators = 356 | if List.is_empty iterators 357 | then [] 358 | else 359 | [ ( Labelled "iterators" 360 | , pexp_tuple 361 | ~loc 362 | (List.map iterators ~f:(fun f -> evar ~loc (Iterator.to_variable_name f))) ) 363 | ] 364 | in 365 | let direct_iterators = 366 | if List.is_empty direct_iterators 367 | then [] 368 | else 369 | [ ( Labelled "direct_iterators" 370 | , pexp_tuple 371 | ~loc 372 | (List.map direct_iterators ~f:(fun f -> 373 | evar ~loc (Direct_iterator.to_variable_name f))) ) 374 | ] 375 | in 376 | Some 377 | (pexp_apply 378 | ~loc 379 | [%expr fields] 380 | (List.concat [ per_field; iterators; direct_iterators ]))) 381 | ;; 382 | 383 | let () = 384 | Driver.add_arg 385 | "-deriving-fields-require-selectors" 386 | (Bool (( := ) selectors_are_mandatory)) 387 | ~doc: 388 | (Printf.sprintf 389 | "BOOL Error if no selectors in [[@@deriving fields]] (default: %b)" 390 | !selectors_are_mandatory) 391 | ;; 392 | -------------------------------------------------------------------------------- /src/selector.mli: -------------------------------------------------------------------------------- 1 | open! Base 2 | open Ppxlib 3 | 4 | module Per_field : sig 5 | type t = 6 | | Local_getters 7 | | Getters 8 | | Setters 9 | | Names 10 | | Fields 11 | end 12 | 13 | module Iterator : sig 14 | type t = 15 | | Create 16 | | Make_creator 17 | | Exists 18 | | Fold 19 | | Fold_right 20 | | For_all 21 | | Iter 22 | | Map 23 | | To_list 24 | | Map_poly 25 | end 26 | 27 | module Direct_iterator : sig 28 | type t = 29 | | Exists 30 | | Fold 31 | | Fold_right 32 | | For_all 33 | | Iter 34 | | Map 35 | | To_list 36 | | Set_all_mutable_fields 37 | end 38 | 39 | type t = 40 | | Per_field of Per_field.t 41 | | Iterator of Iterator.t 42 | | Direct_iterator of Direct_iterator.t 43 | 44 | val all : t list 45 | val compare : t -> t -> int 46 | val equal : t -> t -> bool 47 | val sexp_of_t : t -> Sexp.t 48 | val t_of_sexp : Sexp.t -> t 49 | 50 | include Comparator.S with type t := t 51 | 52 | (** Creates a [@@deriving] generator that determines a set of selectors from optional 53 | flags, or reports a syntax error. *) 54 | val generator 55 | : add_dependencies:bool 56 | (** in the .ml we must define dependencies; in the mli we don't need to export them *) 57 | -> (ctxt:Expansion_context.Deriver.t 58 | -> 'input 59 | -> ((t, comparator_witness) Set.t, Location.Error.t) Result.t 60 | -> 'output) 61 | -> ('output, 'input) Deriving.Generator.t 62 | 63 | (** Creates a [fields] expression for a [@@deriving] attribute, with appropriate arguments 64 | to define the given selectors. Returns [None] if no selectors are chosen. *) 65 | val deriving_clause : loc:location -> t list -> expression option 66 | 67 | (** Produces an expression that reconstructs [t] at runtime. *) 68 | val to_expression : t -> loc:location -> expression 69 | -------------------------------------------------------------------------------- /test/arguments.mlt: -------------------------------------------------------------------------------- 1 | #print_line_numbers true 2 | 3 | type t = 4 | { x : int 5 | ; y : int 6 | } 7 | [@@deriving fields ~fold_right] 8 | 9 | [%%expect 10 | {| 11 | Line 7, characters 20-30: 12 | Error: deriving fields: [~fold_right] is no longer supported; use 13 | [~iterators:fold_right] and/or [~direct_iterators:fold_right] 14 | |}] 15 | 16 | type t = 17 | { x : int 18 | ; y : int 19 | } 20 | [@@deriving fields ~iterators:(1, 2) ~direct_iterators:3] 21 | 22 | [%%expect 23 | {| 24 | Line 16, characters 0-94: 25 | Error: deriving fields: multiple syntax errors 26 | Line 20, characters 31-32: 27 | deriving fields: expected a variable name 28 | Line 20, characters 34-35: 29 | deriving fields: expected a variable name 30 | Line 20, characters 55-56: 31 | deriving fields: expected a variable name or a tuple of variable names 32 | |}] 33 | 34 | type t = 35 | { x : int 36 | ; y : int 37 | } 38 | [@@deriving fields ~iterators:x ~direct_iterators:(y, z)] 39 | 40 | [%%expect 41 | {| 42 | Line 34, characters 0-94: 43 | Error: deriving fields: multiple syntax errors 44 | Line 38, characters 30-31: 45 | deriving fields: [~iterators] does not accept [x] as an argument, valid 46 | arguments are: [create], [make_creator], [exists], [fold], [fold_right], 47 | [for_all], [iter], [map], [to_list], [map_poly] 48 | Line 38, characters 51-52: 49 | deriving fields: [~direct_iterators] does not accept [y] as an argument, 50 | valid arguments are: [exists], [fold], [fold_right], [for_all], [iter], 51 | [map], [to_list], [set_all_mutable_fields] 52 | Line 38, characters 54-55: 53 | deriving fields: [~direct_iterators] does not accept [z] as an argument, 54 | valid arguments are: [exists], [fold], [fold_right], [for_all], [iter], 55 | [map], [to_list], [set_all_mutable_fields] 56 | |}] 57 | 58 | type t = 59 | { x : int 60 | ; y : int 61 | } 62 | [@@deriving fields ~getters:true ~setters:false] 63 | 64 | [%%expect 65 | {| 66 | Line 58, characters 0-85: 67 | Error: deriving fields: multiple syntax errors 68 | Line 62, characters 28-32: 69 | deriving fields: expected no explicit argument to [~getters] 70 | Line 62, characters 42-47: 71 | deriving fields: expected no explicit argument to [~setters] 72 | |}] 73 | 74 | module _ = struct 75 | type t = 76 | { x : int 77 | ; y : int 78 | } 79 | [@@deriving fields ~getters] 80 | 81 | let _ = Fields.iter 82 | end 83 | 84 | [%%expect 85 | {| 86 | Line 81, characters 10-21: 87 | Error: Unbound module Fields 88 | |}] 89 | 90 | module _ (M : sig 91 | type t = 92 | { x : int 93 | ; y : int 94 | } 95 | [@@deriving fields ~getters] 96 | end) = 97 | struct 98 | let _ = M.Fields.iter 99 | end 100 | 101 | [%%expect 102 | {| 103 | Line 98, characters 10-23: 104 | Error: Unbound module M.Fields 105 | |}] 106 | 107 | type t = 108 | { x : int 109 | ; y : int 110 | } 111 | [@@deriving fields ~setters] 112 | 113 | [%%expect 114 | {| 115 | Line 107, characters 5-6: 116 | Error: [@deriving fields]: no definitions generated 117 | |}] 118 | -------------------------------------------------------------------------------- /test/deriving_clause.mlt: -------------------------------------------------------------------------------- 1 | (** This file tests the argument parsing/constructing functions from [Selectors]. *) 2 | 3 | open Base 4 | open Ppxlib 5 | open Ast_builder.Default 6 | module Selector = Ppx_fields_conv.Selector 7 | 8 | (** We define a ppx to simulate our argument-parsing. 9 | 10 | {[ 11 | type t [@@deriving fields_clause ......] 12 | ]} 13 | 14 | produces 15 | 16 | {[ 17 | let selectors = [ ...... ] 18 | ]} 19 | 20 | where [] are the selectors that [@@deriving fields] would use if given the 21 | same [.] *) 22 | 23 | let () = 24 | let str_type_decl = 25 | Selector.generator ~add_dependencies:false (fun ~ctxt _ selectors -> 26 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 27 | let selectors_expr = 28 | match selectors with 29 | | Error error -> Location.Error.raise error 30 | | Ok set -> 31 | List.map (Set.to_list set) ~f:(Selector.to_expression ~loc) |> elist ~loc 32 | in 33 | [%str let (selectors : Selector.t list) = [%e selectors_expr]]) 34 | in 35 | Deriving.add "fields_clause" ~str_type_decl |> Deriving.ignore 36 | ;; 37 | 38 | [%%expect {| |}] 39 | 40 | (** We write an extension to test our argument-construction. 41 | 42 | {[ 43 | expect := [ ...... ] 44 | ;; 45 | 46 | [%%test_fields_clause] 47 | ]} 48 | 49 | produces 50 | 51 | {[ 52 | expect := [ ...... ] 53 | ;; 54 | 55 | type t [@@deriving fields_clause ......] 56 | ;; 57 | 58 | test "fields_clause ... ..." selectors 59 | ]} 60 | 61 | This tests that the selectors list in [expect] round-trips through 62 | [[@@deriving fields_clause]] to produce the same selectors at the end. *) 63 | 64 | let expect = ref [] 65 | 66 | let test deriving actual = 67 | let expect = List.sort !expect ~compare:Selector.compare in 68 | if Poly.equal expect actual 69 | then 70 | Stdio.print_s 71 | (Sexp.message 72 | "Ok" 73 | [ "deriving", String.sexp_of_t deriving 74 | ; "selectors", List.sexp_of_t Selector.sexp_of_t actual 75 | ]) 76 | else 77 | Stdio.print_s 78 | (Sexp.message 79 | "Error" 80 | [ "deriving", String.sexp_of_t deriving 81 | ; "actual", List.sexp_of_t Selector.sexp_of_t actual 82 | ; "expect", List.sexp_of_t Selector.sexp_of_t expect 83 | ]) 84 | ;; 85 | 86 | let () = 87 | let extension = 88 | Extension.V3.declare_inline 89 | "test_fields_clause" 90 | Structure_item 91 | Ast_pattern.(pstr nil) 92 | (fun ~ctxt -> 93 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 94 | let loc = { loc with loc_ghost = true } in 95 | let fields = Selector.deriving_clause ~loc !expect |> Option.value_exn in 96 | let fields_clause = 97 | match fields with 98 | | [%expr fields] -> [%expr fields_clause] 99 | | { pexp_desc = Pexp_apply ([%expr fields], args); _ } -> 100 | pexp_apply ~loc [%expr fields_clause] args 101 | | _ -> assert false 102 | in 103 | let expr = estring ~loc (Pprintast.string_of_expression fields) in 104 | [%str 105 | type t [@@deriving [%e fields_clause]] 106 | 107 | let () = test [%e expr] selectors]) 108 | in 109 | Driver.register_transformation ~extensions:[ extension ] "test_fields_clause" 110 | ;; 111 | 112 | [%%expect {| |}] 113 | 114 | let () = expect := [ Per_field Fields ] 115 | 116 | [%%test_fields_clause] 117 | 118 | [%%expect 119 | {| 120 | (Ok (deriving "fields ~fields") (selectors (~fields))) 121 | |}] 122 | 123 | let () = expect := [ Iterator Create ] 124 | 125 | [%%test_fields_clause] 126 | 127 | [%%expect 128 | {| 129 | (Ok (deriving "fields ~iterators:create") (selectors (~iterators:create))) 130 | |}] 131 | 132 | let () = expect := [ Per_field Names; Direct_iterator Iter; Direct_iterator Fold_right ] 133 | 134 | [%%test_fields_clause] 135 | 136 | [%%expect 137 | {| 138 | (Ok (deriving "fields ~names ~direct_iterators:(fold_right, iter)") 139 | (selectors (~names ~direct_iterators:fold_right ~direct_iterators:iter))) 140 | |}] 141 | 142 | let () = expect := Selector.all 143 | 144 | [%%test_fields_clause] 145 | 146 | [%%expect 147 | {| 148 | (Ok 149 | (deriving 150 | "fields ~local_getters ~getters ~setters ~names ~fields\ 151 | \n ~iterators:(create, make_creator, exists, fold, fold_right, for_all, iter,\ 152 | \n map, to_list, map_poly)\ 153 | \n ~direct_iterators:(exists, fold, fold_right, for_all, iter, map, to_list,\ 154 | \n set_all_mutable_fields)") 155 | (selectors 156 | (~local_getters ~getters ~setters ~names ~fields ~iterators:create 157 | ~iterators:make_creator ~iterators:exists ~iterators:fold 158 | ~iterators:fold_right ~iterators:for_all ~iterators:iter ~iterators:map 159 | ~iterators:to_list ~iterators:map_poly ~direct_iterators:exists 160 | ~direct_iterators:fold ~direct_iterators:fold_right 161 | ~direct_iterators:for_all ~direct_iterators:iter ~direct_iterators:map 162 | ~direct_iterators:to_list ~direct_iterators:set_all_mutable_fields))) 163 | |}] 164 | -------------------------------------------------------------------------------- /test/deriving_inline_with_mli.ml: -------------------------------------------------------------------------------- 1 | include Deriving_inline_without_mli 2 | -------------------------------------------------------------------------------- /test/deriving_inline_with_mli.mli: -------------------------------------------------------------------------------- 1 | module One_thing : sig 2 | type t = 3 | { x : int 4 | ; mutable y : bool 5 | } 6 | [@@deriving_inline fields ~setters] 7 | 8 | include sig 9 | [@@@ocaml.warning "-32"] 10 | 11 | val set_y : t -> bool -> unit 12 | [@@zero_alloc 13 | custom_error_message 14 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 15 | [@@deriving fields] tries to make by default."] 16 | end 17 | [@@ocaml.doc "@inline"] 18 | 19 | [@@@end] 20 | end 21 | 22 | module Local_getters : sig 23 | type t = 24 | { w : string [@globalized] 25 | ; x : int 26 | ; mutable y : bool 27 | ; z : float 28 | } 29 | [@@deriving_inline fields ~local_getters] 30 | 31 | include sig 32 | [@@@ocaml.warning "-32"] 33 | 34 | val z__local : t -> float 35 | [@@zero_alloc 36 | arity 37 | 1 38 | custom_error_message 39 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 40 | [@@deriving fields] tries to make by default."] 41 | 42 | val y__local : t -> bool 43 | [@@zero_alloc 44 | arity 45 | 1 46 | custom_error_message 47 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 48 | [@@deriving fields] tries to make by default."] 49 | 50 | val x__local : t -> int 51 | [@@zero_alloc 52 | arity 53 | 1 54 | custom_error_message 55 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 56 | [@@deriving fields] tries to make by default."] 57 | 58 | val w__local : t -> string 59 | [@@zero_alloc 60 | arity 61 | 1 62 | custom_error_message 63 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 64 | [@@deriving fields] tries to make by default."] 65 | end 66 | [@@ocaml.doc "@inline"] 67 | 68 | [@@@end] 69 | end 70 | 71 | module Everything : sig 72 | type t = 73 | { x : int 74 | ; mutable y : bool 75 | ; z : float 76 | ; f : string -> string 77 | } 78 | [@@deriving equal] 79 | [@@deriving_inline 80 | fields 81 | ~getters 82 | ~setters 83 | ~names 84 | ~fields 85 | ~iterators: 86 | ( create 87 | , make_creator 88 | , exists 89 | , fold 90 | , fold_right 91 | , for_all 92 | , iter 93 | , map 94 | , to_list 95 | , map_poly ) 96 | ~direct_iterators: 97 | (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] 98 | 99 | include sig 100 | [@@@ocaml.warning "-32-60"] 101 | 102 | val f : t -> string -> string 103 | [@@zero_alloc 104 | arity 105 | 1 106 | custom_error_message 107 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 108 | [@@deriving fields] tries to make by default."] 109 | 110 | val z : t -> float 111 | [@@zero_alloc 112 | arity 113 | 1 114 | custom_error_message 115 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 116 | [@@deriving fields] tries to make by default."] 117 | 118 | val y : t -> bool 119 | [@@zero_alloc 120 | arity 121 | 1 122 | custom_error_message 123 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 124 | [@@deriving fields] tries to make by default."] 125 | 126 | val set_y : t -> bool -> unit 127 | [@@zero_alloc 128 | custom_error_message 129 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 130 | [@@deriving fields] tries to make by default."] 131 | 132 | val x : t -> int 133 | [@@zero_alloc 134 | arity 135 | 1 136 | custom_error_message 137 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 138 | [@@deriving fields] tries to make by default."] 139 | 140 | module Fields : sig 141 | val names : string list 142 | val f : (t, string -> string) Fieldslib.Field.t 143 | val z : (t, float) Fieldslib.Field.t 144 | val y : (t, bool) Fieldslib.Field.t 145 | val x : (t, int) Fieldslib.Field.t 146 | 147 | val fold 148 | : 'acc__0 'acc__1 'acc__2 'acc__3 'acc__4. 149 | init:'acc__0 150 | -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> 'acc__1) 151 | -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> 'acc__2) 152 | -> z:('acc__2 -> (t, float) Fieldslib.Field.t -> 'acc__3) 153 | -> f:('acc__3 -> (t, string -> string) Fieldslib.Field.t -> 'acc__4) 154 | -> 'acc__4 155 | 156 | val fold_right 157 | : 'acc__0 'acc__1 'acc__2 'acc__3 'acc__4. 158 | x:((t, int) Fieldslib.Field.t -> 'acc__3 -> 'acc__4) 159 | -> y:((t, bool) Fieldslib.Field.t -> 'acc__2 -> 'acc__3) 160 | -> z:((t, float) Fieldslib.Field.t -> 'acc__1 -> 'acc__2) 161 | -> f:((t, string -> string) Fieldslib.Field.t -> 'acc__0 -> 'acc__1) 162 | -> init:'acc__0 163 | -> 'acc__4 164 | 165 | val make_creator 166 | : 'input__ 'acc__0 'acc__1 'acc__2 'acc__3 'acc__4. 167 | x:((t, int) Fieldslib.Field.t -> 'acc__0 -> ('input__ -> int) * 'acc__1) 168 | -> y:((t, bool) Fieldslib.Field.t -> 'acc__1 -> ('input__ -> bool) * 'acc__2) 169 | -> z:((t, float) Fieldslib.Field.t -> 'acc__2 -> ('input__ -> float) * 'acc__3) 170 | -> f: 171 | ((t, string -> string) Fieldslib.Field.t 172 | -> 'acc__3 173 | -> ('input__ -> string -> string) * 'acc__4) 174 | -> 'acc__0 175 | -> ('input__ -> t) * 'acc__4 176 | 177 | val create : x:int -> y:bool -> z:float -> f:(string -> string) -> t 178 | 179 | val map 180 | : x:((t, int) Fieldslib.Field.t -> int) 181 | -> y:((t, bool) Fieldslib.Field.t -> bool) 182 | -> z:((t, float) Fieldslib.Field.t -> float) 183 | -> f:((t, string -> string) Fieldslib.Field.t -> string -> string) 184 | -> t 185 | 186 | val iter 187 | : x:((t, int) Fieldslib.Field.t -> unit) 188 | -> y:((t, bool) Fieldslib.Field.t -> unit) 189 | -> z:((t, float) Fieldslib.Field.t -> unit) 190 | -> f:((t, string -> string) Fieldslib.Field.t -> unit) 191 | -> unit 192 | 193 | val for_all 194 | : x:((t, int) Fieldslib.Field.t -> bool) 195 | -> y:((t, bool) Fieldslib.Field.t -> bool) 196 | -> z:((t, float) Fieldslib.Field.t -> bool) 197 | -> f:((t, string -> string) Fieldslib.Field.t -> bool) 198 | -> bool 199 | 200 | val exists 201 | : x:((t, int) Fieldslib.Field.t -> bool) 202 | -> y:((t, bool) Fieldslib.Field.t -> bool) 203 | -> z:((t, float) Fieldslib.Field.t -> bool) 204 | -> f:((t, string -> string) Fieldslib.Field.t -> bool) 205 | -> bool 206 | 207 | val to_list 208 | : 'elem__. 209 | x:((t, int) Fieldslib.Field.t -> 'elem__) 210 | -> y:((t, bool) Fieldslib.Field.t -> 'elem__) 211 | -> z:((t, float) Fieldslib.Field.t -> 'elem__) 212 | -> f:((t, string -> string) Fieldslib.Field.t -> 'elem__) 213 | -> 'elem__ list 214 | 215 | val map_poly 216 | : 'x0. 217 | ([< `Read | `Set_and_create ], t, 'x0) Fieldslib.Field.user -> 'x0 list 218 | 219 | module Direct : sig 220 | val iter 221 | : t 222 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> unit) 223 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> unit) 224 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> unit) 225 | -> f: 226 | ((t, string -> string) Fieldslib.Field.t 227 | -> t 228 | -> (string -> string) 229 | -> unit) 230 | -> unit 231 | 232 | val fold 233 | : 'acc__0 'acc__1 'acc__2 'acc__3 'acc__4. 234 | t 235 | -> init:'acc__0 236 | -> x:('acc__0 -> (t, int) Fieldslib.Field.t -> t -> int -> 'acc__1) 237 | -> y:('acc__1 -> (t, bool) Fieldslib.Field.t -> t -> bool -> 'acc__2) 238 | -> z:('acc__2 -> (t, float) Fieldslib.Field.t -> t -> float -> 'acc__3) 239 | -> f: 240 | ('acc__3 241 | -> (t, string -> string) Fieldslib.Field.t 242 | -> t 243 | -> (string -> string) 244 | -> 'acc__4) 245 | -> 'acc__4 246 | 247 | val for_all 248 | : t 249 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) 250 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) 251 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> bool) 252 | -> f: 253 | ((t, string -> string) Fieldslib.Field.t 254 | -> t 255 | -> (string -> string) 256 | -> bool) 257 | -> bool 258 | 259 | val exists 260 | : t 261 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> bool) 262 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) 263 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> bool) 264 | -> f: 265 | ((t, string -> string) Fieldslib.Field.t 266 | -> t 267 | -> (string -> string) 268 | -> bool) 269 | -> bool 270 | 271 | val to_list 272 | : 'elem__. 273 | t 274 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> 'elem__) 275 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> 'elem__) 276 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> 'elem__) 277 | -> f: 278 | ((t, string -> string) Fieldslib.Field.t 279 | -> t 280 | -> (string -> string) 281 | -> 'elem__) 282 | -> 'elem__ list 283 | 284 | val fold_right 285 | : 'acc__0 'acc__1 'acc__2 'acc__3 'acc__4. 286 | t 287 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> 'acc__3 -> 'acc__4) 288 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> 'acc__2 -> 'acc__3) 289 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> 'acc__1 -> 'acc__2) 290 | -> f: 291 | ((t, string -> string) Fieldslib.Field.t 292 | -> t 293 | -> (string -> string) 294 | -> 'acc__0 295 | -> 'acc__1) 296 | -> init:'acc__0 297 | -> 'acc__4 298 | 299 | val map 300 | : t 301 | -> x:((t, int) Fieldslib.Field.t -> t -> int -> int) 302 | -> y:((t, bool) Fieldslib.Field.t -> t -> bool -> bool) 303 | -> z:((t, float) Fieldslib.Field.t -> t -> float -> float) 304 | -> f: 305 | ((t, string -> string) Fieldslib.Field.t 306 | -> t 307 | -> (string -> string) 308 | -> string 309 | -> string) 310 | -> t 311 | 312 | val set_all_mutable_fields : t -> y:bool -> unit 313 | [@@zero_alloc 314 | custom_error_message 315 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees \ 316 | that [@@deriving fields] tries to make by default."] 317 | end 318 | end 319 | end 320 | [@@ocaml.doc "@inline"] 321 | 322 | [@@@end] 323 | end 324 | -------------------------------------------------------------------------------- /test/deriving_inline_without_mli.ml: -------------------------------------------------------------------------------- 1 | open Ppx_compare_lib.Builtin 2 | 3 | module One_thing = struct 4 | type t = 5 | { x : int 6 | ; mutable y : bool 7 | } 8 | [@@deriving_inline fields ~setters] 9 | 10 | let _ = fun (_ : t) -> () 11 | 12 | let set_y _r__ v__ = _r__.y <- v__ 13 | [@@zero_alloc 14 | custom_error_message 15 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 16 | [@@deriving fields] tries to make by default."] 17 | ;; 18 | 19 | let _ = set_y 20 | 21 | [@@@end] 22 | end 23 | 24 | module Local_getters = struct 25 | type t = 26 | { w : string [@globalized] 27 | ; x : int 28 | ; mutable y : bool 29 | ; z : float 30 | } 31 | [@@deriving_inline fields ~local_getters] 32 | 33 | let _ = fun (_ : t) -> () 34 | 35 | let z__local _r__ = _r__.z 36 | [@@zero_alloc 37 | custom_error_message 38 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 39 | [@@deriving fields] tries to make by default."] 40 | ;; 41 | 42 | let _ = z__local 43 | 44 | let y__local _r__ = _r__.y 45 | [@@zero_alloc 46 | custom_error_message 47 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 48 | [@@deriving fields] tries to make by default."] 49 | ;; 50 | 51 | let _ = y__local 52 | 53 | let x__local _r__ = _r__.x 54 | [@@zero_alloc 55 | custom_error_message 56 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 57 | [@@deriving fields] tries to make by default."] 58 | ;; 59 | 60 | let _ = x__local 61 | 62 | let w__local _r__ = _r__.w 63 | [@@zero_alloc 64 | custom_error_message 65 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 66 | [@@deriving fields] tries to make by default."] 67 | ;; 68 | 69 | let _ = w__local 70 | 71 | [@@@end] 72 | end 73 | 74 | module Everything = struct 75 | type t = 76 | { x : int 77 | ; mutable y : bool 78 | ; z : float 79 | ; f : (string -> string[@equal.ignore]) 80 | } 81 | [@@deriving equal] 82 | [@@deriving_inline 83 | fields 84 | ~getters 85 | ~setters 86 | ~names 87 | ~fields 88 | ~iterators: 89 | ( create 90 | , make_creator 91 | , exists 92 | , fold 93 | , fold_right 94 | , for_all 95 | , iter 96 | , map 97 | , to_list 98 | , map_poly ) 99 | ~direct_iterators: 100 | (exists, fold, fold_right, for_all, iter, map, to_list, set_all_mutable_fields)] 101 | 102 | include struct 103 | [@@@ocaml.warning "-60"] 104 | 105 | let _ = fun (_ : t) -> () 106 | 107 | let f _r__ = _r__.f 108 | [@@zero_alloc 109 | custom_error_message 110 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 111 | [@@deriving fields] tries to make by default."] 112 | ;; 113 | 114 | let _ = f 115 | 116 | let z _r__ = _r__.z 117 | [@@zero_alloc 118 | custom_error_message 119 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 120 | [@@deriving fields] tries to make by default."] 121 | ;; 122 | 123 | let _ = z 124 | 125 | let y _r__ = _r__.y 126 | [@@zero_alloc 127 | custom_error_message 128 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 129 | [@@deriving fields] tries to make by default."] 130 | ;; 131 | 132 | let _ = y 133 | 134 | let set_y _r__ v__ = _r__.y <- v__ 135 | [@@zero_alloc 136 | custom_error_message 137 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 138 | [@@deriving fields] tries to make by default."] 139 | ;; 140 | 141 | let _ = set_y 142 | 143 | let x _r__ = _r__.x 144 | [@@zero_alloc 145 | custom_error_message 146 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees that \ 147 | [@@deriving fields] tries to make by default."] 148 | ;; 149 | 150 | let _ = x 151 | 152 | module Fields = struct 153 | let names = [ "x"; "y"; "z"; "f" ] 154 | let _ = names 155 | 156 | let f = 157 | (Fieldslib.Field.Field 158 | { Fieldslib.Field.For_generated_code.force_variance = 159 | (fun (_ : [< `Read | `Set_and_create ]) -> ()) 160 | ; name = "f" 161 | ; getter = f 162 | ; setter = None 163 | ; fset = (fun _r__ v__ -> { _r__ with f = v__ }) 164 | } 165 | : ([< `Read | `Set_and_create ], _, string -> string) Fieldslib.Field.t_with_perm) 166 | ;; 167 | 168 | let _ = f 169 | 170 | let z = 171 | (Fieldslib.Field.Field 172 | { Fieldslib.Field.For_generated_code.force_variance = 173 | (fun (_ : [< `Read | `Set_and_create ]) -> ()) 174 | ; name = "z" 175 | ; getter = z 176 | ; setter = None 177 | ; fset = (fun _r__ v__ -> { _r__ with z = v__ }) 178 | } 179 | : ([< `Read | `Set_and_create ], _, float) Fieldslib.Field.t_with_perm) 180 | ;; 181 | 182 | let _ = z 183 | 184 | let y = 185 | (Fieldslib.Field.Field 186 | { Fieldslib.Field.For_generated_code.force_variance = 187 | (fun (_ : [< `Read | `Set_and_create ]) -> ()) 188 | ; name = "y" 189 | ; getter = y 190 | ; setter = Some set_y 191 | ; fset = (fun _r__ v__ -> { _r__ with y = v__ }) 192 | } 193 | : ([< `Read | `Set_and_create ], _, bool) Fieldslib.Field.t_with_perm) 194 | ;; 195 | 196 | let _ = y 197 | 198 | let x = 199 | (Fieldslib.Field.Field 200 | { Fieldslib.Field.For_generated_code.force_variance = 201 | (fun (_ : [< `Read | `Set_and_create ]) -> ()) 202 | ; name = "x" 203 | ; getter = x 204 | ; setter = None 205 | ; fset = (fun _r__ v__ -> { _r__ with x = v__ }) 206 | } 207 | : ([< `Read | `Set_and_create ], _, int) Fieldslib.Field.t_with_perm) 208 | ;; 209 | 210 | let _ = x 211 | 212 | let make_creator ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ compile_acc__ = 213 | let x_gen__, compile_acc__ = x_fun__ x compile_acc__ in 214 | let y_gen__, compile_acc__ = y_fun__ y compile_acc__ in 215 | let z_gen__, compile_acc__ = z_fun__ z compile_acc__ in 216 | let f_gen__, compile_acc__ = f_fun__ f compile_acc__ in 217 | ( (fun acc__ -> 218 | let x = x_gen__ acc__ in 219 | let y = y_gen__ acc__ in 220 | let z = z_gen__ acc__ in 221 | let f = f_gen__ acc__ in 222 | { x; y; z; f }) 223 | , compile_acc__ ) 224 | ;; 225 | 226 | let _ = make_creator 227 | let create ~x ~y ~z ~f = { x; y; z; f } 228 | let _ = create 229 | 230 | let map ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 231 | { x = x_fun__ x; y = y_fun__ y; z = z_fun__ z; f = f_fun__ f } 232 | ;; 233 | 234 | let _ = map 235 | 236 | let iter ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 237 | (x_fun__ x : unit); 238 | (y_fun__ y : unit); 239 | (z_fun__ z : unit); 240 | (f_fun__ f : unit) 241 | ;; 242 | 243 | let _ = iter 244 | 245 | let fold ~init:init__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 246 | f_fun__ (z_fun__ (y_fun__ (x_fun__ init__ x) y) z) f [@nontail] 247 | ;; 248 | 249 | let _ = fold 250 | 251 | let map_poly record__ = 252 | [ record__.Fieldslib.Field.f x 253 | ; record__.Fieldslib.Field.f y 254 | ; record__.Fieldslib.Field.f z 255 | ; record__.Fieldslib.Field.f f 256 | ] 257 | ;; 258 | 259 | let _ = map_poly 260 | 261 | let for_all ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 262 | (x_fun__ x && y_fun__ y && z_fun__ z && f_fun__ f) [@nontail] 263 | ;; 264 | 265 | let _ = for_all 266 | 267 | let exists ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 268 | (x_fun__ x || y_fun__ y || z_fun__ z || f_fun__ f) [@nontail] 269 | ;; 270 | 271 | let _ = exists 272 | 273 | let to_list ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 274 | [ x_fun__ x; y_fun__ y; z_fun__ z; f_fun__ f ] 275 | ;; 276 | 277 | let _ = to_list 278 | 279 | let fold_right ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ ~init:init__ = 280 | x_fun__ x (y_fun__ y (z_fun__ z (f_fun__ f init__))) [@nontail] 281 | ;; 282 | 283 | let _ = fold_right 284 | 285 | module Direct = struct 286 | let iter record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 287 | x_fun__ x record__ record__.x; 288 | y_fun__ y record__ record__.y; 289 | z_fun__ z record__ record__.z; 290 | f_fun__ f record__ record__.f 291 | ;; 292 | 293 | let _ = iter 294 | 295 | let fold record__ ~init:init__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 296 | f_fun__ 297 | (z_fun__ 298 | (y_fun__ (x_fun__ init__ x record__ record__.x) y record__ record__.y) 299 | z 300 | record__ 301 | record__.z) 302 | f 303 | record__ 304 | record__.f [@nontail] 305 | ;; 306 | 307 | let _ = fold 308 | 309 | let for_all record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 310 | (x_fun__ x record__ record__.x 311 | && y_fun__ y record__ record__.y 312 | && z_fun__ z record__ record__.z 313 | && f_fun__ f record__ record__.f) 314 | [@nontail] 315 | ;; 316 | 317 | let _ = for_all 318 | 319 | let exists record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 320 | (x_fun__ x record__ record__.x 321 | || y_fun__ y record__ record__.y 322 | || z_fun__ z record__ record__.z 323 | || f_fun__ f record__ record__.f) 324 | [@nontail] 325 | ;; 326 | 327 | let _ = exists 328 | 329 | let to_list record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 330 | [ x_fun__ x record__ record__.x 331 | ; y_fun__ y record__ record__.y 332 | ; z_fun__ z record__ record__.z 333 | ; f_fun__ f record__ record__.f 334 | ] 335 | ;; 336 | 337 | let _ = to_list 338 | 339 | let fold_right record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ ~init:init__ = 340 | x_fun__ 341 | x 342 | record__ 343 | record__.x 344 | (y_fun__ 345 | y 346 | record__ 347 | record__.y 348 | (z_fun__ z record__ record__.z (f_fun__ f record__ record__.f init__))) 349 | [@nontail] 350 | ;; 351 | 352 | let _ = fold_right 353 | 354 | let map record__ ~x:x_fun__ ~y:y_fun__ ~z:z_fun__ ~f:f_fun__ = 355 | { x = x_fun__ x record__ record__.x 356 | ; y = y_fun__ y record__ record__.y 357 | ; z = z_fun__ z record__ record__.z 358 | ; f = f_fun__ f record__ record__.f 359 | } 360 | ;; 361 | 362 | let _ = map 363 | 364 | let set_all_mutable_fields _record__ ~y = 365 | let _record__ = Fieldslib.Field.For_generated_code.opaque_identity _record__ in 366 | _record__.y <- y 367 | [@@inline always] 368 | [@@zero_alloc 369 | custom_error_message 370 | "Hint: add [@@fields.no_zero_alloc] to disable the zero-alloc guarantees \ 371 | that [@@deriving fields] tries to make by default."] 372 | ;; 373 | 374 | let _ = set_all_mutable_fields 375 | end 376 | end 377 | end [@@ocaml.doc "@inline"] 378 | 379 | [@@@end] 380 | end 381 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name fieldslib_test) 3 | (libraries base fieldslib ppx_fields_conv) 4 | (preprocess 5 | (pps ppx_compare ppx_fields_conv ppx_inline_test))) 6 | 7 | (rule 8 | (targets example_from_doc.ml) 9 | (deps ../README.md gen_test_from_doc.sh) 10 | (action 11 | (bash "./gen_test_from_doc.sh ../README.md > %{targets}"))) 12 | -------------------------------------------------------------------------------- /test/fields_test.ml: -------------------------------------------------------------------------------- 1 | module Simple : sig 2 | type t = 3 | { x : int 4 | ; w : int 5 | } 6 | [@@deriving 7 | fields 8 | ~iterators:(create, fold_right, for_all, exists, map, to_list, fold, iter) 9 | ~direct_iterators:(for_all, exists, map, to_list, fold, fold_right, iter)] 10 | end = struct 11 | type t = 12 | { x : int 13 | ; w : int 14 | } 15 | [@@deriving 16 | fields 17 | ~iterators:(create, fold_right, for_all, exists, map, to_list, fold, iter) 18 | ~direct_iterators:(for_all, exists, map, to_list, fold, fold_right, iter)] 19 | 20 | let%test _ = Fields.create ~x:2 ~w:4 = { x = 2; w = 4 } 21 | let all_even = { x = 2; w = 4 } 22 | let some_even = { x = 1; w = 4 } 23 | let none_even = { x = 1; w = 3 } 24 | let is_even t field = Fieldslib.Field.get field t mod 2 = 0 25 | let%test _ = Fields.for_all ~x:(is_even all_even) ~w:(is_even all_even) = true 26 | let%test _ = Fields.for_all ~x:(is_even some_even) ~w:(is_even some_even) = false 27 | let%test _ = Fields.exists ~x:(is_even some_even) ~w:(is_even some_even) = true 28 | let%test _ = Fields.exists ~x:(is_even none_even) ~w:(is_even none_even) = false 29 | 30 | let is_even field t n = 31 | assert (Fieldslib.Field.get field t = n); 32 | n mod 2 = 0 33 | ;; 34 | 35 | let%test _ = Fields.Direct.for_all all_even ~x:is_even ~w:is_even = true 36 | let%test _ = Fields.Direct.for_all some_even ~x:is_even ~w:is_even = false 37 | let%test _ = Fields.Direct.exists some_even ~x:is_even ~w:is_even = true 38 | let%test _ = Fields.Direct.exists none_even ~x:is_even ~w:is_even = false 39 | let t = { x = 1; w = 3 } 40 | let add_one t field = Fieldslib.Field.get field t + 1 41 | let%test _ = Fields.map ~x:(add_one t) ~w:(add_one t) = { x = 2; w = 4 } 42 | let%test _ = Fields.to_list ~x:(add_one t) ~w:(add_one t) = [ 2; 4 ] 43 | 44 | let add_one field t n = 45 | assert (Fieldslib.Field.get field t = n); 46 | n + 1 47 | ;; 48 | 49 | let%test _ = Fields.Direct.map t ~x:add_one ~w:add_one = { x = 2; w = 4 } 50 | let%test _ = Fields.Direct.to_list t ~x:add_one ~w:add_one = [ 2; 4 ] 51 | let fold_one t acc field = (Fieldslib.Field.get field t + 1) :: acc 52 | let%test _ = Fields.fold ~init:[] ~x:(fold_one t) ~w:(fold_one t) = [ 4; 2 ] 53 | let fold_one t field acc = (Fieldslib.Field.get field t + 1) :: acc 54 | let%test _ = Fields.fold_right ~x:(fold_one t) ~w:(fold_one t) ~init:[] = [ 2; 4 ] 55 | 56 | let fold_one acc field t n = 57 | assert (Fieldslib.Field.get field t = n); 58 | (n + 1) :: acc 59 | ;; 60 | 61 | let%test _ = Fields.Direct.fold t ~init:[] ~x:fold_one ~w:fold_one = [ 4; 2 ] 62 | 63 | let fold_one field t n acc = 64 | assert (Fieldslib.Field.get field t = n); 65 | (n + 1) :: acc 66 | ;; 67 | 68 | let%test _ = Fields.Direct.fold_right t ~x:fold_one ~w:fold_one ~init:[] = [ 2; 4 ] 69 | let iter_one t buf field = buf := (Fieldslib.Field.get field t + 1) :: !buf 70 | 71 | let%test _ = 72 | let buf = ref [] in 73 | Fields.iter ~x:(iter_one t buf) ~w:(iter_one t buf); 74 | !buf = [ 4; 2 ] 75 | ;; 76 | 77 | let iter_one buf field t n = 78 | assert (Fieldslib.Field.get field t = n); 79 | buf := (n + 1) :: !buf 80 | ;; 81 | 82 | let%test _ = 83 | let buf = ref [] in 84 | Fields.Direct.iter t ~x:(iter_one buf) ~w:(iter_one buf); 85 | !buf = [ 4; 2 ] 86 | ;; 87 | end 88 | 89 | module Rec = struct 90 | type a = { something1 : b } 91 | and b = A of a [@@deriving fields ~getters] 92 | 93 | let _ = something1 94 | end 95 | 96 | module Multiple_names = struct 97 | type a = { a : int } 98 | and b = { b : int } [@@deriving fields ~getters ~fields] 99 | 100 | let%test _ = b { b = 1 } = 1 101 | let%test _ = a { a = 1 } = 1 102 | let _ = Fields_of_a.a 103 | let _ = Fields_of_b.b 104 | let _ = (Fields_of_a.a : (_, _) Fieldslib.Field.t :> (_, _) Fieldslib.Field.readonly_t) 105 | end 106 | 107 | module Private : sig 108 | type t = private 109 | { a : int 110 | ; mutable b : int 111 | } 112 | [@@deriving fields ~fields ~iterators:(fold, map_poly)] 113 | end = struct 114 | type u = 115 | { a : int 116 | ; mutable b : int 117 | } 118 | 119 | type t = u = private 120 | { a : int 121 | ; mutable b : int 122 | } 123 | [@@deriving fields ~fields ~iterators:(fold, map_poly)] 124 | 125 | (* let _ = Fieldslib.Field.setter Fields.a *) 126 | end 127 | 128 | (* let _ = Fieldslib.Field.setter Private.Fields.a *) 129 | let _ = Private.Fields.fold 130 | let _ = Private.Fields.a 131 | let _ = Fieldslib.Field.name Private.Fields.a 132 | let (_ : Private.t -> int) = Fieldslib.Field.get Private.Fields.a 133 | 134 | let _ = 135 | Private.Fields.map_poly 136 | { Fieldslib.Field.f = 137 | (fun f -> 138 | let (_ : Private.t -> _) = Fieldslib.Field.get f in 139 | ()) 140 | } 141 | ;; 142 | 143 | module Warnings : sig 144 | (* could generate an unused warning but for crazy reasons, only 145 | when the type is private *) 146 | type t = private { foo : int } [@@deriving fields ~getters] 147 | 148 | val foo : string 149 | end = struct 150 | type t = { foo : int } [@@deriving fields ~getters] 151 | 152 | let foo = "a" 153 | end 154 | 155 | module Wildcard : sig 156 | type _ t = 157 | { x : int 158 | ; y : string 159 | } 160 | end = struct 161 | type _ t = 162 | { x : int 163 | ; y : string 164 | } 165 | [@@deriving fields ~getters] 166 | 167 | let _ = x 168 | let _ = y 169 | end 170 | 171 | module%test [@name "set_all_mutable_fields"] _ = struct 172 | module M : sig 173 | type 'a t = 174 | { mutable a : int 175 | ; b : string 176 | ; mutable c : 'a 177 | } 178 | [@@deriving fields ~direct_iterators:set_all_mutable_fields] 179 | end = struct 180 | type 'a t = 181 | { mutable a : int 182 | ; b : string 183 | ; mutable c : 'a 184 | } 185 | [@@deriving fields ~direct_iterators:set_all_mutable_fields] 186 | end 187 | 188 | open M 189 | 190 | let%test_unit _ = 191 | let t : _ t = { a = 0; b = ""; c = nan } in 192 | let final_t : _ t = { a = 12; b = t.b; c = 12. } in 193 | Fields.Direct.set_all_mutable_fields t ~a:final_t.a ~c:final_t.c; 194 | assert (t = final_t) 195 | ;; 196 | end 197 | 198 | (* Sometimes it's convenient for the type of the accumulator to change as you handle 199 | the individual fields. *) 200 | module M 201 | (F1 : sig 202 | type t = 203 | { a : int 204 | ; b : string 205 | ; c : bool 206 | } 207 | [@@deriving fields ~iterators:(create, fold) ~direct_iterators:fold] 208 | end) 209 | (F2 : sig 210 | type t = 211 | { a : int 212 | ; b : string 213 | } 214 | [@@deriving fields ~iterators:create] 215 | end) = 216 | struct 217 | let convert : F1.t -> F2.t = 218 | F1.Fields.Direct.fold 219 | ~init:F2.Fields.create 220 | ~a:(fun acc field x _ -> acc ~a:(Fieldslib.Field.get field x)) 221 | ~b:(fun acc field x _ -> acc ~b:(Fieldslib.Field.get field x)) 222 | ~c:(fun acc _field _x _ -> acc) 223 | ;; 224 | 225 | let construct () : F1.t = 226 | F1.Fields.fold 227 | ~init:F1.Fields.create 228 | ~a:(fun f _ -> f ~a:8) 229 | ~b:(fun f _ -> f ~b:"foo") 230 | ~c:(fun f _ -> f ~c:true) 231 | ;; 232 | end 233 | 234 | (* We expect no unused value, unused type, unused module warnings, as only a part of the 235 | generated code is used in normal circumstances. *) 236 | module Unused_warnings : sig end = struct 237 | [@@@ocaml.warning "+60"] 238 | 239 | type t = 240 | { a : int 241 | ; b : int 242 | } 243 | [@@deriving fields ~getters ~iterators:for_all ~direct_iterators:for_all] 244 | end 245 | -------------------------------------------------------------------------------- /test/fieldslib_test.ml: -------------------------------------------------------------------------------- 1 | module Deriving_inline_with_mli = Deriving_inline_with_mli 2 | module Deriving_inline_without_mli = Deriving_inline_without_mli 3 | module Example_from_doc = Example_from_doc 4 | module Fields_test = Fields_test 5 | module Selector_tests = Selector_tests 6 | module Zero_alloc_test = Zero_alloc_test 7 | -------------------------------------------------------------------------------- /test/gen_test_from_doc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e -o pipefail 4 | 5 | INPUT=$1 6 | 7 | function dump 8 | { 9 | local INDENT=$(printf "%*s" $1 "") 10 | local TAG=$2 11 | local BEGIN="^$" 12 | local END="^$" 13 | 14 | if [[ $3 = -remove-deriving ]]; then 15 | local REMOVE_DERIVING=';s/\[@@deriving.**\]//' 16 | else 17 | local REMOVE_DERIVING='' 18 | fi 19 | 20 | sed -nr "/$BEGIN/,/$END/p" $INPUT | \ 21 | sed -r "/^\`\`\`/d;/^