[Exploration] $GenTypeImport TS checker for checking imports via GenType

Makefile

@@ -43,6 +43,7 @@ test-syntax-roundtrip:
 test-gentype:
 	make -C tests/gentype_tests/typescript-react-example clean test
 	make -C tests/gentype_tests/stdlib-no-shims clean test
+	make -C tests/gentype_tests/genimport-single clean test
 
 test-rewatch:
 	./rewatch/tests/suite-ci.sh
@@ -82,6 +83,7 @@ checkformat:
 clean-gentype:
 	make -C tests/gentype_tests/typescript-react-example clean
 	make -C tests/gentype_tests/stdlib-no-shims clean
+	make -C tests/gentype_tests/genimport-single clean
 
 clean-rewatch:
 	cargo clean --manifest-path rewatch/Cargo.toml && rm -f rewatch/rewatch

compiler/gentype/Annotation.ml

@@ -28,10 +28,12 @@ let tag_is_tag s = s = "tag"
 let tag_is_unboxed s = s = "unboxed" || s = "ocaml.unboxed"
 let tag_is_gentype_import s = s = "genType.import" || s = "gentype.import"
 let tag_is_gentype_opaque s = s = "genType.opaque" || s = "gentype.opaque"
+let tag_is_gentype_satisfies s =
+  s = "genType.satisfies" || s = "gentype.satisfies"
 
 let tag_is_one_of_the_gentype_annotations s =
   tag_is_gentype s || tag_is_gentype_as s || tag_is_gentype_import s
-  || tag_is_gentype_opaque s
+  || tag_is_gentype_opaque s || tag_is_gentype_satisfies s
 
 let tag_is_gentype_ignore_interface s =
   s = "genType.ignoreInterface" || s = "gentype.ignoreInterface"
@@ -147,6 +149,25 @@ let get_attribute_import_renaming attributes =
     (Some import_string, Some rename_string)
   | _ -> (None, gentype_as_renaming)
 
+let get_attribute_satisfies attributes =
+  match attributes |> get_attribute_payload tag_is_gentype_satisfies with
+  | Some (_loc, TuplePayload payloads) -> (
+    let strings =
+      payloads
+      |> List.fold_left
+           (fun acc p ->
+             match p with
+             | StringPayload s -> s :: acc
+             | _ -> acc)
+           []
+      |> List.rev
+    in
+    match strings with
+    | [] -> None
+    | import_str :: path -> Some (import_str, path))
+  | Some (_loc, StringPayload s) -> Some (s, [])
+  | _ -> None
+
 let get_tag attributes =
   match attributes |> get_attribute_payload tag_is_tag with
   | Some (_, StringPayload s) -> Some s

compiler/gentype/CodeItem.ml

@@ -15,6 +15,7 @@ type import_value = {
   import_annotation: Annotation.import;
   type_: type_;
   value_name: string;
+  export_binding: bool; (* when false, only emit local satisfies check, no TS export *)
 }
 
 type export_value = {

compiler/gentype/EmitJs.ml

@@ -143,7 +143,8 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name
     Log_.item "Code Item: %s\n"
       (code_item |> code_item_to_string ~config ~type_name_is_interface);
   match code_item with
-  | ImportValue {as_path; import_annotation; type_; value_name} ->
+  | ImportValue {as_path; import_annotation; type_; value_name; export_binding}
+    ->
     let import_path = import_annotation.import_path in
     let first_name_in_path, rest_of_path =
       match value_name = as_path with
@@ -163,8 +164,15 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name
       in
       (emitters, value_name_not_checked, env)
     in
-    let type_ =
+    (* Extract potential satisfies wrapper to drive custom emission. *)
+    let satisfies_rescript_type_opt =
       match type_ with
+      | Ident {builtin = _; name; type_args = [rescript_t; _]}
+        when SatisfiesHelpers.is_helper_ident name -> Some rescript_t
+      | _ -> None
+    in
+    let adjust_for_function_component t =
+      match t with
       | Function
           ({
              arg_types = [{a_type = Object (closed_flag, fields); a_name}];
@@ -217,44 +225,81 @@ let emit_code_item ~config ~emitters ~module_items_emitter ~env ~file_name
             }
           in
           Function function_
-        | _ -> type_)
-      | _ -> type_
+        | _ -> t)
+      | _ -> t
+    in
+    let type_for_emit = adjust_for_function_component type_ in
+    let value_name_type_checked =
+      let base = value_name ^ "TypeChecked" in
+      match export_binding with
+      | false -> "_" ^ base
+      | true -> base
     in
-    let value_name_type_checked = value_name ^ "TypeChecked" in
     let emitters =
-      imported_as_name ^ rest_of_path
-      |> EmitType.emit_export_const ~config
-           ~comment:
-             ("In case of type error, check the type of '" ^ value_name
-            ^ "' in '"
-             ^ (file_name |> ModuleName.to_string)
-             ^ ".res'" ^ " and '"
-             ^ (import_path |> ImportPath.emit)
-             ^ "'.")
-           ~early:true ~emitters ~name:value_name_type_checked ~type_
-           ~type_name_is_interface
+      match satisfies_rescript_type_opt with
+      | Some rescript_type ->
+        let rescript_type = adjust_for_function_component rescript_type in
+        let expr = imported_as_name ^ rest_of_path in
+        (* Non-exported const for the checked binding, emitted early for ordering. *)
+        let comment =
+          match export_binding with
+          | false -> "Check imported TypeScript value conforms to ReScript type"
+          | true -> ""
+        in
+        EmitType.emit_const_satisfies ~early:true ~emitters ~config
+          ~satisfies_type:rescript_type ~type_name_is_interface ~comment
+          value_name_type_checked expr
+      | None ->
+        imported_as_name ^ rest_of_path
+        |> EmitType.emit_export_const ~config
+             ~comment:
+               ("In case of type error, check the type of '" ^ value_name
+              ^ "' in '"
+               ^ (file_name |> ModuleName.to_string)
+               ^ ".res'" ^ " and '"
+               ^ (import_path |> ImportPath.emit)
+               ^ "'.")
+             ~early:true ~emitters ~name:value_name_type_checked ~type_:type_for_emit
+             ~type_name_is_interface
     in
     let value_name_not_default =
       match value_name = "default" with
       | true -> Runtime.default
       | false -> value_name
     in
-    let emitters =
-      value_name_type_checked
-      |> EmitType.emit_type_cast ~config ~type_ ~type_name_is_interface
-      |> EmitType.emit_export_const
-           ~comment:
-             ("Export '" ^ value_name_not_default
-            ^ "' early to allow circular import from the '.bs.js' file.")
-           ~config ~early:true ~emitters ~name:value_name_not_default
-           ~type_:unknown ~type_name_is_interface
-    in
-    let emitters =
-      match value_name = "default" with
-      | true -> EmitType.emit_export_default ~emitters value_name_not_default
-      | false -> emitters
+    let env, emitters =
+      match export_binding with
+      | false -> (env, emitters)
+      | true ->
+        let emitters =
+          match satisfies_rescript_type_opt with
+          | Some _ ->
+            (* For satisfies, we can assign the typed binding directly without casts. *)
+            EmitType.emit_export_const_assign_value ~early:true ~emitters ~config
+              ~name:value_name_not_default ~type_:type_for_emit
+              ~type_name_is_interface value_name_type_checked
+              ~comment:
+                ("Export '" ^ value_name_not_default
+               ^ "' early to allow circular import from the '.bs.js' file.")
+          | None ->
+            value_name_type_checked
+            |> EmitType.emit_type_cast ~config ~type_:type_for_emit
+                 ~type_name_is_interface
+            |> EmitType.emit_export_const
+                 ~comment:
+                   ("Export '" ^ value_name_not_default
+                  ^ "' early to allow circular import from the '.bs.js' file.")
+                 ~config ~early:true ~emitters ~name:value_name_not_default
+                 ~type_:unknown ~type_name_is_interface
+        in
+        let emitters =
+          match value_name = "default" with
+          | true -> EmitType.emit_export_default ~emitters value_name_not_default
+          | false -> emitters
+        in
+        ({env with imported_value_or_component = true}, emitters)
     in
-    ({env with imported_value_or_component = true}, emitters)
+    (env, emitters)
   | ExportValue
       {doc_string; module_access_path; original_name; resolved_name; type_} ->
     let resolved_name_str = ResolvedName.to_string resolved_name in
@@ -654,6 +699,11 @@ let emit_translation_as_string ~config ~file_name
          ~input_cmt_translate_type_declarations ~output_file_relative ~resolver
          ~type_name_is_interface
   in
+  let emitters =
+    match config.emit_satisfies_helper with
+    | true -> SatisfiesHelpers.emit_helper_alias ~emitters
+    | false -> emitters
+  in
   let env, emitters =
     export_from_type_declarations
     |> emit_export_from_type_declarations ~config ~emitters ~env

compiler/gentype/EmitType.ml

@@ -118,18 +118,37 @@ let rec render_type ~(config : Config.t) ?(indent = None)
          ~type_name_is_interface
   | Ident {builtin; name; type_args} ->
     let name = name |> sanitize_type_name in
-    (match
-       (not builtin) && config.export_interfaces
-       && name |> type_name_is_interface
-     with
-    | true -> name |> interface_name ~config
-    | false -> name)
-    ^ EmitText.generics_string
-        ~type_vars:
-          (type_args
-          |> List.map
-               (render_type ~config ~indent ~type_name_is_interface ~in_fun_type)
-          )
+    let rendered_name =
+      match
+        (not builtin) && config.export_interfaces
+        && name |> type_name_is_interface
+      with
+      | true -> name |> interface_name ~config
+      | false -> name
+    in
+    if SatisfiesHelpers.is_helper_ident name then
+      let rendered_type_args_special =
+        type_args
+        |> List.map
+             (render_type ~config ~indent:(Some "  ") ~type_name_is_interface
+                ~in_fun_type)
+      in
+      let rendered_type_args_default =
+        type_args
+        |> List.map
+             (render_type ~config ~indent ~type_name_is_interface ~in_fun_type)
+      in
+      SatisfiesHelpers.render_helper_ident ~rendered_name
+        ~rendered_type_args:rendered_type_args_special
+        ~rendered_type_args_default
+    else
+      rendered_name
+      ^ EmitText.generics_string
+          ~type_vars:
+            (type_args
+            |> List.map
+                 (render_type ~config ~indent ~type_name_is_interface
+                    ~in_fun_type))
   | Null type_ ->
     "(null | "
     ^ (type_ |> render_type ~config ~indent ~type_name_is_interface ~in_fun_type)
@@ -342,6 +361,57 @@ let emit_export_const ~early ?(comment = "") ~config
      | false -> Emitters.export)
        ~emitters
 
+let emit_export_const_satisfies ~early ?(comment = "") ~config
+    ?(doc_string = DocString.empty) ~emitters ~name ~satisfies_type
+    ~type_name_is_interface expr =
+  let type_string =
+    satisfies_type |> type_to_string ~config ~type_name_is_interface
+  in
+  (match comment = "" with
+  | true -> comment
+  | false -> "// " ^ comment ^ "\n")
+  ^ DocString.render doc_string
+  ^ "export const "
+  ^ name
+  ^ " = "
+  ^ expr
+  ^ " satisfies "
+  ^ type_string
+  ^ ";"
+  |> (match early with
+     | true -> Emitters.export_early
+     | false -> Emitters.export)
+       ~emitters
+
+let emit_const_satisfies ~early ~emitters ~config ~satisfies_type
+    ~type_name_is_interface ?(comment = "") name expr =
+  let type_string =
+    satisfies_type |> type_to_string ~config ~type_name_is_interface
+  in
+  ((match comment = "" with
+   | true -> ""
+   | false -> "// " ^ comment ^ "\n")
+  ^ "const " ^ name ^ " = " ^ expr ^ " satisfies " ^ type_string ^ ";")
+  |> (match early with
+     | true -> Emitters.export_early
+     | false -> Emitters.export)
+       ~emitters
+
+let emit_export_const_assign ~early ?(comment = "") ~config
+    ?(doc_string = DocString.empty) ~emitters ~name ~type_
+    ~type_name_is_interface expr =
+  let type_string = type_ |> type_to_string ~config ~type_name_is_interface in
+  (match comment = "" with
+  | true -> comment
+  | false -> "// " ^ comment ^ "\n")
+  ^ DocString.render doc_string
+  ^ "export const " ^ name ^ ": " ^ type_string ^ " = " ^ expr
+  ^ ";" ^ "\n" ^ "// value-satisfies"
+  |> (match early with
+     | true -> Emitters.export_early
+     | false -> Emitters.export)
+       ~emitters
+
 let emit_export_default ~emitters name =
   "export default " ^ name ^ ";" |> Emitters.export ~emitters
 
@@ -453,3 +523,26 @@ let emit_import_type_as ~emitters ~config ~type_name ~as_type_name
 
 let emit_type_cast ~config ~type_ ~type_name_is_interface s =
   s ^ " as " ^ (type_ |> type_to_string ~config ~type_name_is_interface)
+
+let rec type_to_string_for_value ~config ~type_name_is_interface type_ =
+  match type_ with
+  | Ident {builtin = _; name; type_args = res_t :: _}
+    when SatisfiesHelpers.is_helper_ident name ->
+    type_to_string_for_value ~config ~type_name_is_interface res_t
+  | _ -> type_to_string ~config ~type_name_is_interface type_
+
+let emit_export_const_assign_value ~early ?(comment = "") ~config
+    ?(doc_string = DocString.empty) ~emitters ~name ~type_
+    ~type_name_is_interface expr =
+  let type_string =
+    type_ |> type_to_string_for_value ~config ~type_name_is_interface
+  in
+  (match comment = "" with
+  | true -> comment
+  | false -> "// " ^ comment ^ "\n")
+  ^ DocString.render doc_string
+  ^ "export const " ^ name ^ ": " ^ type_string ^ " = " ^ expr ^ ";"
+  |> (match early with
+     | true -> Emitters.export_early
+     | false -> Emitters.export)
+       ~emitters

compiler/gentype/GenTypeCommon.ml

@@ -180,10 +180,13 @@ let ident ?(builtin = true) ?(type_args = []) name =
   Ident {builtin; name; type_args}
 
 let sanitize_type_name name =
-  name
-  |> String.map (function
-       | '\'' -> '_'
-       | c -> c)
+  (* Preserve TS import("...") expressions intact. *)
+  if String.length name >= 7 && String.sub name 0 7 = "import(" then name
+  else
+    name
+    |> String.map (function
+         | '\'' -> '_'
+         | c -> c)
 let unknown = ident "unknown"
 let bigint_t = ident "BigInt"
 let boolean_t = ident "boolean"

compiler/gentype/GenTypeConfig.ml

@@ -17,6 +17,7 @@ type t = {
   bs_dependencies: string list;
   mutable emit_import_curry: bool;
   mutable emit_import_react: bool;
+  mutable emit_satisfies_helper: bool;
   mutable emit_type_prop_done: bool;
   mutable everything: bool;
   export_interfaces: bool;
@@ -37,6 +38,7 @@ let default =
     bs_dependencies = [];
     emit_import_curry = false;
     emit_import_react = false;
+    emit_satisfies_helper = false;
     emit_type_prop_done = false;
     everything = false;
     export_interfaces = false;
@@ -228,6 +230,7 @@ let read_config ~get_config_file ~namespace =
       suffix;
       emit_import_curry = false;
       emit_import_react = false;
+      emit_satisfies_helper = false;
       emit_type_prop_done = false;
       everything;
       export_interfaces;