v11 backport of #7104

CHANGELOG.md

@@ -12,6 +12,7 @@
 
 # 11.1.5 (Unreleased)
 
+- Handle absolute file paths in gentype https://github.com/rescript-lang/rescript-compiler/pull/7111
 - Deprecate JSX 3 https://github.com/rescript-lang/rescript-compiler/pull/7042
 - Deprecate js_cast.res https://github.com/rescript-lang/rescript-compiler/pull/7074
 - Deprecate top-level `"suffix"` option in `rescript.json`. https://github.com/rescript-lang/rescript-compiler/pull/7056

jscomp/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

jscomp/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.
+*)

jscomp/gentype/GenTypeConfig.ml

@@ -234,6 +234,7 @@ let readConfig ~getConfigFile ~namespace =
       sources;
     }
   in
+  let defaultConfig = {default with projectRoot; bsbProjectRoot} in
   match getConfigFile ~projectRoot with
   | Some bsConfigFile -> (
     try
@@ -242,7 +243,7 @@ let readConfig ~getConfigFile ~namespace =
       | Obj {map = bsconf} -> (
         match bsconf |> getOpt "gentypeconfig" with
         | Some (Obj {map = gtconf}) -> parseConfig ~bsconf ~gtconf
-        | _ -> default)
-      | _ -> default
-    with _ -> default)
-  | None -> default
+        | _ -> defaultConfig)
+      | _ -> defaultConfig
+    with _ -> defaultConfig)
+  | None -> defaultConfig

jscomp/gentype/GenTypeMain.ml

@@ -90,74 +90,75 @@ let readCmt cmtFile =
     Log_.item "Try to clean and rebuild.\n\n";
     assert false
 
+let readInputCmt isInterface cmtFile =
+  let inputCMT = readCmt cmtFile in
+  let ignoreInterface = ref false in
+  let checkAnnotation ~loc:_ attributes =
+    if
+      attributes
+      |> Annotation.getAttributePayload Annotation.tagIsGenTypeIgnoreInterface
+      <> None
+    then ignoreInterface := true;
+    attributes
+    |> Annotation.getAttributePayload Annotation.tagIsOneOfTheGenTypeAnnotations
+    <> None
+  in
+  let hasGenTypeAnnotations =
+    inputCMT |> cmtCheckAnnotations ~checkAnnotation
+  in
+  if isInterface then
+    let cmtFileImpl =
+      (cmtFile |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt"
+    in
+    let inputCMTImpl = readCmt cmtFileImpl in
+    let hasGenTypeAnnotationsImpl =
+      inputCMTImpl
+      |> cmtCheckAnnotations ~checkAnnotation:(fun ~loc attributes ->
+             if attributes |> checkAnnotation ~loc then (
+               if not !ignoreInterface then (
+                 Log_.Color.setup ();
+                 Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
+                     Format.fprintf ppf
+                       "Annotation is ignored as there's a .rei file"));
+               true)
+             else false)
+    in
+    ( (match !ignoreInterface with
+      | true -> inputCMTImpl
+      | false -> inputCMT),
+      match !ignoreInterface with
+      | true -> hasGenTypeAnnotationsImpl
+      | false -> hasGenTypeAnnotations )
+  else (inputCMT, hasGenTypeAnnotations)
+
 let processCmtFile cmt =
   let config = Paths.readConfig ~namespace:(cmt |> Paths.findNameSpace) in
   if !Debug.basic then Log_.item "Cmt %s\n" cmt;
   let cmtFile = cmt |> Paths.getCmtFile in
   if cmtFile <> "" then
-    let outputFile = cmt |> Paths.getOutputFile ~config in
-    let outputFileRelative = cmt |> Paths.getOutputFileRelative ~config in
     let fileName = cmt |> Paths.getModuleName in
     let isInterface = Filename.check_suffix cmtFile ".cmti" in
+    let inputCMT, hasGenTypeAnnotations = readInputCmt isInterface cmtFile in
+    let sourceFile =
+      match inputCMT.cmt_annots |> FindSourceFile.cmt with
+      | Some sourceFile -> sourceFile
+      | None -> (
+        (fileName |> ModuleName.toString)
+        ^
+        match isInterface with
+        | true -> ".resi"
+        | false -> ".res")
+    in
+    let outputFile = sourceFile |> Paths.getOutputFile ~config in
+    let outputFileRelative =
+      sourceFile |> Paths.getOutputFileRelative ~config
+    in
     let resolver =
       ModuleResolver.createLazyResolver ~config ~extensions:[".res"; ".shim.ts"]
         ~excludeFile:(fun fname ->
           fname = "React.res" || fname = "ReasonReact.res")
     in
-    let inputCMT, hasGenTypeAnnotations =
-      let inputCMT = readCmt cmtFile in
-      let ignoreInterface = ref false in
-      let checkAnnotation ~loc:_ attributes =
-        if
-          attributes
-          |> Annotation.getAttributePayload
-               Annotation.tagIsGenTypeIgnoreInterface
-          <> None
-        then ignoreInterface := true;
-        attributes
-        |> Annotation.getAttributePayload
-             Annotation.tagIsOneOfTheGenTypeAnnotations
-        <> None
-      in
-      let hasGenTypeAnnotations =
-        inputCMT |> cmtCheckAnnotations ~checkAnnotation
-      in
-      if isInterface then
-        let cmtFileImpl =
-          (cmtFile |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt"
-        in
-        let inputCMTImpl = readCmt cmtFileImpl in
-        let hasGenTypeAnnotationsImpl =
-          inputCMTImpl
-          |> cmtCheckAnnotations ~checkAnnotation:(fun ~loc attributes ->
-                 if attributes |> checkAnnotation ~loc then (
-                   if not !ignoreInterface then (
-                     Log_.Color.setup ();
-                     Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
-                         Format.fprintf ppf
-                           "Annotation is ignored as there's a .rei file"));
-                   true)
-                 else false)
-        in
-        ( (match !ignoreInterface with
-          | true -> inputCMTImpl
-          | false -> inputCMT),
-          match !ignoreInterface with
-          | true -> hasGenTypeAnnotationsImpl
-          | false -> hasGenTypeAnnotations )
-      else (inputCMT, hasGenTypeAnnotations)
-    in
     if hasGenTypeAnnotations then
-      let sourceFile =
-        match inputCMT.cmt_annots |> FindSourceFile.cmt with
-        | Some sourceFile -> sourceFile
-        | None -> (
-          (fileName |> ModuleName.toString)
-          ^
-          match isInterface with
-          | true -> ".resi"
-          | false -> ".res")
-      in
       inputCMT
       |> translateCMT ~config ~outputFileRelative ~resolver
       |> emitTranslation ~config ~fileName ~outputFile ~outputFileRelative

jscomp/gentype/Paths.ml

@@ -28,17 +28,37 @@ let findNameSpace cmt =
   cmt |> Filename.basename |> (Filename.chop_extension [@doesNotRaise])
   |> keepAfterDash
 
-let getOutputFileRelative ~config cmt =
-  (cmt |> handleNamespace) ^ ModuleExtension.tsInputFileSuffix ~config
+let removePathPrefix ~prefix path =
+  let normalizedPrefix = Filename.concat prefix "" in
+  let prefixLen = String.length normalizedPrefix in
+  let pathLen = String.length path in
+  let isPrefix =
+    prefixLen <= pathLen
+    && (String.sub path 0 prefixLen [@doesNotRaise]) = normalizedPrefix
+  in
+  if isPrefix then
+    String.sub path prefixLen (pathLen - prefixLen) [@doesNotRaise]
+  else path
+
+let appendSuffix ~config sourcePath =
+  (sourcePath |> handleNamespace) ^ ModuleExtension.tsInputFileSuffix ~config
 
-let getOutputFile ~(config : Config.t) cmt =
-  Filename.concat config.projectRoot (getOutputFileRelative ~config cmt)
+let getOutputFileRelative ~(config : Config.t) path =
+  let relativePath = removePathPrefix ~prefix:config.projectRoot path in
+  appendSuffix ~config relativePath
+
+let getOutputFile ~(config : Config.t) absoluteSourcePath =
+  let relativeOutputPath = getOutputFileRelative ~config absoluteSourcePath in
+  Filename.concat config.projectRoot relativeOutputPath
 
 let getModuleName cmt =
   cmt |> handleNamespace |> Filename.basename |> ModuleName.fromStringUnsafe
 
 let getCmtFile cmt =
-  let pathCmt = Filename.concat (Sys.getcwd ()) cmt in
+  let pathCmt =
+    if Filename.is_relative cmt then Filename.concat (Sys.getcwd ()) cmt
+    else cmt
+  in
   let cmtFile =
     if Filename.check_suffix pathCmt ".cmt" then
       let pathCmtLowerCase =