TScert: print TypeScript for verification under experimental -bs-emit-ts

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" );

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 ();
   }
 

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;
 }
 

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; optional} ->
+        P.string f (if optional then "?:" else ":");
+        P.space f;
+        P.string f ty
+      | None -> ());
+      cxt)
+    comma_sp
+
 (* IdentMap *)
 (*
 f/122 -->
@@ -447,12 +462,31 @@ 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 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 ->
             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;
@@ -486,6 +520,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 ()
@@ -1584,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))

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
   | _ ->

compiler/core/js_dump_program.ml

@@ -120,6 +120,14 @@ 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
+     | "" -> ()
+     | 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
 

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 =