Remove global state for project root.

cristianoc · cristianoc · commit 80ee525342e4 · 2022-07-14T05:27:48.000+02:00
Move to config.
diff --git a/jscomp/gentype/Config_.ml b/jscomp/gentype/Config_.ml
@@ -1,12 +1,10 @@
 module ModuleNameMap = Map.Make (ModuleName)
 
-let bsbProjectRoot = ref ""
-let projectRoot = ref ""
-
 type module_ = CommonJS | ES6
 type bsVersion = int * int * int
 
 type config = {
+  mutable bsbProjectRoot : string;
   bsDependencies : string list;
   mutable emitImportCurry : bool;
   mutable emitImportReact : bool;
@@ -16,13 +14,15 @@ type config = {
   module_ : module_;
   namespace : string option;
   platformLib : string;
+  mutable projectRoot : string;
   shimsMap : ModuleName.t ModuleNameMap.t;
   sources : Ext_json_types.t option;
   suffix : string;
 }
 
 let default =
   {
+    bsbProjectRoot = "";
     bsDependencies = [];
     emitImportCurry = false;
     emitImportReact = false;
@@ -32,6 +32,7 @@ let default =
     module_ = ES6;
     namespace = None;
     platformLib = "";
+    projectRoot = "";
     shimsMap = ModuleNameMap.empty;
     sources = None;
     suffix = "";
@@ -86,7 +87,25 @@ let setDebug ~gtconf =
   | Some (Obj { map }) -> Map_string.iter map Debug.setItem
   | _ -> ()
 
+let bsconfig = "bsconfig.json"
+
+let rec findProjectRoot ~dir =
+  if Sys.file_exists (Filename.concat dir bsconfig) then dir
+  else
+    let parent = dir |> Filename.dirname in
+    if parent = dir then (
+      prerr_endline
+        ("Error: cannot find project root containing " ^ bsconfig ^ ".");
+      assert false)
+    else findProjectRoot ~dir:parent
+
 let readConfig ~bsVersion ~getBsConfigFile ~namespace =
+  let projectRoot = findProjectRoot ~dir:(Sys.getcwd ()) in
+  let bsbProjectRoot =
+    match Sys.getenv_opt "BSB_PROJECT_ROOT" with
+    | None -> projectRoot
+    | Some s -> s
+  in
   let parseConfig ~bsconf ~gtconf =
     let moduleString = gtconf |> getStringOption "module" in
     let exportInterfacesBool = gtconf |> getBool "exportInterfaces" in
@@ -150,9 +169,9 @@ let readConfig ~bsVersion ~getBsConfigFile ~namespace =
       | Some externalStdlib -> externalStdlib
     in
     if !Debug.config then (
-      Log_.item "Project root: %s\n" !projectRoot;
-      if !bsbProjectRoot <> !projectRoot then
-        Log_.item "bsb project root: %s\n" !bsbProjectRoot;
+      Log_.item "Project root: %s\n" projectRoot;
+      if bsbProjectRoot <> projectRoot then
+        Log_.item "bsb project root: %s\n" bsbProjectRoot;
       Log_.item "Config module:%s shims:%d entries bsVersion:%d.%d.%d\n"
         (match moduleString with None -> "" | Some s -> s)
         (shimsMap |> ModuleNameMap.cardinal)
@@ -186,6 +205,7 @@ let readConfig ~bsVersion ~getBsConfigFile ~namespace =
       | _ -> default.sources
     in
     {
+      bsbProjectRoot;
       bsDependencies;
       suffix;
       emitImportCurry = false;
@@ -196,11 +216,12 @@ let readConfig ~bsVersion ~getBsConfigFile ~namespace =
       module_;
       namespace;
       platformLib;
+      projectRoot;
       shimsMap;
       sources;
     }
   in
-  match getBsConfigFile () with
+  match getBsConfigFile ~projectRoot with
   | Some bsConfigFile -> (
       try
         let json = bsConfigFile |> Ext_json_parse.parse_json_from_file in
diff --git a/jscomp/gentype/EmitJs.ml b/jscomp/gentype/EmitJs.ml
@@ -225,12 +225,12 @@ let rec emitCodeItem ~config ~emitters ~moduleItemsEmitter ~env ~fileName
     let nameGen = EmitText.newNameGen () in
     let importPath =
       fileName
-      |> ModuleResolver.resolveModule ~importExtension:config.suffix
+      |> ModuleResolver.resolveModule ~config ~importExtension:config.suffix
            ~outputFileRelative ~resolver ~useBsDependencies:false
     in
     let fileNameBs = fileName |> ModuleName.forBsFile in
     let envWithRequires =
-      fileNameBs |> requireModule ~import:false ~env ~importPath
+      fileNameBs |> requireModule ~import:false  ~env ~importPath
     in
     let default = "default" in
     let make = "make" in
diff --git a/jscomp/gentype/GenType.ml b/jscomp/gentype/GenType.ml
@@ -1,7 +1,4 @@
-open GenTypeCommon
-
 let version = Version.version
-
 let signFile s = s
 
 type cliCommand = Add of string | Clean | NoOp | Rm of string list
@@ -30,7 +27,7 @@ let cli () =
       ("-clean", Arg.Unit setClean, "clean all the generated files");
       ("-cmt-add", Arg.String setAdd, "compile a .cmt[i] file");
       ( "-cmt-rm",
-        Arg.String (fun s -> setRm [s]),
+        Arg.String (fun s -> setRm [ s ]),
         "remove one or more .cmt[i] files" );
       ("-version", Arg.Unit versionAndExit, "show version information and exit");
       ("--version", Arg.Unit versionAndExit, "show version information and exit");
@@ -39,63 +36,61 @@ let cli () =
   let executeCliCommand ~bsVersion cliCommand =
     match cliCommand with
     | Add s ->
-      Log_.Color.forceColor := true;
-      let splitColon = Str.split (Str.regexp ":") s in
-      let cmt, mlast =
-        match splitColon with
-        | cmt :: rest ->
-          let mlast = rest |> String.concat "" in
-          (cmt, mlast)
-        | _ -> assert false
-      in
-      let config =
-        Paths.readConfig ~bsVersion ~namespace:(cmt |> Paths.findNameSpace)
-      in
-      if !Debug.basic then Log_.item "Add %s  %s\n" cmt mlast;
-      cmt |> GenTypeMain.processCmtFile ~signFile ~config;
-      exit 0
+        Log_.Color.forceColor := true;
+        let splitColon = Str.split (Str.regexp ":") s in
+        let cmt, mlast =
+          match splitColon with
+          | cmt :: rest ->
+              let mlast = rest |> String.concat "" in
+              (cmt, mlast)
+          | _ -> assert false
+        in
+        let config =
+          Paths.readConfig ~bsVersion ~namespace:(cmt |> Paths.findNameSpace)
+        in
+        if !Debug.basic then Log_.item "Add %s  %s\n" cmt mlast;
+        cmt |> GenTypeMain.processCmtFile ~signFile ~config;
+        exit 0
     | Clean ->
-      let config = Paths.readConfig ~bsVersion ~namespace:None in
-      let sourceDirs =
-        ModuleResolver.readSourceDirs ~configSources:config.sources
-      in
-      if !Debug.basic then
-        Log_.item "Clean %d dirs\n" (sourceDirs.dirs |> List.length);
-      let count = ref 0 in
-      sourceDirs.dirs
-      |> List.iter (fun dir ->
-             let files = Sys.readdir dir in
-             files
-             |> Array.iter (fun file ->
-                    if
-                      Filename.check_suffix file ".re"
-                      || Filename.check_suffix file ".res"
-                    then
-                      let extension = EmitType.outputFileSuffix ~config in
-                      let generated =
-                        Filename.concat dir
-                          ((file |> Filename.chop_extension) ^ extension)
-                      in
-                      if Sys.file_exists generated then (
-                        Unix.unlink generated;
-                        incr count)));
-      if !Debug.basic then Log_.item "Cleaned %d files\n" !count;
-      exit 0
+        let config = Paths.readConfig ~bsVersion ~namespace:None in
+        let sourceDirs = ModuleResolver.readSourceDirs ~config in
+        if !Debug.basic then
+          Log_.item "Clean %d dirs\n" (sourceDirs.dirs |> List.length);
+        let count = ref 0 in
+        sourceDirs.dirs
+        |> List.iter (fun dir ->
+               let files = Sys.readdir dir in
+               files
+               |> Array.iter (fun file ->
+                      if
+                        Filename.check_suffix file ".re"
+                        || Filename.check_suffix file ".res"
+                      then
+                        let extension = EmitType.outputFileSuffix ~config in
+                        let generated =
+                          Filename.concat dir
+                            ((file |> Filename.chop_extension) ^ extension)
+                        in
+                        if Sys.file_exists generated then (
+                          Unix.unlink generated;
+                          incr count)));
+        if !Debug.basic then Log_.item "Cleaned %d files\n" !count;
+        exit 0
     | NoOp -> printUsageAndExit ()
     | Rm l ->
-      let removeOne s =
-        let cmtAbsolutePath = s in
-        (* somehow the CMT hook is passing an absolute path here *)
-        let cmt = cmtAbsolutePath |> Paths.relativePathFromBsLib in
-        let config =
-          Paths.readConfig ~bsVersion ~namespace:(cmt |> Paths.findNameSpace)
+        let removeOne s =
+          let cmtAbsolutePath = s in
+          (* somehow the CMT hook is passing an absolute path here *)
+          let cmt = cmtAbsolutePath |> Paths.relativePathFromBsLib in
+          let config =
+            Paths.readConfig ~bsVersion ~namespace:(cmt |> Paths.findNameSpace)
+          in
+          let outputFile = cmt |> Paths.getOutputFile ~config in
+          if !Debug.basic then Log_.item "Remove %s\n" cmt;
+          if Sys.file_exists outputFile then Unix.unlink outputFile
         in
-        let outputFile = cmt |> Paths.getOutputFile ~config in
-        if !Debug.basic then Log_.item "Remove %s\n" cmt;
-        if Sys.file_exists outputFile then Unix.unlink outputFile
-      in
-      l |> List.rev |> List.iter removeOne;
-      exit 0
+        l |> List.rev |> List.iter removeOne;
+        exit 0
   in
   let anonArg s =
     match !cliCommand with
@@ -104,6 +99,6 @@ let cli () =
   in
   Arg.parse speclist anonArg usage;
   executeCliCommand ~bsVersion:!bsVersion !cliCommand
-
 ;;
+
 cli ()
diff --git a/jscomp/gentype/GenTypeCommon.ml b/jscomp/gentype/GenTypeCommon.ml
@@ -7,7 +7,6 @@ let logNotImplemented x =
   if !Debug.notImplemented then Log_.item "Not Implemented: %s\n" x
 
 type optional = Mandatory | Optional
-
 type mutable_ = Immutable | Mutable
 
 type labelJS =
@@ -16,7 +15,7 @@ type labelJS =
   | IntLabel of string
   | StringLabel of string
 
-type case = {label : string; labelJS : labelJS}
+type case = { label : string; labelJS : labelJS }
 
 let isJSSafePropertyName name =
   let jsSafeRegex = {|^[A-z][A-z0-9]*$|} |> Str.regexp in
@@ -42,8 +41,8 @@ let labelJSToString ?(alwaysQuotes = false) case =
   | FloatLabel s -> s |> addQuotes
   | IntLabel i -> i |> addQuotes
   | StringLabel s ->
-    if s = case.label && isNumber s then s |> addQuotes
-    else s |> EmitText.quotes
+      if s = case.label && isNumber s then s |> addQuotes
+      else s |> EmitText.quotes
 
 type closedFlag = Open | Closed
 
@@ -63,8 +62,7 @@ type type_ =
   | Variant of variant
 
 and fields = field list
-
-and argType = {aName : string; aType : type_}
+and argType = { aName : string; aType : type_ }
 
 and field = {
   mutable_ : mutable_;
@@ -82,7 +80,7 @@ and function_ = {
   uncurried : bool;
 }
 
-and ident = {builtin : bool; name : string; typeArgs : type_ list}
+and ident = { builtin : bool; name : string; typeArgs : type_ list }
 
 and variant = {
   bsStringOrInt : bool;
@@ -94,7 +92,7 @@ and variant = {
   unboxed : bool;
 }
 
-and payload = {case : case; inlineRecord : bool; numArgs : int; t : type_}
+and payload = { case : case; inlineRecord : bool; numArgs : int; t : type_ }
 
 let typeIsObject type_ =
   match type_ with
@@ -133,8 +131,8 @@ struct
         let ch = String.unsafe_get s off in
         match ch with
         | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' ->
-          add capital ch;
-          aux false (off + 1) len
+            add capital ch;
+            aux false (off + 1) len
         | '/' | '-' -> aux true (off + 1) len
         | _ -> aux capital (off + 1) len
     in
@@ -159,7 +157,7 @@ struct
 
   (** Common-DemoSomelibrary -> Common *)
   let removeGeneratedModule s =
-    match s |> String.split_on_char '-' with [name; _scope] -> name | _ -> s
+    match s |> String.split_on_char '-' with [ name; _scope ] -> name | _ -> s
 end
 
 let rec depToString dep =
@@ -182,29 +180,30 @@ let createVariant ~bsStringOrInt ~inherits ~noPayloads ~payloads ~polymorphic =
   in
   let unboxed = payloads = [] in
   Variant
-    {bsStringOrInt; hash; inherits; noPayloads; payloads; polymorphic; unboxed}
+    {
+      bsStringOrInt;
+      hash;
+      inherits;
+      noPayloads;
+      payloads;
+      polymorphic;
+      unboxed;
+    }
 
 let variantTable hash ~toJS =
   (match toJS with true -> "$$toJS" | false -> "$$toRE") ^ string_of_int hash
 
 let ident ?(builtin = true) ?(typeArgs = []) name =
-  Ident {builtin; name; typeArgs}
+  Ident { builtin; name; typeArgs }
 
 let sanitizeTypeName name = name |> Str.global_replace (Str.regexp "'") "_"
-
 let unknown = ident "unknown"
-
 let booleanT = ident "boolean"
-
 let dateT = ident "Date"
-
 let numberT = ident "number"
-
 let stringT = ident "string"
-
 let unitT = ident "void"
-
-let int64T = Tuple [numberT; numberT]
+let int64T = Tuple [ numberT; numberT ]
 
 module NodeFilename = struct
   include Filename
@@ -216,9 +215,7 @@ module NodeFilename = struct
     type t
 
     val normalize : string -> t
-
     val concat : t -> string -> t
-
     val toString : t -> string
   end = struct
     type t = string
@@ -229,7 +226,6 @@ module NodeFilename = struct
       | _ -> path
 
     let toString path = path
-
     let length path = String.length path
 
     let concat dirname filename =
diff --git a/jscomp/gentype/ModuleResolver.ml b/jscomp/gentype/ModuleResolver.ml
diff --git a/jscomp/gentype/Paths.ml b/jscomp/gentype/Paths.ml
