Skip to content

Commit 46c75fa

Browse files
pedrobslisboapedrobslisboa
committed
atdml: support <ocaml attr=...> on record fields, variant constructors, and payloads
1 parent 7008fea commit 46c75fa

6 files changed

Lines changed: 229 additions & 17 deletions

File tree

‎CHANGES.md‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,9 @@
88
package-private constructor from `JSONArray`, `toJsonBuffer`, `toJson`,
99
and a public `value` field of type `ArrayList<T>`. List aliases used as
1010
record fields or sum-variant payloads are also handled correctly.
11+
* atdml: Add support for `<ocaml attr="...">` on record fields, variant constructors,
12+
and variant payload types to attach ppx attributes (e.g. `[@deriving.ord.ignore]`)
13+
1114

1215
4.1.0 (2026-04-11)
1316
------------------
@@ -135,8 +138,9 @@
135138
(inline expressions); supported on sum types and records
136139
- `<json name="...">` to override JSON field or constructor names
137140
- `<ocaml name="...">` to rename variant constructors in OCaml
138-
- `<ocaml attr="...">` to attach ppx attributes (e.g. `[@@deriving show]`)
139-
to generated type definitions
141+
- `<ocaml attr="...">` to attach ppx attributes to generated type definitions
142+
(e.g. `[@@deriving show]`), individual record fields, variant constructors,
143+
or variant payload types (e.g. `[@compare.ignore]`)
140144
- `<ocaml private>` on any type definition forces `private` in the generated
141145
`.mli`; `<ocaml public>` on a primitive alias suppresses the default
142146
`private`, making the alias transparent to callers

‎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

‎atdml/tests/named-snapshots/variant_attr‎

Lines changed: 138 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,138 @@
1+
(* Auto-generated from "variant_attr.atd" by atdml. *)
2+
3+
type status =
4+
| Active [@deriving.ord.ignore]
5+
| Inactive
6+
| Pending of (int [@deriving.ord.ignore])
7+
8+
val status_of_yojson : Yojson.Safe.t -> status
9+
val yojson_of_status : status -> Yojson.Safe.t
10+
val status_of_json : string -> status
11+
val json_of_status : status -> string
12+
13+
module Status : sig
14+
type nonrec t = status
15+
val of_yojson : Yojson.Safe.t -> t
16+
val to_yojson : t -> Yojson.Safe.t
17+
val of_json : string -> t
18+
val to_json : t -> string
19+
end
20+
21+
--- ml ---
22+
(* Auto-generated from "variant_attr.atd" by atdml. *)
23+
[@@@ocaml.warning "-27-32-33-35-39"]
24+
25+
(* Inlined runtime — no external dependency needed. *)
26+
module Atdml_runtime = struct
27+
let bad_type expected_type x =
28+
Printf.ksprintf failwith "expected %s, got: %s"
29+
expected_type (Yojson.Safe.to_string x)
30+
31+
let bad_sum type_name x =
32+
Printf.ksprintf failwith "invalid variant for type '%s': %s"
33+
type_name (Yojson.Safe.to_string x)
34+
35+
let missing_field type_name field_name =
36+
Printf.ksprintf failwith "missing field '%s' in object of type '%s'"
37+
field_name type_name
38+
39+
let bool_of_yojson = function
40+
| `Bool b -> b
41+
| x -> bad_type "bool" x
42+
43+
let yojson_of_bool b = `Bool b
44+
45+
let int_of_yojson = function
46+
| `Int n -> n
47+
| x -> bad_type "int" x
48+
49+
let yojson_of_int n = `Int n
50+
51+
let float_of_yojson = function
52+
| `Float f -> f
53+
| `Int n -> Float.of_int n
54+
| x -> bad_type "float" x
55+
56+
let yojson_of_float f = `Float f
57+
58+
let string_of_yojson = function
59+
| `String s -> s
60+
| x -> bad_type "string" x
61+
62+
let yojson_of_string s = `String s
63+
64+
let unit_of_yojson = function
65+
| `Null -> ()
66+
| x -> bad_type "null" x
67+
68+
let yojson_of_unit () = `Null
69+
70+
let list_of_yojson f = function
71+
| `List xs -> List.map f xs
72+
| x -> bad_type "array" x
73+
74+
let yojson_of_list f xs = `List (List.map f xs)
75+
76+
let option_of_yojson f = function
77+
| `String "None" -> None
78+
| `List [`String "Some"; x] -> Some (f x)
79+
| x -> bad_type "option" x
80+
81+
let yojson_of_option f = function
82+
| None -> `String "None"
83+
| Some x -> `List [`String "Some"; f x]
84+
85+
let nullable_of_yojson f = function
86+
| `Null -> None
87+
| x -> Some (f x)
88+
89+
let yojson_of_nullable f = function
90+
| None -> `Null
91+
| Some x -> f x
92+
93+
(* Returns true iff the list has strictly more than [n] elements,
94+
without traversing past element n+1. *)
95+
let rec list_length_gt n = function
96+
| _ :: rest -> if n = 0 then true else list_length_gt (n - 1) rest
97+
| [] -> false
98+
99+
let assoc_of_yojson f = function
100+
| `Assoc pairs -> List.map (fun (k, v) -> (k, f v)) pairs
101+
| x -> bad_type "object" x
102+
103+
let yojson_of_assoc f xs =
104+
`Assoc (List.map (fun (k, v) -> (k, f v)) xs)
105+
end
106+
107+
type status =
108+
| Active [@deriving.ord.ignore]
109+
| Inactive
110+
| Pending of (int [@deriving.ord.ignore])
111+
112+
let status_of_yojson (x : Yojson.Safe.t) : status =
113+
match x with
114+
| `String "Active" -> Active
115+
| `String "Inactive" -> Inactive
116+
| `List [`String "Pending"; v] -> Pending (Atdml_runtime.int_of_yojson v)
117+
| _ -> Atdml_runtime.bad_sum "status" x
118+
119+
let yojson_of_status (x : status) : Yojson.Safe.t =
120+
match x with
121+
| Active -> `String "Active"
122+
| Inactive -> `String "Inactive"
123+
| Pending v -> `List [`String "Pending"; Atdml_runtime.yojson_of_int v]
124+
125+
let status_of_json s =
126+
status_of_yojson (Yojson.Safe.from_string s)
127+
128+
let json_of_status x =
129+
Yojson.Safe.to_string (yojson_of_status x)
130+
131+
module Status = struct
132+
type nonrec t = status
133+
let of_yojson = status_of_yojson
134+
let to_yojson = yojson_of_status
135+
let of_json = status_of_json
136+
let to_json = json_of_status
137+
end
138+

‎atdml/tests/test.ml‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -489,13 +489,23 @@ type shape = [
489489
~atd_src:{|
490490
type point <ocaml attr="deriving show"> = {
491491
x: float;
492-
y: float;
492+
y: float option <ocaml attr="option">;
493493
}
494494

495495
type points <ocaml attr="deriving show"> = point list
496496
|}
497497
;
498498

499+
test_codegen_snapshot "variant attr"
500+
~atd_src:{|
501+
type status = [
502+
| Active <ocaml attr="deriving.ord.ignore">
503+
| Inactive
504+
| Pending of int <ocaml attr="deriving.ord.ignore">
505+
]
506+
|}
507+
;
508+
499509
test_codegen_snapshot "doc"
500510
~atd_src:{|
501511
<doc text="Module-level documentation.">

‎doc/atdml-reference.rst‎

Lines changed: 29 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -419,34 +419,54 @@ Section ``ocaml``
419419
Field ``attr``
420420
""""""""""""""
421421

422-
Position: on a type definition, i.e. on the left-hand side just before the
423-
equal sign ``=``
422+
Position: on a type definition, a record field, a variant constructor, or a
423+
variant payload type expression
424424

425-
Values: the contents of a ppx annotation without the enclosing ``[@@`` and
426-
``]``
425+
Values: the contents of a ppx annotation without the enclosing brackets and
426+
``@`` sigils
427427

428-
Semantics: appends a ppx attribute to the generated OCaml type definition,
429-
in both the ``.mli`` and ``.ml`` files.
428+
Semantics:
430429

431-
Example:
430+
- On a **type definition** (left-hand side just before ``=``), appends a
431+
``[@@attr]`` attribute after the type definition in both the ``.mli`` and
432+
``.ml`` files.
433+
- On a **record field** (after the field type), appends a ``[@attr]``
434+
attribute to that field in the generated type definition.
435+
- On a **variant constructor** (after the constructor name), appends a
436+
``[@attr]`` attribute to that constructor.
437+
- On a **variant payload type** (after the ``of <type>``), wraps the payload
438+
in ``(<type> [@attr])``.
439+
440+
Examples:
432441

433442
.. code:: ocaml
434443
435444
type point <ocaml attr="deriving show, eq"> = {
436445
x: float;
437-
y: float;
446+
y: float <ocaml attr="compare.ignore">;
438447
}
439448
449+
type status = [
450+
| Active <ocaml attr="deriving.ord.ignore">
451+
| Pending of int <ocaml attr="deriving.ord.ignore">
452+
| Inactive
453+
]
454+
440455
translates to
441456

442457
.. code:: ocaml
443458
444459
type point = {
445460
x: float;
446-
y: float;
461+
y: float [@compare.ignore];
447462
}
448463
[@@deriving show, eq]
449464
465+
type status =
466+
| Active [@deriving.ord.ignore]
467+
| Pending of (int [@deriving.ord.ignore])
468+
| Inactive
469+
450470
This is useful for attaching ppx rewriters such as ``ppx_deriving`` or
451471
``ppx_yojson_conv`` to generated types. Note that the ppx library must be
452472
present in the build environment; atdml does not provide it.

0 commit comments

Comments
 (0)