Skip to content

Commit c0d88e6

Browse files
pedrobslisboapedrobslisboa
committed
atdml: support <ocaml attr=...> on record fields
1 parent 7008fea commit c0d88e6

9 files changed

Lines changed: 349 additions & 33 deletions

File tree

‎CHANGES.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
4.1.1 (unreleased)
2+
23
------------------
34

45
* atdj: Top-level list aliases such as `type items = item list` are now
@@ -8,6 +9,9 @@
89
package-private constructor from `JSONArray`, `toJsonBuffer`, `toJson`,
910
and a public `value` field of type `ArrayList<T>`. List aliases used as
1011
record fields or sum-variant payloads are also handled correctly.
12+
* atdml: Add support for `<ocaml attr="...">` on record fields, variant constructors,
13+
and variant payload types to attach ppx attributes (e.g. `[@deriving.ord.ignore]`)
14+
1115

1216
4.1.0 (2026-04-11)
1317
------------------

‎atdgen/src/ocaml.ml‎

Lines changed: 71 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -167,11 +167,14 @@ let annot_schema_ocaml : Atd.Annot.schema_section =
167167
Type_expr, "validator";
168168
Type_expr, "wrap";
169169
Variant, "name";
170+
Variant, "attr";
171+
Type_expr, "attr";
170172
Cell, "default";
171173
Field, "default";
172174
Field, "mutable";
173175
Field, "name";
174176
Field, "repr";
177+
Field, "attr";
175178
]
176179
}
177180

@@ -398,6 +401,27 @@ let get_type_attrs an =
398401
~field:"attr"
399402
an
400403

404+
let get_field_attrs an =
405+
Atd.Annot.get_fields
406+
~parse:(fun s -> Some s)
407+
~sections:["ocaml"]
408+
~field:"attr"
409+
an
410+
411+
let get_variant_attrs an =
412+
Atd.Annot.get_fields
413+
~parse:(fun s -> Some s)
414+
~sections:["ocaml"]
415+
~field:"attr"
416+
an
417+
418+
let get_payload_attrs e =
419+
Atd.Annot.get_fields
420+
~parse:(fun s -> Some s)
421+
~sections:["ocaml"]
422+
~field:"attr"
423+
(Atd.Ast.annot_of_type_expr e)
424+
401425
(*
402426
OCaml syntax tree
403427
*)
@@ -413,9 +437,11 @@ type ocaml_expr =
413437

414438
and ocaml_variant =
415439
string * ocaml_expr option * Atd.Doc.doc option
440+
* string list (* cons attrs *) * string list (* payload attrs *)
416441

417442
and ocaml_field =
418443
(string * bool (* is mutable? *)) * ocaml_expr * Atd.Doc.doc option
444+
* string list (* attrs *)
419445

420446
(*
421447
OCaml type definition:
@@ -499,7 +525,13 @@ and map_variant ~kind target (x : variant) : ocaml_variant =
499525
"Inline records are not allowed in polymorphic variants (not valid in OCaml)"
500526
| _, Variant (loc, (s, an), o) ->
501527
let s = get_ocaml_cons target s an in
502-
(s, Option.map (map_expr target []) o, Atd.Doc.get_doc loc an)
528+
let cons_attrs = get_variant_attrs an in
529+
let payload_attrs = match o with
530+
| None -> []
531+
| Some e -> get_payload_attrs e
532+
in
533+
(s, Option.map (map_expr target []) o, Atd.Doc.get_doc loc an,
534+
cons_attrs, payload_attrs)
503535

504536
and map_field target ocaml_field_prefix (x : field) : ocaml_field =
505537
match x with
@@ -516,7 +548,9 @@ and map_field target ocaml_field_prefix (x : field) : ocaml_field =
516548
else sprintf "%s (*atd %s *)" ocaml_fname atd_fname
517549
in
518550
let is_mutable = get_ocaml_mutable target an in
519-
((fname, is_mutable), map_expr target [] x, Atd.Doc.get_doc loc an)
551+
let field_attrs = get_field_attrs an in
552+
((fname, is_mutable), map_expr target [] x, Atd.Doc.get_doc loc an,
553+
field_attrs)
520554

521555

522556
(* hack to deal with legacy behavior *)
@@ -683,7 +717,7 @@ and ocaml_of_variant_mapping x =
683717
Variant o -> o
684718
| _ -> assert false
685719
in
686-
(o.ocaml_cons, Option.map ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc)
720+
(o.ocaml_cons, Option.map ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc, [], [])
687721

688722
and ocaml_of_field_mapping x =
689723
let o =
@@ -692,7 +726,7 @@ and ocaml_of_field_mapping x =
692726
| _ -> assert false
693727
in
694728
let v = ocaml_of_expr_mapping x.f_value in
695-
((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc)
729+
((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc, [])
696730

697731

698732
(*
@@ -960,7 +994,7 @@ and format_type_expr x =
960994
and format_type_name name args =
961995
horizontal_sequence (prepend_type_args args [ make_atom name ])
962996

963-
and format_field ((s, is_mutable), t, doc) =
997+
and format_field ((s, is_mutable), t, doc, attrs) =
964998
let l =
965999
let l = [make_atom (s ^ ":")] in
9661000
if is_mutable then
@@ -973,22 +1007,49 @@ and format_field ((s, is_mutable), t, doc) =
9731007
format_type_expr t
9741008
)
9751009
in
976-
append_ocamldoc_comment field doc
1010+
let field_with_attrs =
1011+
match attrs with
1012+
| [] -> field
1013+
| _ ->
1014+
let attrs_str =
1015+
List.map (fun a -> sprintf "[@%s]" a) attrs |> String.concat ""
1016+
in
1017+
Label ((field, label), make_atom attrs_str)
1018+
in
1019+
append_ocamldoc_comment field_with_attrs doc
9771020

978-
and format_variant kind (s, o, doc) =
1021+
and format_variant kind (s, o, doc, cons_attrs, payload_attrs) =
9791022
let s = tick kind ^ s in
9801023
let cons = make_atom s in
1024+
let attrs_str attrs =
1025+
List.map (fun a -> sprintf "[@%s]" a) attrs |> String.concat ""
1026+
in
1027+
let format_payload t =
1028+
match payload_attrs with
1029+
| [] -> format_type_expr t
1030+
| _ ->
1031+
Easy_format.List (
1032+
("(", "", ")", shlist),
1033+
[format_type_expr t; make_atom (attrs_str payload_attrs)]
1034+
)
1035+
in
9811036
let variant =
9821037
match o with
983-
None -> cons
984-
| Some t ->
1038+
| None ->
1039+
if cons_attrs = [] then cons
1040+
else Label ((cons, label), make_atom (attrs_str cons_attrs))
1041+
| Some t ->
1042+
let with_payload =
9851043
Label (
9861044
(cons, label),
9871045
Label (
9881046
(make_atom "of", label),
989-
format_type_expr t
1047+
format_payload t
9901048
)
9911049
)
1050+
in
1051+
if cons_attrs = [] then with_payload
1052+
else Label ((with_payload, label), make_atom (attrs_str cons_attrs))
9921053
in
9931054
append_ocamldoc_comment variant doc
9941055

‎atdgen/test/test_ppx.atd‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,16 @@
11
type t <ocaml attr="deriving show,eq" attr="ocamlformat \"disable\""> = {
22
v: int;
3+
w: string <ocaml attr="compare.ignore">;
34
}
5+
6+
type status = [
7+
| Active <ocaml attr="deriving.ord.ignore">
8+
| Pending of int <ocaml attr="deriving.ord.ignore">
9+
| Inactive
10+
]
11+
12+
type poly_status = [
13+
| Active <ocaml attr="deriving.ord.ignore">
14+
| Pending of int <ocaml attr="deriving.ord.ignore">
15+
| Inactive
16+
] <ocaml repr="poly">

‎atdml/src/lib/Codegen.ml‎

Lines changed: 43 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,9 @@ let annot_schema_ocaml : Atd.Annot.schema_section = {
5555
Import, "name"; (* <ocaml name="..."> on an import: override OCaml alias *)
5656
Imported_type, "name"; (* <ocaml name="..."> on an imported type: override type name *)
5757
Variant, "name"; (* <ocaml name="..."> on a variant constructor *)
58+
Variant, "attr"; (* <ocaml attr="..."> on a variant constructor: append [@...] *)
59+
Type_expr, "attr"; (* <ocaml attr="..."> on a variant payload type: append [@...] *)
60+
Field, "attr"; (* <ocaml attr="..."> on a field: append [@...] *)
5861
Field, "default"; (* <ocaml default="..."> on a with-default field *)
5962
Field, "name"; (* <ocaml name="..."> on a field: not supported, warns *)
6063
]
@@ -210,6 +213,30 @@ let get_ocaml_attr an =
210213
~field:"attr"
211214
an
212215

216+
(* Get <ocaml attr="..."> for a field; value is placed inside [@...] *)
217+
let get_ocaml_field_attr an =
218+
Atd.Annot.get_opt_field
219+
~parse:(fun s -> Some s)
220+
~sections:["ocaml"]
221+
~field:"attr"
222+
an
223+
224+
(* Get <ocaml attr="..."> for a variant constructor; value is placed inside [@...] *)
225+
let get_ocaml_variant_attr an =
226+
Atd.Annot.get_opt_field
227+
~parse:(fun s -> Some s)
228+
~sections:["ocaml"]
229+
~field:"attr"
230+
an
231+
232+
(* Get <ocaml attr="..."> for a variant payload type expression; value is placed inside [@...] *)
233+
let get_ocaml_payload_attr e =
234+
Atd.Annot.get_opt_field
235+
~parse:(fun s -> Some s)
236+
~sections:["ocaml"]
237+
~field:"attr"
238+
(Atd.Ast.annot_of_type_expr e)
239+
213240
(* Get wrap-related annotations for a 'wrap' type expression.
214241
Supports:
215242
<ocaml module="M"> → uses M.t, M.wrap, M.unwrap
@@ -875,12 +902,21 @@ let gen_type_def ~is_mli env ({A.loc; name; param=params; annot=an; value=e; _}
875902
in
876903
let gen_case (loc, orig_name, an, opt_e) =
877904
let cons_name = vtr (get_ocaml_name orig_name an) in
905+
let cons_attr = match get_ocaml_variant_attr an with
906+
| None -> ""
907+
| Some attr -> sprintf " [@%s]" attr
908+
in
878909
match opt_e with
879910
| None ->
880-
with_inline_doc (sprintf "| %s%s" tick cons_name) loc an
911+
with_inline_doc (sprintf "| %s%s%s" tick cons_name cons_attr) loc an
881912
| Some e ->
913+
let payload_str =
914+
match get_ocaml_payload_attr e with
915+
| None -> type_expr_str env e
916+
| Some attr -> sprintf "(%s [@%s])" (type_expr_str env e) attr
917+
in
882918
with_inline_doc
883-
(sprintf "| %s%s of %s" tick cons_name (type_expr_str env e))
919+
(sprintf "| %s%s of %s%s" tick cons_name payload_str cons_attr)
884920
loc an
885921
in
886922
let hd =
@@ -917,8 +953,12 @@ let gen_type_def ~is_mli env ({A.loc; name; param=params; annot=an; value=e; _}
917953
B.Block
918954
(concat_map
919955
(fun (loc, (fname, _, an), e) ->
956+
let field_attr = match get_ocaml_field_attr an with
957+
| None -> ""
958+
| Some attr -> sprintf " [@%s]" attr
959+
in
920960
with_inline_doc
921-
(sprintf "%s: %s;" (pftr fname) (type_expr_str env e))
961+
(sprintf "%s: %s%s;" (pftr fname) (type_expr_str env e) field_attr)
922962
loc an)
923963
fields);
924964
B.Line "}";

‎atdml/tests/named-snapshots/attr‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
type point = {
44
x: float;
5-
y: float;
5+
y: float option [@option];
66
}
77
[@@deriving show]
88

@@ -191,7 +191,7 @@ end
191191

192192
type point = {
193193
x: float;
194-
y: float;
194+
y: float option [@option];
195195
}
196196
[@@deriving show]
197197

0 commit comments

Comments
 (0)