Allow implementation and interface files to live in different dirs

jscomp/bsb/bsb_config.mli

@@ -31,7 +31,6 @@ val lib_js : string
 val lib_bs : string
 val lib_es6 : string
 val lib_es6_global : string
-val lib_ocaml : string
 val all_lib_artifacts : string list
 (* we need generate path relative to [lib/bs] directory in the opposite direction *)
 val rev_lib_bs_prefix : string -> string

jscomp/bsb/bsb_db_encode.ml

@@ -58,31 +58,43 @@ let make_encoding length buf : Ext_buffer.t -> int -> unit =
     Ext_buffer.add_char buf '4';
     Ext_buffer.add_int_4
   end else assert false
+
 (* Make sure [tmp_buf1] and [tmp_buf2] is cleared ,
   they are only used to control the order.
   Strictly speaking, [tmp_buf1] is not needed
 *)
 let encode_single (db : Bsb_db.map) (buf : Ext_buffer.t) =
   (* module name section *)
   let len = Map_string.cardinal db in
-  Ext_buffer.add_string_char buf (string_of_int len) '\n';
-  if len <> 0 then begin
+  if len = 0 then begin
+    Ext_buffer.add_string_char buf (string_of_int len) '\n';
+  end else begin
     let mapping = Hash_string.create 50 in
-    Map_string.iter db (fun name {dir} ->
-        Ext_buffer.add_string_char buf name '\n';
-        if not (Hash_string.mem mapping dir) then
-          Hash_string.add mapping dir (Hash_string.length mapping)
-      );
+    (* Pre-processing step because the DB must be sorted with
+       `Ext_string.compare`, which is not equal to String.compare (the former
+       sorts based the length of the string). *)
+    let modules = Map_string.fold db Map_string.empty (fun name {dir; case} acc ->
+        match dir with
+        | Same dir -> Map_string.add acc name (dir, case)
+        | Different { impl; intf } ->
+          let acc = Map_string.add acc (name ^ Literals.suffix_impl) (impl, case) in
+          Map_string.add acc (name ^ Literals.suffix_intf) (intf, case))
+    in
+    Ext_buffer.add_string_char buf (string_of_int (Map_string.cardinal modules)) '\n';
+    Map_string.iter modules (fun name (dir, _) ->
+      Ext_buffer.add_string_char buf name '\n';
+      if not (Hash_string.mem mapping dir) then
+        Hash_string.add mapping dir (Hash_string.length mapping));
     let length = Hash_string.length mapping in
     let rev_mapping = Array.make length "" in
     Hash_string.iter mapping (fun k i -> Array.unsafe_set rev_mapping i k);
     (* directory name section *)
     Ext_array.iter rev_mapping (fun s -> Ext_buffer.add_string_char buf s '\t');
     nl buf; (* module name info section *)
     let len_encoding = make_encoding length buf in
-    Map_string.iter db (fun _ module_info ->
-        len_encoding buf
-          (Hash_string.find_exn  mapping module_info.dir lsl 1 + (Obj.magic (module_info.case : bool) : int)));
+    Map_string.iter modules (fun _ (dir, case) ->
+      len_encoding buf
+        (Hash_string.find_exn  mapping dir  lsl 1 + (Obj.magic (case : bool) : int)));
     nl buf
   end
 

jscomp/bsb/bsb_db_util.ml

@@ -28,15 +28,41 @@ type t = Bsb_db.map
 
 
 
-let conflict_module_info modname (a : module_info) (b : module_info) =
-  Bsb_exception.conflict_module
-    modname
-    a.dir
-    b.dir
+let conflict_module_info modname (a: module_info) (b: module_info) =
+  match a.dir, b.dir with
+  | Same adir, Same bdir
+  | Same adir, Different { impl = bdir }
+  | Different { impl = adir }, Same bdir
+  | Different { impl = adir }, Different { impl = bdir } ->
+    Bsb_exception.conflict_module modname adir bdir
+
+let merge_dirs ~(impl: module_info) ~(intf: module_info) =
+  match impl.dir, intf.dir with
+  | Same impl_dir, Same intf_dir ->
+    { impl with
+      syntax_kind = (match impl.syntax_kind, intf.syntax_kind with
+      | Same a, Same b ->
+        if a = b then
+          Same a
+        else
+          Different { impl = a; intf = b  }
+      | _ -> assert false);
+      dir = Different { impl = impl_dir; intf = intf_dir };
+      info = Impl_intf
+    }
+  | _ -> assert false
+
+let fix_conflict modname (a : module_info) (b : module_info) =
+  match a.info, b.info with
+  | Intf, Impl -> merge_dirs ~impl:b ~intf:a
+  | Impl, Intf -> merge_dirs ~impl:a ~intf:b
+  | Intf, Intf | Impl, Impl | Impl, Impl_intf | Intf, Impl_intf
+  | Impl_intf, Impl | Impl_intf, Intf | Impl_intf, Impl_intf ->
+    raise_notrace (conflict_module_info modname a b)
 
 (* merge data info from two directories*)
 let merge (acc : t) (sources : t) : t =
-  Map_string.disjoint_merge_exn acc sources conflict_module_info
+  Map_string.disjoint_merge acc sources fix_conflict
 
 let sanity_check (map : t) =
   Map_string.iter map (fun m module_info ->
@@ -134,24 +160,8 @@ let add_basename
         (fun  opt_module_info ->
            match opt_module_info with
            | None ->
-             {dir ; name_sans_extension ; info ; syntax_kind ; case }
+             {dir = Same dir ; name_sans_extension ; info ; syntax_kind = Same syntax_kind ; case }
            | Some x ->
-             check x name_sans_extension case syntax_kind info
+             check x name_sans_extension case (Same syntax_kind) info
         )
 
-let (//) = Ext_path.combine
-let filename ~proj_dir ({ syntax_kind; info; name_sans_extension } : Bsb_db.module_info) =
-  match syntax_kind, info with
-  | Ml, (Intf | Impl_intf) ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_mli)
-  | Ml, Impl ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_ml)
-  | Reason, (Intf | Impl_intf) ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_rei)
-  | Reason, Impl ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_re)
-  | Res, (Intf | Impl_intf) ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_resi)
-  | Res, Impl ->
-    proj_dir // (name_sans_extension ^ Literals.suffix_res)
-

jscomp/bsb/bsb_db_util.mli

@@ -49,4 +49,3 @@ val add_basename:
   Bsb_db.map
 
 
-val filename : proj_dir:string -> Bsb_db.module_info -> string

jscomp/bsb/bsb_exception.ml

@@ -31,7 +31,7 @@ type error =
   | Invalid_spec of string
   | Conflict_module of string * string * string
   | No_implementation of string
-  | Not_consistent of string 
+  | Not_consistent of string
 
 exception Error of error
 
@@ -43,20 +43,20 @@ let print (fmt : Format.formatter) (x : error) =
   match x with
   | Conflict_module (modname,dir1,dir2) ->
     Format.fprintf fmt
-    "@{<error>Error:@} %s found in two directories: (%s, %s)\n\
+    "@{<error>Error:@} Module %s found in two directories: (%s, %s)\n\
     File names must be unique per project"
       modname dir1 dir2
-  | Not_consistent modname ->     
-    Format.fprintf fmt 
+  | Not_consistent modname ->
+    Format.fprintf fmt
     "@{<error>Error:@} %s has implementation/interface in non-consistent syntax(reason/ocaml)" modname
-  | No_implementation (modname) ->     
-    Format.fprintf fmt 
+  | No_implementation (modname) ->
+    Format.fprintf fmt
     "@{<error>Error:@} %s does not have implementation file" modname
   | Package_not_found (name,json_opt) ->
     let in_json = match json_opt with
     | None -> Ext_string.empty
     | Some x -> " in " ^ x in
-    let name = Bsb_pkg_types.to_string name in 
+    let name = Bsb_pkg_types.to_string name in
     if Ext_string.equal name !Bs_version.package_name then
       Format.fprintf fmt
       "File \"bsconfig.json\", line 1\n\
@@ -88,9 +88,9 @@ let print (fmt : Format.formatter) (x : error) =
 
 let conflict_module modname dir1 dir2 =
   Error (Conflict_module (modname,dir1,dir2))
-let no_implementation modname =   
+let no_implementation modname =
   error (No_implementation modname)
-let not_consistent modname =   
+let not_consistent modname =
   error (Not_consistent modname)
 let errorf ~loc fmt =
   Format.ksprintf (fun s -> error (Json_config (loc,s))) fmt

jscomp/bsb/bsb_namespace_map_gen.ml

@@ -28,43 +28,40 @@ let (//) = Ext_path.combine
 
 
 
-let write_file fname digest contents = 
-  let oc = open_out_bin fname in 
+let write_file fname digest contents =
+  let oc = open_out_bin fname in
   Digest.output oc digest;
   output_char oc '\n';
   Ext_buffer.output_buffer oc contents;
-  close_out oc 
-(** 
+  close_out oc
+(**
   TODO:
   sort filegroupts to ensure deterministic behavior
-  
+
   if [.bsbuild] is not changed
   [.mlmap] does not need to be changed too
-  
+
 *)
-let output 
-    ~dir 
+let output
+    ~dir
     (namespace : string)
     (file_groups : Bsb_file_groups.file_groups )
-  = 
-  let fname = namespace ^ Literals.suffix_mlmap in 
-  let buf = Ext_buffer.create 10000 in   
-  Ext_list.iter file_groups 
-    (fun  x ->
-       Map_string.iter x.sources (fun k _ -> 
-           Ext_buffer.add_string_char buf k '\n';
-         ) 
-    );
-  (* let contents = Buffer.contents buf in    *)
-  let digest = Ext_buffer.digest buf in 
-  let fname = (dir// fname ) in 
+  =
+  let fname = namespace ^ Literals.suffix_mlmap in
+  let buf = Ext_buffer.create 10000 in
+  let module_set = Ext_list.fold_left file_groups Set_string.empty (fun acc x ->
+    Map_string.fold x.sources acc (fun k _ acc -> Set_string.add acc k))
+  in
+  Set_string.iter module_set (fun  x -> Ext_buffer.add_string_char buf x '\n');
+  let digest = Ext_buffer.digest buf in
+  let fname = (dir// fname ) in
   if Sys.file_exists fname then
-    let ic = open_in_bin fname in 
-    let old_digest = really_input_string ic Ext_digest.length in 
+    let ic = open_in_bin fname in
+    let old_digest = really_input_string ic Ext_digest.length in
     close_in ic ;
-    (if old_digest <> digest then 
+    (if old_digest <> digest then
       write_file fname digest buf)
-  else 
+  else
     write_file fname digest buf
-    
-  
+
+