From 571a0cc5eae156e35c663ab1c532ed7cca334189 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 02:34:13 +0100 Subject: [PATCH 1/8] Print TypeScript for a module under the experimental -bs-emit-ts flag MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: A feasibility study for checking ReScript output with TScert, which reads TypeScript whose top-level functions annotate their parameters and result. The flag writes `.res.ts` (`.mts` for `.mjs`) in place of the JavaScript output, annotates each top-level function from the typed tree, and puts the module's type declarations at the top through genType's translation. The annotations are keyed by `Ident.t` (name and stamp), so one reaches the output only when the J IR prints the identifier the typed tree bound; `RESCRIPT_EMIT_TS_DEBUG=1` reports, per printed top-level function, whether its stamp and its parameters' stamps are the typed tree's. JS modified (top-level functions under -bs-emit-ts): Example: type point = {x: int, y: int, label: string} let moveX = (p: point, dx: int) => {...p, x: p.x + dx} Before (js): function moveX(p, dx) { return { x: p.x + dx | 0, y: p.y, label: p.label }; } After (js): Rec.res.ts export type point = { readonly x: number; readonly y: number; readonly label: string }; function moveX(p: point, dx: number): point { return { x: p.x + dx | 0, y: p.y, label: p.label }; } Review: Do the stamps survive to the printer? For every binding `let f = (…) => …` at the top level or in a nested module, uncurried, inlined into its callers, private or exported, the printed function and each of its parameters carry the typed tree's stamp. A function the optimizer synthesizes, such as `let partial = curried(1)`, has fresh parameters and is printed unannotated. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/bsc/rescript_compiler_driver.ml | 5 + compiler/common/js_config.ml | 2 + compiler/common/js_config.mli | 3 + compiler/core/js_dump.ml | 39 ++++++- compiler/core/js_dump_program.ml | 7 ++ compiler/core/js_implementation.ml | 26 ++--- compiler/core/js_ts_annot.ml | 139 +++++++++++++++++++++++ compiler/core/lam_compile_main.ml | 4 + 8 files changed, 209 insertions(+), 16 deletions(-) create mode 100644 compiler/core/js_ts_annot.ml diff --git a/compiler/bsc/rescript_compiler_driver.ml b/compiler/bsc/rescript_compiler_driver.ml index f0afa80557..eab56ebf7a 100644 --- a/compiler/bsc/rescript_compiler_driver.ml +++ b/compiler/bsc/rescript_compiler_driver.ml @@ -408,6 +408,11 @@ let command_line_flags () : (string * Bsc_args.spec * string) array = ( "-e", string_call (fun s -> eval s ~suffix:Literals.suffix_res), "(experimental) set the string to be evaluated in ReScript syntax" ); + ( "-bs-emit-ts", + set (Js_config.current ()).emit_ts, + "*internal* (experimental) Emit TypeScript: annotate top-level \ + functions, emit the module's type declarations, and write each output \ + with its suffix's .js replaced by .ts" ); ( "-bs-cmi-only", set (Js_config.current ()).cmi_only, "*internal* Stop after generating cmi file" ); diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index 616ea4d903..1757c6e21c 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -53,6 +53,7 @@ type t = { no_stdlib: bool ref; no_export: bool ref; as_pp: bool ref; + emit_ts: bool ref; self_stack: string Stack.t; } @@ -82,6 +83,7 @@ let create () = no_stdlib = ref false; no_export = ref false; as_pp = ref false; + emit_ts = ref false; self_stack = Stack.create (); } diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index 1185045a9f..ee013d824b 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -54,6 +54,9 @@ type t = { no_stdlib: bool ref; no_export: bool ref; as_pp: bool ref; + emit_ts: bool ref; + (** Print TypeScript: annotate top-level functions from the typed tree + and emit the module's type declarations. *) self_stack: string Stack.t; } diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index fcacce78a3..07a0f1381a 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -326,6 +326,21 @@ and record_rest_pattern cxt f fields rest = and formal_parameter_list cxt f l = iter_lst cxt f l Ext_pp_scope.ident comma_sp +(* [-bs-emit-ts]: each parameter followed by its type, where the typed tree + gave one to this identifier. *) +and annotated_parameter_list cxt f l = + iter_lst cxt f l + (fun cxt f id -> + let cxt = Ext_pp_scope.ident cxt f id in + (match Js_ts_annot.param_type id with + | Some ty -> + P.string f ":"; + P.space f; + P.string f ty + | None -> ()); + cxt) + comma_sp + (* IdentMap *) (* f/122 --> @@ -447,12 +462,30 @@ let rec pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) in function_body ?directive ~return_unit cxt f b)) else + let ts_top = + match fn_state with + | Name_top x when Js_ts_annot.enabled () -> + Js_ts_annot.report_function x l; + Some x + | _ -> None + in let cxt = - match l with - | [single] when arrow -> Ext_pp_scope.ident inner_cxt f single - | l -> + match (l, ts_top) with + | l, Some _ -> + P.paren_group f 1 (fun _ -> annotated_parameter_list inner_cxt f l) + | [single], None when arrow -> Ext_pp_scope.ident inner_cxt f single + | l, None -> P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) in + (match ts_top with + | Some x -> ( + match Js_ts_annot.result_type x with + | Some ty -> + P.string f ":"; + P.space f; + P.string f ty + | None -> ()) + | None -> ()); P.space f; if arrow then ( P.string f L.arrow; diff --git a/compiler/core/js_dump_program.ml b/compiler/core/js_dump_program.ml index bbcbbfa070..1ccc0d88d9 100644 --- a/compiler/core/js_dump_program.ml +++ b/compiler/core/js_dump_program.ml @@ -120,6 +120,13 @@ let esmodule_program ~output_dir fmt f (x : J.deps_program) = | _ -> None ))) in let () = P.at_least_two_lines f in + (if Js_ts_annot.enabled () then + match Js_ts_annot.header () with + | "" -> () + | header -> + P.string f header; + P.newline f; + P.at_least_two_lines f); let cxt = Js_dump.statements true cxt f x.program.block in Js_dump_import_export.esmodule_export cxt f x.program.exports diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 72f0b51b61..8e1744134c 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -140,19 +140,19 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = let typedtree_coercion = (typedtree, coercion) in print_if ppf (Clflags.current ()).dump_typedtree Printtyped.implementation_with_coercion typedtree_coercion; - (if !((Js_config.current ()).cmi_only) then Warnings.check_fatal () - else - let implementation = - Translmod.transl_implementation modulename finalenv signature - typedtree_coercion - in - print_if ppf (Clflags.current ()).dump_rawlambda Printlambda.lambda - implementation.lambda; - let js_program = - Lam_compile_main.compile outputprefix implementation - in - if not !((Js_config.current ()).cmj_only) then - Lam_compile_main.lambda_as_module js_program outputprefix); + if !((Js_config.current ()).cmi_only) then Warnings.check_fatal () + else ( + if !((Js_config.current ()).emit_ts) then + Js_ts_annot.collect ~module_name:modulename typedtree; + let implementation = + Translmod.transl_implementation modulename finalenv signature + typedtree_coercion + in + print_if ppf (Clflags.current ()).dump_rawlambda Printlambda.lambda + implementation.lambda; + let js_program = Lam_compile_main.compile outputprefix implementation in + if not !((Js_config.current ()).cmj_only) then + Lam_compile_main.lambda_as_module js_program outputprefix); process_with_gentype (outputprefix ^ ".cmt")) let implementation ~parser ppf ?outputprefix fname = diff --git a/compiler/core/js_ts_annot.ml b/compiler/core/js_ts_annot.ml new file mode 100644 index 0000000000..12baf30985 --- /dev/null +++ b/compiler/core/js_ts_annot.ml @@ -0,0 +1,139 @@ +(* Experimental TypeScript emission ([-bs-emit-ts]). + + The typed tree gives each top-level function's parameters and result a + [Types.type_expr]; genType's translation turns each into TypeScript. The + printer looks the parameters and the function up by their [Ident.t] + (name and stamp), so an annotation reaches the output only when the + identifier the J IR prints is the one the typed tree bound. *) + +type key = string * int + +type state = { + params: (key, string) Hashtbl.t; (** parameter ident -> its type *) + results: (key, string) Hashtbl.t; (** top-level function -> result type *) + names: (string, int) Hashtbl.t; + (** top-level function name -> its stamp, to report lost stamps *) + mutable header: string; (** the module's type declarations *) +} + +let fresh () = + { + params = Hashtbl.create 16; + results = Hashtbl.create 16; + names = Hashtbl.create 16; + header = ""; + } + +let key = Request_local.new_key fresh +let current () = Domain.DLS.get key +let enabled () = !((Js_config.current ()).emit_ts) +let key_of (id : Ident.t) : key = (id.name, id.stamp) + +(* [.res.js] -> [.res.ts], [.mjs] -> [.mts], [.cjs] -> [.cts] *) +let ts_suffix suffix = + if Filename.check_suffix suffix ".mjs" then + Filename.chop_suffix suffix ".mjs" ^ ".mts" + else if Filename.check_suffix suffix ".cjs" then + Filename.chop_suffix suffix ".cjs" ^ ".cts" + else if Filename.check_suffix suffix ".js" then + Filename.chop_suffix suffix ".js" ^ ".ts" + else suffix ^ ".ts" + +let config () = {Gentype_config.default with everything = true} + +let ts_of_type_expr type_env (type_expr : Types.type_expr) = + let config = config () in + let translation = + Translate_type_expr_from_types.translate_type_expr_from_types ~config + ~type_env type_expr + in + Emit_type.type_to_string ~config + ~type_name_is_interface:(fun _ -> false) + translation.type_ + +let debug = Sys.getenv_opt "RESCRIPT_EMIT_TS_DEBUG" <> None + +let collect_function st type_env (id : Ident.t) (e : Typedtree.expression) = + match e.exp_desc with + | Texp_function {params; body} -> + Hashtbl.replace st.names id.name id.stamp; + Ext_list.iter params (fun (p : Typedtree.function_param) -> + Hashtbl.replace st.params (key_of p.fp_param) + (ts_of_type_expr type_env p.fp_pat.pat_type)); + Hashtbl.replace st.results (key_of id) + (ts_of_type_expr type_env body.exp_type) + | _ -> () + +let is_type_declaration (item : Typedtree.structure_item) = + match item.str_desc with + | Tstr_type _ -> true + | _ -> false + +let header_of_structure ~module_name (str : Typedtree.structure) = + let config = config () in + let type_env = Type_env.root () in + let output_file_relative = module_name ^ ".res.ts" in + let resolver = + Module_resolver.create_lazy_resolver ~config + ~extensions:[".res"; ".shim.ts"] ~exclude_file:(fun _ -> false) + in + let translation = + {str with str_items = Ext_list.filter str.str_items is_type_declaration} + |> Translate_structure.translate_structure ~config ~output_file_relative + ~resolver ~type_env + |> Translation.combine + |> Translation.add_type_declarations_from_module_equations ~type_env + in + Emit_js.emit_translation_as_string ~config + ~file_name:(Module_name.from_string_unsafe module_name) + ~output_file_relative ~resolver + ~input_cmt_translate_type_declarations: + Gentype_main.input_cmt_translate_type_declarations translation + +let collect ~module_name (str : Typedtree.structure) = + let st = current () in + Hashtbl.reset st.params; + Hashtbl.reset st.results; + Hashtbl.reset st.names; + let type_env = Type_env.root () in + (* Functions of nested modules are printed at the top level too. *) + let rec items (str : Typedtree.structure) = + Ext_list.iter str.str_items (fun item -> + match item.str_desc with + | Tstr_value (_, vbs) -> + Ext_list.iter vbs (fun (vb : Typedtree.value_binding) -> + match vb.vb_pat.pat_desc with + | Tpat_var (id, _) -> collect_function st type_env id vb.vb_expr + | _ -> ()) + | Tstr_module {mb_expr = {mod_desc = Tmod_structure s}} -> items s + | _ -> ()) + in + items str; + st.header <- header_of_structure ~module_name str + +let header () = (current ()).header + +(* Report, once per top-level function the printer names, whether its stamp + and its parameters' stamps are the typed tree's. *) +let report_function (id : Ident.t) (params : Ident.t list) = + if debug then + let st = current () in + let fn = + if Hashtbl.mem st.results (key_of id) then "stamp kept" + else + match Hashtbl.find_opt st.names id.name with + | Some s -> Printf.sprintf "stamp lost (typed %d, J %d)" s id.stamp + | None -> "not a typed top-level function" + in + let ps = + Ext_list.map params (fun p -> + Printf.sprintf "%s/%d:%s" p.Ident.name p.stamp + (if Hashtbl.mem st.params (key_of p) then "kept" else "lost")) + in + Printf.eprintf "emit-ts: %s/%d %s; params %s\n" id.name id.stamp fn + (String.concat ", " ps) + +let param_type (id : Ident.t) = Hashtbl.find_opt (current ()).params (key_of id) + +let result_type (id : Ident.t) = + Hashtbl.find_opt (current ()).results (key_of id) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index e5f925a003..75703eb4d8 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -513,6 +513,10 @@ let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : (Compiler_request_output.stdout_channel ()) else Js_packages_info.iter package_info (fun {module_system; path; suffix} -> + let suffix = + if !((Js_config.current ()).emit_ts) then Js_ts_annot.ts_suffix suffix + else suffix + in let basename = Ext_namespace.change_ext_ns_suffix (Filename.basename output_prefix) From 8ec2de484b2e4d024026115799bd6ee9cc373689 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 02:36:30 +0100 Subject: [PATCH 2/8] Print an exported top-level function as export function under -bs-emit-ts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: TScert's source fragment admits `export function f(…)` and refuses the trailing export list `export { f, … }`. Under -bs-emit-ts a top-level function exported under its own name is printed with `export` in front and leaves the list; other exports, such as a module record or an alias, stay in it. The printer is assumed to print a top-level function under its source name. JS modified (exports under -bs-emit-ts): Example: let add = (a: int, b: int) => a + b Before (js): function add(a: number, b: number): number { return a + b | 0; } export { add, } After (js): export function add(a: number, b: number): number { return a + b | 0; } Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/core/js_dump.ml | 3 +++ compiler/core/js_dump_import_export.ml | 4 ++++ compiler/core/js_dump_program.ml | 1 + compiler/core/js_ts_annot.ml | 26 ++++++++++++++++++++++++++ 4 files changed, 34 insertions(+) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 07a0f1381a..42e1d4daea 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -519,6 +519,9 @@ let rec pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) param_body (); semi f | Name_top x -> + if Js_ts_annot.export_inline x then ( + P.string f L.export; + P.space f); P.string f (L.function_ ~async ~arrow); ignore (Ext_pp_scope.ident inner_cxt f x : cxt); param_body () diff --git a/compiler/core/js_dump_import_export.ml b/compiler/core/js_dump_import_export.ml index 1038b8be63..7e462560eb 100644 --- a/compiler/core/js_dump_import_export.ml +++ b/compiler/core/js_dump_import_export.ml @@ -79,6 +79,10 @@ let exports cxt f (idents : Ident.t list) = (** Print module in ESModule format, it is ESModule, trailing comma is valid ES code *) let esmodule_export cxt f (idents : Ident.t list) = P.at_least_two_lines f; + (* [-bs-emit-ts]: functions printed as [export function] leave the list *) + let idents = + Ext_list.filter idents (fun id -> not (Js_ts_annot.exported_inline id)) + in match idents with | [] -> cxt | _ -> diff --git a/compiler/core/js_dump_program.ml b/compiler/core/js_dump_program.ml index 1ccc0d88d9..ff1d406f91 100644 --- a/compiler/core/js_dump_program.ml +++ b/compiler/core/js_dump_program.ml @@ -120,6 +120,7 @@ let esmodule_program ~output_dir fmt f (x : J.deps_program) = | _ -> None ))) in let () = P.at_least_two_lines f in + Js_ts_annot.set_exports x.program.exports; (if Js_ts_annot.enabled () then match Js_ts_annot.header () with | "" -> () diff --git a/compiler/core/js_ts_annot.ml b/compiler/core/js_ts_annot.ml index 12baf30985..ed03b1bb44 100644 --- a/compiler/core/js_ts_annot.ml +++ b/compiler/core/js_ts_annot.ml @@ -14,6 +14,9 @@ type state = { names: (string, int) Hashtbl.t; (** top-level function name -> its stamp, to report lost stamps *) mutable header: string; (** the module's type declarations *) + mutable exports: Ident.t list; (** the program's exports *) + inline_exports: (key, unit) Hashtbl.t; + (** exports printed as [export function] *) } let fresh () = @@ -22,6 +25,8 @@ let fresh () = results = Hashtbl.create 16; names = Hashtbl.create 16; header = ""; + exports = []; + inline_exports = Hashtbl.create 16; } let key = Request_local.new_key fresh @@ -137,3 +142,24 @@ let param_type (id : Ident.t) = Hashtbl.find_opt (current ()).params (key_of id) let result_type (id : Ident.t) = Hashtbl.find_opt (current ()).results (key_of id) + +let set_exports exports = + let st = current () in + st.exports <- exports; + Hashtbl.reset st.inline_exports + +(* A top-level function is printed [export function f] when it is exported + under its own name. The printer is assumed to print a top-level function + under its source name. *) +let export_inline (id : Ident.t) = + enabled () + && + let st = current () in + Ext_list.exists st.exports (fun e -> Ident.same e id) + && Ext_ident.convert id.name = id.name + && + (Hashtbl.replace st.inline_exports (key_of id) (); + true) + +let exported_inline (id : Ident.t) = + enabled () && Hashtbl.mem (current ()).inline_exports (key_of id) From 2a07f4e0406b092c2dd843cfabd0b0889c0e68e2 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 03:50:18 +0100 Subject: [PATCH 3/8] Print type parameters and optional parameters under -bs-emit-ts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: A polymorphic function printed its type variables without declaring them, which tsc rejects, and each parameter's variables were named on their own, so distinct variables shared the name T1. Optional labelled arguments printed as mandatory `undefined | T` parameters. JS modified (-bs-emit-ts type parameters): Example: let id = x => x let second = (_x: 'a, y: 'b): 'b => y Before (js): export function id(x: T1): T1 { return x; } export function second(_x: T1, y: T1): T1 { return y; } After (js): export function id(x: T1): T1 { return x; } export function second(_x: a, y: b): b { return y; } JS modified (-bs-emit-ts optional labelled arguments): Example: let scale = (x: int, ~by=2) => x * by let offset = (~from=0, x: int) => x - from Before (js): export function scale(x: number, byOpt: (undefined | number)): number { … export function offset(fromOpt: (undefined | number), x: number): number { After (js): export function scale(x: number, byOpt?: number): number { … export function offset(fromOpt: (undefined | number), x: number): number { Review: Why does `fromOpt` keep `undefined | number`? TypeScript requires every parameter after an optional one to be optional, so `?` goes only on the optional arguments after the last mandatory one; a ReScript call passes `undefined` for an omitted argument in either position. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/core/js_dump.ml | 7 +-- compiler/core/js_ts_annot.ml | 102 ++++++++++++++++++++++++++++++----- 2 files changed, 92 insertions(+), 17 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 42e1d4daea..29baedcb51 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -333,8 +333,8 @@ and annotated_parameter_list cxt f l = (fun cxt f id -> let cxt = Ext_pp_scope.ident cxt f id in (match Js_ts_annot.param_type id with - | Some ty -> - P.string f ":"; + | Some {ty; optional} -> + P.string f (if optional then "?:" else ":"); P.space f; P.string f ty | None -> ()); @@ -471,7 +471,8 @@ let rec pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) in let cxt = match (l, ts_top) with - | l, Some _ -> + | l, Some x -> + P.string f (Js_ts_annot.type_params x); P.paren_group f 1 (fun _ -> annotated_parameter_list inner_cxt f l) | [single], None when arrow -> Ext_pp_scope.ident inner_cxt f single | l, None -> diff --git a/compiler/core/js_ts_annot.ml b/compiler/core/js_ts_annot.ml index ed03b1bb44..bab25d4b0a 100644 --- a/compiler/core/js_ts_annot.ml +++ b/compiler/core/js_ts_annot.ml @@ -8,9 +8,18 @@ type key = string * int +type param = { + ty: string; + optional: bool; + (** printed [p?: ty]: an optional labelled argument followed only by + optional labelled arguments, with [ty] the option's element type *) +} + type state = { - params: (key, string) Hashtbl.t; (** parameter ident -> its type *) + params: (key, param) Hashtbl.t; (** parameter ident -> its annotation *) results: (key, string) Hashtbl.t; (** top-level function -> result type *) + generics: (key, string list) Hashtbl.t; + (** top-level function -> its type parameters, in order of occurrence *) names: (string, int) Hashtbl.t; (** top-level function name -> its stamp, to report lost stamps *) mutable header: string; (** the module's type declarations *) @@ -23,6 +32,7 @@ let fresh () = { params = Hashtbl.create 16; results = Hashtbl.create 16; + generics = Hashtbl.create 16; names = Hashtbl.create 16; header = ""; exports = []; @@ -46,27 +56,85 @@ let ts_suffix suffix = let config () = {Gentype_config.default with everything = true} -let ts_of_type_expr type_env (type_expr : Types.type_expr) = - let config = config () in - let translation = - Translate_type_expr_from_types.translate_type_expr_from_types ~config - ~type_env type_expr - in - Emit_type.type_to_string ~config +let type_to_string type_ = + Emit_type.type_to_string ~config:(config ()) ~type_name_is_interface:(fun _ -> false) - translation.type_ + type_ + +(* The types of one function's parameters and result, translated with one + namer for anonymous type variables, so a variable shared between them gets + one name. Also the type variables, in order of first occurrence. *) +let ts_of_signature type_env (type_exprs : Types.type_expr list) = + let translations = + Translate_type_expr_from_types.translate_type_exprs_from_types + ~config:(config ()) ~type_env type_exprs + in + let type_vars = + List.fold_left + (fun acc (t : Translate_type_expr_from_types.translation) -> + List.fold_left + (fun acc v -> if List.mem v acc then acc else acc @ [v]) + acc (Type_vars.free t.type_)) + [] translations + in + (Ext_list.map translations (fun t -> type_to_string t.type_), type_vars) let debug = Sys.getenv_opt "RESCRIPT_EMIT_TS_DEBUG" <> None +let is_optional (p : Typedtree.function_param) = + match p.fp_lbl with + | Optional _ -> true + | Nolabel | Labelled _ -> false + +(* The element type of [option]. *) +let option_element (t : Types.type_expr) = + match (Ctype.repr t).desc with + | Tconstr (path, [elt], _) when Path.same path Predef.path_option -> Some elt + | _ -> None + +(* The parameters printed [p?: t]: the optional labelled arguments after the + last mandatory one, because TypeScript requires every parameter after an + optional one to be optional. An optional argument earlier in the list + prints [p: undefined | t]; a call from ReScript passes [undefined] for an + omitted argument in either position. *) +let rec trailing_optionals (params : Typedtree.function_param list) = + match params with + | [] -> ([], true) + | p :: rest -> + let flags, all_optional = trailing_optionals rest in + let optional = + all_optional && is_optional p && option_element p.fp_pat.pat_type <> None + in + (optional :: flags, optional) + let collect_function st type_env (id : Ident.t) (e : Typedtree.expression) = match e.exp_desc with | Texp_function {params; body} -> Hashtbl.replace st.names id.name id.stamp; - Ext_list.iter params (fun (p : Typedtree.function_param) -> - Hashtbl.replace st.params (key_of p.fp_param) - (ts_of_type_expr type_env p.fp_pat.pat_type)); - Hashtbl.replace st.results (key_of id) - (ts_of_type_expr type_env body.exp_type) + let optionals, _ = trailing_optionals params in + let param_types = + List.map2 + (fun (p : Typedtree.function_param) optional -> + match option_element p.fp_pat.pat_type with + | Some elt when optional -> elt + | _ -> p.fp_pat.pat_type) + params optionals + in + let types, type_vars = + ts_of_signature type_env (param_types @ [body.exp_type]) + in + if type_vars <> [] then Hashtbl.replace st.generics (key_of id) type_vars; + let rec bind params optionals types = + match (params, optionals, types) with + | [], [], [result] -> Hashtbl.replace st.results (key_of id) result + | ( (p : Typedtree.function_param) :: params, + optional :: optionals, + ty :: types ) -> + Hashtbl.replace st.params (key_of p.fp_param) {ty; optional}; + bind params optionals types + | _ -> assert false + in + bind params optionals types | _ -> () let is_type_declaration (item : Typedtree.structure_item) = @@ -99,6 +167,7 @@ let collect ~module_name (str : Typedtree.structure) = let st = current () in Hashtbl.reset st.params; Hashtbl.reset st.results; + Hashtbl.reset st.generics; Hashtbl.reset st.names; let type_env = Type_env.root () in (* Functions of nested modules are printed at the top level too. *) @@ -143,6 +212,11 @@ let param_type (id : Ident.t) = Hashtbl.find_opt (current ()).params (key_of id) let result_type (id : Ident.t) = Hashtbl.find_opt (current ()).results (key_of id) +let type_params (id : Ident.t) = + match Hashtbl.find_opt (current ()).generics (key_of id) with + | Some vars -> "<" ^ String.concat ", " vars ^ ">" + | None -> "" + let set_exports exports = let st = current () in st.exports <- exports; From ed4458a3821cc356859a9661222a2334c08d732a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 03:54:56 +0100 Subject: [PATCH 4/8] Check in the -bs-emit-ts examples and their TypeScript output The build test tests/build_tests/emit_ts compiles seven examples with -bs-emit-ts and type-checks the checked-in .res.ts output with tsc --strict against declarations for the runtime functions the output imports. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- tests/build_tests/emit_ts/input.js | 26 +++++++++ tests/build_tests/emit_ts/rescript.json | 10 ++++ .../runtime-dts/Primitive_option.d.mts | 5 ++ .../emit_ts/runtime-dts/Stdlib_Array.d.mts | 7 +++ .../emit_ts/runtime-dts/Stdlib_Option.d.mts | 9 +++ tests/build_tests/emit_ts/src/Arith.res | 3 + tests/build_tests/emit_ts/src/Arith.res.ts | 16 ++++++ tests/build_tests/emit_ts/src/Arr.res | 12 ++++ tests/build_tests/emit_ts/src/Arr.res.ts | 26 +++++++++ tests/build_tests/emit_ts/src/Gen.res | 17 ++++++ tests/build_tests/emit_ts/src/Gen.res.ts | 40 ++++++++++++++ tests/build_tests/emit_ts/src/Opt.res | 16 ++++++ tests/build_tests/emit_ts/src/Opt.res.ts | 27 +++++++++ tests/build_tests/emit_ts/src/OptArg.res | 27 +++++++++ tests/build_tests/emit_ts/src/OptArg.res.ts | 55 +++++++++++++++++++ tests/build_tests/emit_ts/src/Rec.res | 5 ++ tests/build_tests/emit_ts/src/Rec.res.ts | 30 ++++++++++ tests/build_tests/emit_ts/src/Shape.res | 18 ++++++ tests/build_tests/emit_ts/src/Shape.res.ts | 30 ++++++++++ tests/build_tests/emit_ts/tsconfig.json | 15 +++++ 20 files changed, 394 insertions(+) create mode 100644 tests/build_tests/emit_ts/input.js create mode 100644 tests/build_tests/emit_ts/rescript.json create mode 100644 tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts create mode 100644 tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts create mode 100644 tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts create mode 100644 tests/build_tests/emit_ts/src/Arith.res create mode 100644 tests/build_tests/emit_ts/src/Arith.res.ts create mode 100644 tests/build_tests/emit_ts/src/Arr.res create mode 100644 tests/build_tests/emit_ts/src/Arr.res.ts create mode 100644 tests/build_tests/emit_ts/src/Gen.res create mode 100644 tests/build_tests/emit_ts/src/Gen.res.ts create mode 100644 tests/build_tests/emit_ts/src/Opt.res create mode 100644 tests/build_tests/emit_ts/src/Opt.res.ts create mode 100644 tests/build_tests/emit_ts/src/OptArg.res create mode 100644 tests/build_tests/emit_ts/src/OptArg.res.ts create mode 100644 tests/build_tests/emit_ts/src/Rec.res create mode 100644 tests/build_tests/emit_ts/src/Rec.res.ts create mode 100644 tests/build_tests/emit_ts/src/Shape.res create mode 100644 tests/build_tests/emit_ts/src/Shape.res.ts create mode 100644 tests/build_tests/emit_ts/tsconfig.json diff --git a/tests/build_tests/emit_ts/input.js b/tests/build_tests/emit_ts/input.js new file mode 100644 index 0000000000..063cc262c7 --- /dev/null +++ b/tests/build_tests/emit_ts/input.js @@ -0,0 +1,26 @@ +// @ts-check + +// The examples compiled with -bs-emit-ts. The generated src/*.res.ts are +// checked in, and must type-check under tsc --strict against the runtime +// declarations in runtime-dts/. + +import * as assert from "node:assert"; +import * as child_process from "node:child_process"; +import * as path from "node:path"; +import { setup } from "#dev/process"; + +const { execBuildOrThrow, execClean } = setup(import.meta.dirname); + +await execClean(); +await execBuildOrThrow(); + +const tsc = child_process.spawnSync( + process.execPath, + [ + path.join(import.meta.dirname, "../../../node_modules/typescript/bin/tsc"), + "-p", + import.meta.dirname, + ], + { encoding: "utf8" }, +); +assert.equal(tsc.status, 0, tsc.stdout + tsc.stderr); diff --git a/tests/build_tests/emit_ts/rescript.json b/tests/build_tests/emit_ts/rescript.json new file mode 100644 index 0000000000..b94e83093d --- /dev/null +++ b/tests/build_tests/emit_ts/rescript.json @@ -0,0 +1,10 @@ +{ + "name": "emit_ts", + "sources": ["src"], + "package-specs": { + "module": "esmodule", + "in-source": true + }, + "suffix": ".res.js", + "compiler-flags": ["-bs-emit-ts"] +} diff --git a/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts b/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts new file mode 100644 index 0000000000..e820f34006 --- /dev/null +++ b/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts @@ -0,0 +1,5 @@ +// External contract for Primitive_option.valFromOption, the unboxing of a +// value already tested to be Some. Stated for an element type that does not +// itself include undefined: there the runtime value of Some(v) is v, and +// valFromOption returns it unchanged. +export declare function valFromOption(x: A): A; diff --git a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts new file mode 100644 index 0000000000..d6a1c05924 --- /dev/null +++ b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts @@ -0,0 +1,7 @@ +// External contract for the one function of Stdlib_Array the examples use: +// reduce(arr, init, f) is arr.reduce(f, init). +export declare function reduce( + arr: readonly A[], + init: B, + f: (acc: B, x: A) => B, +): B; diff --git a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts new file mode 100644 index 0000000000..b78368f109 --- /dev/null +++ b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts @@ -0,0 +1,9 @@ +// External contract for the two functions of Stdlib_Option the examples use. +// Stated for an element type that does not itself include undefined: the +// runtime boxes a nested None (Primitive_option.some), which `A | undefined` +// does not describe. +export declare function map( + opt: A | undefined, + f: (x: A) => B, +): B | undefined; +export declare function getOr(opt: A | undefined, d: A): A; diff --git a/tests/build_tests/emit_ts/src/Arith.res b/tests/build_tests/emit_ts/src/Arith.res new file mode 100644 index 0000000000..c04d119947 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Arith.res @@ -0,0 +1,3 @@ +let add = (a: int, b: int) => a + b +let scale = (x: float, k: float) => x *. k +. 1.0 +let mean = (a: int, b: int) => Int.toFloat(a + b) /. 2.0 diff --git a/tests/build_tests/emit_ts/src/Arith.res.ts b/tests/build_tests/emit_ts/src/Arith.res.ts new file mode 100644 index 0000000000..af127a62e2 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Arith.res.ts @@ -0,0 +1,16 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +export function add(a: number, b: number): number { + return a + b | 0; +} + +export function scale(x: number, k: number): number { + return x * k + 1.0; +} + +export function mean(a: number, b: number): number { + return (a + b | 0) / 2.0; +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/Arr.res b/tests/build_tests/emit_ts/src/Arr.res new file mode 100644 index 0000000000..849ae495d4 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Arr.res @@ -0,0 +1,12 @@ +let rec sumFrom = (xs: array, i: int) => + if i >= Array.length(xs) { + 0 + } else { + xs[i]->Option.getOr(0) + sumFrom(xs, i + 1) + } + +let squares = (xs: array) => Array.map(xs, x => x * x) + +let total = (xs: array) => Array.reduce(xs, 0, (acc, x) => acc + x) + +let sumOfSquares = (xs: array) => sumFrom(squares(xs), 0) diff --git a/tests/build_tests/emit_ts/src/Arr.res.ts b/tests/build_tests/emit_ts/src/Arr.res.ts new file mode 100644 index 0000000000..4cbb862716 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Arr.res.ts @@ -0,0 +1,26 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Stdlib_Array from "@rescript/runtime/lib/es6/Stdlib_Array.mjs"; +import * as Stdlib_Option from "@rescript/runtime/lib/es6/Stdlib_Option.mjs"; + +export function sumFrom(xs: number[], i: number): number { + if (i >= xs.length) { + return 0; + } else { + return Stdlib_Option.getOr(xs[i], 0) + sumFrom(xs, i + 1 | 0) | 0; + } +} + +export function squares(xs: number[]): number[] { + return xs.map(x => x * x | 0); +} + +export function total(xs: number[]): number { + return Stdlib_Array.reduce(xs, 0, (acc, x) => acc + x | 0); +} + +export function sumOfSquares(xs: number[]): number { + return sumFrom(squares(xs), 0); +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/Gen.res b/tests/build_tests/emit_ts/src/Gen.res new file mode 100644 index 0000000000..e1ef078670 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Gen.res @@ -0,0 +1,17 @@ +let id = x => x + +let konst = (x, _y) => x + +let second = (_x: 'a, y: 'b): 'b => y + +let pair = (a, b) => (a, b) + +let applyTwice = (f, x) => f(f(x)) + +let getOr = (o, d) => + switch o { + | Some(v) => v + | None => d + } + +let useId = (n: int) => id(n) + applyTwice(x => x + 1, n) diff --git a/tests/build_tests/emit_ts/src/Gen.res.ts b/tests/build_tests/emit_ts/src/Gen.res.ts new file mode 100644 index 0000000000..eb49d506f6 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Gen.res.ts @@ -0,0 +1,40 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +export function id(x: T1): T1 { + return x; +} + +export function konst(x: T1, _y: T2): T1 { + return x; +} + +export function second(_x: a, y: b): b { + return y; +} + +export function pair(a: T1, b: T2): [T1, T2] { + return [ + a, + b + ]; +} + +export function applyTwice(f: (_1:T1) => T1, x: T1): T1 { + return f(f(x)); +} + +export function getOr(o: (undefined | T1), d: T1): T1 { + if (o !== undefined) { + return Primitive_option.valFromOption(o); + } else { + return d; + } +} + +export function useId(n: number): number { + return n + ((n + 1 | 0) + 1 | 0) | 0; +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/Opt.res b/tests/build_tests/emit_ts/src/Opt.res new file mode 100644 index 0000000000..2770dc0587 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Opt.res @@ -0,0 +1,16 @@ +let orZero = (o: option) => + switch o { + | Some(n) => n + | None => 0 + } + +let double = (o: option) => Option.map(o, n => n * 2) + +let firstPositive = (a: int, b: int) => + if a > 0 { + Some(a) + } else if b > 0 { + Some(b) + } else { + None + } diff --git a/tests/build_tests/emit_ts/src/Opt.res.ts b/tests/build_tests/emit_ts/src/Opt.res.ts new file mode 100644 index 0000000000..339a6812ef --- /dev/null +++ b/tests/build_tests/emit_ts/src/Opt.res.ts @@ -0,0 +1,27 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Stdlib_Option from "@rescript/runtime/lib/es6/Stdlib_Option.mjs"; + +export function orZero(o: (undefined | number)): number { + if (o !== undefined) { + return o; + } else { + return 0; + } +} + +export function double(o: (undefined | number)): (undefined | number) { + return Stdlib_Option.map(o, n => (n << 1)); +} + +export function firstPositive(a: number, b: number): (undefined | number) { + if (a > 0) { + return a; + } else if (b > 0) { + return b; + } else { + return; + } +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/OptArg.res b/tests/build_tests/emit_ts/src/OptArg.res new file mode 100644 index 0000000000..56abb79200 --- /dev/null +++ b/tests/build_tests/emit_ts/src/OptArg.res @@ -0,0 +1,27 @@ +let scale = (x: int, ~by=2) => x * by + +let greet = (~name, ~greeting=?) => + switch greeting { + | Some(g) => g ++ " " ++ name + | None => "Hello " ++ name + } + +let offset = (~from=0, x: int) => x - from + +let clamp = (~lo=0, ~hi=100, x: int) => + if x < lo { + lo + } else if x > hi { + hi + } else { + x + } + +let wrap = (x, ~tag=?) => + switch tag { + | Some(t) => (t, x) + | None => ("none", x) + } + +let useAll = () => + scale(3) + scale(3, ~by=4) + offset(5) + clamp(500) + String.length(greet(~name="a")) diff --git a/tests/build_tests/emit_ts/src/OptArg.res.ts b/tests/build_tests/emit_ts/src/OptArg.res.ts new file mode 100644 index 0000000000..3d42627bfd --- /dev/null +++ b/tests/build_tests/emit_ts/src/OptArg.res.ts @@ -0,0 +1,55 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +export function scale(x: number, byOpt?: number): number { + let by = byOpt !== undefined ? byOpt : 2; + return x * by | 0; +} + +export function greet(name: string, greeting?: string): string { + if (greeting !== undefined) { + return greeting + " " + name; + } else { + return "Hello " + name; + } +} + +export function offset(fromOpt: (undefined | number), x: number): number { + let from = fromOpt !== undefined ? fromOpt : 0; + return x - from | 0; +} + +export function clamp(loOpt: (undefined | number), hiOpt: (undefined | number), x: number): number { + let lo = loOpt !== undefined ? loOpt : 0; + let hi = hiOpt !== undefined ? hiOpt : 100; + if (x < lo) { + return lo; + } else if (x > hi) { + return hi; + } else { + return x; + } +} + +export function wrap(x: T1, tag?: string): [string, T1] { + if (tag !== undefined) { + return [ + tag, + x + ]; + } else { + return [ + "none", + x + ]; + } +} + +export function useAll(): number { + let by = 2; + let by$1 = 4; + let from = 0; + return ((((3 * by | 0) + (3 * by$1 | 0) | 0) + (5 - from | 0) | 0) + clamp(undefined, undefined, 500) | 0) + greet("a", undefined).length | 0; +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/Rec.res b/tests/build_tests/emit_ts/src/Rec.res new file mode 100644 index 0000000000..31f9846c52 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Rec.res @@ -0,0 +1,5 @@ +type point = {x: int, y: int, label: string} + +let make = (x: int, y: int) => {x, y, label: "p"} +let norm1 = (p: point) => Math.Int.abs(p.x) + Math.Int.abs(p.y) +let moveX = (p: point, dx: int) => {...p, x: p.x + dx} diff --git a/tests/build_tests/emit_ts/src/Rec.res.ts b/tests/build_tests/emit_ts/src/Rec.res.ts new file mode 100644 index 0000000000..18fea30c25 --- /dev/null +++ b/tests/build_tests/emit_ts/src/Rec.res.ts @@ -0,0 +1,30 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +export type point = { + readonly x: number; + readonly y: number; + readonly label: string +}; + +export function make(x: number, y: number): point { + return { + x: x, + y: y, + label: "p" + }; +} + +export function norm1(p: point): number { + return Math.abs(p.x) + Math.abs(p.y) | 0; +} + +export function moveX(p: point, dx: number): point { + return { + x: p.x + dx | 0, + y: p.y, + label: p.label + }; +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/src/Shape.res b/tests/build_tests/emit_ts/src/Shape.res new file mode 100644 index 0000000000..256b532f9f --- /dev/null +++ b/tests/build_tests/emit_ts/src/Shape.res @@ -0,0 +1,18 @@ +type shape = + | Circle(float) + | Rect(float, float) + | Empty + +let area = (s: shape) => + switch s { + | Circle(r) => r *. r *. 3.14 + | Rect(w, h) => w *. h + | Empty => 0.0 + } + +let describe = (s: shape) => + switch s { + | Circle(_) => "circle" + | Rect(_, _) => "rect" + | Empty => "empty" + } diff --git a/tests/build_tests/emit_ts/src/Shape.res.ts b/tests/build_tests/emit_ts/src/Shape.res.ts new file mode 100644 index 0000000000..6fa8c82c0c --- /dev/null +++ b/tests/build_tests/emit_ts/src/Shape.res.ts @@ -0,0 +1,30 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +export type shape = + "Empty" + | { TAG: "Circle"; _0: number } + | { TAG: "Rect"; _0: number; _1: number }; + +export function area(s: shape): number { + if (typeof s !== "object") { + return 0.0; + } + if (s.TAG !== "Circle") { + return s._0 * s._1; + } + let r = s._0; + return r * r * 3.14; +} + +export function describe(s: shape): string { + if (typeof s !== "object") { + return "empty"; + } else if (s.TAG === "Circle") { + return "circle"; + } else { + return "rect"; + } +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/tsconfig.json b/tests/build_tests/emit_ts/tsconfig.json new file mode 100644 index 0000000000..17fd0ff087 --- /dev/null +++ b/tests/build_tests/emit_ts/tsconfig.json @@ -0,0 +1,15 @@ +{ + "compilerOptions": { + "strict": true, + "module": "ESNext", + "moduleResolution": "Bundler", + "target": "ES2022", + "noEmit": true, + "allowImportingTsExtensions": true, + "skipLibCheck": false, + "paths": { + "@rescript/runtime/lib/es6/*.mjs": ["./runtime-dts/*.d.mts"] + } + }, + "include": ["src/*.res.ts"] +} From beb62847a8b0e403672953b5ccac1eaf64e2a264 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 05:32:47 +0100 Subject: [PATCH 5/8] Print option types true of the nested-option encoding under -bs-emit-ts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: `option` printed `undefined | t`, but `Some(v)` is a marker object `{BS_PRIVATE_NESTED_SOME_NONE: depth}` when `v` is `undefined` or a marker, so the type was false for `option>` and `option`. At a type parameter it was false at a nested instantiation, and the runtime declarations `valFromOption(x: A): A`, `getOr` and `map` were false there: at `A` the marker type, `valFromOption(some(undefined))` returns `undefined`. A verifier taking those declarations accepted programs returning wrong values. Representation modified (option under -bs-emit-ts): Before (representation): option ↦ undefined | number option> ↦ undefined | (undefined | number) option<'a> ↦ undefined | a After (representation): option ↦ undefined | number option> ↦ undefined | (undefined | number) | { readonly BS_PRIVATE_NESTED_SOME_NONE: number } option<'a> ↦ undefined | a, with a extends string | number | boolean | bigint option<'a> in a type declaration ↦ undefined | a | { readonly BS_PRIVATE_NESTED_SOME_NONE: number } rule: the marker arm is printed where Typeopt.type_cannot_contain_undefined fails for the payload, the test that selects Psome over Psome_not_nest JS modified (-bs-emit-ts type parameters): Example: let getOr = (o, d) => switch o { | Some(v) => v | None => d } Before (js): export function getOr(o: (undefined | T1), d: T1): T1 { After (js): export function getOr(o: (undefined | T1), d: T1): T1 { JS modified (-bs-emit-ts nested options): Example: type box<'a> = {v: option<'a>} let keep = (o: option>) => o Before (js): export type box = { readonly v: (undefined | a) }; export function keep(o: (undefined | (undefined | number))): (undefined | (undefined | number)) { After (js): export type box = { readonly v: (undefined | ( a | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })) }; export function keep(o: (undefined | ( (undefined | number) | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): … Review: Why bound a type parameter by the primitives, and not by every type without the marker key? `some(x)` and `valFromOption(x)` return `x` exactly when `x` is not `undefined` and its key `BS_PRIVATE_NESTED_SOME_NONE` reads `undefined`. A primitive owns no keys and its untampered prototypes hold none. A TypeScript record type admits values owning further keys, and a weak type `{ BS_PRIVATE_NESTED_SOME_NONE?: undefined }` rejects every record that does not state that field, so no wider bound is both true and usable. Review: What does the bound refuse? A call of such a function at a non-primitive instantiation, `getOr` of an `option` say, fails tsc. A nested match such as `Some(Some(n))` fails tsc too: the marker arm erases the depth, so no true declaration of `valFromOption` returns the payload type there. The runtime declarations in runtime-dts state the same bound, each line audited against Primitive_option.res and Stdlib_Option.res, and Stdlib_Array.reduce's callback receives the index and the array that Array.prototype.reduce passes. The Nest example shows the marker arm and the bound. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/core/js_ts_annot.ml | 112 +++++++++++++++--- compiler/gentype/gentype_config.ml | 6 + .../gentype/translate_type_expr_from_types.ml | 36 ++++++ .../runtime-dts/Primitive_option.d.mts | 18 ++- .../emit_ts/runtime-dts/Stdlib_Array.d.mts | 9 +- .../emit_ts/runtime-dts/Stdlib_Option.d.mts | 24 ++-- tests/build_tests/emit_ts/src/Gen.res.ts | 2 +- tests/build_tests/emit_ts/src/Nest.res | 17 +++ tests/build_tests/emit_ts/src/Nest.res.ts | 39 ++++++ 9 files changed, 229 insertions(+), 34 deletions(-) create mode 100644 tests/build_tests/emit_ts/src/Nest.res create mode 100644 tests/build_tests/emit_ts/src/Nest.res.ts diff --git a/compiler/core/js_ts_annot.ml b/compiler/core/js_ts_annot.ml index bab25d4b0a..d4cac97a98 100644 --- a/compiler/core/js_ts_annot.ml +++ b/compiler/core/js_ts_annot.ml @@ -19,7 +19,8 @@ type state = { params: (key, param) Hashtbl.t; (** parameter ident -> its annotation *) results: (key, string) Hashtbl.t; (** top-level function -> result type *) generics: (key, string list) Hashtbl.t; - (** top-level function -> its type parameters, in order of occurrence *) + (** top-level function -> its type parameters, in order of occurrence, + each with its bound if it has one *) names: (string, int) Hashtbl.t; (** top-level function name -> its stamp, to report lost stamps *) mutable header: string; (** the module's type declarations *) @@ -56,6 +57,57 @@ let ts_suffix suffix = let config () = {Gentype_config.default with everything = true} +(* [option] holds [undefined] for [None], and for [Some(v)] the value + [Primitive_option.some(v)]: [v] itself, or a frozen marker object + [{BS_PRIVATE_NESTED_SOME_NONE: depth}] when [v] is [undefined] or a marker. + The compiler unwraps and wraps with the identity where the payload type + cannot hold [undefined] ([Typeopt.type_cannot_contain_undefined]); there + [option] prints [undefined | t]. Elsewhere it prints + [undefined | t | {readonly BS_PRIVATE_NESTED_SOME_NONE: number}], except + at a function's type parameter, which is bounded instead (below). *) +let payload_may_nest ~env (t : Types.type_expr) = + not (Typeopt.type_cannot_contain_undefined t env) + +let signature_payload_may_nest ~env (t : Types.type_expr) = + match (Ctype.repr t).desc with + | Tvar _ -> false + | _ -> payload_may_nest ~env t + +(* The bound of a function's type parameter that is an option's payload: the + types none of whose values is [undefined] or a marker, so that + [Primitive_option.some] and [valFromOption] return such a value unchanged + and [option] is exactly [undefined | a]. A primitive owns no key + [BS_PRIVATE_NESTED_SOME_NONE], and its prototypes hold none. A record type + does not exclude the key: TypeScript's object types admit further keys. *) +let payload_bound = "string | number | boolean | bigint" + +(* The type variables that are the payload of an option in [t]. *) +let rec payload_vars (t : Gentype_common.type_) = + match t with + | Option (TypeVar v) -> [v] + | Array (t, _) | Dict t | Null t | Nullable t | Option t | Promise t -> + payload_vars t + | Function {arg_types; ret_type} -> + List.concat_map + (fun (a : Gentype_common.arg_type) -> payload_vars a.a_type) + arg_types + @ payload_vars ret_type + | Ident {type_args} -> List.concat_map payload_vars type_args + | Object (_, fields) -> + List.concat_map + (fun (f : Gentype_common.field) -> + match (f.optional, f.type_) with + | Optional, TypeVar v -> [v] + | _ -> payload_vars f.type_) + fields + | Tuple ts -> List.concat_map payload_vars ts + | TypeVar _ -> [] + | Variant {inherits; payloads} -> + List.concat_map payload_vars inherits + @ List.concat_map + (fun (p : Gentype_common.payload) -> payload_vars p.t) + payloads + let type_to_string type_ = Emit_type.type_to_string ~config:(config ()) ~type_name_is_interface:(fun _ -> false) @@ -64,10 +116,13 @@ let type_to_string type_ = (* The types of one function's parameters and result, translated with one namer for anonymous type variables, so a variable shared between them gets one name. Also the type variables, in order of first occurrence. *) -let ts_of_signature type_env (type_exprs : Types.type_expr list) = +let ts_of_signature ~env type_env (type_exprs : Types.type_expr list) = + let config = + {(config ()) with option_payload_may_nest = signature_payload_may_nest ~env} + in let translations = - Translate_type_expr_from_types.translate_type_exprs_from_types - ~config:(config ()) ~type_env type_exprs + Translate_type_expr_from_types.translate_type_exprs_from_types ~config + ~type_env type_exprs in let type_vars = List.fold_left @@ -77,7 +132,9 @@ let ts_of_signature type_env (type_exprs : Types.type_expr list) = acc (Type_vars.free t.type_)) [] translations in - (Ext_list.map translations (fun t -> type_to_string t.type_), type_vars) + ( Ext_list.map translations (fun t -> type_to_string t.type_), + type_vars, + Ext_list.map translations (fun t -> t.type_) ) let debug = Sys.getenv_opt "RESCRIPT_EMIT_TS_DEBUG" <> None @@ -94,16 +151,21 @@ let option_element (t : Types.type_expr) = (* The parameters printed [p?: t]: the optional labelled arguments after the last mandatory one, because TypeScript requires every parameter after an - optional one to be optional. An optional argument earlier in the list - prints [p: undefined | t]; a call from ReScript passes [undefined] for an - omitted argument in either position. *) -let rec trailing_optionals (params : Typedtree.function_param list) = + optional one to be optional, whose element type [t] holds no marker. An + optional argument earlier in the list prints [p: undefined | t]; a call + from ReScript passes [undefined] for an omitted argument in either + position. *) +let rec trailing_optionals ~env (params : Typedtree.function_param list) = match params with | [] -> ([], true) | p :: rest -> - let flags, all_optional = trailing_optionals rest in + let flags, all_optional = trailing_optionals ~env rest in let optional = - all_optional && is_optional p && option_element p.fp_pat.pat_type <> None + all_optional && is_optional p + && + match option_element p.fp_pat.pat_type with + | Some elt -> not (signature_payload_may_nest ~env elt) + | None -> false in (optional :: flags, optional) @@ -111,7 +173,8 @@ let collect_function st type_env (id : Ident.t) (e : Typedtree.expression) = match e.exp_desc with | Texp_function {params; body} -> Hashtbl.replace st.names id.name id.stamp; - let optionals, _ = trailing_optionals params in + let env = e.exp_env in + let optionals, _ = trailing_optionals ~env params in let param_types = List.map2 (fun (p : Typedtree.function_param) optional -> @@ -120,10 +183,22 @@ let collect_function st type_env (id : Ident.t) (e : Typedtree.expression) = | _ -> p.fp_pat.pat_type) params optionals in - let types, type_vars = - ts_of_signature type_env (param_types @ [body.exp_type]) + let types, type_vars, translated = + ts_of_signature ~env type_env (param_types @ [body.exp_type]) in - if type_vars <> [] then Hashtbl.replace st.generics (key_of id) type_vars; + let bounded = + List.concat + (List.map2 + (fun optional (t : Gentype_common.type_) -> + match (optional, t) with + | true, TypeVar v -> [v] + | _ -> payload_vars t) + (optionals @ [false]) translated) + in + if type_vars <> [] then + Hashtbl.replace st.generics (key_of id) + (Ext_list.map type_vars (fun v -> + if List.mem v bounded then v ^ " extends " ^ payload_bound else v)); let rec bind params optionals types = match (params, optionals, types) with | [], [], [result] -> Hashtbl.replace st.results (key_of id) result @@ -143,7 +218,12 @@ let is_type_declaration (item : Typedtree.structure_item) = | _ -> false let header_of_structure ~module_name (str : Typedtree.structure) = - let config = config () in + let config = + { + (config ()) with + option_payload_may_nest = payload_may_nest ~env:str.str_final_env; + } + in let type_env = Type_env.root () in let output_file_relative = module_name ^ ".res.ts" in let resolver = diff --git a/compiler/gentype/gentype_config.ml b/compiler/gentype/gentype_config.ml index 45635bf1d2..169ec3f603 100644 --- a/compiler/gentype/gentype_config.ml +++ b/compiler/gentype/gentype_config.ml @@ -28,6 +28,10 @@ type t = { shims_map: Module_name.t Module_name_map.t; sources: string list; suffix: string; + option_payload_may_nest: Types.type_expr -> bool; + (** Whether [option] can hold a nested-option marker for this + payload [t]: [Some(v)] is a marker when [v] is [undefined] or a + marker, so the option then prints with the marker type *) } let default = @@ -47,6 +51,7 @@ let default = shims_map = Module_name_map.empty; sources = []; suffix = ".bs.js"; + option_payload_may_nest = (fun _ -> false); } (* ----- CLI-flag backing state ----------------------------------------- *) @@ -195,4 +200,5 @@ let build_config ~namespace = shims_map; sources = !(source_dirs_flag ()); suffix; + option_payload_may_nest = default.option_payload_may_nest; } diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index 33a2d33c95..48a50e79b5 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -470,6 +470,22 @@ let process_variant row_fields = in row_fields |> loop ~no_payloads:[] ~payloads:[] ~unknowns:[] +(* The runtime's representation of [Some(v)] when [v] is [undefined] or + itself a marker: a frozen object holding the nesting depth + (Primitive_option.marker). *) +let nested_option_marker = + Object + ( Closed, + [ + { + mutable_ = Immutable; + name_js = "BS_PRIVATE_NESTED_SOME_NONE"; + optional = Mandatory; + type_ = number_t; + doc_string = Doc_string.empty; + }; + ] ) + let rec translate_arrow_type ~config ~type_vars_gen ~type_env (params : Types.arg list) (ret : Types.type_expr) = let rev_arg_deps, rev_args = @@ -539,6 +555,26 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env | Tconstr (path, [{desc = Tlink te}], r) -> {type_expr with desc = Types.Tconstr (path, [te], r)} |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + | Tconstr (path, [payload], _) + when Path.same path Predef.path_option + && config.Config.option_payload_may_nest payload -> + let translation = + payload |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + in + { + translation with + type_ = + Option + (Variant + { + inherits = [translation.type_; nested_option_marker]; + no_payloads = []; + payloads = []; + polymorphic = false; + tag = None; + unboxed = false; + }); + } | Tconstr (path, type_params, _) -> let params_translation = type_params diff --git a/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts b/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts index e820f34006..3d2fc321d1 100644 --- a/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts +++ b/tests/build_tests/emit_ts/runtime-dts/Primitive_option.d.mts @@ -1,5 +1,13 @@ -// External contract for Primitive_option.valFromOption, the unboxing of a -// value already tested to be Some. Stated for an element type that does not -// itself include undefined: there the runtime value of Some(v) is v, and -// valFromOption returns it unchanged. -export declare function valFromOption(x: A): A; +// External contract for Primitive_option.some and valFromOption +// (packages/@rescript/runtime/Primitive_option.res), the boxing of a payload +// into Some and its unboxing, at a primitive payload. Each returns its +// argument x unless x is undefined, or is not null and owns or inherits a +// defined BS_PRIVATE_NESTED_SOME_NONE (a nested-option marker). A string, +// number, boolean or bigint is not undefined and owns no such key, and its +// standard prototype chain, untampered, holds none, so x is returned. +export declare function some( + x: A, +): A; +export declare function valFromOption< + A extends string | number | boolean | bigint, +>(x: A): A; diff --git a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts index d6a1c05924..e34feeac12 100644 --- a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts +++ b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Array.d.mts @@ -1,7 +1,10 @@ -// External contract for the one function of Stdlib_Array the examples use: -// reduce(arr, init, f) is arr.reduce(f, init). +// External contract for the one function of Stdlib_Array the examples use +// (packages/@rescript/runtime/Stdlib_Array.res): reduce(arr, init, f) is +// arr.reduce(f, init), the standard Array.prototype.reduce, untampered. It +// calls f with the accumulator, an element, its index and the array, for +// each index present, and returns init for an empty array. export declare function reduce( arr: readonly A[], init: B, - f: (acc: B, x: A) => B, + f: (acc: B, x: A, index: number, array: readonly A[]) => B, ): B; diff --git a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts index b78368f109..27167d9528 100644 --- a/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts +++ b/tests/build_tests/emit_ts/runtime-dts/Stdlib_Option.d.mts @@ -1,9 +1,15 @@ -// External contract for the two functions of Stdlib_Option the examples use. -// Stated for an element type that does not itself include undefined: the -// runtime boxes a nested None (Primitive_option.some), which `A | undefined` -// does not describe. -export declare function map( - opt: A | undefined, - f: (x: A) => B, -): B | undefined; -export declare function getOr(opt: A | undefined, d: A): A; +// External contract for the two functions of Stdlib_Option +// (packages/@rescript/runtime/Stdlib_Option.res) the examples use, at +// primitive payloads, where Primitive_option.some and valFromOption return +// their argument (Primitive_option.d.mts): +// - map(opt, f) is undefined for undefined, else some(f(valFromOption(opt))), +// calling f once with one argument; +// - getOr(opt, d) is d for undefined, else valFromOption(opt). +export declare function map< + A extends string | number | boolean | bigint, + B extends string | number | boolean | bigint, +>(opt: undefined | A, f: (x: A) => B): undefined | B; +export declare function getOr( + opt: undefined | A, + d: A, +): A; diff --git a/tests/build_tests/emit_ts/src/Gen.res.ts b/tests/build_tests/emit_ts/src/Gen.res.ts index eb49d506f6..da2ee69a70 100644 --- a/tests/build_tests/emit_ts/src/Gen.res.ts +++ b/tests/build_tests/emit_ts/src/Gen.res.ts @@ -25,7 +25,7 @@ export function applyTwice(f: (_1:T1) => T1, x: T1): T1 { return f(f(x)); } -export function getOr(o: (undefined | T1), d: T1): T1 { +export function getOr(o: (undefined | T1), d: T1): T1 { if (o !== undefined) { return Primitive_option.valFromOption(o); } else { diff --git a/tests/build_tests/emit_ts/src/Nest.res b/tests/build_tests/emit_ts/src/Nest.res new file mode 100644 index 0000000000..ec191baf2d --- /dev/null +++ b/tests/build_tests/emit_ts/src/Nest.res @@ -0,0 +1,17 @@ +type box<'a> = {v: option<'a>} + +let keep = (o: option>) => o + +let skip = (o: option) => + switch o { + | Some(_) => 1 + | None => 0 + } + +let rewrap = (o: option<'a>) => + switch o { + | Some(x) => Some(x) + | None => None + } + +let boxed = (x: int) => {v: Some(x)} diff --git a/tests/build_tests/emit_ts/src/Nest.res.ts b/tests/build_tests/emit_ts/src/Nest.res.ts new file mode 100644 index 0000000000..d365b9395b --- /dev/null +++ b/tests/build_tests/emit_ts/src/Nest.res.ts @@ -0,0 +1,39 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +export type box = { readonly v: (undefined | ( + a + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })) }; + +export function keep(o: (undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): (undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })) { + return o; +} + +export function skip(o: (undefined | ( + void + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): number { + if (o !== undefined) { + return 1; + } else { + return 0; + } +} + +export function rewrap(o: (undefined | a)): (undefined | a) { + if (o !== undefined) { + return Primitive_option.some(Primitive_option.valFromOption(o)); + } +} + +export function boxed(x: number): box { + return { + v: x + }; +} + +/* No side effect */ From ccb1f14e7827beae6f925886c113455228fd980d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 05:39:10 +0100 Subject: [PATCH 6/8] Print the marker arm of option in aliases and optional arguments of arrows Why: The marker arm reached only options genType translated from a type expression as `option`. A type declaration's manifest, translated from its core type, and an optional argument of a function type, whose option genType rebuilds, still printed `undefined | t` for a payload that can hold a marker. An optional argument of a function type in a type declaration also lost its option: the core type of `~x: int=?` is its payload `int`, which genType read as the whole argument. JS modified (-bs-emit-ts type declarations): Example: type opt<'a> = option<'a> type callback = (~x: option=?) => int type cb2 = (~x: int=?) => int Before (js): export type opt = (undefined | a); export type callback = (x:(undefined | number)) => number; export type cb2 = (x:number) => number; After (js): export type opt = (undefined | ( a | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })); export type callback = (x:(undefined | ( (undefined | number) | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))) => number; export type cb2 = (x:(undefined | number)) => number; Review: Does this change genType's own output? Only where a type declaration has an optional argument in a function type, which genType printed without its `undefined`; the marker arm is off outside -bs-emit-ts, and the gentype tests' outputs are unchanged. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/gentype/translate_core_type.ml | 60 +++++++++---------- .../gentype/translate_type_expr_from_types.ml | 33 +++++----- tests/build_tests/emit_ts/src/Nest.res | 12 ++++ tests/build_tests/emit_ts/src/Nest.res.ts | 24 ++++++++ 4 files changed, 83 insertions(+), 46 deletions(-) diff --git a/compiler/gentype/translate_core_type.ml b/compiler/gentype/translate_core_type.ml index 6a961d32d5..7f5ea0c21b 100644 --- a/compiler/gentype/translate_core_type.ml +++ b/compiler/gentype/translate_core_type.ml @@ -1,19 +1,6 @@ open Gentype_common open! Translate_type_expr_from_types -let remove_option ~(label : Asttypes.arg_label) - (core_type : Typedtree.core_type) = - match (core_type.ctyp_desc, label) with - | Ttyp_constr (Path.Pident id, _, [t]), Optional {txt = lbl} - when Ident.name id = "option" -> - Some (lbl, t) - | ( Ttyp_constr (Pdot (Path.Pident name_space, id, _), _, [t]), - Optional {txt = lbl} ) - when (* This has a different representation in 4.03+ *) - Ident.name name_space = "FB" && id = "option" -> - Some (lbl, t) - | _ -> None - type process_variant = { no_payloads: (string * Typedtree.attributes) list; payloads: (string * Typedtree.attributes * Typedtree.core_type) list; @@ -62,30 +49,31 @@ let rec translate_arrow_type ~config ~type_vars_gen in ( List.rev_append dependencies rev_arg_deps, (Nolabel, type_) :: rev_args ) - | (Labelled {txt = lbl_txt} | Optional {txt = lbl_txt}) as label -> ( + | Labelled {txt = lbl_txt} -> let as_label = match attrs |> Annotation.get_gentype_as_renaming with | Some s -> s | None -> "" in - match typ |> remove_option ~label with - | None -> - let {dependencies; type_ = type1} = - typ |> translateCoreType_ ~config ~type_vars_gen ~type_env - in - ( List.rev_append dependencies rev_arg_deps, - ( Label - (match as_label = "" with - | true -> lbl_txt - | false -> as_label), - type1 ) - :: rev_args ) - | Some (lbl_txt, t1) -> - let {dependencies; type_ = type1} = - t1 |> translateCoreType_ ~config ~type_vars_gen ~type_env - in - ( List.rev_append dependencies rev_arg_deps, - (OptLabel lbl_txt, type1) :: rev_args ))) + let {dependencies; type_ = type1} = + typ |> translateCoreType_ ~config ~type_vars_gen ~type_env + in + ( List.rev_append dependencies rev_arg_deps, + ( Label + (match as_label = "" with + | true -> lbl_txt + | false -> as_label), + type1 ) + :: rev_args ) + | Optional {txt = lbl_txt} -> + (* The core type of an optional argument is its option's payload: + Typetexp wraps it in [option] *) + let {dependencies; type_ = type1} = + typ |> translateCoreType_ ~config ~type_vars_gen ~type_env + in + let type1 = some_type ~config typ.ctyp_type type1 in + ( List.rev_append dependencies rev_arg_deps, + (OptLabel lbl_txt, type1) :: rev_args )) ([], []) params in let {dependencies; type_ = ret_type} = @@ -137,6 +125,14 @@ and translateCoreType_ ~config ~type_vars_gen | true -> Closed | false -> Open) fields_translations + | Ttyp_constr (path, _, [payload]) when Path.same path Predef.path_option -> + let translation = + payload |> translateCoreType_ ~config ~type_vars_gen ~type_env + in + { + translation with + type_ = Option (some_type ~config payload.ctyp_type translation.type_); + } | Ttyp_constr (path, _, type_params) -> let params_translation = type_params |> translateCoreTypes_ ~config ~type_vars_gen ~type_env diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index 48a50e79b5..5f1d1308ef 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -486,6 +486,22 @@ let nested_option_marker = }; ] ) +(* The payload of an option as the option's representation holds it: the + payload's type, joined with the marker type where the payload can hold a + marker. *) +let some_type ~config (payload : Types.type_expr) type_ = + if config.Config.option_payload_may_nest payload then + Variant + { + inherits = [type_; nested_option_marker]; + no_payloads = []; + payloads = []; + polymorphic = false; + tag = None; + unboxed = false; + } + else type_ + let rec translate_arrow_type ~config ~type_vars_gen ~type_env (params : Types.arg list) (ret : Types.type_expr) = let rev_arg_deps, rev_args = @@ -511,6 +527,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env let {dependencies; type_ = type1} = t1 |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env in + let type1 = some_type ~config t1 type1 in ( List.rev_append dependencies rev_arg_deps, (OptLabel lbl_txt, type1) :: rev_args ))) ([], []) params @@ -555,25 +572,13 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env | Tconstr (path, [{desc = Tlink te}], r) -> {type_expr with desc = Types.Tconstr (path, [te], r)} |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - | Tconstr (path, [payload], _) - when Path.same path Predef.path_option - && config.Config.option_payload_may_nest payload -> + | Tconstr (path, [payload], _) when Path.same path Predef.path_option -> let translation = payload |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env in { translation with - type_ = - Option - (Variant - { - inherits = [translation.type_; nested_option_marker]; - no_payloads = []; - payloads = []; - polymorphic = false; - tag = None; - unboxed = false; - }); + type_ = Option (some_type ~config payload translation.type_); } | Tconstr (path, type_params, _) -> let params_translation = diff --git a/tests/build_tests/emit_ts/src/Nest.res b/tests/build_tests/emit_ts/src/Nest.res index ec191baf2d..05b8a35956 100644 --- a/tests/build_tests/emit_ts/src/Nest.res +++ b/tests/build_tests/emit_ts/src/Nest.res @@ -1,7 +1,17 @@ type box<'a> = {v: option<'a>} +type opt<'a> = option<'a> + +type nested = option> + +type callback = (~x: option=?) => int + let keep = (o: option>) => o +let keepAlias = (o: opt<'a>) => o + +let keepNested = (o: nested) => o + let skip = (o: option) => switch o { | Some(_) => 1 @@ -15,3 +25,5 @@ let rewrap = (o: option<'a>) => } let boxed = (x: int) => {v: Some(x)} + +let call = (f: callback) => f() diff --git a/tests/build_tests/emit_ts/src/Nest.res.ts b/tests/build_tests/emit_ts/src/Nest.res.ts index d365b9395b..6dc7753dcd 100644 --- a/tests/build_tests/emit_ts/src/Nest.res.ts +++ b/tests/build_tests/emit_ts/src/Nest.res.ts @@ -6,6 +6,18 @@ export type box = { readonly v: (undefined | ( a | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })) }; +export type opt = (undefined | ( + a + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })); + +export type nested = (undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number })); + +export type callback = (x:(undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))) => number; + export function keep(o: (undefined | ( (undefined | number) | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): (undefined | ( @@ -14,6 +26,14 @@ export function keep(o: (undefined | ( return o; } +export function keepAlias(o: opt): opt { + return o; +} + +export function keepNested(o: nested): nested { + return o; +} + export function skip(o: (undefined | ( void | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): number { @@ -36,4 +56,8 @@ export function boxed(x: number): box { }; } +export function call(f: callback): number { + return f(undefined); +} + /* No side effect */ From b0a9c17b2454e1b43e65909fb409d104c821ad4e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 06:12:51 +0100 Subject: [PATCH 7/8] Print a function body that is only return; under -bs-emit-ts Why: The printer drops a lone `return;`, so such a function prints an empty body. TypeScript requires a `return` in a function whose declared result type is other than `undefined`, `void` or `any`, and rejects the empty body with TS2355. JS modified (-bs-emit-ts body that is only return;): Example: let none = (): option => None Before (js): export function none(): (undefined | number) { } After (js): export function none(): (undefined | number) { return; } Review: Does JavaScript output change? No: the statement is kept only under -bs-emit-ts. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- compiler/core/js_dump.ml | 8 +++++++- tests/build_tests/emit_ts/src/Opt.res | 2 ++ tests/build_tests/emit_ts/src/Opt.res.ts | 4 ++++ 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 29baedcb51..280f0a8eae 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1621,7 +1621,13 @@ and function_body ?directive (cxt : cxt) f ~return_unit (b : J.block) : unit = ignore (statement false cxt f {s with statement_desc = If (bool, then_, [])} : cxt) - | Return {expression_desc = Undefined _} -> () + (* A function whose body is only [return;] prints an empty body, except + under [-bs-emit-ts]: TypeScript requires a [return] in a function + whose declared result type is other than [undefined], [void] or + [any]. *) + | Return {expression_desc = Undefined _} when not (Js_ts_annot.enabled ()) + -> + () | Return exp when return_unit -> ignore (statement false cxt f (S.exp exp) : cxt) | _ -> ignore (statement false cxt f s : cxt)) diff --git a/tests/build_tests/emit_ts/src/Opt.res b/tests/build_tests/emit_ts/src/Opt.res index 2770dc0587..6e53bb4212 100644 --- a/tests/build_tests/emit_ts/src/Opt.res +++ b/tests/build_tests/emit_ts/src/Opt.res @@ -14,3 +14,5 @@ let firstPositive = (a: int, b: int) => } else { None } + +let none = (): option => None diff --git a/tests/build_tests/emit_ts/src/Opt.res.ts b/tests/build_tests/emit_ts/src/Opt.res.ts index 339a6812ef..69d4b5528e 100644 --- a/tests/build_tests/emit_ts/src/Opt.res.ts +++ b/tests/build_tests/emit_ts/src/Opt.res.ts @@ -24,4 +24,8 @@ export function firstPositive(a: number, b: number): (undefined | number) { } } +export function none(): (undefined | number) { + return; +} + /* No side effect */ From 8a1bb7e7fe6db45ea59d3408535c2cc85a58c089 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Nov 2026 06:12:51 +0100 Subject: [PATCH 8/8] Record tsc's diagnostics for the emit_ts examples, with nested-option unwrapping The emit_ts test writes what tsc --strict reports for the generated TypeScript to a checked-in tsc.txt, so an example the printed types refuse is checked in with its diagnostics. NestMatch unwraps nested options: a nested match and the generic getOr at 'a = option, which the primitive bound on Primitive_option refuses. Co-Authored-By: Claude Opus 5.5 Signed-off-by: Cristiano Calcagno --- tests/build_tests/emit_ts/input.js | 14 ++++--- tests/build_tests/emit_ts/src/NestMatch.res | 22 +++++++++++ .../build_tests/emit_ts/src/NestMatch.res.ts | 37 +++++++++++++++++++ tests/build_tests/emit_ts/tsc.txt | 8 ++++ 4 files changed, 76 insertions(+), 5 deletions(-) create mode 100644 tests/build_tests/emit_ts/src/NestMatch.res create mode 100644 tests/build_tests/emit_ts/src/NestMatch.res.ts create mode 100644 tests/build_tests/emit_ts/tsc.txt diff --git a/tests/build_tests/emit_ts/input.js b/tests/build_tests/emit_ts/input.js index 063cc262c7..6859bd0d86 100644 --- a/tests/build_tests/emit_ts/input.js +++ b/tests/build_tests/emit_ts/input.js @@ -1,11 +1,12 @@ // @ts-check // The examples compiled with -bs-emit-ts. The generated src/*.res.ts are -// checked in, and must type-check under tsc --strict against the runtime -// declarations in runtime-dts/. +// checked in, and so is tsc.txt: what tsc --strict reports for them against +// the runtime declarations in runtime-dts/. import * as assert from "node:assert"; import * as child_process from "node:child_process"; +import * as fs from "node:fs/promises"; import * as path from "node:path"; import { setup } from "#dev/process"; @@ -19,8 +20,11 @@ const tsc = child_process.spawnSync( [ path.join(import.meta.dirname, "../../../node_modules/typescript/bin/tsc"), "-p", - import.meta.dirname, + ".", + "--pretty", + "false", ], - { encoding: "utf8" }, + { cwd: import.meta.dirname, encoding: "utf8" }, ); -assert.equal(tsc.status, 0, tsc.stdout + tsc.stderr); +assert.equal(tsc.stderr, ""); +await fs.writeFile(path.join(import.meta.dirname, "tsc.txt"), tsc.stdout); diff --git a/tests/build_tests/emit_ts/src/NestMatch.res b/tests/build_tests/emit_ts/src/NestMatch.res new file mode 100644 index 0000000000..3a07461a98 --- /dev/null +++ b/tests/build_tests/emit_ts/src/NestMatch.res @@ -0,0 +1,22 @@ +// Nested options unwrapped, which the primitive bound on Primitive_option +// refuses. + +let getOr = (o: option<'a>, d: 'a) => + switch o { + | Some(v) => v + | None => d + } + +// The generic getOr at 'a = option. +let useNested = (o: option>) => getOr(o, Some(3)) + +// The same call on constants, which the optimizer folds to None. +let useNestedFolded = () => getOr(Some(None), Some(3)) + +// A nested match. +let inner = (o: option>) => + switch o { + | Some(Some(n)) => n + | Some(None) => -1 + | None => 0 + } diff --git a/tests/build_tests/emit_ts/src/NestMatch.res.ts b/tests/build_tests/emit_ts/src/NestMatch.res.ts new file mode 100644 index 0000000000..1763404bb3 --- /dev/null +++ b/tests/build_tests/emit_ts/src/NestMatch.res.ts @@ -0,0 +1,37 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +export function getOr(o: (undefined | a), d: a): a { + if (o !== undefined) { + return Primitive_option.valFromOption(o); + } else { + return d; + } +} + +export function useNested(o: (undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): (undefined | number) { + return getOr(o, 3); +} + +export function useNestedFolded(): (undefined | number) { + return; +} + +export function inner(o: (undefined | ( + (undefined | number) + | { readonly BS_PRIVATE_NESTED_SOME_NONE: number }))): number { + if (o === undefined) { + return 0; + } + let n = Primitive_option.valFromOption(o); + if (n !== undefined) { + return n; + } else { + return -1; + } +} + +/* No side effect */ diff --git a/tests/build_tests/emit_ts/tsc.txt b/tests/build_tests/emit_ts/tsc.txt new file mode 100644 index 0000000000..1ed5568c8b --- /dev/null +++ b/tests/build_tests/emit_ts/tsc.txt @@ -0,0 +1,8 @@ +src/NestMatch.res.ts(16,3): error TS2322: Type 'string | number | bigint | boolean' is not assignable to type 'number | undefined'. + Type 'string' is not assignable to type 'number'. +src/NestMatch.res.ts(16,16): error TS2345: Argument of type 'number | { readonly BS_PRIVATE_NESTED_SOME_NONE: number; } | undefined' is not assignable to parameter of type 'string | number | bigint | boolean | undefined'. + Type '{ readonly BS_PRIVATE_NESTED_SOME_NONE: number; }' is not assignable to type 'string | number | bigint | boolean | undefined'. +src/NestMatch.res.ts(29,42): error TS2345: Argument of type 'number | { readonly BS_PRIVATE_NESTED_SOME_NONE: number; }' is not assignable to parameter of type 'string | number | bigint | boolean'. + Type '{ readonly BS_PRIVATE_NESTED_SOME_NONE: number; }' is not assignable to type 'string | number | bigint | boolean'. +src/NestMatch.res.ts(31,5): error TS2322: Type 'string | number | bigint | boolean' is not assignable to type 'number'. + Type 'string' is not assignable to type 'number'.