From b5d7c862f414c0547205d3528b38183fa711ac91 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 16 Oct 2026 07:47:33 +0000 Subject: [PATCH 1/3] Represent fixed external arguments in the parsetree `@as(value) _` arguments of externals become `Parg_fixed`, holding the value as written. `Pconst_json` is gone: `json` templates are ordinary tagged templates except as fixed values, whose v0 encoding is unchanged. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01NP47qMfjMbjUTKZDsLthDo Signed-off-by: Christoph Knittel --- analysis/src/completion_front_end.ml | 2 +- analysis/src/document_symbol.ml | 2 +- analysis/src/dump_ast.ml | 1 - analysis/src/signature_help.ml | 59 +++++---- .../fixed-external-args-parsetree.internal.md | 1 + changes/json-tagged-template.polish.md | 1 + compiler/ext/config.ml | 8 +- compiler/frontend/ast_attributes.ml | 12 +- compiler/frontend/ast_config.ml | 1 - compiler/frontend/ast_derive_projector.ml | 8 +- compiler/frontend/ast_exp_extension.ml | 1 - compiler/frontend/ast_exp_handle_external.ml | 19 ++- compiler/frontend/ast_external_process.ml | 81 ++++++++---- compiler/frontend/bs_builtin_ppx.ml | 10 +- compiler/frontend/ppx_entry.ml | 24 ---- compiler/ml/ast_fixed_arg.ml | 96 ++++++++++++++ compiler/ml/ast_fixed_arg.mli | 23 ++++ compiler/ml/ast_helper.ml | 5 +- compiler/ml/ast_iterator.ml | 6 +- compiler/ml/ast_mapper.ml | 11 +- compiler/ml/ast_mapper_from0.ml | 19 ++- compiler/ml/ast_mapper_to0.ml | 39 +++++- compiler/ml/ast_payload.ml | 19 --- compiler/ml/ast_payload.mli | 4 - compiler/ml/ast_untagged_variants.ml | 1 - compiler/ml/builtin_attributes.ml | 4 +- compiler/ml/depend.ml | 6 +- compiler/ml/parsetree.ml | 25 +++- compiler/ml/pprintast.ml | 24 ++-- compiler/ml/printast.ml | 29 ++++- compiler/ml/translcore.ml | 4 +- compiler/ml/typecore.ml | 10 +- compiler/ml/typecore.mli | 1 - compiler/ml/typetexp.ml | 29 +++-- compiler/syntax/src/jsx_v4.ml | 5 +- compiler/syntax/src/res_comments_table.ml | 37 ++++-- compiler/syntax/src/res_core.ml | 25 ++-- compiler/syntax/src/res_parsetree_viewer.ml | 2 +- compiler/syntax/src/res_printer.ml | 60 ++++++--- tests/ERROR_VARIANTS.md | 1 - .../expected/json_literal_inline.res.expected | 9 -- .../json_literal_inline_payload.res.expected | 9 -- ...json_literal_outside_external.res.expected | 8 -- .../json_literal_todo_payload.res.expected | 8 -- ...ntaxErrors_json_interpolation.res.expected | 8 +- .../fixtures/json_literal_inline.res | 2 - .../fixtures/json_literal_inline_payload.res | 2 - .../json_literal_outside_external.res | 1 - .../fixtures/json_literal_todo_payload.res | 1 - tests/ounit_tests/ounit_ast_mapper0_tests.ml | 122 +++++++++++++++++- .../ounit_tests/ounit_string_literal_tests.ml | 44 +++++-- .../data/ast-mapping/FixedExternal.res | 5 + .../expected/FixedExternal.res.txt | 5 + .../expressions/expected/es6template.res.txt | 2 +- .../typexpr/expected/fixedExternal.res.txt | 28 ++++ .../data/printer/typexpr/fixedExternal.res | 22 ++++ tests/tests/src/tagged_template_test.mjs | 39 +++--- tests/tests/src/tagged_template_test.res | 11 ++ tools/src/tools.ml | 1 - 59 files changed, 730 insertions(+), 312 deletions(-) create mode 100644 changes/fixed-external-args-parsetree.internal.md create mode 100644 changes/json-tagged-template.polish.md create mode 100644 compiler/ml/ast_fixed_arg.ml create mode 100644 compiler/ml/ast_fixed_arg.mli delete mode 100644 tests/build_tests/super_errors/expected/json_literal_inline.res.expected delete mode 100644 tests/build_tests/super_errors/expected/json_literal_inline_payload.res.expected delete mode 100644 tests/build_tests/super_errors/expected/json_literal_outside_external.res.expected delete mode 100644 tests/build_tests/super_errors/expected/json_literal_todo_payload.res.expected delete mode 100644 tests/build_tests/super_errors/fixtures/json_literal_inline.res delete mode 100644 tests/build_tests/super_errors/fixtures/json_literal_inline_payload.res delete mode 100644 tests/build_tests/super_errors/fixtures/json_literal_outside_external.res delete mode 100644 tests/build_tests/super_errors/fixtures/json_literal_todo_payload.res create mode 100644 tests/syntax_tests/data/ast-mapping/FixedExternal.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/FixedExternal.res.txt create mode 100644 tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt create mode 100644 tests/syntax_tests/data/printer/typexpr/fixedExternal.res diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index c6586977108..dee20d26c96 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -210,7 +210,7 @@ let rec expr_to_context_path_inner ~(in_jsx_context : bool) (e : Parsetree.expression) = match e.pexp_desc with | Pexp_braces {expr} -> expr_to_context_path_inner ~in_jsx_context expr - | Pexp_constant (Pconst_string _ | Pconst_json _ | Pconst_raw_source _) -> + | Pexp_constant (Pconst_string _ | Pconst_raw_source _) -> Some Completable.CPString | Pexp_template _ -> Some Completable.CPString | Pexp_tagged_template {tag} -> ( diff --git a/analysis/src/document_symbol.ml b/analysis/src/document_symbol.ml index 2687480e094..ed96a799f0e 100644 --- a/analysis/src/document_symbol.ml +++ b/analysis/src/document_symbol.ml @@ -20,7 +20,7 @@ let get_symbols ~source ~kind_file = | Pexp_fun _ -> Lsp.Types.SymbolKind.Function | Pexp_braces {expr} -> expr_kind expr | Pexp_constraint (e, _) -> expr_kind e - | Pexp_constant (Pconst_string _ | Pconst_json _ | Pconst_raw_source _) -> + | Pexp_constant (Pconst_string _ | Pconst_raw_source _) -> Lsp.Types.SymbolKind.String | Pexp_template _ -> Lsp.Types.SymbolKind.String | Pexp_constant (Pconst_float _ | Pconst_integer _) -> diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index f18658b570a..53437c830e3 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -51,7 +51,6 @@ let print_constant const = ^ ", semantic=" ^ String_literal.string_semantic payload ^ ")" - | Pconst_json source -> "Pconst_json(" ^ source ^ ")" | Pconst_raw_source source -> "Pconst_raw_source(" ^ source ^ ")" | Pconst_float (s, _) -> "Pconst_float(" ^ s ^ ")" diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index a11208df6d6..3462855f540 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -114,33 +114,38 @@ let extract_parameters ~signature ~type_str_for_parser ~label_prefix_len = Psig_value {pval_type = {ptyp_desc = Ptyp_arrow {params = args}}}; }; ] -> - List.map - (fun (arg : Parsetree.arg) -> - let start_loc = - (* For a labeled argument the label precedes the type. *) - match arg.lbl with - | Asttypes.Labelled {loc} | Optional {loc} -> loc |> Loc.start - | Nolabel -> arg.typ.ptyp_loc |> Loc.start - in - let start_offset = - start_loc |> Pos.position_to_offset type_str_for_parser |> Option.get - in - let end_offset = - arg.typ.ptyp_loc |> Loc.end_ - |> Pos.position_to_offset type_str_for_parser - |> Option.get - in - (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *) - let end_offset = - match arg.lbl with - | Asttypes.Optional _ -> end_offset + 2 - | _ -> end_offset - in - ( arg.lbl, - (* Remove the label prefix offset here, since we're not - showing that to the end user. *) - start_offset - label_prefix_len, - end_offset - label_prefix_len )) + List.filter_map + (function + | Parsetree.Parg_fixed _ -> None + | Parsetree.Parg_type {lbl; typ; _} -> + let start_loc = + (* For a labeled argument the label precedes the type. *) + match lbl with + | Asttypes.Labelled {loc} | Optional {loc} -> loc |> Loc.start + | Nolabel -> typ.ptyp_loc |> Loc.start + in + let start_offset = + start_loc + |> Pos.position_to_offset type_str_for_parser + |> Option.get + in + let end_offset = + typ.ptyp_loc |> Loc.end_ + |> Pos.position_to_offset type_str_for_parser + |> Option.get + in + (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *) + let end_offset = + match lbl with + | Asttypes.Optional _ -> end_offset + 2 + | _ -> end_offset + in + Some + ( lbl, + (* Remove the label prefix offset here, since we're not + showing that to the end user. *) + start_offset - label_prefix_len, + end_offset - label_prefix_len )) args | _ -> [] diff --git a/changes/fixed-external-args-parsetree.internal.md b/changes/fixed-external-args-parsetree.internal.md new file mode 100644 index 00000000000..25a68e3b123 --- /dev/null +++ b/changes/fixed-external-args-parsetree.internal.md @@ -0,0 +1 @@ +- Represent fixed external arguments, written `@as(value) _`, with a dedicated parsetree node. https://github.com/rescript-lang/rescript/pull/8875 diff --git a/changes/json-tagged-template.polish.md b/changes/json-tagged-template.polish.md new file mode 100644 index 00000000000..0f8d815ff6d --- /dev/null +++ b/changes/json-tagged-template.polish.md @@ -0,0 +1 @@ +- Treat `json` template literals outside `` @as(json`...`) _ `` as ordinary tagged templates instead of rejecting them. https://github.com/rescript-lang/rescript/pull/8875 diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index ea65a69d406..863cd6353e4 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,10 +1,10 @@ -let cmi_magic_number = "Caml1999I036" +let cmi_magic_number = "Caml1999I037" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01315" +and ast_impl_magic_number = "ResImpl01316" -and ast_intf_magic_number = "ResIntf01315" +and ast_intf_magic_number = "ResIntf01316" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a @@ -13,7 +13,7 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T043" +and cmt_magic_number = "Caml1999T044" let get_load_path () = (Compiler_request_state.current ()).load_path let set_load_path path = (Compiler_request_state.current ()).load_path <- path diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index 38cd94f5150..ecd78c16218 100644 --- a/compiler/frontend/ast_attributes.ml +++ b/compiler/frontend/ast_attributes.ml @@ -181,7 +181,17 @@ let as_const (attrs : t) = { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_json s); pexp_loc}, _); + ( { + pexp_desc = + Pexp_tagged_template + { + tag = + {pexp_desc = Pexp_ident {txt = Lident "json"}}; + raw_sources = [{txt = s; loc = pexp_loc}]; + values = []; + }; + }, + _ ); }; ] -> ( (* Check that it is a valid object literal. *) diff --git a/compiler/frontend/ast_config.ml b/compiler/frontend/ast_config.ml index 9e1c7fd86d6..9766d0ab3c8 100644 --- a/compiler/frontend/ast_config.ml +++ b/compiler/frontend/ast_config.ml @@ -47,7 +47,6 @@ let process_directives str = |> List.iter (fun (item : Parsetree.structure_item) -> match item.pstr_desc with | Pstr_attribute ({txt = "directive"}, payload) -> ( - Ast_payload.reject_json_literal_payload payload; match Ast_payload.semantic_string_of_payload payload with | Some d -> (Js_config.current ()).directives := diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index ccc6fe3469c..bfb8ec0b5d6 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -132,7 +132,9 @@ let init () = Ext_list.map label_declarations (fun {pld_name; pld_type} -> Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = core_type}] + [ + Parg_type {attrs = []; lbl = Nolabel; typ = core_type}; + ] pld_type (*arity will alwys be 1 since these are single param functions*))) | Ptype_variant constructor_declarations -> @@ -160,8 +162,8 @@ let init () = {loc; txt = Ext_string.uncapitalize_ascii con_name} (match Ext_list.map pcd_args (fun x -> - ({attrs = []; lbl = Nolabel; typ = x} - : Parsetree.arg)) + Parsetree.Parg_type + {attrs = []; lbl = Nolabel; typ = x}) with | [] -> (* zero-argument constructor: the accessor is a value *) diff --git a/compiler/frontend/ast_exp_extension.ml b/compiler/frontend/ast_exp_extension.ml index 072d5d0a78c..233f1652d5a 100644 --- a/compiler/frontend/ast_exp_extension.ml +++ b/compiler/frontend/ast_exp_extension.ml @@ -27,7 +27,6 @@ let handle_extension e (_self : Ast_mapper.mapper) (({txt; loc}, payload) : Parsetree.extension) = match txt with | "todo" -> - Ast_payload.reject_json_literal_payload payload; let todo_message = match Ast_payload.semantic_string_of_payload payload with | Some s -> Some s diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml index 4ab1212186f..e110d00a4c1 100644 --- a/compiler/frontend/ast_exp_handle_external.ml +++ b/compiler/frontend/ast_exp_handle_external.ml @@ -28,7 +28,7 @@ let handle_debugger loc (payload : Ast_payload.t) = Ast_external_mk.local_external_apply loc ~pval_prim:(Prim_name "%debugger") ~pval_type: (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] + [Parg_type {attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] (Ast_literal.type_unit ())) [Ast_literal.val_unit ~loc ()] | _ -> @@ -49,7 +49,10 @@ let handle_raw loc payload = ~pval_prim:(Prim_name "#raw_expr") ~pval_type: (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] + [ + Parg_type + {attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}; + ] (Ast_helper.Typ.any ())) [exp]; pexp_attributes = @@ -79,7 +82,7 @@ let handle_ffi ~loc ~payload = let effective_arity = if arity = 0 then 1 else arity in let args = Ext_list.init effective_arity (fun _ -> - ({attrs = []; lbl = Nolabel; typ = any} : Parsetree.arg)) + Parsetree.Parg_type {attrs = []; lbl = Nolabel; typ = any}) in Ast_helper.Typ.arrow ~loc args any in @@ -95,7 +98,10 @@ let handle_ffi ~loc ~payload = ~pval_prim:(Prim_name "#raw_expr") ~pval_type: (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] + [ + Parg_type + {attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}; + ] (Ast_helper.Typ.any ())) [exp]; pexp_attributes = @@ -115,7 +121,10 @@ let handle_raw_structure loc payload = ~pval_prim:(Prim_name "#raw_stmt") ~pval_type: (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] + [ + Parg_type + {attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}; + ] (Ast_helper.Typ.any ())) [exp]; } diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 6717e5f332e..2efd51690a7 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -66,28 +66,31 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) : if nolabel then Extern_unit else Nothing | _ -> Nothing) +let arg_cst_of_as_const : + Ast_attributes.as_const_payload -> External_arg_spec.attr = function + | Int i -> + (* This type is used in obj only to construct obj type*) + Arg_cst (External_arg_spec.cst_int i) + | Str s -> Arg_cst (External_arg_spec.cst_string s) + | Json s -> Arg_cst (External_arg_spec.cst_json s) + (* is_optional = false *) let refine_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : External_arg_spec.attr = - if ptyp.ptyp_desc = Ptyp_any then + if ptyp.ptyp_desc = Ptyp_any then ( let ptyp_attrs = ptyp.ptyp_attributes in let payload = Ast_attributes.as_const ptyp_attrs in match payload with | None -> spec_of_ptyp nolabel ptyp - | Some cst -> ( + | Some cst -> (* (_[@as ])*) (* when ppx start dropping attributes we should warn, there is a trade off whether we should warn dropped non bs attribute or not *) Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs; - match cst with - | Int i -> - (* This type is used in obj only to construct obj type*) - Arg_cst (External_arg_spec.cst_int i) - | Str s -> Arg_cst (External_arg_spec.cst_string s) - | Json s -> Arg_cst (External_arg_spec.cst_json s)) + arg_cst_of_as_const cst) else (* ([`a|`b] [@string]) *) spec_of_ptyp nolabel ptyp @@ -103,14 +106,7 @@ let refine_obj_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs; match payload with | None -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external - | Some (Int i) -> - (* @as(24) *) - (* This type is used in obj only to construct obj type *) - Arg_cst (External_arg_spec.cst_int i) - | Some (Str s) -> - (* @as("foo") *) - Arg_cst (External_arg_spec.cst_string s) - | Some (Json s) -> Arg_cst (External_arg_spec.cst_json s)) + | Some cst -> arg_cst_of_as_const cst) else (* ([`a|`b] [@string]) *) spec_of_ptyp nolabel ptyp @@ -207,7 +203,6 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) | PStr [] -> prim_name_or_pval_prim (* It is okay to have [@@val] without payload *) | _ -> ( - Ast_payload.reject_json_literal_payload payload; match Ast_payload.semantic_string_of_payload payload with | Some val_name -> {name = val_name; source = Payload} | None -> Location.raise_errorf ~loc "Invalid payload") @@ -403,6 +398,26 @@ type response = { no_inline_cross_module: bool; } +(* A fixed argument means what [@as(value) _] means, so decode it with the + same reader. *) +let fixed_arg_type + ((value, loc) : Parsetree.fixed_value Location.loc * Location.t) = + match Ast_attributes.as_const [Ast_fixed_arg.to_attribute ~loc value] with + | Some cst -> arg_cst_of_as_const cst + | None -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal + +(* The label and type of an argument. A fixed argument is typed as its [_], so + the checks for [@as(value) _] apply to it unchanged. Its location ends with + that [_]. *) +let arg_parts (arg : Parsetree.arg) = + match arg with + | Parg_type {attrs; lbl; typ} -> (lbl, attrs, typ, None) + | Parg_fixed {attrs; lbl; value; loc} -> + ( lbl, + attrs, + Ast_helper.Typ.any ~loc:(Ast_fixed_arg.underscore_loc loc) (), + Some (value, loc) ) + let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) (arg_types_ty : Parsetree.arg list) (result_type : Ast_core_type.t) : int * Parsetree.core_type * External_ffi_types.t = @@ -434,8 +449,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) param_type (arg_labels, (arg_types : Parsetree.arg list), result_types) -> - let arg_label = param_type.lbl in - let ty = param_type.typ in + let arg_label, param_attrs, ty, fixed = arg_parts param_type in let new_arg_label, new_arg_types, output_tys = match arg_label with | Nolabel -> ( @@ -449,11 +463,15 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) "expect label, optional, or unit here") | Labelled {txt = label} -> ( let field_name = - match Ast_attributes.as_string param_type.attrs with + match Ast_attributes.as_string param_attrs with | Some alias -> alias | None -> label in - let obj_arg_type = refine_obj_arg_type ~nolabel:false ty in + let obj_arg_type = + match fixed with + | Some fixed -> fixed_arg_type fixed + | None -> refine_obj_arg_type ~nolabel:false ty + in match obj_arg_type with | Ignore -> ( External_arg_spec.empty_kind obj_arg_type, @@ -506,7 +524,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) "%@obj label %s does not support %@unwrap arguments" label) | Optional {txt = label} -> ( let field_name = - match Ast_attributes.as_string param_type.attrs with + match Ast_attributes.as_string param_attrs with | Some alias -> alias | None -> label in @@ -914,8 +932,7 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type) Ext_list.fold_right arg_types_ty (([], [], 0) : External_arg_spec.params * Parsetree.arg list * int) (fun param_type (arg_type_specs, arg_types, i) -> - let arg_label = param_type.lbl in - let ty = param_type.typ in + let arg_label, _, ty, fixed = arg_parts param_type in (if i = 0 && splice then match arg_label with | Optional _ -> @@ -948,14 +965,22 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type) s | _ -> (Arg_optional, arg_type, param_type :: arg_types)) | Labelled _ -> ( - let arg_type = refine_arg_type ~nolabel:false ty in + let arg_type = + match fixed with + | Some fixed -> fixed_arg_type fixed + | None -> refine_arg_type ~nolabel:false ty + in ( Arg_label, arg_type, match arg_type with | Arg_cst _ -> arg_types | _ -> param_type :: arg_types )) | Nolabel -> ( - let arg_type = refine_arg_type ~nolabel:true ty in + let arg_type = + match fixed with + | Some fixed -> fixed_arg_type fixed + | None -> refine_arg_type ~nolabel:true ty + in ( Arg_empty, arg_type, match arg_type with @@ -977,7 +1002,9 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type) (Location.mkloc (Longident.Lident "unit") loc) [] in - let unit_arg = {Parsetree.attrs = []; lbl = Nolabel; typ = unit_type} in + let unit_arg = + Parsetree.Parg_type {attrs = []; lbl = Nolabel; typ = unit_type} + in ( [unit_arg], arg_type_specs @ [{External_arg_spec.arg_label = Arg_empty; arg_type = Extern_unit}] diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 9f5a1e67b9d..de147ec53cf 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -101,9 +101,6 @@ let pat_mapper (self : mapper) (p : Parsetree.pattern) = match p.ppat_desc with | Ppat_constant (Pconst_integer (s, Some 'l')) -> {p with ppat_desc = Ppat_constant (Pconst_integer (s, None))} - | Ppat_constant (Pconst_json _) -> - Location.raise_errorf ~loc:p.ppat_loc - "Tagged template literals are not supported in patterns" | _ -> default_pat_mapper self p (* Unpack requires core_type package for type inference: @@ -142,7 +139,9 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ~pval_prim:(Prim_name "#raw_expr") ~pval_type: (Ast_helper.Typ.arrow - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] + [ + Parg_type {attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}; + ] (Ast_helper.Typ.any ())) [Ast_helper.Exp.constant ~loc (Pconst_raw_source source)] in @@ -596,9 +595,6 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : let has_inline_property = Ast_attributes.has_inline_payload pvb_attributes in - Option.iter - (fun (_, payload) -> Ast_payload.reject_json_literal_payload payload) - has_inline_property; match (has_inline_property, (Ast_payload.unwrap_braces pvb_expr).pexp_desc) with diff --git a/compiler/frontend/ppx_entry.ml b/compiler/frontend/ppx_entry.ml index 71b74ed474b..e59a6ec5a0c 100644 --- a/compiler/frontend/ppx_entry.ml +++ b/compiler/frontend/ppx_entry.ml @@ -24,28 +24,6 @@ let unsafe_mapper = Bs_builtin_ppx.mapper -(* [json] payloads are syntax-level expressions until built-in FFI processing - consumes valid [@as(json`...`)] occurrences. Reject anything left only - after that processing, so generic attributes and ordinary expressions - cannot reinterpret them as strings. *) -let unconsumed_json_iterator = - let default = Ast_iterator.default_iterator in - { - default with - expr = - (fun self expression -> - match expression.pexp_desc with - | Pexp_constant (Pconst_json _) -> - Ast_payload.reject_json_literal ~loc:expression.pexp_loc - | _ -> default.expr self expression); - pat = - (fun self pattern -> - match pattern.ppat_desc with - | Ppat_constant (Pconst_json _) -> - Ast_payload.reject_json_literal ~loc:pattern.ppat_loc - | _ -> default.pat self pattern); - } - let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = Bs_ast_invariant.iter_warnings_on_sigi ast; Ast_config.process_sig ast; @@ -61,7 +39,6 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = if !((Js_config.current ()).no_builtin_ppx) then ast else let result = unsafe_mapper.signature unsafe_mapper ast in - unconsumed_json_iterator.signature unconsumed_json_iterator result; (* Keep this check, since the check is not inexpensive*) Bs_ast_invariant.emit_external_warnings_on_signature result; result @@ -81,7 +58,6 @@ let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = if !((Js_config.current ()).no_builtin_ppx) then ast else let result = unsafe_mapper.structure unsafe_mapper ast in - unconsumed_json_iterator.structure unconsumed_json_iterator result; (* Keep this check since it is not inexpensive*) Bs_ast_invariant.emit_external_warnings_on_structure result; result diff --git a/compiler/ml/ast_fixed_arg.ml b/compiler/ml/ast_fixed_arg.ml new file mode 100644 index 00000000000..3a1ad5306ea --- /dev/null +++ b/compiler/ml/ast_fixed_arg.ml @@ -0,0 +1,96 @@ +open Parsetree + +let of_payload (payload : payload) : fixed_value Location.loc option = + match payload with + | PStr [{pstr_desc = Pstr_eval ({pexp_desc; pexp_loc}, _); pstr_loc = loc}] + -> ( + let fixed txt = Some {Location.txt; loc} in + match pexp_desc with + | Pexp_constant (Pconst_integer (source, None)) -> + fixed (Pfixed_int {txt = source; loc = pexp_loc}) + | Pexp_constant (Pconst_string payload) -> fixed (Pfixed_string payload) + | Pexp_template {source_segments = [source]; values = []} -> + fixed (Pfixed_template source) + | Pexp_tagged_template + { + tag = {pexp_desc = Pexp_ident {txt = Lident "json"}}; + raw_sources = [source]; + values = []; + } -> + fixed (Pfixed_json source) + | _ -> None) + | _ -> None + +let to_expression ?(loc = Location.none) (value : fixed_value) : expression = + match value with + | Pfixed_int source -> + Ast_helper.Exp.constant ~loc:source.loc (Pconst_integer (source.txt, None)) + | Pfixed_string payload -> + Ast_helper.Exp.constant ~loc (Pconst_string payload) + | Pfixed_template source -> Ast_helper.Exp.template ~loc [source] [] + | Pfixed_json source -> + Ast_helper.Exp.tagged_template ~loc + (Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "json") loc)) + [source] [] + +let to_attribute ?(loc = Location.none) (value : fixed_value Location.loc) : + attribute = + ( Location.mkloc "as" loc, + PStr + [ + Ast_helper.Str.eval ~loc:value.loc + (to_expression ~loc:value.loc value.txt); + ] ) + +(* [@as(value) _] on a direct argument becomes [Parg_fixed]. An argument with + an invalid payload stays as written, so external processing reports it as + before. So do the rare arguments that [Parg_fixed] could not print back as + written: a [_] with other attributes too, and a braced payload such as + [@as({1})]. *) +let normalize_arg (arg : arg) : arg = + match arg with + | Parg_type + {attrs; lbl; typ = {ptyp_desc = Ptyp_any; ptyp_loc; ptyp_attributes}} -> ( + let rec split before = function + | [] -> None + | (({txt = "as"; loc}, payload) : attribute) :: after -> + Some (List.rev before, loc, payload, after) + | attr :: after -> split (attr :: before) after + in + match split [] ptyp_attributes with + | Some ([], as_loc, payload, []) -> ( + match of_payload payload with + | None -> arg + | Some value -> + let loc = + if as_loc = Location.none then ptyp_loc + else {as_loc with loc_end = ptyp_loc.loc_end} + in + Parg_fixed {attrs; lbl; value; loc}) + | Some _ | None -> arg) + | Parg_type _ | Parg_fixed _ -> arg + +let underscore_loc (loc : Location.t) = + if loc.loc_ghost then loc + else + { + loc with + loc_start = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - 1}; + } + +let as_name_loc (loc : Location.t) = + if loc.loc_ghost then loc + else + { + loc with + loc_end = {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3}; + } + +let normalize_external_type (typ : core_type) : core_type = + match typ.ptyp_desc with + | Ptyp_arrow {params; ret} -> + { + typ with + ptyp_desc = Ptyp_arrow {params = List.map normalize_arg params; ret}; + } + | _ -> typ diff --git a/compiler/ml/ast_fixed_arg.mli b/compiler/ml/ast_fixed_arg.mli new file mode 100644 index 00000000000..71bef131619 --- /dev/null +++ b/compiler/ml/ast_fixed_arg.mli @@ -0,0 +1,23 @@ +(** Fixed external arguments, written [@as(value) _]. *) + +val of_payload : Parsetree.payload -> Parsetree.fixed_value Location.loc option +(** The fixed value denoted by an [@as] payload: an integer, a string, a + non-interpolated backquoted string, or a [json] literal. *) + +val to_expression : + ?loc:Location.t -> Parsetree.fixed_value -> Parsetree.expression +(** The payload expression that spells [value]. *) + +val to_attribute : + ?loc:Location.t -> Parsetree.fixed_value Location.loc -> Parsetree.attribute +(** The [@as] attribute that spells [value], with its name located at [loc]. *) + +val underscore_loc : Location.t -> Location.t +(** The location of the [_] that ends a fixed argument located at [loc]. *) + +val as_name_loc : Location.t -> Location.t +(** The location of the [@as] that starts a fixed argument located at [loc]. *) + +val normalize_external_type : Parsetree.core_type -> Parsetree.core_type +(** Turn the [@as(value) _] arguments of an external's type into + [Parg_fixed]. *) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 162c6753f7e..8931123e97b 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -73,7 +73,10 @@ module Typ = struct { params = List.map - (fun (arg : Parsetree.arg) -> {arg with typ = loop arg.typ}) + (function + | Parsetree.Parg_type arg -> + Parsetree.Parg_type {arg with typ = loop arg.typ} + | Parsetree.Parg_fixed _ as arg -> arg) params; ret = loop ret; } diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index d9eabd9de6e..a9ba4539829 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -101,7 +101,11 @@ module T = struct match desc with | Ptyp_any | Ptyp_var _ -> () | Ptyp_arrow {params; ret} -> - List.iter (fun (arg : Parsetree.arg) -> sub.typ sub arg.typ) params; + List.iter + (function + | Parsetree.Parg_type {typ} -> sub.typ sub typ + | Parsetree.Parg_fixed _ -> ()) + params; sub.typ sub ret | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl | Ptyp_constr (lid, tl) -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 09619a640d3..c32184d938a 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -100,7 +100,16 @@ module T = struct | Ptyp_arrow {params; ret} -> Typ.arrow ~loc ~attrs (List.map - (fun (arg : Parsetree.arg) -> {arg with typ = sub.typ sub arg.typ}) + (function + | Parsetree.Parg_type arg -> + Parsetree.Parg_type {arg with typ = sub.typ sub arg.typ} + | Parsetree.Parg_fixed arg -> + Parsetree.Parg_fixed + { + arg with + value = map_loc sub arg.value; + loc = sub.location sub arg.loc; + }) params) (sub.typ sub ret) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index a6da6241a72..3ad2d426cee 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -135,7 +135,7 @@ let map_constant ~loc = function Pconst_char {source = String_literal.encode_char_source semantic; semantic} | Pconst_string (s, Some ("js" | "*j")) -> source_string ~loc s | Pconst_string (s, None) -> semantic_string s - | Pconst_string (s, Some "json") -> Pconst_json s + | Pconst_string (s, Some "json") -> Pconst_raw_source s (* Other v0 quotation delimiters are syntax, not part of the string value. Tagged ReScript templates are represented as applications before PPX. *) | Pconst_string (semantic, Some _) -> semantic_string semantic @@ -314,7 +314,7 @@ module T = struct | None -> ([], attrs) in Typ.arrow ~loc ~attrs:node_attrs - [{attrs = arg_attrs; lbl; typ = sub.typ sub t1}] + [Parg_type {attrs = arg_attrs; lbl; typ = sub.typ sub t1}] (sub.typ sub t2) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> ( @@ -787,8 +787,11 @@ module E = struct ~attrs:(sub.attributes sub await_attrs0) inner | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant (Pconst_string (source, Some "json")) -> + let tag = ident ~loc (Location.mkloc (Longident.Lident "json") loc) in + tagged_template ~loc ~attrs tag [{txt = source; loc}] [] | Pexp_constant (Pconst_string (text, delimiter)) - when has_template_attr attrs && delimiter <> Some "json" -> + when has_template_attr attrs -> let attrs = remove_template_attr attrs in let source = template_source_from0 (text, delimiter) in template ~loc ~attrs [{txt = source; loc}] [] @@ -1479,7 +1482,15 @@ let default_mapper = Location.raise_errorf ~loc:pval_loc "An external declaration can carry only a single primitive string" in - Val.mk (map_loc this pval_name) (this.typ this pval_type) + let typ = this.typ this pval_type in + (* Like the parser, read an external's [@as(value) _] arguments as + fixed arguments. *) + let typ = + match prim with + | Some _ -> Ast_fixed_arg.normalize_external_type typ + | None -> typ + in + Val.mk (map_loc this pval_name) typ ~attrs:(this.attributes this pval_attributes) ~loc:(this.location this pval_loc) ?prim); diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 148a0eb0c0f..85d3ffd2cd7 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -81,7 +81,6 @@ let map_constant = function | Pconst_string payload -> Pconst_string (String_literal.string_source payload, Some "js") | Pconst_raw_source s -> Pconst_string (s, Some "js") - | Pconst_json s -> Pconst_string (s, Some "json") | Pconst_float (s, suffix) -> Pconst_float (s, suffix) let template_attr = (Location.mknoloc "res.template", Pt.PStr []) @@ -177,8 +176,37 @@ module T = struct match params with | [] -> sub.typ sub ret | (arg : Parsetree.arg) :: rest -> - let lbl = Asttypes.to_noloc arg.lbl in - let arg_attrs = sub.attributes sub arg.attrs in + let arg_lbl, arg_attrs, arg_typ0 = + match arg with + | Parg_type {attrs; lbl; typ} -> (lbl, attrs, sub.typ sub typ) + | Parg_fixed {attrs; lbl; value; loc} -> + (* v0 spells a fixed argument [_ [@as value]], with [json] as a + [json]-delimited string, as before [json] was an ordinary + tagged template. [@as] and [_] get their own locations, from + which [Ast_fixed_arg] restores the argument's. *) + let as_loc = Ast_fixed_arg.as_name_loc loc in + let as_attr = + match value.txt with + | Pfixed_json source -> + ( {txt = "as"; loc = as_loc}, + Pt.PStr + [ + Ast_helper0.Str.eval ~loc:value.loc + (Ast_helper0.Exp.constant ~loc:source.loc + (Pt.Pconst_string (source.txt, Some "json"))); + ] ) + | Pfixed_int _ | Pfixed_string _ | Pfixed_template _ -> + sub.attribute sub + (Ast_fixed_arg.to_attribute ~loc:as_loc value) + in + ( lbl, + attrs, + Ast_helper0.Typ.any + ~loc:(Ast_fixed_arg.underscore_loc loc) + ~attrs:[as_attr] () ) + in + let lbl = Asttypes.to_noloc arg_lbl in + let arg_attrs = sub.attributes sub arg_attrs in let is_head = List.length rest = arity - 1 in let merged_attrs = if is_head && attrs <> [] then @@ -190,10 +218,9 @@ module T = struct in let arrow_loc = if is_head then loc - else {loc with loc_start = arg.typ.ptyp_loc.loc_start} + else {loc with loc_start = arg_typ0.ptyp_loc.loc_start} in - arrow ~loc:arrow_loc ~attrs:merged_attrs lbl (sub.typ sub arg.typ) - (build rest) + arrow ~loc:arrow_loc ~attrs:merged_attrs lbl arg_typ0 (build rest) in let typ0 = build params in let arity_string = "Has_arity" ^ string_of_int arity in diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index cb04f540d7c..6f5295d5756 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -36,25 +36,6 @@ let unwrap_payload_expression (payload : t) = [{item with pstr_desc = Pstr_eval (unwrap_braces expression, attrs)}] | payload -> payload -let json_literal_outside_external_message = - "A `json` literal can only be used in an external attribute such as `@as`" - -let reject_json_literal ~loc = - Location.raise_errorf ~loc "%s" json_literal_outside_external_message - -let reject_json_literal_payload (payload : t) = - match unwrap_payload_expression payload with - | PStr - [ - { - pstr_desc = - Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_json _); pexp_loc; _}, _); - }; - ] -> - reject_json_literal ~loc:pexp_loc - | _ -> () - let semantic_string_of_expression (expression : Parsetree.expression) = match unwrap_braces expression with | {pexp_desc = Pexp_constant (Pconst_string payload); _} -> diff --git a/compiler/ml/ast_payload.mli b/compiler/ml/ast_payload.mli index 75a00cd8b90..8abd5d67cf4 100644 --- a/compiler/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -31,10 +31,6 @@ type lid = string Asttypes.loc type action = lid * Parsetree.expression option -val json_literal_outside_external_message : string -val reject_json_literal : loc:Location.t -> 'a -val reject_json_literal_payload : t -> unit - val unwrap_braces : Parsetree.expression -> Parsetree.expression (** Ignore explicit brace wrappers when interpreting an attribute payload. *) diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index f95b6074840..cfded53fe56 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -192,7 +192,6 @@ let process_tag_name (attrs : Parsetree.attributes) = match txt with | "tag" -> if !st = None then ( - Ast_payload.reject_json_literal_payload payload; (match Ast_payload.semantic_string_of_payload payload with | None -> () | Some s -> st := Some s); diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index 67c6132ab9e..6c4c06b28a6 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -16,9 +16,7 @@ open Asttypes open Parsetree -let string_of_payload payload = - Ast_payload.reject_json_literal_payload payload; - Ast_payload.semantic_string_of_payload payload +let string_of_payload payload = Ast_payload.semantic_string_of_payload payload let string_of_opt_payload p = match string_of_payload p with diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 3763262d1fb..a2e2240685f 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -99,7 +99,11 @@ let rec add_type bv ty = | Ptyp_any -> () | Ptyp_var _ -> () | Ptyp_arrow {params; ret} -> - List.iter (fun arg -> add_type bv arg.typ) params; + List.iter + (function + | Parg_type {typ} -> add_type bv typ + | Parg_fixed _ -> ()) + params; add_type bv ret | Ptyp_tuple tl -> List.iter (add_type bv) tl | Ptyp_constr (c, tl) -> diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 58327b4b021..bd865de669e 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -47,12 +47,6 @@ type constant = legacy three-digit decimal escapes to hexadecimal escapes. Compiler-created Payloads are constructed through [String_literal], which validates this relationship. *) - | Pconst_json of string - (* The JavaScript source inside a non-interpolated [json`...`] literal. For - example, [@as(json`{"ok": true}`)] stores ["{\"ok\": true}"]. Built-in - FFI processing consumes this form in supported external attributes; - otherwise the frontend rejects it. The string is JavaScript source, not a - decoded ReScript string value. *) | Pconst_raw_source of string (* JavaScript source carried by a compiler extension such as [raw] or [ffi]. For example, [%raw("x + 1")] stores ["x + 1"]. The extension @@ -101,7 +95,24 @@ and core_type = { ptyp_attributes: attributes; (* ... [@id1] [@id2] *) } -and arg = {attrs: attributes; lbl: arg_label; typ: core_type} +and arg = + | Parg_type of {attrs: attributes; lbl: arg_label; typ: core_type} + | Parg_fixed of { + attrs: attributes; + lbl: arg_label; + value: fixed_value loc; (* located at the payload *) + loc: Location.t; (* the whole argument, from [@as] to [_] *) + } +(* An external function argument whose value is fixed by the binding and + omitted at call sites, written [@as(value) _]. *) + +and fixed_value = + | Pfixed_int of string loc (* [@as(1)]: the integer literal's source *) + | Pfixed_string of String_literal.string_literal (* [@as("s")] *) + | Pfixed_template of string loc + (* [@as(`s`)]: the source between the backquotes *) + | Pfixed_json of string loc +(* [@as(json`{}`)]: the JavaScript source between the backquotes *) and core_type_desc = | Ptyp_any (* _ *) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index c188bc5438c..00bb5711e1c 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -252,8 +252,6 @@ let constant f = function | Pconst_string payload -> pp f "{js|%a|js}" print_string_with_byte_width (String_literal.string_source payload) - | Pconst_json source -> - pp f "{json|%a|json}" print_string_with_byte_width source | Pconst_raw_source source -> pp f "{js|%a|js}" print_string_with_byte_width source | Pconst_integer (i, None) -> paren (i.[0] = '-') (fun f -> pp f "%s") f i @@ -294,14 +292,24 @@ let tyvar_loc f str = pp f "'%s" str.txt let string_quot f x = pp f "`%s" x let rec type_with_label ctxt f arg = - match arg.lbl with - | Nolabel -> - pp f "%a%a" (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs - (* otherwise parenthesize *) + let attrs, lbl, typ = + match arg with + | Parg_type {attrs; lbl; typ} -> (attrs, lbl, typ) + | Parg_fixed {attrs; lbl; value; loc} -> + (* Printed in its legacy spelling, [_ [@as value]]. *) + ( attrs, + lbl, + Ast_helper.Typ.any ~loc + ~attrs:[Ast_fixed_arg.to_attribute ~loc value] + () ) + in + match lbl with + | Nolabel -> pp f "%a%a" (core_type1 ctxt) typ (attributes ctxt) attrs + (* otherwise parenthesize *) | Labelled {txt = s} -> - pp f "%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs + pp f "%s:%a%a" s (core_type1 ctxt) typ (attributes ctxt) attrs | Optional {txt = s} -> - pp f "?%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs + pp f "?%s:%a%a" s (core_type1 ctxt) typ (attributes ctxt) attrs and core_type ctxt f x = if x.ptyp_attributes <> [] then diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 22153df4717..574b3c7bb39 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -66,7 +66,6 @@ let fmt_constant f x = fprintf f "PConst_string (source=%S, semantic=%S)" (String_literal.string_source payload) (String_literal.string_semantic payload) - | Pconst_json source -> fprintf f "PConst_json %S" source | Pconst_raw_source source -> fprintf f "PConst_raw_source %S" source | Pconst_float (s, m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m @@ -128,6 +127,19 @@ let arg_label_loc i ppf = function | Optional {txt = s} -> line i ppf "Optional \"%s\"\n" s | Labelled {txt = s} -> line i ppf "Labelled \"%s\"\n" s +let fixed_value i ppf (x : fixed_value) = + match x with + | Pfixed_int source -> + line i ppf "Pfixed_int %s %a\n" source.txt fmt_location source.loc + | Pfixed_string payload -> + line i ppf "Pfixed_string (source=%S, semantic=%S)\n" + (String_literal.string_source payload) + (String_literal.string_semantic payload) + | Pfixed_template source -> + line i ppf "Pfixed_template %S %a\n" source.txt fmt_location source.loc + | Pfixed_json source -> + line i ppf "Pfixed_json %S %a\n" source.txt fmt_location source.loc + let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; attributes i ppf x.ptyp_attributes; @@ -139,10 +151,17 @@ let rec core_type i ppf x = line i ppf "Ptyp_arrow\n"; line i ppf "arity = %d\n" (List.length params); List.iter - (fun (arg : Parsetree.arg) -> - arg_label_loc i ppf arg.lbl; - attributes i ppf arg.attrs; - core_type i ppf arg.typ) + (function + | Parsetree.Parg_type {attrs; lbl; typ} -> + arg_label_loc i ppf lbl; + attributes i ppf attrs; + core_type i ppf typ + | Parsetree.Parg_fixed {attrs; lbl; value; loc} -> + arg_label_loc i ppf lbl; + attributes i ppf attrs; + line i ppf "Parg_fixed %a\n" fmt_location loc; + line (i + 1) ppf "value %a\n" fmt_location value.loc; + fixed_value (i + 2) ppf value.txt) params; core_type i ppf ret | Ptyp_tuple l -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 8934814cdeb..80618a82a77 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -946,9 +946,7 @@ let pack_trywith_exn id handler = let extract_directive_for_fn exp = exp.exp_attributes |> List.find_map (fun ({txt}, payload) -> - if txt = "directive" then ( - Ast_payload.reject_json_literal_payload payload; - Ast_payload.semantic_string_of_payload payload) + if txt = "directive" then Ast_payload.semantic_string_of_payload payload else None) let hoisted_function_attr_name = "res.hoistedFunction" diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index bca077aa4a6..38f4e491c1c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -85,7 +85,6 @@ type error = | Polyvar_literal_overflow | Unknown_literal of string * char | Invalid_string_escape_sequence - | Json_literal_outside_external | Illegal_letrec_pat | Empty_record_literal | Uncurried_arity_mismatch of { @@ -338,7 +337,6 @@ let constant : Parsetree.constant -> (Asttypes.constant, error) result = | Pconst_char {semantic} -> Ok (Const_char semantic) | Pconst_string payload -> Ok (Const_string (String_literal.string_semantic payload)) - | Pconst_json _ -> Error Json_literal_outside_external | Pconst_raw_source s -> Ok (Const_string s) | Pconst_float (f, None) -> Ok (Const_float f) | Pconst_float (f, Some c) -> Error (Unknown_literal (f, c)) @@ -2087,7 +2085,11 @@ let rec approx_type env sty = newty (Tarrow ( List.map - (fun ({lbl = p} : Parsetree.arg) -> + (fun (arg : Parsetree.arg) -> + let p = + match arg with + | Parg_type {lbl} | Parg_fixed {lbl} -> lbl + in { Types.lbl = p; typ = @@ -5395,8 +5397,6 @@ let report_error env loc ppf error = fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m | Invalid_string_escape_sequence -> fprintf ppf "Invalid string escape sequence" - | Json_literal_outside_external -> - fprintf ppf "%s" Ast_payload.json_literal_outside_external_message | Illegal_letrec_pat -> fprintf ppf "Only variables are allowed as left-hand side of `let rec`" | Empty_record_literal -> diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index fd4f8bd2548..cf38d410092 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -101,7 +101,6 @@ type error = | Polyvar_literal_overflow | Unknown_literal of string * char | Invalid_string_escape_sequence - | Json_literal_outside_external | Illegal_letrec_pat | Empty_record_literal | Uncurried_arity_mismatch of { diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 69c7984ac69..51a81a827fd 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -321,31 +321,32 @@ and transl_type_aux env policy styp = | Ptyp_arrow {params; ret} -> let cparams = List.map - (fun (arg : Parsetree.arg) -> - let cty = transl_type env policy arg.typ in - let ty = - if Btype.is_optional arg.lbl then - newty (Tconstr (Predef.path_option, [cty.ctyp_type], ref Mnil)) - else cty.ctyp_type - in - (arg, cty, ty)) + (function + | Parsetree.Parg_type {attrs; lbl; typ} -> + let cty = transl_type env policy typ in + let ty = + if Btype.is_optional lbl then + newty (Tconstr (Predef.path_option, [cty.ctyp_type], ref Mnil)) + else cty.ctyp_type + in + (attrs, lbl, cty, ty) + | Parsetree.Parg_fixed {loc} -> + (* External processing removes fixed arguments before typing. *) + Location.raise_errorf ~loc + "Fixed arguments are only allowed in external declarations") params in let cty2 = transl_type env policy ret in let ty = newty (Tarrow - ( List.map - (fun ((arg : Parsetree.arg), _, ty1) -> - {Types.lbl = arg.lbl; typ = ty1}) - cparams, + ( List.map (fun (_, lbl, _, ty1) -> {Types.lbl; typ = ty1}) cparams, cty2.ctyp_type )) in ctyp (Ttyp_arrow ( List.map - (fun ((arg : Parsetree.arg), cty1, _) -> - {Typedtree.attrs = arg.attrs; lbl = arg.lbl; typ = cty1}) + (fun (attrs, lbl, cty1, _) -> {Typedtree.attrs; lbl; typ = cty1}) cparams, cty2 )) ty diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 4dc97938f0f..4b6d01e5490 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -941,7 +941,7 @@ let rec collect_prop_types types {ptyp_desc} = in let rec go types = function | [] -> if ret_is_arrow then collect_prop_types types ret else types - | ({lbl; attrs; typ} : Parsetree.arg) :: rest + | Parsetree.Parg_type {lbl; attrs; typ} :: rest when is_labelled lbl || is_optional lbl -> let loc = match (rest, ret_is_arrow) with @@ -949,7 +949,8 @@ let rec collect_prop_types types {ptyp_desc} = | _ -> typ.ptyp_loc in go ((lbl, attrs, loc, typ) :: types) rest - | _ :: rest -> go types rest + | (Parsetree.Parg_type _ | Parsetree.Parg_fixed _) :: rest -> + go types rest in go types params | _ -> types diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 2cc860d3c40..72140ca7382 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -335,7 +335,7 @@ let arrow_type ct = let open Parsetree in match ct with | {ptyp_desc = Ptyp_arrow {params; ret}; ptyp_attributes = attrs} -> - (attrs, params |> List.map (fun (p : arg) -> (p.attrs, p.lbl, p.typ)), ret) + (attrs, params, ret) | typ -> ([], [], typ) (* TODO: avoiding the dependency on Parsetree_viewer here, is this a good idea? *) @@ -2244,21 +2244,34 @@ and walk_object_field field t comments = and walk_type_parameters type_parameters t comments = visit_list_but_continue_with_remaining_comments - ~get_loc:(fun (_, lbl, typexpr) -> + ~get_loc:(fun parameter -> + let lbl, end_loc = + match parameter with + | Parsetree.Parg_type {lbl; typ} -> (lbl, typ.ptyp_loc) + | Parsetree.Parg_fixed {lbl; loc} -> + (lbl, Ast_fixed_arg.underscore_loc loc) + in let lbl_loc = Asttypes.get_lbl_loc lbl in - if lbl_loc <> Location.none then - {lbl_loc with loc_end = typexpr.Parsetree.ptyp_loc.loc_end} - else typexpr.ptyp_loc) + if lbl_loc <> Location.none then {lbl_loc with loc_end = end_loc.loc_end} + else end_loc) ~walk_node:walk_type_parameter ~newline_delimited:false type_parameters t comments -and walk_type_parameter (_attrs, _lbl, typexpr) t comments = - let before_typ, inside_typ, after_typ = - partition_by_loc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc before_typ; - walk_core_type typexpr t inside_typ; - attach t.trailing typexpr.ptyp_loc after_typ +and walk_type_parameter parameter t comments = + match parameter with + | Parsetree.Parg_type {typ = typexpr} -> + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Parsetree.Parg_fixed {loc} -> + (* Like the [_] it is written with, which is where its comments go. *) + let loc = Ast_fixed_arg.underscore_loc loc in + let before, after = partition_leading_trailing comments loc in + attach t.leading loc before; + attach t.trailing loc after and walk_package_type package_type t comments = let longident, package_constraints = package_type in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 2eeab13eb84..b990394e08b 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -2442,16 +2442,6 @@ and parse_template_expr ?prefix p = in match prefix with - | Some {txt = Longident.Lident "json"; _} -> ( - match (parts, values) with - | [(source, loc, None)], [] -> - Ast_helper.Exp.constant ~loc (Pconst_json source) - | (source, loc, _) :: _, _ -> - Parser.err ~start_pos:template_loc.loc_start ~end_pos:template_loc.loc_end - p - (Diagnostics.message "`json` literals do not support interpolation"); - Ast_helper.Exp.constant ~loc (Pconst_json source) - | [], _ -> assert false) | None -> List.iter (fun ({Location.txt = source; loc} : string Location.loc) -> @@ -4309,7 +4299,9 @@ and parse_poly_type_expr ?current_type_name_path ?inline_types_context p = let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc typ.Parsetree.ptyp_loc.loc_start (Parser.position p) in - Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ}] return_type + Ast_helper.Typ.arrow ~loc + [Parg_type {attrs = []; lbl = Nolabel; typ}] + return_type | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) | _ -> parse_typ_expr ?current_type_name_path ?inline_types_context p @@ -4735,7 +4727,7 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p arrow, exactly like its parenthesized form [(~x: t) => u]; it must carry the same arity or the two spellings produce types that print identically but do not unify. *) - Ast_helper.Typ.arrow ~loc [{attrs; lbl; typ}] return_type + Ast_helper.Typ.arrow ~loc [Parg_type {attrs; lbl; typ}] return_type | DocComment _ -> assert false | _ -> ( let parameters = @@ -4753,7 +4745,7 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p let params = List.map (fun {attrs; label = arg_lbl; typ; start_pos = _} -> - {Parsetree.attrs; lbl = arg_lbl; typ}) + Parsetree.Parg_type {attrs; lbl = arg_lbl; typ}) parameters in let loc = mk_loc start_pos (Parser.position p) in @@ -4826,7 +4818,9 @@ and parse_arrow_type_rest ?current_type_name_path ?inline_types_context ?inline_types_context p in let loc = mk_loc start_pos (Parser.position p) in - Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ}] return_type + Ast_helper.Typ.arrow ~loc + [Parg_type {attrs = []; lbl = Nolabel; typ}] + return_type | _ -> typ and parse_typ_expr_region p = @@ -5598,7 +5592,7 @@ and parse_type_equation_or_constr_decl p = let loc = mk_loc uident_start_pos (Parser.position p) in let arrow_type = Ast_helper.Typ.arrow ~loc - [{attrs = []; lbl = Nolabel; typ}] + [Parg_type {attrs = []; lbl = Nolabel; typ}] return_type in let typ = parse_type_alias p arrow_type in @@ -6291,6 +6285,7 @@ and parse_external_def ~attrs ~start_pos p = in let typ_expr = parse_external_type_expr ~current_type_name_path ~inline_types_context p + |> Ast_fixed_arg.normalize_external_type in let equal_start = Parser.start_pos p in let equal_end = Parser.end_pos p in diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index ce789d733f4..9cfa1954242 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -227,7 +227,7 @@ let is_multiline_text txt = let is_huggable_expression expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ - | Pexp_constant (Pconst_json _ | Pconst_char _) + | Pexp_constant (Pconst_char _) | Pexp_template {values = []} | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) | Pexp_object_literal _ | Pexp_record _ | Pexp_braces _ -> diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index ceb4c551dc2..910d699fec0 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -665,8 +665,6 @@ let print_constant c = print_string_contents (String_literal.string_source payload); Doc.text "\""; ] - | Pconst_json source -> - Doc.concat [Doc.text "json`"; print_string_contents source; Doc.text "`"] | Pconst_raw_source source -> let delimiter = if raw_source_fits_double_quotes source then "\"" else "`" @@ -1993,7 +1991,10 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) in match args with | [] -> Doc.nil - | [{attrs = []; lbl = Nolabel; typ}] -> + | [ + (( Parg_type {attrs = []; lbl = Nolabel} + | Parg_fixed {attrs = []; lbl = Nolabel} ) as arg); + ] -> let has_attrs_before = not (attrs_before = []) in let attrs = if has_attrs_before then @@ -2001,12 +2002,16 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) else Doc.nil in let typ_doc = - let doc = - print_typ_expr ?inline_record_definitions ~state typ cmt_tbl - in - match typ.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> add_parens doc - | _ -> doc + match arg with + | Parg_type {typ} -> ( + let doc = + print_typ_expr ?inline_record_definitions ~state typ cmt_tbl + in + match typ.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> add_parens doc + | _ -> doc) + | Parg_fixed _ -> + print_type_parameter ?inline_record_definitions ~state arg cmt_tbl in Doc.group (Doc.concat @@ -2398,8 +2403,29 @@ and print_object_field ~state (field : Parsetree.object_field) cmt_tbl = (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) -and print_type_parameter ?inline_record_definitions ~state {attrs; lbl; typ} - cmt_tbl = +and print_type_parameter ?inline_record_definitions ~state parameter cmt_tbl = + let attrs, lbl, value_doc, end_loc = + match parameter with + | Parsetree.Parg_type {attrs; lbl; typ} -> + ( attrs, + lbl, + print_typ_expr ?inline_record_definitions ~state typ cmt_tbl, + typ.ptyp_loc ) + | Parsetree.Parg_fixed {attrs; lbl; value; loc} -> + (* Comments go around [@as(...) _], as for the [_] it is written with. *) + let loc = Ast_fixed_arg.underscore_loc loc in + let as_doc, _ = + print_attribute ~state + (Ast_fixed_arg.to_attribute {value with loc = Location.none}) + cmt_tbl + in + ( attrs, + lbl, + print_comments + (Doc.group (Doc.concat [as_doc; Doc.space; Doc.text "_"])) + cmt_tbl loc, + loc ) + in (* Converting .ml code to .res requires processing uncurried attributes *) let attrs = print_attributes ~state attrs cmt_tbl in let label = @@ -2415,16 +2441,8 @@ and print_type_parameter ?inline_record_definitions ~state {attrs; lbl; typ} | Nolabel | Labelled _ -> Doc.nil | Optional _ -> Doc.text "=?" in - let loc = {(Asttypes.get_lbl_loc lbl) with loc_end = typ.ptyp_loc.loc_end} in - let doc = - Doc.group - (Doc.concat - [ - attrs; - label; - print_typ_expr ?inline_record_definitions ~state typ cmt_tbl; - ]) - in + let loc = {(Asttypes.get_lbl_loc lbl) with loc_end = end_loc.loc_end} in + let doc = Doc.group (Doc.concat [attrs; label; value_doc]) in (* [loc] ends before [=?]. *) print_comments_before_marker doc cmt_tbl loc optional_indicator diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 524f40baee1..fdf23273eee 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -244,7 +244,6 @@ Source: `type error` in [typecore.ml](../compiler/ml/typecore.ml). | `Polyvar_literal_overflow` | ✓ | `polyvar_int_overflow.res`, `polyvar_int_overflow_payload.res`, `polyvar_int_overflow_pattern.res` | | | `Unknown_literal` | ✓ | `unknown_literal.res` | | | `Invalid_string_escape_sequence` | ☐ | — | Regular source is rejected by the parser; the typer check remains defensive for malformed AST produced by a PPX. `syntaxErrors_invalid_ordinary_template_escape.res` covers the parser diagnostic. | -| `Json_literal_outside_external` | ✓ | `json_literal_outside_external.res` | Constant `json` payloads are reserved for external attributes such as `@as`. | | `Illegal_letrec_pat` | ✓ | `illegal_letrec_pat.res` | | | `Empty_record_literal` | ✓ | `empty_record_literal.res` | | | `Uncurried_arity_mismatch` | ✓ | `arity_mismatch3.res` etc. | | diff --git a/tests/build_tests/super_errors/expected/json_literal_inline.res.expected b/tests/build_tests/super_errors/expected/json_literal_inline.res.expected deleted file mode 100644 index 0e6bf0eab50..00000000000 --- a/tests/build_tests/super_errors/expected/json_literal_inline.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/json_literal_inline.res:2:17-28 - - 1 │ @inline - 2 │ let value = json`{foo: true}` - 3 │ - - A `json` literal can only be used in an external attribute such as `@as` \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/json_literal_inline_payload.res.expected b/tests/build_tests/super_errors/expected/json_literal_inline_payload.res.expected deleted file mode 100644 index 349ce978301..00000000000 --- a/tests/build_tests/super_errors/expected/json_literal_inline_payload.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/json_literal_inline_payload.res:1:13-17 - - 1 │ @inline(json`null`) - 2 │ let value = "ignored" - 3 │ - - A `json` literal can only be used in an external attribute such as `@as` \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/json_literal_outside_external.res.expected b/tests/build_tests/super_errors/expected/json_literal_outside_external.res.expected deleted file mode 100644 index 258909bc038..00000000000 --- a/tests/build_tests/super_errors/expected/json_literal_outside_external.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/json_literal_outside_external.res:1:17-29 - - 1 │ let value = json`{answer: 42}` - 2 │ - - A `json` literal can only be used in an external attribute such as `@as` \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/json_literal_todo_payload.res.expected b/tests/build_tests/super_errors/expected/json_literal_todo_payload.res.expected deleted file mode 100644 index 4998cb09352..00000000000 --- a/tests/build_tests/super_errors/expected/json_literal_todo_payload.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/json_literal_todo_payload.res:1:23-30 - - 1 │ let value = %todo(json`message`) - 2 │ - - A `json` literal can only be used in an external attribute such as `@as` \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/syntaxErrors_json_interpolation.res.expected b/tests/build_tests/super_errors/expected/syntaxErrors_json_interpolation.res.expected index 9476845ce36..fcc02fbe5c8 100644 --- a/tests/build_tests/super_errors/expected/syntaxErrors_json_interpolation.res.expected +++ b/tests/build_tests/super_errors/expected/syntaxErrors_json_interpolation.res.expected @@ -1,8 +1,8 @@ - Syntax error! - /.../fixtures/syntaxErrors_json_interpolation.res:1:17-35 + We've found a bug for you! + /.../fixtures/syntaxErrors_json_interpolation.res:1:13-16 - 1 │ let value = json`head${"value"}tail` + 1 │ let value = json`head${"value"}tail` 2 │ - `json` literals do not support interpolation \ No newline at end of file + The value json can't be found \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/json_literal_inline.res b/tests/build_tests/super_errors/fixtures/json_literal_inline.res deleted file mode 100644 index c496f5e47c9..00000000000 --- a/tests/build_tests/super_errors/fixtures/json_literal_inline.res +++ /dev/null @@ -1,2 +0,0 @@ -@inline -let value = json`{foo: true}` diff --git a/tests/build_tests/super_errors/fixtures/json_literal_inline_payload.res b/tests/build_tests/super_errors/fixtures/json_literal_inline_payload.res deleted file mode 100644 index 285bd2605c1..00000000000 --- a/tests/build_tests/super_errors/fixtures/json_literal_inline_payload.res +++ /dev/null @@ -1,2 +0,0 @@ -@inline(json`null`) -let value = "ignored" diff --git a/tests/build_tests/super_errors/fixtures/json_literal_outside_external.res b/tests/build_tests/super_errors/fixtures/json_literal_outside_external.res deleted file mode 100644 index e5fcc0bb2c3..00000000000 --- a/tests/build_tests/super_errors/fixtures/json_literal_outside_external.res +++ /dev/null @@ -1 +0,0 @@ -let value = json`{answer: 42}` diff --git a/tests/build_tests/super_errors/fixtures/json_literal_todo_payload.res b/tests/build_tests/super_errors/fixtures/json_literal_todo_payload.res deleted file mode 100644 index df4ea11cb6a..00000000000 --- a/tests/build_tests/super_errors/fixtures/json_literal_todo_payload.res +++ /dev/null @@ -1 +0,0 @@ -let value = %todo(json`message`) diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 2130d516963..d0c42263afb 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -238,6 +238,110 @@ let test_constructor_runtime_tag_reaches_ast0_as_an_attribute _ = OUnit.assert_bool "Expected a plain @as attribute on the ast0 wire" (has_attr "as" constructor0.pcd_attributes) +let test_fixed_argument_roundtrips_through_ast0 _ = + (* [@as(1) _, int] *) + let fixed_loc = source_loc 1 9 and value_loc = source_loc 5 6 in + let value = + { + Location.txt = Parsetree.Pfixed_int {txt = "1"; loc = value_loc}; + loc = value_loc; + } + in + let int_type = + Ast_helper.Typ.constr ~loc (Location.mknoloc (Longident.Lident "int")) [] + in + let typ = + Ast_helper.Typ.arrow ~loc + [ + Parg_fixed {attrs = []; lbl = Nolabel; value; loc = fixed_loc}; + Parg_type {attrs = []; lbl = Nolabel; typ = int_type}; + ] + int_type + in + let vd = + Ast_helper.Val.mk ~prim:(Parsetree.Prim_name "f") (Location.mknoloc "f") typ + in + let vd0 = + Ast_mapper_to0.default_mapper.value_description + Ast_mapper_to0.default_mapper vd + in + (* v0 spells a fixed argument [_ [@as 1]], as before it had its own node. *) + (match vd0.pval_type.ptyp_desc with + | Ptyp_constr (_, [{ptyp_desc = Ptyp_arrow (Nolabel, arg0, _)}; _]) -> ( + match arg0 with + | { + ptyp_desc = Ptyp_any; + ptyp_attributes = + [ + ( {txt = "as"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ( {pexp_desc = Pexp_constant (Pconst_integer ("1", None))}, + [] ); + }; + ] ); + ]; + } -> + () + | _ -> assert_failure "Expected [_ [@as 1]] on the ast0 wire") + | _ -> assert_failure "Expected an external arrow on the ast0 wire"); + let vd' = + Ast_mapper_from0.default_mapper.value_description + Ast_mapper_from0.default_mapper vd0 + in + match vd'.pval_type.ptyp_desc with + | Ptyp_arrow + { + params = + [ + Parg_fixed {attrs = []; lbl = Nolabel; value = value'; loc}; + Parg_type _; + ]; + } -> + OUnit.assert_equal value value'; + OUnit.assert_equal fixed_loc loc + | _ -> assert_failure "Expected the fixed argument back from ast0" + +let test_fixed_argument_is_external_only _ = + (* A non-external arrow keeps [@as(1) _] as an ordinary argument. *) + let any_as = + Ast_helper.Typ.any ~loc + ~attrs: + [ + ( Location.mknoloc "as", + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant (Pconst_integer ("1", None))); + ] ); + ] + () + in + let typ = + Ast_helper.Typ.arrow ~loc + [Parg_type {attrs = []; lbl = Nolabel; typ = any_as}] + (Ast_helper.Typ.any ()) + in + let vd = Ast_helper.Val.mk (Location.mknoloc "f") typ in + let roundtrip vd = + Ast_mapper_from0.default_mapper.value_description + Ast_mapper_from0.default_mapper + (Ast_mapper_to0.default_mapper.value_description + Ast_mapper_to0.default_mapper vd) + in + (match (roundtrip vd).pval_type.ptyp_desc with + | Ptyp_arrow {params = [Parg_type _]} -> () + | _ -> assert_failure "Expected an ordinary argument in a value declaration"); + match + (roundtrip {vd with pval_prim = Some (Parsetree.Prim_name "f")}).pval_type + .ptyp_desc + with + | Ptyp_arrow {params = [Parg_fixed _]} -> () + | _ -> assert_failure "Expected a fixed argument in an external" + let map_expr0 e = Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e @@ -1455,12 +1559,20 @@ let test_string_literals_roundtrip_through_ast0 _ = (String_literal.string_semantic payload) | _ -> assert_failure "Expected a string pattern after ast0 roundtrip"); let json_expr = - Ast_helper.Exp.constant ~loc (Parsetree.Pconst_json {|{"answer":42}|}) + Ast_helper.Exp.tagged_template ~loc + (Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "json") loc)) + [located_string {|{"answer":42}|}] + [] in (match (map_expr0 (map_expr_to0 json_expr)).pexp_desc with - | Pexp_constant (Pconst_json actual) -> + | Pexp_tagged_template + { + tag = {pexp_desc = Pexp_ident {txt = Lident "json"}}; + raw_sources = [{txt = actual}]; + values = []; + } -> OUnit.assert_equal ~printer:(Printf.sprintf "%S") {|{"answer":42}|} actual - | _ -> assert_failure "Expected a JSON literal"); + | _ -> assert_failure "Expected a legacy json tagged template"); let char_pattern = Ast_helper.Pat.constant ~loc (Parsetree.Pconst_char {source = {|\u{61}|}; semantic = 0x61}) @@ -2175,4 +2287,8 @@ let suites = "constructor_runtime_tag_reaches_ast0_as_an_attribute" >:: test_constructor_runtime_tag_reaches_ast0_as_an_attribute; "ppx_context_on_the_wire" >:: test_ppx_context_on_the_wire; + "fixed_argument_roundtrips_through_ast0" + >:: test_fixed_argument_roundtrips_through_ast0; + "fixed_argument_is_external_only" + >:: test_fixed_argument_is_external_only; ] diff --git a/tests/ounit_tests/ounit_string_literal_tests.ml b/tests/ounit_tests/ounit_string_literal_tests.ml index 2aa1f5fde08..a4a879cbd0d 100644 --- a/tests/ounit_tests/ounit_string_literal_tests.ml +++ b/tests/ounit_tests/ounit_string_literal_tests.ml @@ -244,13 +244,36 @@ let assert_tagged_template_location () = pexp_loc.loc_end.pos_cnum | _ -> OUnit.assert_failure "expected a parsed tagged template" -let assert_invalid_json_interpolation () = +let assert_json_interpolation_is_a_tagged_template () = let result = Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:{|let value = json`head${item}tail`|} in - OUnit.assert_bool "expected JSON interpolation to be rejected" result.invalid + match result.parsetree with + | [ + { + pstr_desc = + Pstr_value + ( _, + [ + { + pvb_expr = + { + pexp_desc = + Pexp_tagged_template + { + tag = {pexp_desc = Pexp_ident {txt = Lident "json"}}; + raw_sources = [_; _]; + values = [_]; + }; + }; + }; + ] ); + }; + ] -> + () + | _ -> OUnit.assert_failure "expected an ordinary tagged template" let assert_int_equal expected actual = OUnit.assert_equal ~printer:string_of_int expected actual @@ -354,6 +377,14 @@ let template_payload source = Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.template [located_string source] [])] +let tagged_payload tag source = + let tag = Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident tag)) in + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.tagged_template tag [located_string source] []); + ] + let suites = __FILE__ >::: [ @@ -441,7 +472,7 @@ let suites = >:: fun _ -> assert_parsed_template (); assert_tagged_template_location (); - assert_invalid_json_interpolation () ); + assert_json_interpolation_is_a_tagged_template () ); ( "template expression escapes are parser diagnostics" >:: fun _ -> List.iter assert_invalid_template_expression [{|bad \xZZ escape|}; {|a\1b|}; {|a\01b|}; {|a\8b|}] ); @@ -519,10 +550,7 @@ let suites = (Asttypes.Const_string "a\n😀") semantic; OUnit.assert_equal ~printer:Ext_obj.dump (Ast_helper.Const.string "a\n😀") - (Untypeast.constant semantic); - OUnit.assert_equal ~printer:Ext_obj.dump - (Error Typecore.Json_literal_outside_external) - (Typecore.constant (Parsetree.Pconst_json {|{"answer":42}|})) ); + (Untypeast.constant semantic) ); ( "constant backquoted attribute strings become semantic" >:: fun _ -> OUnit.assert_equal ~printer:Ext_obj.dump (Some "a\n😀") (Ast_payload.semantic_string_of_payload @@ -535,7 +563,7 @@ let suites = ]); OUnit.assert_equal ~printer:Ext_obj.dump None (Ast_payload.semantic_string_of_payload - (string_payload (Pconst_json {|{"answer":42}|}))); + (tagged_payload "json" {|{"answer":42}|})); match Ast_payload.semantic_string_of_payload (template_payload {|\uD800|}) diff --git a/tests/syntax_tests/data/ast-mapping/FixedExternal.res b/tests/syntax_tests/data/ast-mapping/FixedExternal.res new file mode 100644 index 00000000000..9c9a31b3f06 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/FixedExternal.res @@ -0,0 +1,5 @@ +@val external json: (@as(json`{"a": [1, 2]}`) _, int) => int = "f" +@val external strings: (@as("s") _, @as(`t`) _, int) => int = "f" +@val external labelled: (~mode: @as(1) _, ~other: @as("o") _, int) => int = "f" +@obj external obj: (~a: @as(1) _, ~b: int, unit) => _ = "" +@val external single: @as(-1) _ => int = "f" diff --git a/tests/syntax_tests/data/ast-mapping/expected/FixedExternal.res.txt b/tests/syntax_tests/data/ast-mapping/expected/FixedExternal.res.txt new file mode 100644 index 00000000000..9c9a31b3f06 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/FixedExternal.res.txt @@ -0,0 +1,5 @@ +@val external json: (@as(json`{"a": [1, 2]}`) _, int) => int = "f" +@val external strings: (@as("s") _, @as(`t`) _, int) => int = "f" +@val external labelled: (~mode: @as(1) _, ~other: @as("o") _, int) => int = "f" +@obj external obj: (~a: @as(1) _, ~b: int, unit) => _ = "" +@val external single: @as(-1) _ => int = "f" diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/es6template.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/es6template.res.txt index 1de94e6031a..c326581be79 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/es6template.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/es6template.res.txt @@ -32,7 +32,7 @@ let s = :) ` let s = `$dollar without $braces $interpolation` -let s = {json|null|json} +let s = json`null` let x = `foo\`bar\$\\foo` let x = `foo\`bar\$\\foo${a} \` ${b} \` xx` let thisIsFine = `$something` diff --git a/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt b/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt new file mode 100644 index 00000000000..f42926e2320 --- /dev/null +++ b/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt @@ -0,0 +1,28 @@ +@val +external unsafeAddStyle: (@as(json`{}`) _, t, {..}) => t = "Object.assign" + +@module("react") +external useEffect0: (unit => option unit>, @as(json`[]`) _) => unit = "useEffect" + +@send external createElement: (document, @as("img") _) => element = "createElement" + +@val external templateString: (@as(`ab`) _, int) => int = "f" + +@val external numbers: (@as(1) _, @as(-1) _, @as(0x10) _, int) => int = "f" + +@obj +external makeOptions: ( + ~objectMode: @as(false) _, + ~name: string, + ~mode: @as("fast") _, + unit, +) => options = "" + +@val external single: @as(1) _ => int = "f" + +@val external attributes: (@foo @as(1) _, @as(1) @foo _, @as({1}) _, int) => int = "f" + +@val +external commented: (/* a */ /* b */ @as(1) _ /* c */, /* d */ @as("s") _, int) => int = "f" + +type notExternal = (@as(1) _, int) => int diff --git a/tests/syntax_tests/data/printer/typexpr/fixedExternal.res b/tests/syntax_tests/data/printer/typexpr/fixedExternal.res new file mode 100644 index 00000000000..af8169afd30 --- /dev/null +++ b/tests/syntax_tests/data/printer/typexpr/fixedExternal.res @@ -0,0 +1,22 @@ +@val +external unsafeAddStyle: (@as(json`{}`) _, t, {..}) => t = "Object.assign" + +@module("react") +external useEffect0: (unit => option unit>, @as(json`[]`) _) => unit = "useEffect" + +@send external createElement: (document, @as("img") _) => element = "createElement" + +@val external templateString: (@as(`ab`) _, int) => int = "f" + +@val external numbers: (@as(1) _, @as(-1) _, @as(0x10) _, int) => int = "f" + +@obj external makeOptions: (~objectMode: @as(false) _, ~name: string, ~mode: @as("fast") _, unit) => options = "" + +@val external single: @as(1) _ => int = "f" + +@val external attributes: (@foo @as(1) _, @as(1) @foo _, @as({1}) _, int) => int = "f" + +@val +external commented: (/* a */ @as(1) /* b */ _ /* c */, @as(/* d */ "s") _, int) => int = "f" + +type notExternal = (@as(1) _, int) => int diff --git a/tests/tests/src/tagged_template_test.mjs b/tests/tests/src/tagged_template_test.mjs index 839c31017fe..efb0d26eba9 100644 --- a/tests/tests/src/tagged_template_test.mjs +++ b/tests/tests/src/tagged_template_test.mjs @@ -20,6 +20,10 @@ let id = "5"; let queryWithModule = sql`SELECT * FROM ${table} WHERE id = ${id}`; +let json = Tagged_template_libJs.sql; + +let jsonTaggedQuery = json`SELECT * FROM ${table}`; + let query = sql` " SELECT * FROM ${table} WHERE id = ${id}`; @@ -67,33 +71,34 @@ let rawTag = Tagged_template_libJs.rawTag; let rawResult = rawTag`a ${1} b ${2} c`; Mocha.describe("tagged templates", () => { - Mocha.test("with externals, it should return a string with the correct interpolations", () => Test_utils.eq("File \"tagged_template_test.res\", line 92, characters 6-13", query, ` + Mocha.test("with externals, it should return a string with the correct interpolations", () => Test_utils.eq("File \"tagged_template_test.res\", line 99, characters 6-13", query, ` " SELECT * FROM 'users' WHERE id = '5'`)); - Mocha.test("with module scoped externals, it should also return a string with the correct interpolations", () => Test_utils.eq("File \"tagged_template_test.res\", line 101, characters 13-20", queryWithModule, "SELECT * FROM 'users' WHERE id = '5'")); - Mocha.test("with externals, it should return the result of the function", () => Test_utils.eq("File \"tagged_template_test.res\", line 104, characters 79-86", length$1, 52)); - Mocha.test("with a runtime-constructed tag (factory), it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 107, characters 7-14", factoryQuery, "PREFIX SELECT * FROM 'users'")); - Mocha.test("with a tag from a bare package import, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 113, characters 7-14", bareImportQuery, "PG: SELECT * FROM 'users'")); - Mocha.test("with a tag passed as a function argument, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 117, characters 7-14", paramQuery, "SELECT id = '5'")); - Mocha.test("with a tag imported from another module, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 121, characters 7-14", crossModuleQuery, "X: SELECT * FROM 'users'")); + Mocha.test("with module scoped externals, it should also return a string with the correct interpolations", () => Test_utils.eq("File \"tagged_template_test.res\", line 108, characters 13-20", queryWithModule, "SELECT * FROM 'users' WHERE id = '5'")); + Mocha.test("a tag named json remains an ordinary tagged template", () => Test_utils.eq("File \"tagged_template_test.res\", line 112, characters 7-14", jsonTaggedQuery, "SELECT * FROM 'users'")); + Mocha.test("with externals, it should return the result of the function", () => Test_utils.eq("File \"tagged_template_test.res\", line 115, characters 79-86", length$1, 52)); + Mocha.test("with a runtime-constructed tag (factory), it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 118, characters 7-14", factoryQuery, "PREFIX SELECT * FROM 'users'")); + Mocha.test("with a tag from a bare package import, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 124, characters 7-14", bareImportQuery, "PG: SELECT * FROM 'users'")); + Mocha.test("with a tag passed as a function argument, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 128, characters 7-14", paramQuery, "SELECT id = '5'")); + Mocha.test("with a tag imported from another module, it should emit tagged-template syntax", () => Test_utils.eq("File \"tagged_template_test.res\", line 132, characters 7-14", crossModuleQuery, "X: SELECT * FROM 'users'")); Mocha.test("it should call the tag as a real tagged template (TemplateStringsArray with .raw)", () => { - Test_utils.eq("File \"tagged_template_test.res\", line 125, characters 7-14", rawResult.hasRaw, true); - Test_utils.eq("File \"tagged_template_test.res\", line 126, characters 7-14", rawResult.cooked, [ + Test_utils.eq("File \"tagged_template_test.res\", line 136, characters 7-14", rawResult.hasRaw, true); + Test_utils.eq("File \"tagged_template_test.res\", line 137, characters 7-14", rawResult.cooked, [ "a ", " b ", " c" ]); - Test_utils.eq("File \"tagged_template_test.res\", line 127, characters 7-14", rawResult.raw, [ + Test_utils.eq("File \"tagged_template_test.res\", line 138, characters 7-14", rawResult.raw, [ "a ", " b ", " c" ]); - Test_utils.eq("File \"tagged_template_test.res\", line 128, characters 7-14", rawResult.values, [ + Test_utils.eq("File \"tagged_template_test.res\", line 139, characters 7-14", rawResult.values, [ 1, 2 ]); }); - Mocha.test("with a ReScript tag lifted via TaggedTemplate.make, it should return the correct interpolation", () => Test_utils.eq("File \"tagged_template_test.res\", line 133, characters 13-20", greeting, "hello Ada you're 36 years old!")); - Mocha.test("a regular string interpolation should continue working", () => Test_utils.eq("File \"tagged_template_test.res\", line 137, characters 7-14", `some random string interpolation`, "some random string interpolation")); + Mocha.test("with a ReScript tag lifted via TaggedTemplate.make, it should return the correct interpolation", () => Test_utils.eq("File \"tagged_template_test.res\", line 144, characters 13-20", greeting, "hello Ada you're 36 years old!")); + Mocha.test("a regular string interpolation should continue working", () => Test_utils.eq("File \"tagged_template_test.res\", line 148, characters 7-14", `some random string interpolation`, "some random string interpolation")); Mocha.test("ordinary interpolation evaluates values once from left to right", () => { let calls = []; let record = value => { @@ -101,15 +106,15 @@ Mocha.describe("tagged templates", () => { return value; }; let result = `start ${record("first")} middle ${record("second")} end`; - Test_utils.eq("File \"tagged_template_test.res\", line 147, characters 7-14", result, "start first middle second end"); - Test_utils.eq("File \"tagged_template_test.res\", line 148, characters 7-14", calls, [ + Test_utils.eq("File \"tagged_template_test.res\", line 158, characters 7-14", result, "start first middle second end"); + Test_utils.eq("File \"tagged_template_test.res\", line 159, characters 7-14", calls, [ "first", "second" ]); }); Mocha.test("invalid escapes remain valid in tagged-template segments", () => { let result = rawTag`\unicode`; - Test_utils.eq("File \"tagged_template_test.res\", line 153, characters 7-14", result.raw, ["\\unicode"]); + Test_utils.eq("File \"tagged_template_test.res\", line 164, characters 7-14", result.raw, ["\\unicode"]); }); }); @@ -120,6 +125,8 @@ export { table, id, queryWithModule, + json, + jsonTaggedQuery, query, extraLength, length$1 as length, diff --git a/tests/tests/src/tagged_template_test.res b/tests/tests/src/tagged_template_test.res index aa61e166607..afa20e9e5c9 100644 --- a/tests/tests/src/tagged_template_test.res +++ b/tests/tests/src/tagged_template_test.res @@ -13,6 +13,13 @@ let id = "5" let queryWithModule = Pg.sql`SELECT * FROM ${table} WHERE id = ${id}` +// `json` is not reserved: outside the legacy fixed-external parameter shape, +// it behaves exactly like every other tagged-template identifier. +@module("./tagged_template_lib.js") +external json: taggedTemplate = "sql" + +let jsonTaggedQuery = json`SELECT * FROM ${table}` + // The tag still emits backticks when used through `open` (i.e. once it has // crossed the module boundary as a value of the `taggedTemplate` type). open Pg @@ -101,6 +108,10 @@ describe("tagged templates", () => { () => eq(__LOC__, queryWithModule, "SELECT * FROM 'users' WHERE id = '5'"), ) + test("a tag named json remains an ordinary tagged template", () => + eq(__LOC__, jsonTaggedQuery, "SELECT * FROM 'users'") + ) + test("with externals, it should return the result of the function", () => eq(__LOC__, length, 52)) test("with a runtime-constructed tag (factory), it should emit tagged-template syntax", () => diff --git a/tools/src/tools.ml b/tools/src/tools.ml index d1a80b92638..b8bd83d2abe 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -866,7 +866,6 @@ module Format_codeblocks = struct match (name, payload) with | {txt = "res.doc"}, PStr [{pstr_desc = Pstr_eval ({pexp_loc}, _)}] -> ( - Ast_payload.reject_json_literal_payload payload; match Ast_payload.semantic_string_of_payload payload with | Some contents -> let formatted_contents, had_code_blocks = From 99b7a845756b627c5ad0e844f17efb6ad7bdfea3 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 16 Oct 2026 12:53:00 +0000 Subject: [PATCH 2/3] Map fixed-argument locations in the AST mappers and iterator Relocating mappers now reach every location of a fixed argument, including the ones `Ast_mapper_to0` synthesizes for the v0 spelling. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01NP47qMfjMbjUTKZDsLthDo Signed-off-by: Christoph Knittel --- compiler/ml/ast_iterator.ml | 8 ++- compiler/ml/ast_mapper.ml | 10 ++- compiler/ml/ast_mapper_to0.ml | 10 +-- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 71 ++++++++++++++++++++ 4 files changed, 93 insertions(+), 6 deletions(-) diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index a9ba4539829..a8dfb9d1991 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -104,7 +104,13 @@ module T = struct List.iter (function | Parsetree.Parg_type {typ} -> sub.typ sub typ - | Parsetree.Parg_fixed _ -> ()) + | Parsetree.Parg_fixed {value; loc} -> ( + sub.location sub loc; + sub.location sub value.loc; + match value.txt with + | Pfixed_int source | Pfixed_template source | Pfixed_json source -> + sub.location sub source.loc + | Pfixed_string _ -> ())) params; sub.typ sub ret | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index c32184d938a..ad378652250 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -104,10 +104,18 @@ module T = struct | Parsetree.Parg_type arg -> Parsetree.Parg_type {arg with typ = sub.typ sub arg.typ} | Parsetree.Parg_fixed arg -> + let txt : Parsetree.fixed_value = + match arg.value.txt with + | Pfixed_int source -> Pfixed_int (map_loc sub source) + | Pfixed_string _ as value -> value + | Pfixed_template source -> + Pfixed_template (map_loc sub source) + | Pfixed_json source -> Pfixed_json (map_loc sub source) + in Parsetree.Parg_fixed { arg with - value = map_loc sub arg.value; + value = {txt; loc = sub.location sub arg.value.loc}; loc = sub.location sub arg.loc; }) params) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 85d3ffd2cd7..e5e8112580a 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -188,11 +188,13 @@ module T = struct let as_attr = match value.txt with | Pfixed_json source -> - ( {txt = "as"; loc = as_loc}, + ( {txt = "as"; loc = sub.location sub as_loc}, Pt.PStr [ - Ast_helper0.Str.eval ~loc:value.loc - (Ast_helper0.Exp.constant ~loc:source.loc + Ast_helper0.Str.eval + ~loc:(sub.location sub value.loc) + (Ast_helper0.Exp.constant + ~loc:(sub.location sub source.loc) (Pt.Pconst_string (source.txt, Some "json"))); ] ) | Pfixed_int _ | Pfixed_string _ | Pfixed_template _ -> @@ -202,7 +204,7 @@ module T = struct ( lbl, attrs, Ast_helper0.Typ.any - ~loc:(Ast_fixed_arg.underscore_loc loc) + ~loc:(sub.location sub (Ast_fixed_arg.underscore_loc loc)) ~attrs:[as_attr] () ) in let lbl = Asttypes.to_noloc arg_lbl in diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index d0c42263afb..f0ebbb5b864 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -305,6 +305,75 @@ let test_fixed_argument_roundtrips_through_ast0 _ = OUnit.assert_equal fixed_loc loc | _ -> assert_failure "Expected the fixed argument back from ast0" +let test_fixed_argument_locations_go_through_the_mapper _ = + let marker = source_loc 100 101 in + let int_type = + Ast_helper.Typ.constr ~loc (Location.mknoloc (Longident.Lident "int")) [] + in + let fixed (txt : Parsetree.fixed_value) : Parsetree.arg = + Parg_fixed + { + attrs = []; + lbl = Nolabel; + value = {txt; loc = source_loc 5 9}; + loc = source_loc 1 12; + } + in + let vd = + Ast_helper.Val.mk ~prim:(Parsetree.Prim_name "f") (Location.mknoloc "f") + (Ast_helper.Typ.arrow ~loc + [ + fixed (Pfixed_json {txt = "{}"; loc = source_loc 6 8}); + fixed (Pfixed_int {txt = "1"; loc = source_loc 5 6}); + Parg_type {attrs = []; lbl = Nolabel; typ = int_type}; + ] + int_type) + in + let relocate = + {Ast_mapper.default_mapper with location = (fun _ _ -> marker)} + in + (match (relocate.value_description relocate vd).pval_type.ptyp_desc with + | Ptyp_arrow {params = [Parg_fixed json; Parg_fixed int; Parg_type _]} -> + List.iter + (fun (arg_loc, (value : Parsetree.fixed_value Location.loc)) -> + OUnit.assert_equal marker arg_loc; + OUnit.assert_equal marker value.loc; + match value.txt with + | Pfixed_int source | Pfixed_template source | Pfixed_json source -> + OUnit.assert_equal marker source.loc + | Pfixed_string _ -> ()) + [(json.loc, json.value); (int.loc, int.value)] + | _ -> assert_failure "Expected the fixed arguments back"); + let relocate0 = + {Ast_mapper_to0.default_mapper with location = (fun _ _ -> marker)} + in + let vd0 = relocate0.value_description relocate0 vd in + let assert_relocated_v0_fixed (typ : Parsetree0.core_type) = + OUnit.assert_equal marker typ.ptyp_loc; + match typ.ptyp_attributes with + | [ + ( {txt = "as"; loc = name_loc}, + PStr [{pstr_loc; pstr_desc = Pstr_eval ({pexp_loc}, [])}] ); + ] -> + OUnit.assert_equal marker name_loc; + OUnit.assert_equal marker pstr_loc; + OUnit.assert_equal marker pexp_loc + | _ -> assert_failure "Expected [_ [@as value]] on the ast0 wire" + in + match vd0.pval_type.ptyp_desc with + | Ptyp_constr + ( _, + [ + { + ptyp_desc = + Ptyp_arrow (_, json0, {ptyp_desc = Ptyp_arrow (_, int0, _)}); + }; + _; + ] ) -> + assert_relocated_v0_fixed json0; + assert_relocated_v0_fixed int0 + | _ -> assert_failure "Expected an external arrow on the ast0 wire" + let test_fixed_argument_is_external_only _ = (* A non-external arrow keeps [@as(1) _] as an ordinary argument. *) let any_as = @@ -2291,4 +2360,6 @@ let suites = >:: test_fixed_argument_roundtrips_through_ast0; "fixed_argument_is_external_only" >:: test_fixed_argument_is_external_only; + "fixed_argument_locations_go_through_the_mapper" + >:: test_fixed_argument_locations_go_through_the_mapper; ] From 0b64bf2fa00e6c27e69eb1477789377a01366b83 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 16 Oct 2026 13:17:08 +0000 Subject: [PATCH 3/3] Keep fixed-argument payloads with attributes as written `@as(@foo 1) _` stays an attribute, so `@foo` is not dropped. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01NP47qMfjMbjUTKZDsLthDo Signed-off-by: Christoph Knittel --- compiler/ml/ast_fixed_arg.ml | 13 ++++++++++--- .../printer/typexpr/expected/fixedExternal.res.txt | 2 ++ .../data/printer/typexpr/fixedExternal.res | 2 ++ 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/compiler/ml/ast_fixed_arg.ml b/compiler/ml/ast_fixed_arg.ml index 3a1ad5306ea..c46d7f36f64 100644 --- a/compiler/ml/ast_fixed_arg.ml +++ b/compiler/ml/ast_fixed_arg.ml @@ -2,8 +2,14 @@ open Parsetree let of_payload (payload : payload) : fixed_value Location.loc option = match payload with - | PStr [{pstr_desc = Pstr_eval ({pexp_desc; pexp_loc}, _); pstr_loc = loc}] - -> ( + (* A payload with attributes stays an attribute, which keeps them. *) + | PStr + [ + { + pstr_desc = Pstr_eval ({pexp_desc; pexp_loc; pexp_attributes = []}, []); + pstr_loc = loc; + }; + ] -> ( let fixed txt = Some {Location.txt; loc} in match pexp_desc with | Pexp_constant (Pconst_integer (source, None)) -> @@ -13,7 +19,8 @@ let of_payload (payload : payload) : fixed_value Location.loc option = fixed (Pfixed_template source) | Pexp_tagged_template { - tag = {pexp_desc = Pexp_ident {txt = Lident "json"}}; + tag = + {pexp_desc = Pexp_ident {txt = Lident "json"}; pexp_attributes = []}; raw_sources = [source]; values = []; } -> diff --git a/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt b/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt index f42926e2320..0f6440d64d7 100644 --- a/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt +++ b/tests/syntax_tests/data/printer/typexpr/expected/fixedExternal.res.txt @@ -26,3 +26,5 @@ external makeOptions: ( external commented: (/* a */ /* b */ @as(1) _ /* c */, /* d */ @as("s") _, int) => int = "f" type notExternal = (@as(1) _, int) => int + +@val external payloadAttributes: (@as(@foo (1)) _, @as(@foo (json`{}`)) _, int) => int = "f" diff --git a/tests/syntax_tests/data/printer/typexpr/fixedExternal.res b/tests/syntax_tests/data/printer/typexpr/fixedExternal.res index af8169afd30..2d6fcb16ffc 100644 --- a/tests/syntax_tests/data/printer/typexpr/fixedExternal.res +++ b/tests/syntax_tests/data/printer/typexpr/fixedExternal.res @@ -20,3 +20,5 @@ external useEffect0: (unit => option unit>, @as(json`[]`) _) => unit = " external commented: (/* a */ @as(1) /* b */ _ /* c */, @as(/* d */ "s") _, int) => int = "f" type notExternal = (@as(1) _, int) => int + +@val external payloadAttributes: (@as(@foo 1) _, @as(@foo json`{}`) _, int) => int = "f"