diff --git a/CHANGELOG.md b/CHANGELOG.md index a4debfd5cb..37a91b0811 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/jscomp/gentype/FindSourceFile.ml b/jscomp/gentype/FindSourceFile.ml index b935a5e2bb..b646f077cb 100644 --- a/jscomp/gentype/FindSourceFile.ml +++ b/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 diff --git a/jscomp/gentype/FindSourceFile.mli b/jscomp/gentype/FindSourceFile.mli new file mode 100644 index 0000000000..6c7bab7a7d --- /dev/null +++ b/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. +*) diff --git a/jscomp/gentype/GenTypeConfig.ml b/jscomp/gentype/GenTypeConfig.ml index 9e5ec193c8..73847c8365 100644 --- a/jscomp/gentype/GenTypeConfig.ml +++ b/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 diff --git a/jscomp/gentype/GenTypeMain.ml b/jscomp/gentype/GenTypeMain.ml index 5b733f1e57..ff75f56fd1 100644 --- a/jscomp/gentype/GenTypeMain.ml +++ b/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 diff --git a/jscomp/gentype/Paths.ml b/jscomp/gentype/Paths.ml index ed95905268..a79c721d84 100644 --- a/jscomp/gentype/Paths.ml +++ b/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 =