Skip to content

Commit 25c9033

Browse files
mjambonclaude
mjambon
and
claude
authored
atdml: Add support for <ocaml field_prefix> + no prefix on function labels (#455)
* [atdml] Support <ocaml field_prefix="..."> on record types Prefixes are applied to generated OCaml record field names but not to labeled arguments in create_ functions, matching the task description from issue #433 (last comment). Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com> * [atdml] Fix field_prefix keyword safety: apply prefix before keyword check Introduce make_prefixed_trs which builds two separate name translators: - label_tr: keyword-checks the raw field name (no prefix) for labeled args - pftr: concatenates the prefix with the raw name *then* keyword-checks, so "mod"^"ule" = "module" (keyword) → "module_", while the label is "ule"; and "mod"^"if" = "modif" (not a keyword) → "modif", while the label is "if_". Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com> * [atdml] Extend field_prefix test to cover keyword collision in labels Test 'type t = { ule: int; if: int; if_: int } <ocaml field_prefix="mod">'. Shows that "if_" (ATD) gets label ~if__ because ~if_ was already claimed by the rename of the keyword field "if". Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com> * [doc] Update atdml-reference: create_, private aliases, field_prefix - Rename all make_ → create_ (make_foo → create_foo, val make → val create) - Add "Primitive type aliases" subsection: documents private type in .mli, create_* constructor, :> coercion, zero runtime overhead - Extend "Reserved name handling" to mention record fields and variants - Add "Field field_prefix" entry under Section ocaml: documents the annotation, the unprefixed-label / prefixed-field split, and the keyword-escaping semantics with the mod+ule/mod+if worked example Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com> --------- Co-authored-by: Claude Sonnet 4.6 <noreply@anthropic.com>
1 parent 0f64592 commit 25c9033

File tree

5 files changed

+391
-43
lines changed

5 files changed

+391
-43
lines changed

‎CHANGES.md‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,12 @@ unreleased
1313
(e.g. `(x :> string)`). The `.ml` implementation keeps a transparent alias,
1414
so `create_email` is an identity function with no runtime overhead.
1515

16+
* atdml: The `<ocaml field_prefix="pre_">` annotation is now supported on record
17+
types. It prepends the given prefix to all generated OCaml record field names
18+
(e.g. `type point = { p_x: float; p_y: float }`) while keeping the labeled
19+
arguments of the `create_` function unprefixed (e.g.
20+
`create_point ~x ~y () : point`). JSON field names are unaffected.
21+
1622
* atdml: Record creation functions renamed from `make_foo` to `create_foo`
1723
(and `val make` in the submodule to `val create`) to align with the naming
1824
used by the new primitive alias constructors and to match atdgen's convention.

‎atdml/src/lib/Codegen.ml‎

Lines changed: 85 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -44,11 +44,12 @@ let annot_schema_ocaml : Atd.Annot.schema_section = {
4444
Type_def, "attr"; (* <ocaml attr="..."> on a type def: append [@@...] *)
4545
Type_def, "module"; (* <ocaml module="M"> on a type def: not supported, warns *)
4646
Type_def, "t"; (* <ocaml t="..."> on a type def: not supported, warns *)
47-
Type_expr, "repr"; (* <ocaml repr="poly"> on a sum type *)
48-
Type_expr, "module"; (* <ocaml module="M"> on a wrap: use M.t/M.wrap/M.unwrap *)
49-
Type_expr, "t"; (* <ocaml t="..."> on a wrap: explicit OCaml type *)
50-
Type_expr, "wrap"; (* <ocaml wrap="..."> on a wrap: deserialize function *)
51-
Type_expr, "unwrap"; (* <ocaml unwrap="..."> on a wrap: serialize function *)
47+
Type_expr, "repr"; (* <ocaml repr="poly"> on a sum type *)
48+
Type_expr, "field_prefix"; (* <ocaml field_prefix="t_"> on a record type *)
49+
Type_expr, "module"; (* <ocaml module="M"> on a wrap: use M.t/M.wrap/M.unwrap *)
50+
Type_expr, "t"; (* <ocaml t="..."> on a wrap: explicit OCaml type *)
51+
Type_expr, "wrap"; (* <ocaml wrap="..."> on a wrap: deserialize function *)
52+
Type_expr, "unwrap"; (* <ocaml unwrap="..."> on a wrap: serialize function *)
5253
Import, "name"; (* <ocaml name="..."> on an import: override OCaml alias *)
5354
Variant, "name"; (* <ocaml name="..."> on a variant constructor *)
5455
Field, "default"; (* <ocaml default="..."> on a with-default field *)
@@ -168,6 +169,26 @@ let make_local_env names =
168169
List.iter (fun n -> ignore (Atd.Unique_name.translate registry n)) names;
169170
Atd.Unique_name.translate registry
170171

172+
(*
173+
Build two name translators for a prefixed record:
174+
- label_tr: ATD field name → OCaml-safe label name (no prefix applied).
175+
E.g. "if" → "if_".
176+
- pftr: ATD field name → OCaml-safe record field name (prefix concatenated
177+
with the raw ATD name *before* checking for keyword conflicts).
178+
E.g. with prefix "mod": "ule" → "module_", "if" → "modif".
179+
When prefix = "" both translators are identical.
180+
*)
181+
let make_prefixed_trs prefix field_names =
182+
let label_tr = make_local_env field_names in
183+
let pftr =
184+
if prefix = "" then label_tr
185+
else
186+
let pnames = List.map (fun n -> prefix ^ n) field_names in
187+
let field_tr = make_local_env pnames in
188+
fun fname -> field_tr (prefix ^ fname)
189+
in
190+
(label_tr, pftr)
191+
171192
(* ============ Annotation helpers ============ *)
172193

173194
(* Get <ocaml default="..."> for with-default fields *)
@@ -281,6 +302,17 @@ let with_inline_doc decl_str loc an : B.t =
281302
| [one_line] -> [B.Line (sprintf "%s (** %s *)" decl_str one_line)]
282303
| lines -> B.Line decl_str :: ocamldoc_comment_block lines
283304

305+
(* Get <ocaml field_prefix="..."> from a record type expression's annotation.
306+
Returns the prefix string, or "" if the annotation is absent. *)
307+
let get_field_prefix rec_an =
308+
match Atd.Annot.get_opt_field
309+
~parse:(fun s -> Some s)
310+
~sections:["ocaml"] ~field:"field_prefix"
311+
rec_an
312+
with
313+
| None -> ""
314+
| Some prefix -> prefix
315+
284316
(* Get <ocaml name="..."> to rename OCaml identifiers *)
285317
let get_ocaml_name default_name an =
286318
Atd.Annot.get_field
@@ -657,23 +689,24 @@ let gen_type_def ~is_mli env ({A.name; param=params; annot=an; value=e; _} as de
657689
B.Line (sprintf "type %s%s =" params_str ocaml_name);
658690
B.Block (concat_map gen_case flat);
659691
]
660-
| Record (_, fields, _) ->
692+
| Record (_, fields, rec_an) ->
693+
let prefix = get_field_prefix rec_an in
661694
let fields =
662695
List.filter_map (fun (f : field) -> match f with
663696
| Field x -> Some x
664697
| Inherit _ -> assert false
665698
) fields
666699
in
667-
let ftr =
668-
make_local_env (List.map (fun (_, (fname, _, _), _) -> fname) fields)
700+
let (_, pftr) =
701+
make_prefixed_trs prefix (List.map (fun (_, (fname, _, _), _) -> fname) fields)
669702
in
670703
[
671704
B.Line (sprintf "type %s%s = {" params_str ocaml_name);
672705
B.Block
673706
(concat_map
674707
(fun (loc, (fname, _, an), e) ->
675708
with_inline_doc
676-
(sprintf "%s: %s;" (ftr fname) (type_expr_str env e))
709+
(sprintf "%s: %s;" (pftr fname) (type_expr_str env e))
677710
loc an)
678711
fields);
679712
B.Line "}";
@@ -763,16 +796,16 @@ let gen_make_fun env ({A.name; param=params; value=e; _} : A.type_def) : B.t =
763796
let name = Atd.Type_name.basename name in
764797
let ocaml_name = env.tr name in
765798
match e with
766-
| Record (_, fields, _) ->
799+
| Record (_, fields, rec_an) ->
800+
let prefix = get_field_prefix rec_an in
767801
let fields =
768802
List.filter_map (fun (f : field) -> match f with
769803
| Field x -> Some x
770804
| Inherit _ -> assert false
771805
) fields
772806
in
773-
let ftr =
774-
make_local_env (List.map (fun (_, (fname, _, _), _) -> fname) fields)
775-
in
807+
let fnames = List.map (fun (_, (fname, _, _), _) -> fname) fields in
808+
let (label_tr, pftr) = make_prefixed_trs prefix fnames in
776809
(* Try to resolve the default for a With_default field.
777810
Returns None if no default can be determined, in which case
778811
we skip generating make_* for this type. *)
@@ -792,17 +825,24 @@ let gen_make_fun env ({A.name; param=params; value=e; _} : A.type_def) : B.t =
792825
if List.exists (fun r -> r = None) resolved then []
793826
else
794827
let gen_param (_, (fname, kind, _), _) default_opt =
795-
let ofname = ftr fname in
828+
let lname = label_tr fname in
796829
match kind with
797-
| Required -> sprintf "~%s" ofname
798-
| Optional -> sprintf "?%s" ofname
830+
| Required -> sprintf "~%s" lname
831+
| Optional -> sprintf "?%s" lname
799832
| With_default ->
800833
let default = Option.get (Option.get default_opt) in
801-
sprintf "?(%s = %s)" ofname default
834+
sprintf "?(%s = %s)" lname default
802835
in
803836
let param_strs = List.map2 gen_param fields resolved in
804-
let field_names =
805-
List.map (fun (_, (fname, _, _), _) -> ftr fname) fields
837+
(* Labels are unprefixed; record field names carry the prefix.
838+
Emit 'pfname = lname' when they differ, else use shorthand. *)
839+
let field_assigns =
840+
List.map (fun (_, (fname, _, _), _) ->
841+
let lname = label_tr fname in
842+
let pfname = pftr fname in
843+
if pfname = lname then pfname
844+
else sprintf "%s = %s" pfname lname
845+
) fields
806846
in
807847
[
808848
B.Line
@@ -811,7 +851,7 @@ let gen_make_fun env ({A.name; param=params; value=e; _} : A.type_def) : B.t =
811851
(String.concat " " param_strs)
812852
(full_type_name ocaml_name params));
813853
B.Block
814-
[B.Line (sprintf "{ %s }" (String.concat "; " field_names))];
854+
[B.Line (sprintf "{ %s }" (String.concat "; " field_assigns))];
815855
]
816856
| _ -> []
817857

@@ -944,17 +984,25 @@ let gen_of_yojson env ({A.name; param=params; annot=an; value=e; _} : A.type_def
944984
@ List.map gen_case flat
945985
@ [B.Line (sprintf "| _ -> Atdml_runtime.bad_sum \"%s\" x" name)])
946986
| Record (_, fields, rec_an) ->
987+
let prefix = get_field_prefix rec_an in
947988
let fields =
948989
List.filter_map (fun (f : field) -> match f with
949990
| Field x -> Some x
950991
| Inherit _ -> assert false)
951992
fields
952993
in
953-
let ftr =
954-
make_local_env (List.map (fun (_, (fname, _, _), _) -> fname) fields)
955-
in
956-
let field_names =
957-
List.map (fun (_, (fname, _, _), _) -> ftr fname) fields
994+
let fnames = List.map (fun (_, (fname, _, _), _) -> fname) fields in
995+
let (label_tr, pftr) = make_prefixed_trs prefix fnames in
996+
(* Local variable bindings use label_tr (unprefixed, keyword-safe).
997+
The record literal uses pftr (prefix applied before keyword check).
998+
Emit 'pfname = lname' when they differ, else use shorthand. *)
999+
let field_assigns =
1000+
List.map (fun (_, (fname, _, _), _) ->
1001+
let lname = label_tr fname in
1002+
let pfname = pftr fname in
1003+
if pfname = lname then pfname
1004+
else sprintf "%s = %s" pfname lname
1005+
) fields
9581006
in
9591007
let (normalize, _) =
9601008
adapter_exprs (Atd.Json.get_json_record rec_an).json_record_adapter
@@ -984,8 +1032,8 @@ let gen_of_yojson env ({A.name; param=params; annot=an; value=e; _} : A.type_def
9841032
B.Line "(fun key -> Hashtbl.find_opt tbl key)" ];
9851033
B.Line "else (fun key -> List.assoc_opt key fields)" ];
9861034
B.Line "in" ]
987-
@ List.map (gen_of_yojson_field env ftr name) fields
988-
@ [B.Line (sprintf "{ %s }" (String.concat "; " field_names))]);
1035+
@ List.map (gen_of_yojson_field env label_tr name) fields
1036+
@ [B.Line (sprintf "{ %s }" (String.concat "; " field_assigns))]);
9891037
B.Line (sprintf "| _ -> Atdml_runtime.bad_type \"%s\" x" name) ])
9901038
in
9911039
match_block
@@ -1015,9 +1063,11 @@ let gen_of_yojson env ({A.name; param=params; annot=an; value=e; _} : A.type_def
10151063

10161064
(* ============ Serialization function generation ============ *)
10171065

1018-
let gen_yojson_of_field env ftr (_, (fname, kind, an), e) : B.node =
1066+
(* [pftr] maps the ATD field name to the prefixed OCaml field name
1067+
used in the record type definition (e.g. "pre_" ^ ftr fname). *)
1068+
let gen_yojson_of_field env pftr (_, (fname, kind, an), e) : B.node =
10191069
let json_name = Atd.Json.get_json_fname fname an in
1020-
let ofname = ftr fname in
1070+
let ofname = pftr fname in
10211071
match kind with
10221072
| Required | With_default ->
10231073
B.Line (sprintf "[(\"%s\", %s x.%s)];" json_name (writer_expr env e) ofname)
@@ -1088,23 +1138,25 @@ let gen_yojson_of env ({A.name; param=params; annot=an; value=e; _} : A.type_def
10881138
(B.Line "match x with"
10891139
:: List.map gen_case flat))
10901140
| Record (_, fields, rec_an) ->
1141+
let prefix = get_field_prefix rec_an in
10911142
let fields =
10921143
List.filter_map (fun (f : field) -> match f with
10931144
| Field x -> Some x
10941145
| Inherit _ -> assert false)
10951146
fields
10961147
in
1097-
let ftr =
1098-
make_local_env (List.map (fun (_, (fname, _, _), _) -> fname) fields)
1099-
in
1148+
let fnames = List.map (fun (_, (fname, _, _), _) -> fname) fields in
1149+
(* pftr maps ATD field names to the prefixed OCaml record field names,
1150+
with the prefix applied before keyword checking. *)
1151+
let (_, pftr) = make_prefixed_trs prefix fnames in
11001152
let (_, restore) =
11011153
adapter_exprs (Atd.Json.get_json_record rec_an).json_record_adapter
11021154
in
11031155
apply_restore restore
11041156
(B.Block
11051157
[
11061158
B.Line "`Assoc (List.concat [";
1107-
B.Block (List.map (gen_yojson_of_field env ftr) fields);
1159+
B.Block (List.map (gen_yojson_of_field env pftr) fields);
11081160
B.Line "])";
11091161
])
11101162
| e ->

0 commit comments

Comments
 (0)