diff --git a/CHANGES.md b/CHANGES.md index 2ffdebd8..68f12ae4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,5 @@ 4.1.1 (unreleased) + ------------------ * atdj: Top-level list aliases such as `type items = item list` are now @@ -8,6 +9,9 @@ package-private constructor from `JSONArray`, `toJsonBuffer`, `toJson`, and a public `value` field of type `ArrayList`. List aliases used as record fields or sum-variant payloads are also handled correctly. +* atdml: Add support for `` on record fields, variant constructors, + and variant payload types to attach ppx attributes (e.g. `[@deriving.ord.ignore]`) + 4.1.0 (2026-04-11) ------------------ diff --git a/atdgen/src/ocaml.ml b/atdgen/src/ocaml.ml index 4c262924..0c868f87 100644 --- a/atdgen/src/ocaml.ml +++ b/atdgen/src/ocaml.ml @@ -167,11 +167,14 @@ let annot_schema_ocaml : Atd.Annot.schema_section = Type_expr, "validator"; Type_expr, "wrap"; Variant, "name"; + Variant, "attr"; + Type_expr, "attr"; Cell, "default"; Field, "default"; Field, "mutable"; Field, "name"; Field, "repr"; + Field, "attr"; ] } @@ -398,6 +401,27 @@ let get_type_attrs an = ~field:"attr" an +let get_field_attrs an = + Atd.Annot.get_fields + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + an + +let get_variant_attrs an = + Atd.Annot.get_fields + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + an + +let get_payload_attrs e = + Atd.Annot.get_fields + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + (Atd.Ast.annot_of_type_expr e) + (* OCaml syntax tree *) @@ -413,9 +437,11 @@ type ocaml_expr = and ocaml_variant = string * ocaml_expr option * Atd.Doc.doc option + * string list (* cons attrs *) * string list (* payload attrs *) and ocaml_field = (string * bool (* is mutable? *)) * ocaml_expr * Atd.Doc.doc option + * string list (* attrs *) (* OCaml type definition: @@ -499,7 +525,13 @@ and map_variant ~kind target (x : variant) : ocaml_variant = "Inline records are not allowed in polymorphic variants (not valid in OCaml)" | _, Variant (loc, (s, an), o) -> let s = get_ocaml_cons target s an in - (s, Option.map (map_expr target []) o, Atd.Doc.get_doc loc an) + let cons_attrs = get_variant_attrs an in + let payload_attrs = match o with + | None -> [] + | Some e -> get_payload_attrs e + in + (s, Option.map (map_expr target []) o, Atd.Doc.get_doc loc an, + cons_attrs, payload_attrs) and map_field target ocaml_field_prefix (x : field) : ocaml_field = match x with @@ -516,7 +548,9 @@ and map_field target ocaml_field_prefix (x : field) : ocaml_field = else sprintf "%s (*atd %s *)" ocaml_fname atd_fname in let is_mutable = get_ocaml_mutable target an in - ((fname, is_mutable), map_expr target [] x, Atd.Doc.get_doc loc an) + let field_attrs = get_field_attrs an in + ((fname, is_mutable), map_expr target [] x, Atd.Doc.get_doc loc an, + field_attrs) (* hack to deal with legacy behavior *) @@ -683,7 +717,7 @@ and ocaml_of_variant_mapping x = Variant o -> o | _ -> assert false in - (o.ocaml_cons, Option.map ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc) + (o.ocaml_cons, Option.map ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc, [], []) and ocaml_of_field_mapping x = let o = @@ -692,7 +726,7 @@ and ocaml_of_field_mapping x = | _ -> assert false in let v = ocaml_of_expr_mapping x.f_value in - ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc) + ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc, []) (* @@ -960,7 +994,7 @@ and format_type_expr x = and format_type_name name args = horizontal_sequence (prepend_type_args args [ make_atom name ]) -and format_field ((s, is_mutable), t, doc) = +and format_field ((s, is_mutable), t, doc, attrs) = let l = let l = [make_atom (s ^ ":")] in if is_mutable then @@ -973,22 +1007,49 @@ and format_field ((s, is_mutable), t, doc) = format_type_expr t ) in - append_ocamldoc_comment field doc + let field_with_attrs = + match attrs with + | [] -> field + | _ -> + let attrs_str = + List.map (fun a -> sprintf "[@%s]" a) attrs |> String.concat "" + in + Label ((field, label), make_atom attrs_str) + in + append_ocamldoc_comment field_with_attrs doc -and format_variant kind (s, o, doc) = +and format_variant kind (s, o, doc, cons_attrs, payload_attrs) = let s = tick kind ^ s in let cons = make_atom s in + let attrs_str attrs = + List.map (fun a -> sprintf "[@%s]" a) attrs |> String.concat "" + in + let format_payload t = + match payload_attrs with + | [] -> format_type_expr t + | _ -> + Easy_format.List ( + ("(", "", ")", shlist), + [format_type_expr t; make_atom (attrs_str payload_attrs)] + ) + in let variant = match o with - None -> cons - | Some t -> + | None -> + if cons_attrs = [] then cons + else Label ((cons, label), make_atom (attrs_str cons_attrs)) + | Some t -> + let with_payload = Label ( (cons, label), Label ( (make_atom "of", label), - format_type_expr t + format_payload t ) ) + in + if cons_attrs = [] then with_payload + else Label ((with_payload, label), make_atom (attrs_str cons_attrs)) in append_ocamldoc_comment variant doc diff --git a/atdgen/test/test_ppx.atd b/atdgen/test/test_ppx.atd index d41999df..32215b00 100644 --- a/atdgen/test/test_ppx.atd +++ b/atdgen/test/test_ppx.atd @@ -1,3 +1,16 @@ type t = { v: int; + w: string ; } + +type status = [ + | Active + | Pending of int + | Inactive +] + +type poly_status = [ + | Active + | Pending of int + | Inactive +] diff --git a/atdml/src/lib/Codegen.ml b/atdml/src/lib/Codegen.ml index f3f00c1e..ae9515a5 100644 --- a/atdml/src/lib/Codegen.ml +++ b/atdml/src/lib/Codegen.ml @@ -55,6 +55,9 @@ let annot_schema_ocaml : Atd.Annot.schema_section = { Import, "name"; (* on an import: override OCaml alias *) Imported_type, "name"; (* on an imported type: override type name *) Variant, "name"; (* on a variant constructor *) + Variant, "attr"; (* on a variant constructor: append [@...] *) + Type_expr, "attr"; (* on a variant payload type: append [@...] *) + Field, "attr"; (* on a field: append [@...] *) Field, "default"; (* on a with-default field *) Field, "name"; (* on a field: not supported, warns *) ] @@ -210,6 +213,30 @@ let get_ocaml_attr an = ~field:"attr" an +(* Get for a field; value is placed inside [@...] *) +let get_ocaml_field_attr an = + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + an + +(* Get for a variant constructor; value is placed inside [@...] *) +let get_ocaml_variant_attr an = + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + an + +(* Get for a variant payload type expression; value is placed inside [@...] *) +let get_ocaml_payload_attr e = + Atd.Annot.get_opt_field + ~parse:(fun s -> Some s) + ~sections:["ocaml"] + ~field:"attr" + (Atd.Ast.annot_of_type_expr e) + (* Get wrap-related annotations for a 'wrap' type expression. Supports: → 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; _} in let gen_case (loc, orig_name, an, opt_e) = let cons_name = vtr (get_ocaml_name orig_name an) in + let cons_attr = match get_ocaml_variant_attr an with + | None -> "" + | Some attr -> sprintf " [@%s]" attr + in match opt_e with | None -> - with_inline_doc (sprintf "| %s%s" tick cons_name) loc an + with_inline_doc (sprintf "| %s%s%s" tick cons_name cons_attr) loc an | Some e -> + let payload_str = + match get_ocaml_payload_attr e with + | None -> type_expr_str env e + | Some attr -> sprintf "(%s [@%s])" (type_expr_str env e) attr + in with_inline_doc - (sprintf "| %s%s of %s" tick cons_name (type_expr_str env e)) + (sprintf "| %s%s of %s%s" tick cons_name payload_str cons_attr) loc an in let hd = @@ -917,8 +953,12 @@ let gen_type_def ~is_mli env ({A.loc; name; param=params; annot=an; value=e; _} B.Block (concat_map (fun (loc, (fname, _, an), e) -> + let field_attr = match get_ocaml_field_attr an with + | None -> "" + | Some attr -> sprintf " [@%s]" attr + in with_inline_doc - (sprintf "%s: %s;" (pftr fname) (type_expr_str env e)) + (sprintf "%s: %s%s;" (pftr fname) (type_expr_str env e) field_attr) loc an) fields); B.Line "}"; diff --git a/atdml/tests/named-snapshots/attr b/atdml/tests/named-snapshots/attr index cacf1043..41135ab9 100644 --- a/atdml/tests/named-snapshots/attr +++ b/atdml/tests/named-snapshots/attr @@ -2,7 +2,7 @@ type point = { x: float; - y: float; + y: float option [@option]; } [@@deriving show] @@ -191,7 +191,7 @@ end type point = { x: float; - y: float; + y: float option [@option]; } [@@deriving show] diff --git a/atdml/tests/named-snapshots/variant_attr b/atdml/tests/named-snapshots/variant_attr new file mode 100644 index 00000000..af8fd08f --- /dev/null +++ b/atdml/tests/named-snapshots/variant_attr @@ -0,0 +1,138 @@ +(* Auto-generated from "variant_attr.atd" by atdml. *) + +type status = + | Active [@deriving.ord.ignore] + | Inactive + | Pending of (int [@deriving.ord.ignore]) + +val status_of_yojson : Yojson.Safe.t -> status +val yojson_of_status : status -> Yojson.Safe.t +val status_of_json : string -> status +val json_of_status : status -> string + +module Status : sig + type nonrec t = status + val of_yojson : Yojson.Safe.t -> t + val to_yojson : t -> Yojson.Safe.t + val of_json : string -> t + val to_json : t -> string +end + +--- ml --- +(* Auto-generated from "variant_attr.atd" by atdml. *) +[@@@ocaml.warning "-27-32-33-35-39"] + +(* Inlined runtime — no external dependency needed. *) +module Atdml_runtime = struct + let bad_type expected_type x = + Printf.ksprintf failwith "expected %s, got: %s" + expected_type (Yojson.Safe.to_string x) + + let bad_sum type_name x = + Printf.ksprintf failwith "invalid variant for type '%s': %s" + type_name (Yojson.Safe.to_string x) + + let missing_field type_name field_name = + Printf.ksprintf failwith "missing field '%s' in object of type '%s'" + field_name type_name + + let bool_of_yojson = function + | `Bool b -> b + | x -> bad_type "bool" x + + let yojson_of_bool b = `Bool b + + let int_of_yojson = function + | `Int n -> n + | x -> bad_type "int" x + + let yojson_of_int n = `Int n + + let float_of_yojson = function + | `Float f -> f + | `Int n -> Float.of_int n + | x -> bad_type "float" x + + let yojson_of_float f = `Float f + + let string_of_yojson = function + | `String s -> s + | x -> bad_type "string" x + + let yojson_of_string s = `String s + + let unit_of_yojson = function + | `Null -> () + | x -> bad_type "null" x + + let yojson_of_unit () = `Null + + let list_of_yojson f = function + | `List xs -> List.map f xs + | x -> bad_type "array" x + + let yojson_of_list f xs = `List (List.map f xs) + + let option_of_yojson f = function + | `String "None" -> None + | `List [`String "Some"; x] -> Some (f x) + | x -> bad_type "option" x + + let yojson_of_option f = function + | None -> `String "None" + | Some x -> `List [`String "Some"; f x] + + let nullable_of_yojson f = function + | `Null -> None + | x -> Some (f x) + + let yojson_of_nullable f = function + | None -> `Null + | Some x -> f x + + (* Returns true iff the list has strictly more than [n] elements, + without traversing past element n+1. *) + let rec list_length_gt n = function + | _ :: rest -> if n = 0 then true else list_length_gt (n - 1) rest + | [] -> false + + let assoc_of_yojson f = function + | `Assoc pairs -> List.map (fun (k, v) -> (k, f v)) pairs + | x -> bad_type "object" x + + let yojson_of_assoc f xs = + `Assoc (List.map (fun (k, v) -> (k, f v)) xs) +end + +type status = + | Active [@deriving.ord.ignore] + | Inactive + | Pending of (int [@deriving.ord.ignore]) + +let status_of_yojson (x : Yojson.Safe.t) : status = + match x with + | `String "Active" -> Active + | `String "Inactive" -> Inactive + | `List [`String "Pending"; v] -> Pending (Atdml_runtime.int_of_yojson v) + | _ -> Atdml_runtime.bad_sum "status" x + +let yojson_of_status (x : status) : Yojson.Safe.t = + match x with + | Active -> `String "Active" + | Inactive -> `String "Inactive" + | Pending v -> `List [`String "Pending"; Atdml_runtime.yojson_of_int v] + +let status_of_json s = + status_of_yojson (Yojson.Safe.from_string s) + +let json_of_status x = + Yojson.Safe.to_string (yojson_of_status x) + +module Status = struct + type nonrec t = status + let of_yojson = status_of_yojson + let to_yojson = yojson_of_status + let of_json = status_of_json + let to_json = json_of_status +end + diff --git a/atdml/tests/test.ml b/atdml/tests/test.ml index 14b3a104..844ae831 100644 --- a/atdml/tests/test.ml +++ b/atdml/tests/test.ml @@ -489,13 +489,23 @@ type shape = [ ~atd_src:{| type point = { x: float; - y: float; + y: float option ; } type points = point list |} ; + test_codegen_snapshot "variant attr" + ~atd_src:{| +type status = [ + | Active + | Inactive + | Pending of int +] +|} + ; + test_codegen_snapshot "doc" ~atd_src:{| diff --git a/doc/atdgen-reference.rst b/doc/atdgen-reference.rst index 4a493efe..c23fb467 100644 --- a/doc/atdgen-reference.rst +++ b/doc/atdgen-reference.rst @@ -973,28 +973,58 @@ Section ``ocaml`` Field ``attr`` """""""""""""" -Position: on a type definition, i.e. on the left-handside just before -the equal sign ``=`` +Position: on a type definition, a record field, a variant constructor, +or a variant payload type expression -Semantics: specifies custom ppx attributes for the type -definition. Overrides any default attributes set globally via -the command line option ``-type-attr``. +Semantics: -Values: the contents of a ppx annotation without the enclosing -``[@@`` and ``]`` +- On a **type definition** (left-hand side just before ``=``), specifies + custom ppx attributes for the type definition. Overrides any default + attributes set globally via the command line option ``-type-attr``. + Multiple ``attr`` annotations are allowed and combined. +- On a **record field** (after the field type), appends a ``[@attr]`` + attribute to that field. +- On a **variant constructor** (after the constructor name), appends a + ``[@attr]`` attribute to that constructor. +- On a **variant payload type** (after the ``of ``), wraps the + payload in ``( [@attr])``. -Example: +Values: the contents of a ppx annotation without the enclosing brackets +and ``@`` sigils + +Examples: .. code:: ocaml type foo = int list + type point = { + x: float; + y: float ; + } + + type status = [ + | Active + | Pending of int + | Inactive + ] + translates to .. code:: ocaml type foo = int list [@@deriving show,eq] + type point = { + x: float; + y: float [@compare.ignore]; + } + + type status = + | Active [@deriving.ord.ignore] + | Pending of (int [@deriving.ord.ignore]) + | Inactive + Field ``predef`` """""""""""""""" diff --git a/doc/atdml-reference.rst b/doc/atdml-reference.rst index 1147b8aa..f6b6941c 100644 --- a/doc/atdml-reference.rst +++ b/doc/atdml-reference.rst @@ -419,34 +419,54 @@ Section ``ocaml`` Field ``attr`` """""""""""""" -Position: on a type definition, i.e. on the left-hand side just before the -equal sign ``=`` +Position: on a type definition, a record field, a variant constructor, or a +variant payload type expression -Values: the contents of a ppx annotation without the enclosing ``[@@`` and -``]`` +Values: the contents of a ppx annotation without the enclosing brackets and +``@`` sigils -Semantics: appends a ppx attribute to the generated OCaml type definition, -in both the ``.mli`` and ``.ml`` files. +Semantics: -Example: +- On a **type definition** (left-hand side just before ``=``), appends a + ``[@@attr]`` attribute after the type definition in both the ``.mli`` and + ``.ml`` files. +- On a **record field** (after the field type), appends a ``[@attr]`` + attribute to that field in the generated type definition. +- On a **variant constructor** (after the constructor name), appends a + ``[@attr]`` attribute to that constructor. +- On a **variant payload type** (after the ``of ``), wraps the payload + in ``( [@attr])``. + +Examples: .. code:: ocaml type point = { x: float; - y: float; + y: float ; } + type status = [ + | Active + | Pending of int + | Inactive + ] + translates to .. code:: ocaml type point = { x: float; - y: float; + y: float [@compare.ignore]; } [@@deriving show, eq] + type status = + | Active [@deriving.ord.ignore] + | Pending of (int [@deriving.ord.ignore]) + | Inactive + This is useful for attaching ppx rewriters such as ``ppx_deriving`` or ``ppx_yojson_conv`` to generated types. Note that the ppx library must be present in the build environment; atdml does not provide it.