Handle absolute paths in typegen

CHANGELOG.md

@@ -22,9 +22,10 @@
 
 - Use FORCE_COLOR environmental variable to force colorized output https://github.com/rescript-lang/rescript-compiler/pull/7033
 - Allow spreads of variants in patterns (`| ...someVariant as v => `) when the variant spread is a subtype of the variant matched on. https://github.com/rescript-lang/rescript-compiler/pull/6721
-- Fix the issue where dynamic imports are not working for function-defined externals. https://github.com/rescript-lang/rescript-compiler/pull/7060 
+- Fix the issue where dynamic imports are not working for function-defined externals. https://github.com/rescript-lang/rescript-compiler/pull/7060
 - Allow pattern matching on dicts. `switch someDict { | dict{"one": 1} => Js.log("one is one") }`. https://github.com/rescript-lang/rescript-compiler/pull/7059
 - "ReScript Core" standard library is now included in the `rescript` npm package. https://github.com/rescript-lang/rescript-compiler/pull/7108
+- Handle absolute filepaths in gentype. https://github.com/rescript-lang/rescript-compiler/pull/7104
 
 #### :bug: Bug fix
 

compiler/gentype/FindSourceFile.ml

@@ -14,8 +14,17 @@ let rec implementation items =
     | false -> Some str_loc.loc_start.pos_fname)
   | [] -> None
 
+let transform_to_absolute_path (path : string option) =
+  let transform path =
+    if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path
+    else path
+  in
+  Option.map transform path
+
 let cmt cmt_annots =
   match cmt_annots with
-  | Cmt_format.Interface signature -> interface signature.sig_items
-  | Implementation structure -> implementation structure.str_items
+  | Cmt_format.Interface signature ->
+    transform_to_absolute_path (interface signature.sig_items)
+  | Implementation structure ->
+    transform_to_absolute_path (implementation structure.str_items)
   | _ -> None

compiler/gentype/FindSourceFile.mli

@@ -0,0 +1,8 @@
+val cmt : Cmt_format.binary_annots -> string option
+(** 
+  [cmt annots] given [Cmt_format.binary_annots] it returns an absolute source file path
+  if the file exists, otherwise it returns None.
+
+  @param annots The binary annotations to be processed.
+  @return An optional absolute path to the source file.
+*)

compiler/gentype/GenTypeConfig.ml

@@ -239,6 +239,7 @@ let read_config ~get_config_file ~namespace =
       sources;
     }
   in
+  let default_config = {default with project_root; bsb_project_root} in
   match get_config_file ~project_root with
   | Some bs_config_file -> (
     try
@@ -247,7 +248,7 @@ let read_config ~get_config_file ~namespace =
       | Obj {map = bsconf} -> (
         match bsconf |> get_opt "gentypeconfig" with
         | Some (Obj {map = gtconf}) -> parse_config ~bsconf ~gtconf
-        | _ -> default)
-      | _ -> default
-    with _ -> default)
-  | None -> default
+        | _ -> default_config)
+      | _ -> default_config
+    with _ -> default_config)
+  | None -> default_config

compiler/gentype/GenTypeMain.ml

@@ -90,74 +90,79 @@ let read_cmt cmt_file =
     Log_.item "Try to clean and rebuild.\n\n";
     assert false
 
+let read_input_cmt is_interface cmt_file =
+  let input_cmt = read_cmt cmt_file in
+  let ignore_interface = ref false in
+  let check_annotation ~loc:_ attributes =
+    if
+      attributes
+      |> Annotation.get_attribute_payload
+           Annotation.tag_is_gentype_ignore_interface
+      <> None
+    then ignore_interface := true;
+    attributes
+    |> Annotation.get_attribute_payload
+         Annotation.tag_is_one_of_the_gentype_annotations
+    <> None
+  in
+  let has_gentype_annotations =
+    input_cmt |> cmt_check_annotations ~check_annotation
+  in
+  if is_interface then
+    let cmt_file_impl =
+      (cmt_file |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt"
+    in
+    let input_cmt_impl = read_cmt cmt_file_impl in
+    let has_gentype_annotations_impl =
+      input_cmt_impl
+      |> cmt_check_annotations ~check_annotation:(fun ~loc attributes ->
+             if attributes |> check_annotation ~loc then (
+               if not !ignore_interface then (
+                 Log_.Color.setup ();
+                 Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
+                     Format.fprintf ppf
+                       "Annotation is ignored as there's a .resi file"));
+               true)
+             else false)
+    in
+    ( (match !ignore_interface with
+      | true -> input_cmt_impl
+      | false -> input_cmt),
+      match !ignore_interface with
+      | true -> has_gentype_annotations_impl
+      | false -> has_gentype_annotations )
+  else (input_cmt, has_gentype_annotations)
+
 let process_cmt_file cmt =
   let config = Paths.read_config ~namespace:(cmt |> Paths.find_name_space) in
   if !Debug.basic then Log_.item "Cmt %s\n" cmt;
   let cmt_file = cmt |> Paths.get_cmt_file in
   if cmt_file <> "" then
-    let output_file = cmt |> Paths.get_output_file ~config in
-    let output_file_relative = cmt |> Paths.get_output_file_relative ~config in
     let file_name = cmt |> Paths.get_module_name in
     let is_interface = Filename.check_suffix cmt_file ".cmti" in
+    let input_cmt, has_gentype_annotations =
+      read_input_cmt is_interface cmt_file
+    in
+    let source_file =
+      match input_cmt.cmt_annots |> FindSourceFile.cmt with
+      | Some source_file -> source_file
+      | None -> (
+        (file_name |> ModuleName.to_string)
+        ^
+        match is_interface with
+        | true -> ".resi"
+        | false -> ".res")
+    in
+    let output_file = source_file |> Paths.get_output_file ~config in
+    let output_file_relative =
+      source_file |> Paths.get_output_file_relative ~config
+    in
     let resolver =
       ModuleResolver.create_lazy_resolver ~config
         ~extensions:[".res"; ".shim.ts"] ~exclude_file:(fun fname ->
           fname = "React.res" || fname = "ReasonReact.res")
     in
-    let input_cmt, has_gentype_annotations =
-      let input_cmt = read_cmt cmt_file in
-      let ignore_interface = ref false in
-      let check_annotation ~loc:_ attributes =
-        if
-          attributes
-          |> Annotation.get_attribute_payload
-               Annotation.tag_is_gentype_ignore_interface
-          <> None
-        then ignore_interface := true;
-        attributes
-        |> Annotation.get_attribute_payload
-             Annotation.tag_is_one_of_the_gentype_annotations
-        <> None
-      in
-      let has_gentype_annotations =
-        input_cmt |> cmt_check_annotations ~check_annotation
-      in
-      if is_interface then
-        let cmt_file_impl =
-          (cmt_file |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt"
-        in
-        let input_cmt_impl = read_cmt cmt_file_impl in
-        let has_gentype_annotations_impl =
-          input_cmt_impl
-          |> cmt_check_annotations ~check_annotation:(fun ~loc attributes ->
-                 if attributes |> check_annotation ~loc then (
-                   if not !ignore_interface then (
-                     Log_.Color.setup ();
-                     Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
-                         Format.fprintf ppf
-                           "Annotation is ignored as there's a .resi file"));
-                   true)
-                 else false)
-        in
-        ( (match !ignore_interface with
-          | true -> input_cmt_impl
-          | false -> input_cmt),
-          match !ignore_interface with
-          | true -> has_gentype_annotations_impl
-          | false -> has_gentype_annotations )
-      else (input_cmt, has_gentype_annotations)
-    in
     if has_gentype_annotations then
-      let source_file =
-        match input_cmt.cmt_annots |> FindSourceFile.cmt with
-        | Some source_file -> source_file
-        | None -> (
-          (file_name |> ModuleName.to_string)
-          ^
-          match is_interface with
-          | true -> ".resi"
-          | false -> ".res")
-      in
       input_cmt
       |> translate_c_m_t ~config ~output_file_relative ~resolver
       |> emit_translation ~config ~file_name ~output_file ~output_file_relative

compiler/gentype/Paths.ml

@@ -29,17 +29,40 @@ let find_name_space cmt =
   cmt |> Filename.basename |> (Filename.chop_extension [@doesNotRaise])
   |> keep_after_dash
 
-let get_output_file_relative ~config cmt =
-  (cmt |> handle_namespace) ^ ModuleExtension.ts_input_file_suffix ~config
+let remove_path_prefix ~prefix path =
+  let normalized_prefix = Filename.concat prefix "" in
+  let prefix_len = String.length normalized_prefix in
+  let path_len = String.length path in
+  let is_prefix =
+    prefix_len <= path_len
+    && (String.sub path 0 prefix_len [@doesNotRaise]) = normalized_prefix
+  in
+  if is_prefix then
+    String.sub path prefix_len (path_len - prefix_len) [@doesNotRaise]
+  else path
+
+let append_suffix ~config source_path =
+  (source_path |> handle_namespace)
+  ^ ModuleExtension.ts_input_file_suffix ~config
 
-let get_output_file ~(config : Config.t) cmt =
-  Filename.concat config.project_root (get_output_file_relative ~config cmt)
+let get_output_file_relative ~(config : Config.t) source_path =
+  let relativePath =
+    remove_path_prefix ~prefix:config.project_root source_path
+  in
+  append_suffix ~config relativePath
+
+let get_output_file ~(config : Config.t) source_path =
+  let relative_output_path = get_output_file_relative ~config source_path in
+  Filename.concat config.project_root relative_output_path
 
 let get_module_name cmt =
   cmt |> handle_namespace |> Filename.basename |> ModuleName.from_string_unsafe
 
 let get_cmt_file cmt =
-  let path_cmt = Filename.concat (Sys.getcwd ()) cmt in
+  let path_cmt =
+    if Filename.is_relative cmt then Filename.concat (Sys.getcwd ()) cmt
+    else cmt
+  in
   let cmt_file =
     if Filename.check_suffix path_cmt ".cmt" then
       let path_cmt_lower_case =