diff --git a/jscomp/bsb/bsb_config.mli b/jscomp/bsb/bsb_config.mli index d016911df9..b828dcc993 100644 --- a/jscomp/bsb/bsb_config.mli +++ b/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 diff --git a/jscomp/bsb/bsb_db_encode.ml b/jscomp/bsb/bsb_db_encode.ml index 51e65bc20a..b1e5a2bbf2 100644 --- a/jscomp/bsb/bsb_db_encode.ml +++ b/jscomp/bsb/bsb_db_encode.ml @@ -58,6 +58,7 @@ 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 @@ -65,14 +66,25 @@ let make_encoding length buf : Ext_buffer.t -> int -> unit = 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); @@ -80,9 +92,9 @@ let encode_single (db : Bsb_db.map) (buf : Ext_buffer.t) = 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 diff --git a/jscomp/bsb/bsb_db_util.ml b/jscomp/bsb/bsb_db_util.ml index a46c19c2d5..de04b67f2f 100644 --- a/jscomp/bsb/bsb_db_util.ml +++ b/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) - diff --git a/jscomp/bsb/bsb_db_util.mli b/jscomp/bsb/bsb_db_util.mli index 6e7c8d6078..caf79e81a8 100644 --- a/jscomp/bsb/bsb_db_util.mli +++ b/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 diff --git a/jscomp/bsb/bsb_exception.ml b/jscomp/bsb/bsb_exception.ml index d65f83ee83..d7c021af75 100644 --- a/jscomp/bsb/bsb_exception.ml +++ b/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:@} %s found in two directories: (%s, %s)\n\ + "@{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:@} %s has implementation/interface in non-consistent syntax(reason/ocaml)" modname - | No_implementation (modname) -> - Format.fprintf fmt + | No_implementation (modname) -> + Format.fprintf fmt "@{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 diff --git a/jscomp/bsb/bsb_namespace_map_gen.ml b/jscomp/bsb/bsb_namespace_map_gen.ml index 9982186de9..78b6a9f83d 100644 --- a/jscomp/bsb/bsb_namespace_map_gen.ml +++ b/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 - - \ No newline at end of file + + diff --git a/jscomp/bsb/bsb_ninja_file_groups.ml b/jscomp/bsb/bsb_ninja_file_groups.ml index d520114a1c..74983d1469 100644 --- a/jscomp/bsb/bsb_ninja_file_groups.ml +++ b/jscomp/bsb/bsb_ninja_file_groups.ml @@ -60,6 +60,12 @@ let res_suffixes = { intf = Literals.suffix_resi; } +let syntax_kind_to_rule ~(rules : Bsb_ninja_rule.builtin) (syntax_kind : Bsb_db.syntax_kind) = + match syntax_kind with + | Ml -> rules.build_ast + | Reason + | Res -> rules.build_ast_from_re + let emit_module_build (rules : Bsb_ninja_rule.builtin) (package_specs : Bsb_package_specs.t) @@ -71,15 +77,39 @@ let emit_module_build ~bs_dev_dependencies js_post_build_cmd namespace + ~cur_dir (module_info : Bsb_db.module_info) = - let cur_dir = module_info.dir in + let impl_dir, intf_dir = match module_info.dir with + | Same dir -> dir, dir + | Different { impl; intf } -> impl, intf + in + let which = match impl_dir = cur_dir, intf_dir = cur_dir with + | true, true -> `both + | true, false -> `impl + | false, true -> `intf + | false, false -> assert false + in let has_intf_file = module_info.info = Impl_intf in - let config, ast_rule = + let impl_kind, intf_kind = match module_info.syntax_kind with + | Same kind -> kind, kind + | Different { impl; intf } -> impl, intf + in + let config = match module_info.syntax_kind with - | Reason -> re_suffixes, rules.build_ast_from_re - | Ml -> ml_suffixes, rules.build_ast - | Res -> res_suffixes, rules.build_ast_from_re (* FIXME: better names *) + | Same Reason -> re_suffixes + | Same Ml -> ml_suffixes + | Same Res -> res_suffixes + | Different { impl; intf } -> + assert (impl <> intf); + match impl, intf with + | Ml, Reason -> { impl = ml_suffixes.impl; intf = re_suffixes.intf } + | Reason, Ml -> { impl = re_suffixes.impl; intf = ml_suffixes.intf } + | Ml, Res -> { impl = ml_suffixes.impl; intf = res_suffixes.intf } + | Res, Ml -> { impl = res_suffixes.impl; intf = ml_suffixes.intf } + | Reason, Res -> { impl = re_suffixes.impl; intf = res_suffixes.intf } + | Res, Reason -> { impl = res_suffixes.impl; intf = re_suffixes.intf } + | Ml, Ml | Reason, Reason | Res, Res -> assert false in let filename_sans_extension = module_info.name_sans_extension in let input_impl = Bsb_config.proj_rel (filename_sans_extension ^ config.impl ) in @@ -87,14 +117,20 @@ let emit_module_build let output_ast = filename_sans_extension ^ Literals.suffix_ast in let output_iast = filename_sans_extension ^ Literals.suffix_iast in let output_d = filename_sans_extension ^ Literals.suffix_d in - let output_d_as_dep = Format.asprintf "(:dep_file %s)" (basename output_d) in + let output_d_as_dep = + let output_d = + (Ext_path.rel_normalized_absolute_path + ~from:(per_proj_dir // cur_dir) + (per_proj_dir // impl_dir)) // basename output_d + in + Format.asprintf "(:dep_file %s)" output_d in let output_filename_sans_extension = Ext_namespace_encode.make ?ns:namespace filename_sans_extension in let output_cmi = output_filename_sans_extension ^ Literals.suffix_cmi in let output_cmj = output_filename_sans_extension ^ Literals.suffix_cmj in let rel_proj_dir = Ext_path.rel_normalized_absolute_path - ~from:(Ext_path.combine per_proj_dir module_info.dir) + ~from:(Ext_path.combine per_proj_dir cur_dir) per_proj_dir in let maybe_gentype_deps = Option.map (fun _ -> @@ -102,18 +138,25 @@ let emit_module_build in let output_js = Bsb_package_specs.get_list_of_output_js package_specs output_filename_sans_extension in - Bsb_ninja_targets.output_build cur_dir buf - ~implicit_deps:(Option.value ~default:[] maybe_gentype_deps) - ~outputs:[output_ast] - ~inputs:[basename input_impl] - ~rule:ast_rule; - Bsb_ninja_targets.output_build - cur_dir - buf - ~outputs:[output_d] - ~inputs:(Ext_list.map (if has_intf_file then [output_ast;output_iast] else [output_ast] ) basename) - ~rule:(if is_dev then rules.build_bin_deps_dev else rules.build_bin_deps) - ; + if which <> `intf then begin + Bsb_ninja_targets.output_build cur_dir buf + ~implicit_deps:(Option.value ~default:[] maybe_gentype_deps) + ~outputs:[output_ast] + ~inputs:[basename input_impl] + ~rule:(syntax_kind_to_rule ~rules impl_kind); + + let output_iast = + (Ext_path.rel_normalized_absolute_path + ~from:(per_proj_dir // cur_dir) + (per_proj_dir // intf_dir)) // basename output_iast + in + Bsb_ninja_targets.output_build + cur_dir + buf + ~outputs:[output_d] + ~inputs:(if has_intf_file then [basename output_ast; output_iast] else [basename output_ast] ) + ~rule:(if is_dev then rules.build_bin_deps_dev else rules.build_bin_deps); + end; let relative_ns_cmi = match namespace with | Some ns -> @@ -124,28 +167,26 @@ let emit_module_build | None -> [] in let bs_dependencies = Ext_list.map bs_dependencies (fun dir -> - (Ext_path.rel_normalized_absolute_path ~from:(per_proj_dir // cur_dir) dir) // Literals.bsb_world - ) + (Ext_path.rel_normalized_absolute_path ~from:(per_proj_dir // cur_dir) dir) // Literals.bsb_world) in let rel_bs_config_json = rel_proj_dir // Literals.bsconfig_json in let bs_dependencies = if is_dev then let dev_dependencies = Ext_list.map bs_dev_dependencies (fun dir -> - (Ext_path.rel_normalized_absolute_path ~from:(per_proj_dir // cur_dir) dir) // Literals.bsb_world - ) + (Ext_path.rel_normalized_absolute_path ~from:(per_proj_dir // cur_dir) dir) // Literals.bsb_world) in dev_dependencies @ bs_dependencies else bs_dependencies in - if has_intf_file then begin + if has_intf_file && which <> `impl then begin Bsb_ninja_targets.output_build cur_dir buf ~outputs:[output_iast] (* TODO: we can get rid of absloute path if we fixed the location to be [lib/bs], better for testing? *) ~inputs:[basename input_intf] - ~rule:ast_rule - ; + ~rule:(syntax_kind_to_rule ~rules intf_kind); + Bsb_ninja_targets.output_build cur_dir buf ~implicit_deps:[output_d_as_dep] ~outputs:[output_cmi] @@ -165,18 +206,23 @@ let emit_module_build else rules.mij ) in - Bsb_ninja_targets.output_build cur_dir buf - ~outputs:[output_cmj] - ~implicit_outputs: - (if has_intf_file then [] else [ output_cmi ]) - ~js_outputs:output_js - ~inputs:[basename output_ast] - ~implicit_deps:(if has_intf_file then [(basename output_cmi); output_d_as_dep] else [output_d_as_dep]) - ~bs_dependencies - ~rel_deps:(rel_bs_config_json :: relative_ns_cmi) - ~rule; - output_js, output_d - + if which <> `intf then begin + let output_cmi = + (Ext_path.rel_normalized_absolute_path + ~from:(per_proj_dir // cur_dir) + (per_proj_dir // intf_dir)) // basename output_cmi + in + Bsb_ninja_targets.output_build cur_dir buf + ~outputs:[output_cmj] + ~implicit_outputs:(if has_intf_file then [] else [ output_cmi ]) + ~js_outputs:output_js + ~inputs:[basename output_ast] + ~implicit_deps:(if has_intf_file then [output_cmi; output_d_as_dep] else [output_d_as_dep]) + ~bs_dependencies + ~rel_deps:(rel_bs_config_json :: relative_ns_cmi) + ~rule; + end; + if which <> `intf then Some output_js else None let handle_files_per_dir buf @@ -215,25 +261,28 @@ let handle_files_per_dir | Export_set set -> fun module_name -> Set_string.mem set module_name in - let js_targets, _d_targets = Map_string.fold group.sources ([], []) (fun module_name module_info (acc_js, acc_d) -> - if installable module_name then - Queue.add - module_info files_to_install; - let js_outputs, output_d = emit_module_build rules - package_specs - is_dev - buf - ~per_proj_dir - ~bs_dependencies - ~bs_dev_dependencies - ?gentype_config:global_config.gentypeconfig - js_post_build_cmd - global_config.namespace module_info - in - (List.map fst js_outputs :: acc_js, output_d :: acc_d) - ) + let db = global_config.db in + let js_targets = Map_string.fold group.sources [] (fun module_name _ acc_js -> + let module_info = Map_string.find_exn (if is_dev then db.dev else db.lib) module_name in + if installable module_name then + Queue.add + module_info files_to_install; + let js_outputs = emit_module_build rules + package_specs + is_dev + buf + ~per_proj_dir + ~bs_dependencies + ~bs_dev_dependencies + ?gentype_config:global_config.gentypeconfig + ~cur_dir:group.dir + js_post_build_cmd + global_config.namespace module_info + in + match js_outputs with + | None -> acc_js + | Some js -> (List.map fst js) :: acc_js) in - Bsb_ninja_targets.output_alias buf ~name:Literals.bsb_world ~deps:(List.concat js_targets); Buffer.add_string buf ")"; Buffer.add_string buf "\n" diff --git a/jscomp/bsb/bsb_ninja_gen.ml b/jscomp/bsb/bsb_ninja_gen.ml index 1b32bb3dd8..3f674590de 100644 --- a/jscomp/bsb/bsb_ninja_gen.ml +++ b/jscomp/bsb/bsb_ninja_gen.ml @@ -43,102 +43,6 @@ let get_bsc_flags let bsc_lib_includes (bs_dependencies : Bsb_config_types.dependencies) = (Ext_list.flat_map bs_dependencies (fun x -> x.package_install_dirs)) -(* let output_static_resources - (static_resources : string list) - ~cur_dir - copy_rule - oc - = - Ext_list.iter static_resources (fun output -> - Bsb_ninja_targets.output_build - cur_dir - oc - ~outputs:[output] - ~inputs:[Bsb_config.proj_rel output] - ~rule:copy_rule); - if static_resources <> [] then - Bsb_ninja_targets.phony - oc - ~order_only_deps:static_resources - ~inputs:[] - ~output:Literals.build_ninja *) -(* - FIXME: check if the trick still works - phony build.ninja : | resources -*) -let mark_rescript oc = - output_string oc "rescript = 1\n" -let output_installation_file cwd_lib_bs namespace files_to_install = - let install_oc = open_out_bin (cwd_lib_bs // "install.ninja") in - mark_rescript install_oc; - let o s = output_string install_oc s in - let[@inline] oo suffix ~dest ~src = - o "o " ; - o dest ; - o suffix; - o " : cp "; - o src; - o suffix; o "\n" in - let bs = ".."//"bs" in - let sb = ".."//".." in - o (if Ext_sys.is_windows_or_cygwin then - "rule cp\n command = cmd.exe /C copy /Y $i $out >NUL\n\ - rule touch\n command = cmd.exe /C type nul >>$out & copy $out+,, >NUL\n" - else - "rule cp\n command = cp $i $out\n\ - rule touch\n command = touch $out\n" - ); - let essentials = Ext_buffer.create 1_000 in - files_to_install - |> Queue.iter (fun ({name_sans_extension;syntax_kind; info} : Bsb_db.module_info) -> - let base = Filename.basename name_sans_extension in - let dest = Ext_namespace_encode.make ?ns:namespace base in - let ns_origin = Ext_namespace_encode.make ?ns:namespace name_sans_extension in - let src = bs//ns_origin in - oo Literals.suffix_cmi ~dest ~src; - oo Literals.suffix_cmj ~dest ~src; - oo Literals.suffix_cmt ~dest ~src; - - Ext_buffer.add_string essentials dest ; - Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; - Ext_buffer.add_string essentials dest ; - Ext_buffer.add_string_char essentials Literals.suffix_cmj ' '; - - let suffix = - match syntax_kind with - | Ml -> Literals.suffix_ml - | Reason -> Literals.suffix_re - | Res -> Literals.suffix_res - in oo suffix ~dest:base ~src:(sb//name_sans_extension); - match info with - | Intf -> assert false - | Impl -> () - | Impl_intf -> - let suffix_b = - match syntax_kind with - | Ml -> Literals.suffix_mli - | Reason -> Literals.suffix_rei - | Res -> Literals.suffix_resi in - oo suffix_b ~dest:base ~src:(sb//name_sans_extension); - oo Literals.suffix_cmti ~dest ~src - ); - begin match namespace with - | None -> () - | Some dest -> - let src = bs // dest in - oo Literals.suffix_cmi ~dest ~src; - oo Literals.suffix_cmj ~dest ~src; - oo Literals.suffix_cmt ~dest ~src; - Ext_buffer.add_string essentials dest ; - Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; - Ext_buffer.add_string essentials dest ; - Ext_buffer.add_string essentials Literals.suffix_cmj - end; - Ext_buffer.add_char essentials '\n'; - o "build install.stamp : touch "; - Ext_buffer.output_buffer install_oc essentials; - close_out install_oc - let output_ninja_and_namespace_map ~buf ~per_proj_dir @@ -172,23 +76,15 @@ let output_ninja_and_namespace_map let bsc_flags = (get_bsc_flags bsc_flags) in let bs_groups : Bsb_db.t = {lib = Map_string.empty; dev = Map_string.empty} in let source_dirs : string list Bsb_db.cat = {lib = []; dev = []} in - let _static_resources = - Ext_list.fold_left - bs_file_groups - [] ( - fun - (acc_resources : string list) - {sources; dir; resources; is_dev} - -> - if is_dev then begin - bs_groups.dev <- Bsb_db_util.merge bs_groups.dev sources ; - source_dirs.dev <- dir :: source_dirs.dev; - end else begin - bs_groups.lib <- Bsb_db_util.merge bs_groups.lib sources ; - source_dirs.lib <- dir :: source_dirs.lib - end; - Ext_list.map_append resources acc_resources (fun x -> dir//x) - ) in + Ext_list.iter bs_file_groups (fun + {sources; dir; resources; is_dev} -> + if is_dev then begin + bs_groups.dev <- Bsb_db_util.merge bs_groups.dev sources ; + source_dirs.dev <- dir :: source_dirs.dev; + end else begin + bs_groups.lib <- Bsb_db_util.merge bs_groups.lib sources ; + source_dirs.lib <- dir :: source_dirs.lib + end); let g_stdlib_incl = if built_in_dependency then let path = Bsb_config.stdlib_path ~cwd:per_proj_dir in [ path ] @@ -197,6 +93,7 @@ let output_ninja_and_namespace_map let global_config = Bsb_ninja_global_vars.make ~package_name + ~db:bs_groups ~src_root_dir:per_proj_dir ~bsc:(Ext_filename.maybe_quote Bsb_global_paths.vendor_bsc) ~bsdep:(Ext_filename.maybe_quote Bsb_global_paths.vendor_bsdep) diff --git a/jscomp/bsb/bsb_ninja_global_vars.ml b/jscomp/bsb/bsb_ninja_global_vars.ml index 2b9c71a2c9..2779f41182 100644 --- a/jscomp/bsb/bsb_ninja_global_vars.ml +++ b/jscomp/bsb/bsb_ninja_global_vars.ml @@ -24,6 +24,7 @@ type t = { + db : Bsb_db.t; package_name : string; src_root_dir: string; bsc: string; @@ -43,6 +44,7 @@ type t = } let make + ~db ~package_name ~src_root_dir ~bsc @@ -60,6 +62,7 @@ let make ~pp_flags ~namespace = { + db; package_name; src_root_dir; bsc; diff --git a/jscomp/bsb/bsb_ninja_rule.ml b/jscomp/bsb/bsb_ninja_rule.ml index 14d40ca011..70b89b4bdd 100644 --- a/jscomp/bsb/bsb_ninja_rule.ml +++ b/jscomp/bsb/bsb_ninja_rule.ml @@ -131,6 +131,8 @@ let make_custom_rules Buffer.add_string buf "(action\n (progn "; Buffer.add_string buf "(dynamic-run "; Buffer.add_string buf global_config.bs_dep_parse; + Buffer.add_string buf " -cwd "; + Buffer.add_string buf cur_dir; Buffer.add_string buf " %{dep_file}) (run "; Buffer.add_string buf global_config.bsc; Buffer.add_string buf ns_flag; diff --git a/jscomp/bsb/bsb_world.ml b/jscomp/bsb/bsb_world.ml index 758a2caef6..0298b74772 100644 --- a/jscomp/bsb/bsb_world.ml +++ b/jscomp/bsb/bsb_world.ml @@ -28,8 +28,6 @@ let (//) = Ext_path.combine let install_targets cwd ({ namespace; pinned_dependencies} as config : Bsb_config_types.t ) = let deps = config.package_specs in let lib_artifacts_dir = Bsb_config.lib_bs in - let destdir = cwd // Bsb_config.lib_ocaml in (* lib is already there after building, so just mkdir [lib/ocaml] *) - if not @@ Sys.file_exists destdir then begin Unix.mkdir destdir 0o777 end; begin Bsb_log.info "@{Installing started@}@."; let file_groups = ref [] in diff --git a/jscomp/bsb_helper/bsb_db_decode.ml b/jscomp/bsb_helper/bsb_db_decode.ml index 2dd0888733..2f4d423ac9 100644 --- a/jscomp/bsb_helper/bsb_db_decode.ml +++ b/jscomp/bsb_helper/bsb_db_decode.ml @@ -43,32 +43,7 @@ type t = { type cursor = int ref - -(*TODO: special case when module_count is zero *) -let rec decode (x : string) : t = - let (offset : cursor) = ref 0 in - let lib = decode_single x offset in - let dev = decode_single x offset in - {lib; dev; content = x} - -and decode_single (x : string) (offset : cursor) : group = - let module_number = Ext_pervasives.parse_nat_of_string x offset in - incr offset; - if module_number <> 0 then begin - let modules = decode_modules x offset module_number in - let dir_info_offset = !offset in - let module_info_offset = - String.index_from x dir_info_offset '\n' + 1 in - let dir_length = Char.code x.[module_info_offset] - 48 (* Char.code '0'*) in - offset := - module_info_offset + - 1 + - dir_length * module_number + - 1 - ; - Group { modules ; dir_info_offset; module_info_offset ; dir_length} - end else Dummy -and decode_modules (x : string) (offset : cursor) module_number : string array = +let decode_modules (x : string) (offset : cursor) module_number : string array = let result = Array.make module_number "" in let last = ref !offset in let cur = ref !offset in @@ -88,6 +63,30 @@ and decode_modules (x : string) (offset : cursor) module_number : string array = offset := !cur; result +let decode_single (x : string) (offset : cursor) : group = + let module_number = Ext_pervasives.parse_nat_of_string x offset in + incr offset; + if module_number <> 0 then begin + let modules = decode_modules x offset module_number in + let dir_info_offset = !offset in + let module_info_offset = + String.index_from x dir_info_offset '\n' + 1 in + let dir_length = Char.code x.[module_info_offset] - 48 (* Char.code '0'*) in + offset := + module_info_offset + + 1 + + dir_length * module_number + + 1 + ; + Group { modules ; dir_info_offset; module_info_offset ; dir_length} + end else Dummy + +(*TODO: special case when module_count is zero *) +let decode (x : string) : t = + let (offset : cursor) = ref 0 in + let lib = decode_single x offset in + let dev = decode_single x offset in + {lib; dev; content = x} (* TODO: shall we check the consistency of digest *) let read_build_cache ~dir : t = @@ -105,12 +104,22 @@ type module_info = { let find_opt ({content = whole; _ } as db : t ) + ~(kind: [`impl | `intf]) lib (key : string) : module_info option = match if lib then db.lib else db.dev with | Dummy -> None | Group ({ modules; _ } as group) -> let i = Ext_string_array.find_sorted modules key in + let i = match i with + | Some _ -> i + | None -> + let suffix = match kind with + | `impl -> Literals.suffix_impl + | `intf -> Literals.suffix_intf + in + Ext_string_array.find_sorted modules (key ^ suffix) + in match i with | None -> None | Some count -> @@ -135,11 +144,11 @@ let find_opt in Some {case ; dir_name = String.sub whole dir_name_start (dir_name_finish - dir_name_start)} -let find db dependent_module is_not_lib_dir = - let opt = find_opt db true dependent_module in +let find db ~(kind: [`impl | `intf]) dependent_module is_not_lib_dir = + let opt = find_opt db ~kind true dependent_module in match opt with | Some _ -> opt | None -> if is_not_lib_dir then - find_opt db false dependent_module + find_opt ~kind db false dependent_module else None diff --git a/jscomp/bsb_helper/bsb_db_decode.mli b/jscomp/bsb_helper/bsb_db_decode.mli index 9f11e14b6b..510b73f179 100644 --- a/jscomp/bsb_helper/bsb_db_decode.mli +++ b/jscomp/bsb_helper/bsb_db_decode.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2019 - Present Authors of ReScript - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,30 +17,30 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - type group = private - | Dummy + + + type group = private + | Dummy | Group of { - modules : string array ; + modules : string array ; dir_length : int; - dir_info_offset : int ; + dir_info_offset : int ; module_info_offset : int; } -type t = { +type t = { lib : group ; - dev : group ; + dev : group ; content : string (* string is whole content*) } -val read_build_cache : +val read_build_cache : dir:string -> t @@ -48,13 +48,14 @@ val read_build_cache : type module_info = { case : bool (* Bsb_db.case*); dir_name : string -} +} val find: t -> (* contains global info *) + kind:[`impl | `intf] -> string -> (* module name *) bool -> (* more likely to be zero *) - module_info option + module_info option -val decode : string -> t \ No newline at end of file +val decode : string -> t diff --git a/jscomp/bsb_helper/bsb_helper_depfile_gen.ml b/jscomp/bsb_helper/bsb_helper_depfile_gen.ml index 5b560f0adb..03859e094c 100644 --- a/jscomp/bsb_helper/bsb_helper_depfile_gen.ml +++ b/jscomp/bsb_helper/bsb_helper_depfile_gen.ml @@ -22,8 +22,9 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +let (//) = Ext_path.combine -let lib_bs = Ext_path.combine "lib" "bs" +let lib_bs = "lib" // "bs" let dep_lit = " : " let write_buf name buf = let oc = open_out_bin name in @@ -104,13 +105,6 @@ let oc_cmi buf namespace source = output_file buf source namespace; Ext_buffer.add_string buf Literals.suffix_cmi -let rel_target_path ~cwd ~dependent_module_dir ~cur_module_dir = - (* `cwd` is the project root. module dir groups are relative to it. *) - let module_path = Ext_path.combine cwd dependent_module_dir in - let cur_module_path = Ext_path.combine cwd cur_module_dir in - (* Ext_path.rel_normalized_absolute_path ~from:cwd module_path *) - Ext_path.rel_normalized_absolute_path ~from:cur_module_path module_path - (* For cases with self cycle e.g, in b.ml @@ -133,29 +127,28 @@ let oc_deps (namespace : string option) (buf : Ext_buffer.t) (kind : [`impl | `intf ]) - ~cwd : unit + : unit = (* TODO: move namespace upper, it is better to resolve ealier *) let cur_module_name = Ext_filename.module_name ast_file in - let cur_module_dir = match Bsb_db_decode.find db cur_module_name is_dev with + let cur_module_impl_dir = match Bsb_db_decode.find db ~kind:`impl cur_module_name is_dev with + | Some { dir_name; _ } -> dir_name + | None -> assert false + in + let cur_module_intf_dir = match Bsb_db_decode.find db ~kind:`intf cur_module_name is_dev with | Some { dir_name; _ } -> dir_name | None -> assert false in let at_most_once : unit lazy_t = lazy ( - output_file buf (Ext_filename.chop_extension_maybe ast_file) namespace ; + let dir = if kind = `impl then cur_module_impl_dir else cur_module_intf_dir in + output_file buf (dir // (Ext_filename.chop_extension_maybe (Filename.basename ast_file))) namespace ; Ext_buffer.add_string buf (if kind = `impl then Literals.suffix_cmj else Literals.suffix_cmi); (* print the source *) Ext_buffer.add_string buf dep_lit ) in Ext_option.iter namespace (fun ns -> - let rel = - rel_target_path - ~cwd - ~dependent_module_dir:(Ext_path.combine cwd lib_bs) - ~cur_module_dir - in Lazy.force at_most_once; Ext_buffer.add_char buf ' '; - Ext_buffer.add_string buf (Ext_path.combine rel ns); + Ext_buffer.add_string buf (lib_bs // ns); Ext_buffer.add_string buf Literals.suffix_cmi; (* always cmi *) ) ; (* TODO: moved into static files*) let s = extract_dep_raw_string ast_file in @@ -171,31 +164,26 @@ let oc_deps end ); (match - Bsb_db_decode.find db dependent_module is_dev + Bsb_db_decode.find db ~kind:`impl dependent_module is_dev, + Bsb_db_decode.find db ~kind:`intf dependent_module is_dev with - | None -> () - | Some ({dir_name; case }) -> + | None, None -> () + | Some _ , None | None, Some _ -> assert false + | Some ({dir_name = impl_dir_name; case }), Some ({ dir_name = intf_dir_name; _ }) -> begin Lazy.force at_most_once; - let rel_dir = - rel_target_path - ~cwd - ~dependent_module_dir:dir_name - ~cur_module_dir - in let module_basename = if case then dependent_module else Ext_string.uncapitalize_ascii dependent_module in - let source = Ext_path.concat rel_dir module_basename in Ext_buffer.add_char buf ' '; if kind = `impl then begin - output_file buf source namespace; + output_file buf (impl_dir_name // module_basename) namespace; Ext_buffer.add_string buf Literals.suffix_cmj; end; (* #3260 cmj changes does not imply cmi change anymore *) - oc_cmi buf namespace source + oc_cmi buf namespace (intf_dir_name // module_basename) end); offset := next_tab + 1 @@ -208,7 +196,7 @@ let emit_d (is_dev : bool) (namespace : string option) (mlast : string) (mliast : string) = let data = - Bsb_db_decode.read_build_cache ~dir:(Ext_path.combine cwd lib_bs) + Bsb_db_decode.read_build_cache ~dir:(cwd // lib_bs) in let buf = Ext_buffer.create 2048 in let filename = @@ -218,7 +206,6 @@ let emit_d is_dev data namespace - ~cwd buf `impl ; if mliast <> "" then begin @@ -227,7 +214,6 @@ let emit_d is_dev data namespace - ~cwd buf `intf end; write_file filename buf diff --git a/jscomp/ext/bsb_db.ml b/jscomp/ext/bsb_db.ml index 511f5c6653..c6bf334305 100644 --- a/jscomp/ext/bsb_db.ml +++ b/jscomp/ext/bsb_db.ml @@ -1,6 +1,6 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -18,7 +18,7 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) @@ -26,35 +26,38 @@ type case = bool (** true means upper case*) - -type info = - | Intf (* intemediate state *) +type info = + | Intf | Impl | Impl_intf -type syntax_kind = - | Ml - | Reason +type syntax_kind = + | Ml + | Reason | Res - -type module_info = + +type 'a diff = + | Same of 'a + | Different of { impl: 'a; intf: 'a } + +type module_info = { mutable info : info; - dir : string ; - syntax_kind : syntax_kind; + dir : string diff; + syntax_kind : syntax_kind diff; case : bool; name_sans_extension : string ; } -type map = module_info Map_string.t +type map = module_info Map_string.t type 'a cat = { mutable lib : 'a; mutable dev : 'a } -type t = map cat +type t = map cat (** indexed by the group *) diff --git a/jscomp/ext/bsb_db.mli b/jscomp/ext/bsb_db.mli index 3832c5295d..7bf29d6385 100644 --- a/jscomp/ext/bsb_db.mli +++ b/jscomp/ext/bsb_db.mli @@ -1,6 +1,6 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -18,36 +18,40 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Store a file called [.bsbuild] that can be communicated - between [bsb.exe] and [bsb_helper.exe]. - [bsb.exe] stores such data which would be retrieved by - [bsb_helper.exe]. It is currently used to combine with +(** Store a file called [.bsbuild] that can be communicated + between [bsb.exe] and [bsb_helper.exe]. + [bsb.exe] stores such data which would be retrieved by + [bsb_helper.exe]. It is currently used to combine with ocamldep to figure out which module->file it depends on -*) +*) -type case = bool +type case = bool -type info = +type info = | Intf (* intemediate state *) | Impl | Impl_intf -type syntax_kind = - | Ml - | Reason +type syntax_kind = + | Ml + | Reason | Res -type module_info = +type 'a diff = + | Same of 'a + | Different of { impl: 'a; intf: 'a } + +type module_info = { mutable info : info; - dir : string; - syntax_kind : syntax_kind; - (* This is actually not stored in bsbuild meta info + dir : string diff; + syntax_kind : syntax_kind diff; + (* This is actually not stored in bsbuild meta info since creating .d file only emit .cmj/.cmi dependencies, so it does not need know which syntax it is written *) @@ -55,21 +59,21 @@ type module_info = name_sans_extension : string; } -type map = module_info Map_string.t +type map = module_info Map_string.t type 'a cat = { - mutable lib : 'a ; + mutable lib : 'a ; mutable dev : 'a; } -type t = map cat +type t = map cat (** store the meta data indexed by {!Bsb_dir_index} {[ 0 --> lib group 1 --> dev 1 group . - + ]} *) diff --git a/jscomp/ext/literals.ml b/jscomp/ext/literals.ml index 9f117b0009..ef0b1212d0 100644 --- a/jscomp/ext/literals.ml +++ b/jscomp/ext/literals.ml @@ -108,6 +108,9 @@ let suffix_cjs = ".cjs" let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" +let suffix_impl = ".impl" +let suffix_intf = ".intf" + let commonjs = "commonjs" let es6 = "es6" diff --git a/jscomp/ext/map.cppo.ml b/jscomp/ext/map.cppo.ml index 7ca4f0e350..ba7e21cd0e 100644 --- a/jscomp/ext/map.cppo.ml +++ b/jscomp/ext/map.cppo.ml @@ -160,10 +160,10 @@ let rec split (tree : (key,'a) Map_gen.t) x : 'a split = No {result with l = Map_gen.join l k v result.l} -let rec disjoint_merge_exn +let rec disjoint_merge (s1 : _ Map_gen.t) (s2 : _ Map_gen.t) - fail : _ Map_gen.t = + fix_conflict : _ Map_gen.t = match s1 with | Empty -> s2 | Leaf ({k } as l1) -> @@ -171,14 +171,14 @@ let rec disjoint_merge_exn | Empty -> s1 | Leaf l2 -> let c = compare_key k l2.k in - if c = 0 then raise_notrace (fail k l1.v l2.v) + if c = 0 then Map_gen.singleton k (fix_conflict k l1.v l2.v) else if c < 0 then Map_gen.unsafe_two_elements l1.k l1.v l2.k l2.v else Map_gen.unsafe_two_elements l2.k l2.v k l1.v | Node _ -> adjust s2 k (fun data -> match data with | None -> l1.v - | Some s2v -> raise_notrace (fail k l1.v s2v) + | Some s2v -> (fix_conflict k l1.v s2v) ) end | Node ({k} as xs1) -> @@ -186,26 +186,35 @@ let rec disjoint_merge_exn begin match split s2 k with | No {l; r} -> Map_gen.join - (disjoint_merge_exn xs1.l l fail) + (disjoint_merge xs1.l l fix_conflict) k xs1.v - (disjoint_merge_exn xs1.r r fail) - | Yes { v = s2v} -> - raise_notrace (fail k xs1.v s2v) + (disjoint_merge xs1.r r fix_conflict) + | Yes { l; v = s2v; r} -> + let fixed = fix_conflict k xs1.v s2v in + Map_gen.join + (disjoint_merge xs1.l l fix_conflict) + k + fixed + (disjoint_merge xs1.r r fix_conflict) end else let [@warning "-8"] (Node ({k} as s2) : _ Map_gen.t) = s2 in - begin match split s1 k with + begin match split s1 k with | No {l; r} -> Map_gen.join - (disjoint_merge_exn l s2.l fail) k s2.v - (disjoint_merge_exn r s2.r fail) - | Yes { v = s1v} -> - raise_notrace (fail k s1v s2.v) + (disjoint_merge l s2.l fix_conflict) k s2.v + (disjoint_merge r s2.r fix_conflict) + | Yes { l; v = s1v; r} -> + let fixed = fix_conflict k s1v s2.v in + Map_gen.join + (disjoint_merge l s2.l fix_conflict) + k + fixed + (disjoint_merge r s2.r fix_conflict) end - - - +let disjoint_merge_exn s1 s2 fail = + disjoint_merge s1 s2 (fun k s1v s2v -> raise_notrace (fail k s1v s2v)) let add_list (xs : _ list ) init = diff --git a/jscomp/ext/map_gen.ml b/jscomp/ext/map_gen.ml index 507874c4bb..ea4889d43c 100644 --- a/jscomp/ext/map_gen.ml +++ b/jscomp/ext/map_gen.ml @@ -28,7 +28,7 @@ type ('key,'a) t0 = let empty = Empty let rec map x f = match x with Empty -> Empty - | Leaf {k;v} -> Leaf {k; v = f v} + | Leaf {k;v} -> Leaf {k; v = f v} | Node ({l; v ; r} as x) -> let l' = map l f in let d' = f v in @@ -37,27 +37,27 @@ let rec map x f = match x with let rec mapi x f = match x with Empty -> Empty - | Leaf {k;v} -> Leaf {k; v = f k v} + | Leaf {k;v} -> Leaf {k; v = f k v} | Node ({l; k ; v ; r} as x) -> let l' = mapi l f in let v' = f k v in let r' = mapi r f in Node {x with l = l'; v = v'; r = r'} -let [@inline] calc_height a b = (if a >= b then a else b) + 1 +let [@inline] calc_height a b = (if a >= b then a else b) + 1 let [@inline] singleton k v = Leaf {k;v} let [@inline] height = function | Empty -> 0 | Leaf _ -> 1 | Node {h} -> h -let [@inline] unsafe_node k v l r h = +let [@inline] unsafe_node k v l r h = Node {l; k; v; r; h} -let [@inline] unsafe_two_elements k1 v1 k2 v2 = - unsafe_node k2 v2 (singleton k1 v1) empty 2 -let [@inline] unsafe_node_maybe_leaf k v l r h = - if h = 1 then Leaf {k ; v} - else Node{l;k;v;r; h } +let [@inline] unsafe_two_elements k1 v1 k2 v2 = + unsafe_node k2 v2 (singleton k1 v1) empty 2 +let [@inline] unsafe_node_maybe_leaf k v l r h = + if h = 1 then Leaf {k ; v} + else Node{l;k;v;r; h } type ('key, + 'a) t = ('key,'a) t0 = private @@ -75,12 +75,12 @@ let [@inline] unsafe_node_maybe_leaf k v l r h = } let rec cardinal_aux acc = function - | Empty -> acc + | Empty -> acc | Leaf _ -> acc + 1 - | Node {l; r} -> - cardinal_aux (cardinal_aux (acc + 1) r ) l + | Node {l; r} -> + cardinal_aux (cardinal_aux (acc + 1) r ) l -let cardinal s = cardinal_aux 0 s +let cardinal s = cardinal_aux 0 s let rec bindings_aux accu = function | Empty -> accu @@ -90,50 +90,50 @@ let rec bindings_aux accu = function let bindings s = bindings_aux [] s -let rec fill_array_with_f (s : _ t) i arr f : int = - match s with - | Empty -> i - | Leaf {k;v} -> +let rec fill_array_with_f (s : _ t) i arr f : int = + match s with + | Empty -> i + | Leaf {k;v} -> Array.unsafe_set arr i (f k v); i + 1 - | Node {l; k; v; r} -> - let inext = fill_array_with_f l i arr f in + | Node {l; k; v; r} -> + let inext = fill_array_with_f l i arr f in Array.unsafe_set arr inext (f k v); fill_array_with_f r (inext + 1) arr f -let rec fill_array_aux (s : _ t) i arr : int = - match s with - | Empty -> i - | Leaf {k;v} -> +let rec fill_array_aux (s : _ t) i arr : int = + match s with + | Empty -> i + | Leaf {k;v} -> Array.unsafe_set arr i (k, v); i + 1 - | Node {l;k;v;r} -> - let inext = fill_array_aux l i arr in + | Node {l;k;v;r} -> + let inext = fill_array_aux l i arr in Array.unsafe_set arr inext (k,v); - fill_array_aux r (inext + 1) arr + fill_array_aux r (inext + 1) arr -let to_sorted_array (s : ('key,'a) t) : ('key * 'a ) array = - match s with +let to_sorted_array (s : ('key,'a) t) : ('key * 'a ) array = + match s with | Empty -> [||] | Leaf {k;v} -> [|k,v|] - | Node {l;k;v;r} -> - let len = - cardinal_aux (cardinal_aux 1 r) l in + | Node {l;k;v;r} -> + let len = + cardinal_aux (cardinal_aux 1 r) l in let arr = - Array.make len (k,v) in + Array.make len (k,v) in ignore (fill_array_aux s 0 arr : int); - arr + arr -let to_sorted_array_with_f (type key a b ) (s : (key,a) t) (f : key -> a -> b): b array = - match s with +let to_sorted_array_with_f (type key a b ) (s : (key,a) t) (f : key -> a -> b): b array = + match s with | Empty -> [||] | Leaf {k;v} -> [| f k v|] - | Node {l;k;v;r} -> - let len = - cardinal_aux (cardinal_aux 1 r) l in + | Node {l;k;v;r} -> + let len = + cardinal_aux (cardinal_aux 1 r) l in let arr = - Array.make len (f k v) in + Array.make len (f k v) in ignore (fill_array_with_f s 0 arr f: int); - arr + arr let rec keys_aux accu = function Empty -> accu @@ -151,42 +151,42 @@ let bal l x d r = let hr = height r in if hl > hr + 2 then begin let [@warning "-8"] Node ({l=ll; r = lr} as l) = l in - let hll = height ll in - let hlr = height lr in + let hll = height ll in + let hlr = height lr in if hll >= hlr then - let hnode = calc_height hlr hr in - unsafe_node l.k l.v - ll + let hnode = calc_height hlr hr in + unsafe_node l.k l.v + ll (unsafe_node_maybe_leaf x d lr r hnode) (calc_height hll hnode) - else - let [@warning "-8"] Node ({l=lrl; r=lrr} as lr) = lr in - let hlrl = height lrl in - let hlrr = height lrr in - let hlnode = calc_height hll hlrl in - let hrnode = calc_height hlrr hr in - unsafe_node lr.k lr.v - (unsafe_node_maybe_leaf l.k l.v ll lrl hlnode) - (unsafe_node_maybe_leaf x d lrr r hrnode) + else + let [@warning "-8"] Node ({l=lrl; r=lrr} as lr) = lr in + let hlrl = height lrl in + let hlrr = height lrr in + let hlnode = calc_height hll hlrl in + let hrnode = calc_height hlrr hr in + unsafe_node lr.k lr.v + (unsafe_node_maybe_leaf l.k l.v ll lrl hlnode) + (unsafe_node_maybe_leaf x d lrr r hrnode) (calc_height hlnode hrnode) end else if hr > hl + 2 then begin - let [@warning "-8"] Node ({l=rl; r=rr} as r) = r in - let hrr = height rr in - let hrl = height rl in + let [@warning "-8"] Node ({l=rl; r=rr} as r) = r in + let hrr = height rr in + let hrl = height rl in if hrr >= hrl then let hnode = calc_height hl hrl in - unsafe_node r.k r.v + unsafe_node r.k r.v (unsafe_node_maybe_leaf x d l rl hnode) rr (calc_height hnode hrr) - else - let [@warning "-8"] Node ({l=rll; r=rlr} as rl) = rl in - let hrll = height rll in - let hrlr = height rlr in + else + let [@warning "-8"] Node ({l=rll; r=rlr} as rl) = rl in + let hrll = height rll in + let hrlr = height rlr in let hlnode = (calc_height hl hrll) in - let hrnode = (calc_height hrlr hrr) in - unsafe_node rl.k rl.v - (unsafe_node_maybe_leaf x d l rll hlnode) + let hrnode = (calc_height hrlr hrr) in + unsafe_node rl.k rl.v + (unsafe_node_maybe_leaf x d l rll hlnode) (unsafe_node_maybe_leaf r.k r.v rlr rr hrnode) (calc_height hlnode hrnode) end else @@ -198,18 +198,18 @@ let [@inline] is_empty = function Empty -> true | _ -> false let rec min_binding_exn = function Empty -> raise Not_found - | Leaf {k;v} -> (k,v) - | Node{l; k; v} -> - match l with - | Empty -> (k, v) + | Leaf {k;v} -> (k,v) + | Node{l; k; v} -> + match l with + | Empty -> (k, v) | Leaf _ - | Node _ -> + | Node _ -> min_binding_exn l let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" - | Leaf _ -> empty + | Leaf _ -> empty | Node{l=Empty;r} -> r | Node{l; k; v ; r} -> bal (remove_min_binding l) k v r @@ -222,9 +222,9 @@ let merge t1 t2 = bal t1 x d (remove_min_binding t2) -let rec iter x f = match x with +let rec iter x f = match x with Empty -> () - | Leaf {k;v} -> (f k v : unit) + | Leaf {k;v} -> (f k v : unit) | Node{l; k ; v ; r} -> iter l f; f k v; iter r f @@ -233,18 +233,18 @@ let rec iter x f = match x with let rec fold m accu f = match m with Empty -> accu - | Leaf {k;v} -> f k v accu + | Leaf {k;v} -> f k v accu | Node {l; k; v; r} -> - fold r (f k v (fold l accu f)) f + fold r (f k v (fold l accu f)) f -let rec for_all x p = match x with +let rec for_all x p = match x with Empty -> true - | Leaf {k; v} -> p k v + | Leaf {k; v} -> p k v | Node{l; k; v ; r} -> p k v && for_all l p && for_all r p let rec exists x p = match x with Empty -> false - | Leaf {k; v} -> p k v + | Leaf {k; v} -> p k v | Node{l; k; v; r} -> p k v || exists l p || exists r p (* Beware: those two functions assume that the added k is *strictly* @@ -276,13 +276,13 @@ let rec join l v d r = | Leaf leaf -> add_min leaf.k leaf.v (add_min v d r) | Node xl -> - match r with + match r with | Empty -> add_max v d l - | Leaf leaf -> - add_max leaf.k leaf.v (add_max v d l) + | Leaf leaf -> + add_max leaf.k leaf.v (add_max v d l) | Node xr -> - let lh = xl.h in - let rh = xr.h in + let lh = xl.h in + let rh = xr.h in if lh > rh + 2 then bal xl.l xl.k xl.v (join xl.r v d r) else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r else unsafe_node v d l r (calc_height lh rh) @@ -304,28 +304,28 @@ let concat_or_join t1 v d t2 = | Some d -> join t1 v d t2 | None -> concat t1 t2 - + module type S = sig type key type +'a t val empty: 'a t - val compare_key: key -> key -> int + val compare_key: key -> key -> int val is_empty: 'a t -> bool val mem: 'a t -> key -> bool - val to_sorted_array : + val to_sorted_array : 'a t -> (key * 'a ) array - val to_sorted_array_with_f : - 'a t -> (key -> 'a -> 'b) -> 'b array + val to_sorted_array_with_f : + 'a t -> (key -> 'a -> 'b) -> 'b array val add: 'a t -> key -> 'a -> 'a t - (** [add x y m] + (** [add x y m] If [x] was already bound in [m], its previous binding disappears. *) - val adjust: 'a t -> key -> ('a option-> 'a) -> 'a t - (** [adjust acc k replace ] if not exist [add (replace None ], otherwise + val adjust: 'a t -> key -> ('a option-> 'a) -> 'a t + (** [adjust acc k replace ] if not exist [add (replace None ], otherwise [add k v (replace (Some old))] *) - + val singleton: key -> 'a -> 'a t val remove: 'a t -> key -> 'a t @@ -341,9 +341,17 @@ module type S = @since 3.12.0 *) - val disjoint_merge_exn : - 'a t - -> 'a t + + val disjoint_merge : + 'a t -> + 'a t -> + (key -> 'a -> 'a -> 'a) -> + 'a t + + + val disjoint_merge_exn : + 'a t + -> 'a t -> (key -> 'a -> 'a -> exn) -> 'a t (* merge two maps, will raise if they have the same key *) @@ -366,7 +374,7 @@ module type S = val exists: 'a t -> (key -> 'a -> bool) -> bool (** [exists p m] checks if at least one binding of the map - satisfy the predicate [p]. + satisfy the predicate [p]. order unspecified *) @@ -390,7 +398,7 @@ module type S = (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering *) - val keys : 'a t -> key list + val keys : 'a t -> key list (* Increasing order *) @@ -410,7 +418,7 @@ module type S = (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val find_opt: 'a t -> key ->'a option - val find_default: 'a t -> key -> 'a -> 'a + val find_default: 'a t -> key -> 'a -> 'a val map: 'a t -> ('a -> 'b) -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been @@ -422,8 +430,8 @@ module type S = (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) - val of_list : (key * 'a) list -> 'a t - val of_array : (key * 'a ) array -> 'a t + val of_list : (key * 'a) list -> 'a t + val of_array : (key * 'a ) array -> 'a t val add_list : (key * 'b) list -> 'b t -> 'b t end diff --git a/jscomp/ext/map_gen.mli b/jscomp/ext/map_gen.mli index b5ae59a4b1..d047a62ad5 100644 --- a/jscomp/ext/map_gen.mli +++ b/jscomp/ext/map_gen.mli @@ -29,20 +29,20 @@ val height : ('a, 'b) t -> int val singleton : 'a -> 'b -> ('a, 'b) t -val [@inline] unsafe_node : - 'a -> - 'b -> +val [@inline] unsafe_node : + 'a -> + 'b -> ('a, 'b ) t -> ('a, 'b ) t -> - int -> + int -> ('a, 'b ) t (** smaller comes first *) val [@inline] unsafe_two_elements : - 'a -> - 'b -> - 'a -> - 'b -> + 'a -> + 'b -> + 'a -> + 'b -> ('a, 'b) t val bal : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t @@ -82,12 +82,18 @@ module type S = val remove : 'a t -> key -> 'a t (* val merge : 'a t -> 'b t -> (key -> 'a option -> 'b option -> 'c option) -> 'c t *) - val disjoint_merge_exn : - 'a t -> - 'a t -> - (key -> 'a -> 'a -> exn) -> + val disjoint_merge : + 'a t -> + 'a t -> + (key -> 'a -> 'a -> 'a) -> 'a t - + + val disjoint_merge_exn : + 'a t -> + 'a t -> + (key -> 'a -> 'a -> exn) -> + 'a t + val iter : 'a t -> (key -> 'a -> unit) -> unit val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b val for_all : 'a t -> (key -> 'a -> bool) -> bool diff --git a/jscomp/main/bsb_parse_depend.ml b/jscomp/main/bsb_parse_depend.ml index b89e4ba641..b6ea808430 100644 --- a/jscomp/main/bsb_parse_depend.ml +++ b/jscomp/main/bsb_parse_depend.ml @@ -52,23 +52,31 @@ let parse_deps_exn lines = | line :: _ -> match split2 line ~sep:':' with | None -> assert false - | Some (_basename, deps) -> - extract_blank_separated_words deps + | Some (_fname, deps) -> extract_blank_separated_words deps -let single_file file = +let single_file ~cwd file = let chan = open_in_bin file in let deps = parse_deps_exn (input_lines chan) in close_in chan; - let rules = List.map (fun file -> D.read_file ~path:(P.of_string file)) - deps + let cwd_segments = Ext_string.split ~keep_empty:false cwd Filename.dir_sep.[0] in + let rel_project_root = + let arr = + Array.init (List.length cwd_segments) (fun _ -> Filename.parent_dir_name) + in + String.concat Filename.dir_sep (Array.to_list arr) + in + let rules = + List.map (fun file -> + let file' = rel_project_root // file in + D.read_file ~path:(P.of_string file')) deps in List.fold_left (fun acc item -> let+ _ = D.both acc item in ()) (D.return ()) rules -let parse_depends files = - let rules = List.map single_file files in +let parse_depends ~cwd files = + let rules = List.map (single_file ~cwd) files in let rule = List.fold_left (fun acc item -> let+ _ = D.both acc item in ()) (D.return ()) @@ -76,17 +84,21 @@ let parse_depends files = in D.run rule - let () = let argv = Sys.argv in let l = Array.length argv in let current = ref 1 in + let cwd = ref None in let rev_list = ref [] in while !current < l do let s = argv.(!current) in incr current; if s <> "" && s.[0] = '-' then begin match s with + | "-cwd" -> + let cwd_arg = argv.(!current) in + cwd := Some cwd_arg; + incr current | "-help" -> prerr_endline ("usage: bsb_parse_depend.exe [-help] file1 file2 ..."); exit 0 @@ -97,6 +109,10 @@ let () = end else rev_list := s :: !rev_list done; - parse_depends !rev_list + match !cwd with + | None -> + prerr_endline "-cwd is a required option"; + exit 2 + | Some cwd -> parse_depends ~cwd !rev_list ;; diff --git a/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml b/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml index c692fa79a7..9f47dd5d85 100644 --- a/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml +++ b/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml @@ -3,74 +3,74 @@ let ((>::), (>:::)) = OUnit.((>::),(>:::)) -let printer_string = fun x -> x -let (=~) = OUnit.assert_equal ~printer:printer_string +let printer_string = fun x -> x +let (=~) = OUnit.assert_equal ~printer:printer_string -let scope_test s (a,b,c)= - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope(a0,b0),c0 -> +let scope_test s (a,b,c)= + match Bsb_pkg_types.extract_pkg_name_and_file s with + | Scope(a0,b0),c0 -> a =~ a0 ; b =~ b0 ; c =~ c0 | Global _,_ -> OUnit.assert_failure __LOC__ -let global_test s (a,b) = - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope _, _ -> +let global_test s (a,b) = + match Bsb_pkg_types.extract_pkg_name_and_file s with + | Scope _, _ -> OUnit.assert_failure __LOC__ - | Global a0, b0-> + | Global a0, b0-> a=~a0; b=~b0 -let s_test0 s (a,b)= - match Bsb_pkg_types.string_as_package s with - | Scope(name,scope) -> - a =~ name ; b =~scope - | _ -> OUnit.assert_failure __LOC__ +let s_test0 s (a,b)= + match Bsb_pkg_types.string_as_package s with + | Scope(name,scope) -> + a =~ name ; b =~scope + | _ -> OUnit.assert_failure __LOC__ -let s_test1 s a = - match Bsb_pkg_types.string_as_package s with - | Global x -> +let s_test1 s a = + match Bsb_pkg_types.string_as_package s with + | Global x -> a =~ x - | _ -> OUnit.assert_failure __LOC__ + | _ -> OUnit.assert_failure __LOC__ let group0 = Map_string.of_list [ - "Liba", - {Bsb_db.info = Impl_intf; dir= "a";syntax_kind=Ml;case = false; + "Liba", + {Bsb_db.info = Impl_intf; dir= Same "a";syntax_kind=Same Ml;case = false; name_sans_extension = "liba"} ] let group1 = Map_string.of_list [ - "Ciba", - {Bsb_db.info = Impl_intf; dir= "b";syntax_kind=Ml;case = false; + "Ciba", + {Bsb_db.info = Impl_intf; dir= Same "b";syntax_kind=Same Ml;case = false; name_sans_extension = "liba"} -] +] -let parse_db db : Bsb_db_decode.t = - let buf = Ext_buffer.create 10_000 in +let parse_db db : Bsb_db_decode.t = + let buf = Ext_buffer.create 10_000 in Bsb_db_encode.encode db buf; let s = Ext_buffer.contents buf in Bsb_db_decode.decode s -let suites = +let suites = __FILE__ >::: [ - __LOC__ >:: begin fun _ -> + __LOC__ >:: begin fun _ -> scope_test "@hello/hi" ("hi", "@hello",""); scope_test "@hello/hi/x" ("hi", "@hello","x"); - + scope_test "@hello/hi/x/y" - ("hi", "@hello","x/y"); + ("hi", "@hello","x/y"); end ; - __LOC__ >:: begin fun _ -> + __LOC__ >:: begin fun _ -> global_test "hello" ("hello",""); global_test "hello/x" - ("hello","x"); + ("hello","x"); global_test "hello/x/y" - ("hello","x/y") + ("hello","x/y") end ; - __LOC__ >:: begin fun _ -> + __LOC__ >:: begin fun _ -> s_test0 "@x/y" ("y","@x"); s_test0 "@x/y/z" ("y/z","@x"); s_test1 "xx" "xx"; @@ -78,35 +78,35 @@ let suites = end; __LOC__ >:: begin fun _ -> - match parse_db {lib= group0; dev = group1}with + match parse_db {lib= group0; dev = group1}with | {lib = Group {modules = [|"Liba"|]}; dev = Group {modules = [|"Ciba"|]}} -> OUnit.assert_bool __LOC__ true | _ -> - OUnit.assert_failure __LOC__ + OUnit.assert_failure __LOC__ end ; - __LOC__ >:: begin fun _ -> + __LOC__ >:: begin fun _ -> match parse_db {lib = group0;dev = Map_string.empty } with | {lib = Group {modules = [|"Liba"|]}; dev = Dummy} -> OUnit.assert_bool __LOC__ true | _ -> - OUnit.assert_failure __LOC__ + OUnit.assert_failure __LOC__ end ; - __LOC__ >:: begin fun _ -> + __LOC__ >:: begin fun _ -> match parse_db {lib = Map_string.empty ; dev = group1} with | {lib = Dummy; dev = Group {modules = [|"Ciba"|]} } -> OUnit.assert_bool __LOC__ true | _ -> - OUnit.assert_failure __LOC__ + OUnit.assert_failure __LOC__ end - (* __LOC__ >:: begin fun _ -> + (* __LOC__ >:: begin fun _ -> OUnit.assert_equal parse_data_one data_one end ; - __LOC__ >:: begin fun _ -> - + __LOC__ >:: begin fun _ -> + OUnit.assert_equal parse_data_two data_two end *) ]