matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #716 from rgrinberg/sexp-stdune 

Move Code_error to stdune
This commit is contained in:
Rudi Grinberg 2018-04-23 18:20:15 +07:00 committed by GitHub
parent f9373b2e46 24041593da
commit e991c261ca
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
59 changed files with 327 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
bin/main.ml
View File

@ -131,10 +131,10 @@ let do_build (setup : Main.setup) targets =
let find_root () = let find_root () =
let cwd = Sys.getcwd () in let cwd = Sys.getcwd () in
let rec loop counter ~candidates ~to_cwd dir = let rec loop counter ~candidates ~to_cwd dir =
let files = Sys.readdir dir |> Array.to_list |> String_set.of_list in let files = Sys.readdir dir |> Array.to_list |> String.Set.of_list in
if String_set.mem files "jbuild-workspace" then if String.Set.mem files "jbuild-workspace" then
cont counter ~candidates:((0, dir, to_cwd) :: candidates) dir ~to_cwd cont counter ~candidates:((0, dir, to_cwd) :: candidates) dir ~to_cwd
else if String_set.exists files ~f:(fun fn -> else if String.Set.exists files ~f:(fun fn ->
String.is_prefix fn ~prefix:"jbuild-workspace") then String.is_prefix fn ~prefix:"jbuild-workspace") then
cont counter ~candidates:((1, dir, to_cwd) :: candidates) dir ~to_cwd cont counter ~candidates:((1, dir, to_cwd) :: candidates) dir ~to_cwd
else else
@ -571,12 +571,12 @@ let target_hint (setup : Main.setup) path =
else else
None) None)
in in
let candidates = String_set.of_list candidates |> String_set.to_list in let candidates = String.Set.of_list candidates |> String.Set.to_list in
hint (Path.to_string path) candidates hint (Path.to_string path) candidates
let check_path contexts = let check_path contexts =
let contexts = let contexts =
String_set.of_list (List.map contexts ~f:(fun c -> c.Context.name)) String.Set.of_list (List.map contexts ~f:(fun c -> c.Context.name))
in in
fun path -> fun path ->
let internal path = let internal path =
@ -588,11 +588,11 @@ let check_path contexts =
| None -> internal path | None -> internal path
| Some (name, _) -> | Some (name, _) ->
if name = "" || name.[0] = '.' then internal path; if name = "" || name.[0] = '.' then internal path;
if not (name = "install" || String_set.mem contexts name) then if not (name = "install" || String.Set.mem contexts name) then
die "%s refers to unknown build context: %s%s" die "%s refers to unknown build context: %s%s"
(Path.to_string_maybe_quoted path) (Path.to_string_maybe_quoted path)
name name
(hint name (String_set.to_list contexts)) (hint name (String.Set.to_list contexts))
let resolve_targets ~log common (setup : Main.setup) user_targets = let resolve_targets ~log common (setup : Main.setup) user_targets =
match user_targets with match user_targets with
@ -735,7 +735,7 @@ let clean =
, Term.info "clean" ~doc ~man) , Term.info "clean" ~doc ~man)
let format_external_libs libs = let format_external_libs libs =
String_map.to_list libs String.Map.to_list libs
|> List.map ~f:(fun (name, kind) -> |> List.map ~f:(fun (name, kind) ->
match (kind : Build.lib_dep_kind) with match (kind : Build.lib_dep_kind) with
| Optional -> sprintf "- %s (optional)" name | Optional -> sprintf "- %s (optional)" name
@ -761,18 +761,18 @@ let external_lib_deps =
let targets = resolve_targets_exn ~log common setup targets in let targets = resolve_targets_exn ~log common setup targets in
let request = request_of_targets setup targets in let request = request_of_targets setup targets in
let failure = let failure =
String_map.foldi ~init:false String.Map.foldi ~init:false
(Build_system.all_lib_deps_by_context setup.build_system ~request) (Build_system.all_lib_deps_by_context setup.build_system ~request)
~f:(fun context_name lib_deps acc -> ~f:(fun context_name lib_deps acc ->
let internals = let internals =
Jbuild.Stanzas.lib_names Jbuild.Stanzas.lib_names
(match String_map.find setup.Main.stanzas context_name with (match String.Map.find setup.Main.stanzas context_name with
| None -> assert false | None -> assert false
| Some x -> x) | Some x -> x)
in in
let externals = let externals =
String_map.filteri lib_deps ~f:(fun name _ -> String.Map.filteri lib_deps ~f:(fun name _ ->
not (String_set.mem internals name)) not (String.Set.mem internals name))
in in
if only_missing then begin if only_missing then begin
let context = let context =
@ -783,12 +783,12 @@ let external_lib_deps =
| Some c -> c | Some c -> c
in in
let missing = let missing =
String_map.filteri externals ~f:(fun name _ -> String.Map.filteri externals ~f:(fun name _ ->
not (Findlib.available context.findlib name)) not (Findlib.available context.findlib name))
in in
if String_map.is_empty missing then if String.Map.is_empty missing then
acc acc
else if String_map.for_alli missing else if String.Map.for_alli missing
~f:(fun _ kind -> kind = Build.Optional) ~f:(fun _ kind -> kind = Build.Optional)
then begin then begin
Format.eprintf Format.eprintf
@ -806,13 +806,13 @@ let external_lib_deps =
Hint: try: opam install %s@." Hint: try: opam install %s@."
context_name context_name
(format_external_libs missing) (format_external_libs missing)
(String_map.to_list missing (String.Map.to_list missing
|> List.filter_map ~f:(fun (name, kind) -> |> List.filter_map ~f:(fun (name, kind) ->
match (kind : Build.lib_dep_kind) with match (kind : Build.lib_dep_kind) with
| Optional -> None | Optional -> None
| Required -> Some (Findlib.root_package_name name)) | Required -> Some (Findlib.root_package_name name))
|> String_set.of_list |> String.Set.of_list
|> String_set.to_list |> String.Set.to_list
|> String.concat ~sep:" "); |> String.concat ~sep:" ");
true true
end end

10
src/action.ml
View File

@ -852,7 +852,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
(match Path.kind path with (match Path.kind path with
| External _ -> | External _ ->
(* Internally we make sure never to do that, and [Unexpanded.*expand] check that *) (* Internally we make sure never to do that, and [Unexpanded.*expand] check that *)
Sexp.code_error Exn.code_error
"(mkdir ...) is not supported for paths outside of the workspace" "(mkdir ...) is not supported for paths outside of the workspace"
[ "mkdir", Path.sexp_of_t path ] [ "mkdir", Path.sexp_of_t path ]
| Local path -> | Local path ->
@ -890,18 +890,18 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
| Merge_files_into (sources, extras, target) -> | Merge_files_into (sources, extras, target) ->
let lines = let lines =
List.fold_left List.fold_left
~init:(String_set.of_list extras) ~init:(String.Set.of_list extras)
~f:(fun set source_path -> ~f:(fun set source_path ->
Path.to_string source_path Path.to_string source_path
|> Io.lines_of_file |> Io.lines_of_file
|> String_set.of_list |> String.Set.of_list
|> String_set.union set |> String.Set.union set
) )
sources sources
in in
Io.write_lines Io.write_lines
(Path.to_string target) (Path.to_string target)
(String_set.to_list lines); (String.Set.to_list lines);
Fiber.return () Fiber.return ()
and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to = and redirect outputs fn t ~ectx ~dir ~env ~stdout_to ~stderr_to =

8
src/artifacts.ml
View File

@ -3,14 +3,14 @@ open Jbuild
type t = type t =
{ context : Context.t { context : Context.t
; local_bins : Path.t String_map.t ; local_bins : Path.t String.Map.t
; public_libs : Lib.DB.t ; public_libs : Lib.DB.t
} }
let create (context : Context.t) ~public_libs l ~f = let create (context : Context.t) ~public_libs l ~f =
let bin_dir = Config.local_install_bin_dir ~context:context.name in let bin_dir = Config.local_install_bin_dir ~context:context.name in
let local_bins = let local_bins =
List.fold_left l ~init:String_map.empty ~f:(fun acc x -> List.fold_left l ~init:String.Map.empty ~f:(fun acc x ->
List.fold_left (f x) ~init:acc ~f:(fun local_bins stanza -> List.fold_left (f x) ~init:acc ~f:(fun local_bins stanza ->
match (stanza : Stanza.t) with match (stanza : Stanza.t) with
| Install { section = Bin; files; _ } -> | Install { section = Bin; files; _ } ->
@ -42,7 +42,7 @@ let create (context : Context.t) ~public_libs l ~f =
in in
Path.relative bin_dir fn Path.relative bin_dir fn
in in
String_map.add acc key in_bin_dir) String.Map.add acc key in_bin_dir)
| _ -> | _ ->
local_bins)) local_bins))
in in
@ -55,7 +55,7 @@ let binary t ?hint name =
if not (Filename.is_relative name) then if not (Filename.is_relative name) then
Ok (Path.absolute name) Ok (Path.absolute name)
else else
match String_map.find t.local_bins name with match String.Map.find t.local_bins name with
| Some path -> Ok path | Some path -> Ok path
| None -> | None ->
match Context.which t.context name with match Context.which t.context name with

8
src/build.ml
View File

@ -9,7 +9,7 @@ end
type lib_dep_kind = type lib_dep_kind =
| Optional | Optional
| Required | Required
type lib_deps = lib_dep_kind String_map.t type lib_deps = lib_dep_kind String.Map.t
let merge_lib_dep_kind a b = let merge_lib_dep_kind a b =
match a, b with match a, b with
@ -73,7 +73,7 @@ include Repr
let repr t = t let repr t = t
let merge_lib_deps a b = let merge_lib_deps a b =
String_map.merge a b ~f:(fun _ a b -> String.Map.merge a b ~f:(fun _ a b ->
match a, b with match a, b with
| None, None -> None | None, None -> None
| x, None | None, x -> x | x, None | None, x -> x
@ -91,9 +91,9 @@ let record_lib_deps ~kind lib_deps =
| Jbuild.Lib_dep.Direct (_, s) -> [(s, kind)] | Jbuild.Lib_dep.Direct (_, s) -> [(s, kind)]
| Select { choices; _ } -> | Select { choices; _ } ->
List.concat_map choices ~f:(fun c -> List.concat_map choices ~f:(fun c ->
String_set.to_list c.Jbuild.Lib_dep.required String.Set.to_list c.Jbuild.Lib_dep.required
|> List.map ~f:(fun d -> (d, Optional)))) |> List.map ~f:(fun d -> (d, Optional))))
|> String_map.of_list_reduce ~f:merge_lib_dep_kind) |> String.Map.of_list_reduce ~f:merge_lib_dep_kind)
module O = struct module O = struct
let ( >>> ) a b = let ( >>> ) a b =

2
src/build.mli
View File

@ -174,7 +174,7 @@ val record_lib_deps
-> Jbuild.Lib_dep.t list -> Jbuild.Lib_dep.t list
-> ('a, 'a) t -> ('a, 'a) t
type lib_deps = lib_dep_kind String_map.t type lib_deps = lib_dep_kind String.Map.t
val record_lib_deps_simple : lib_deps -> ('a, 'a) t val record_lib_deps_simple : lib_deps -> ('a, 'a) t

4
src/build_interpret.ml
View File

@ -144,7 +144,7 @@ let lib_deps =
| Memo m -> loop m.t acc | Memo m -> loop m.t acc
| Catch (t, _) -> loop t acc | Catch (t, _) -> loop t acc
in in
fun t -> loop (Build.repr t) String_map.empty fun t -> loop (Build.repr t) String.Map.empty
let targets = let targets =
let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc -> let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc ->
@ -208,7 +208,7 @@ module Rule = struct
if Path.parent path <> dir then if Path.parent path <> dir then
match loc with match loc with
| None -> | None ->
Sexp.code_error "rule has targets in different directories" Exn.code_error "rule has targets in different directories"
[ "targets", Sexp.To_sexp.list Path.sexp_of_t [ "targets", Sexp.To_sexp.list Path.sexp_of_t
(List.map targets ~f:Target.path) (List.map targets ~f:Target.path)
] ]

80
src/build_system.ml
View File

@ -315,7 +315,7 @@ module Dir_status = struct
type rules_collector = type rules_collector =
{ mutable rules : Build_interpret.Rule.t list { mutable rules : Build_interpret.Rule.t list
; mutable aliases : alias String_map.t ; mutable aliases : alias String.Map.t
; mutable stage : collection_stage ; mutable stage : collection_stage
} }
@ -328,15 +328,15 @@ end
module Files_of = struct module Files_of = struct
type t = type t =
{ files_by_ext : Path.t list String_map.t { files_by_ext : Path.t list String.Map.t
; dir_hash : string ; dir_hash : string
; mutable stamps : Path.t String_map.t ; mutable stamps : Path.t String.Map.t
} }
end end
type extra_sub_directories_to_keep = type extra_sub_directories_to_keep =
| All | All
| These of String_set.t | These of String.Set.t
type hook = type hook =
| Rule_started | Rule_started
@ -345,7 +345,7 @@ type hook =
type t = type t =
{ (* File specification by targets *) { (* File specification by targets *)
files : (Path.t, File_spec.packed) Hashtbl.t files : (Path.t, File_spec.packed) Hashtbl.t
; contexts : Context.t String_map.t ; contexts : Context.t String.Map.t
; (* Table from target to digest of ; (* Table from target to digest of
[(deps (filename + contents), targets (filename only), action)] *) [(deps (filename + contents), targets (filename only), action)] *)
trace : (Path.t, Digest.t) Hashtbl.t trace : (Path.t, Digest.t) Hashtbl.t
@ -353,7 +353,7 @@ type t =
; mutable local_mkdirs : Path.Local.Set.t ; mutable local_mkdirs : Path.Local.Set.t
; mutable dirs : (Path.t, Dir_status.t) Hashtbl.t ; mutable dirs : (Path.t, Dir_status.t) Hashtbl.t
; mutable gen_rules : ; mutable gen_rules :
(dir:Path.t -> string list -> extra_sub_directories_to_keep) String_map.t (dir:Path.t -> string list -> extra_sub_directories_to_keep) String.Map.t
; mutable load_dir_stack : Path.t list ; mutable load_dir_stack : Path.t list
; (* Set of directories under _build that have at least one rule and ; (* Set of directories under _build that have at least one rule and
all their ancestors. *) all their ancestors. *)
@ -373,7 +373,7 @@ let string_of_paths set =
|> String.concat ~sep:"\n" |> String.concat ~sep:"\n"
let set_rule_generators t generators = let set_rule_generators t generators =
assert (String_map.keys generators = String_map.keys t.contexts); assert (String.Map.keys generators = String.Map.keys t.contexts);
t.gen_rules <- generators t.gen_rules <- generators
let get_dir_status t ~dir = let get_dir_status t ~dir =
@ -393,12 +393,12 @@ let get_dir_status t ~dir =
let (ctx, sub_dir) = Option.value_exn (Path.extract_build_context dir) in let (ctx, sub_dir) = Option.value_exn (Path.extract_build_context dir) in
if ctx = ".aliases" then if ctx = ".aliases" then
Forward (Path.(append build_dir) sub_dir) Forward (Path.(append build_dir) sub_dir)
else if ctx <> "install" && not (String_map.mem t.contexts ctx) then else if ctx <> "install" && not (String.Map.mem t.contexts ctx) then
Dir_status.Loaded Pset.empty Dir_status.Loaded Pset.empty
else else
Collecting_rules Collecting_rules
{ rules = [] { rules = []
; aliases = String_map.empty ; aliases = String.Map.empty
; stage = Pending { lazy_generators = [] } ; stage = Pending { lazy_generators = [] }
} }
end) end)
@ -624,7 +624,7 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep =
match subdirs_to_keep with match subdirs_to_keep with
| All -> () | All -> ()
| These set -> | These set ->
if String_set.mem set fn || if String.Set.mem set fn ||
Pset.mem t.build_dirs_to_keep path then Pset.mem t.build_dirs_to_keep path then
() ()
else else
@ -643,13 +643,13 @@ let no_rule_found =
match Path.extract_build_context fn with match Path.extract_build_context fn with
| None -> fail fn | None -> fail fn
| Some (ctx, _) -> | Some (ctx, _) ->
if String_map.mem t.contexts ctx then if String.Map.mem t.contexts ctx then
fail fn fail fn
else else
die "Trying to build %s but build context %s doesn't exist.%s" die "Trying to build %s but build context %s doesn't exist.%s"
(Path.to_string_maybe_quoted fn) (Path.to_string_maybe_quoted fn)
ctx ctx
(hint ctx (String_map.keys t.contexts)) (hint ctx (String.Map.keys t.contexts))
let rec compile_rule t ?(copy_source=false) pre_rule = let rec compile_rule t ?(copy_source=false) pre_rule =
let { Pre_rule. let { Pre_rule.
@ -854,9 +854,9 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
(* Load all the rules *) (* Load all the rules *)
let extra_subdirs_to_keep = let extra_subdirs_to_keep =
if context_name = "install" then if context_name = "install" then
These String_set.empty These String.Set.empty
else else
let gen_rules = Option.value_exn (String_map.find t.gen_rules context_name) in let gen_rules = Option.value_exn (String.Map.find t.gen_rules context_name) in
gen_rules ~dir (Option.value_exn (Path.explode sub_dir)) gen_rules ~dir (Option.value_exn (Path.explode sub_dir))
in in
let rules = collector.rules in let rules = collector.rules in
@ -865,7 +865,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in
let alias_rules, alias_stamp_files = let alias_rules, alias_stamp_files =
let open Build.O in let open Build.O in
String_map.foldi collector.aliases ~init:([], Pset.empty) String.Map.foldi collector.aliases ~init:([], Pset.empty)
~f:(fun name { Dir_status. deps; dyn_deps; actions } (rules, alias_stamp_files) -> ~f:(fun name { Dir_status. deps; dyn_deps; actions } (rules, alias_stamp_files) ->
let base_path = Path.relative alias_dir name in let base_path = Path.relative alias_dir name in
let rules, deps = let rules, deps =
@ -922,13 +922,13 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
| "install" -> | "install" ->
(user_rule_targets, (user_rule_targets,
None, None,
String_set.empty) String.Set.empty)
| ctx_name -> | ctx_name ->
(* This condition is [true] because of [get_dir_status] *) (* This condition is [true] because of [get_dir_status] *)
assert (String_map.mem t.contexts ctx_name); assert (String.Map.mem t.contexts ctx_name);
let files, subdirs = let files, subdirs =
match File_tree.find_dir t.file_tree sub_dir with match File_tree.find_dir t.file_tree sub_dir with
| None -> (Pset.empty, String_set.empty) | None -> (Pset.empty, String.Set.empty)
| Some dir -> | Some dir ->
(File_tree.Dir.file_paths dir, (File_tree.Dir.file_paths dir,
File_tree.Dir.sub_dir_names dir) File_tree.Dir.sub_dir_names dir)
@ -946,7 +946,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
let subdirs_to_keep = let subdirs_to_keep =
match extra_subdirs_to_keep with match extra_subdirs_to_keep with
| All -> All | All -> All
| These set -> These (String_set.union subdirs_to_keep set) | These set -> These (String.Set.union subdirs_to_keep set)
in in
(* Filter out fallback rules *) (* Filter out fallback rules *)
@ -1076,20 +1076,20 @@ let stamp_file_for_files_of t ~dir ~ext =
targets_of t ~dir targets_of t ~dir
|> Path.Set.to_list |> Path.Set.to_list
|> List.map ~f:(fun fn -> Filename.extension (Path.to_string fn), fn) |> List.map ~f:(fun fn -> Filename.extension (Path.to_string fn), fn)
|> String_map.of_list_multi |> String.Map.of_list_multi
in in
{ files_by_ext { files_by_ext
; dir_hash = Path.to_string dir |> Digest.string |> Digest.to_hex ; dir_hash = Path.to_string dir |> Digest.string |> Digest.to_hex
; stamps = String_map.empty ; stamps = String.Map.empty
}) })
in in
match String_map.find files_of_dir.stamps ext with match String.Map.find files_of_dir.stamps ext with
| Some fn -> fn | Some fn -> fn
| None -> | None ->
let stamp_file = Path.relative misc_dir (files_of_dir.dir_hash ^ ext) in let stamp_file = Path.relative misc_dir (files_of_dir.dir_hash ^ ext) in
let files = let files =
Option.value Option.value
(String_map.find files_of_dir.files_by_ext ext) (String.Map.find files_of_dir.files_by_ext ext)
~default:[] ~default:[]
in in
compile_rule t compile_rule t
@ -1100,7 +1100,7 @@ let stamp_file_for_files_of t ~dir ~ext =
Build.action ~targets:[stamp_file] Build.action ~targets:[stamp_file]
(Action.with_stdout_to stamp_file (Action.with_stdout_to stamp_file
(Action.digest_files files)))); (Action.digest_files files))));
files_of_dir.stamps <- String_map.add files_of_dir.stamps ext stamp_file; files_of_dir.stamps <- String.Map.add files_of_dir.stamps ext stamp_file;
stamp_file stamp_file
module Trace = struct module Trace = struct
@ -1136,7 +1136,7 @@ module Trace = struct
end end
let all_targets t = let all_targets t =
String_map.iter t.contexts ~f:(fun ctx -> String.Map.iter t.contexts ~f:(fun ctx ->
File_tree.fold t.file_tree ~traverse_ignored_dirs:true ~init:() File_tree.fold t.file_tree ~traverse_ignored_dirs:true ~init:()
~f:(fun dir () -> ~f:(fun dir () ->
load_dir t load_dir t
@ -1155,7 +1155,7 @@ let create ~contexts ~file_tree ~hook =
Utils.Cached_digest.load (); Utils.Cached_digest.load ();
let contexts = let contexts =
List.map contexts ~f:(fun c -> (c.Context.name, c)) List.map contexts ~f:(fun c -> (c.Context.name, c))
|> String_map.of_list_exn |> String.Map.of_list_exn
in in
let t = let t =
{ contexts { contexts
@ -1166,7 +1166,7 @@ let create ~contexts ~file_tree ~hook =
; dirs = Hashtbl.create 1024 ; dirs = Hashtbl.create 1024
; load_dir_stack = [] ; load_dir_stack = []
; file_tree ; file_tree
; gen_rules = String_map.map contexts ~f:(fun _ ~dir:_ -> ; gen_rules = String.Map.map contexts ~f:(fun _ ~dir:_ ->
die "gen_rules called too early") die "gen_rules called too early")
; build_dirs_to_keep = Pset.empty ; build_dirs_to_keep = Pset.empty
; files_of = Hashtbl.create 1024 ; files_of = Hashtbl.create 1024
@ -1261,7 +1261,7 @@ let all_lib_deps t ~request =
List.fold_left (rules_for_targets t targets) ~init:Pmap.empty List.fold_left (rules_for_targets t targets) ~init:Pmap.empty
~f:(fun acc (rule : Internal_rule.t) -> ~f:(fun acc (rule : Internal_rule.t) ->
let deps = Build_interpret.lib_deps rule.build in let deps = Build_interpret.lib_deps rule.build in
if String_map.is_empty deps then if String.Map.is_empty deps then
acc acc
else else
let deps = let deps =
@ -1276,15 +1276,15 @@ let all_lib_deps_by_context t ~request =
let rules = rules_for_targets t targets in let rules = rules_for_targets t targets in
List.fold_left rules ~init:[] ~f:(fun acc (rule : Internal_rule.t) -> List.fold_left rules ~init:[] ~f:(fun acc (rule : Internal_rule.t) ->
let deps = Build_interpret.lib_deps rule.build in let deps = Build_interpret.lib_deps rule.build in
if String_map.is_empty deps then if String.Map.is_empty deps then
acc acc
else else
match Path.extract_build_context rule.dir with match Path.extract_build_context rule.dir with
| None -> acc | None -> acc
| Some (context, _) -> (context, deps) :: acc) | Some (context, _) -> (context, deps) :: acc)
|> String_map.of_list_multi |> String.Map.of_list_multi
|> String_map.map ~f:(function |> String.Map.map ~f:(function
| [] -> String_map.empty | [] -> String.Map.empty
| x :: l -> List.fold_left l ~init:x ~f:Build.merge_lib_deps) | x :: l -> List.fold_left l ~init:x ~f:Build.merge_lib_deps)
module Rule = struct module Rule = struct
@ -1443,12 +1443,12 @@ let rec add_build_dir_to_keep t ~dir =
let get_collector t ~dir = let get_collector t ~dir =
match get_dir_status t ~dir with match get_dir_status t ~dir with
| Collecting_rules collector -> | Collecting_rules collector ->
if collector.rules = [] && String_map.is_empty collector.aliases then if collector.rules = [] && String.Map.is_empty collector.aliases then
add_build_dir_to_keep t ~dir; add_build_dir_to_keep t ~dir;
collector collector
| Failed_to_load -> raise Already_reported | Failed_to_load -> raise Already_reported
| Loaded _ | Forward _ -> | Loaded _ | Forward _ ->
Sexp.code_error Exn.code_error
(if Path.is_in_source_tree dir then (if Path.is_in_source_tree dir then
"Build_system.get_collector called on source directory" "Build_system.get_collector called on source directory"
else if dir = Path.build_dir then else if dir = Path.build_dir then
@ -1477,7 +1477,7 @@ let prefix_rules t prefix ~f =
begin match Build_interpret.targets prefix with begin match Build_interpret.targets prefix with
| [] -> () | [] -> ()
| targets -> | targets ->
Sexp.code_error "Build_system.prefix_rules' prefix contains targets" Exn.code_error "Build_system.prefix_rules' prefix contains targets"
["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)] ["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)]
end; end;
let prefix = let prefix =
@ -1497,7 +1497,7 @@ let on_load_dir t ~dir ~f =
let lazy_generators = p.lazy_generators in let lazy_generators = p.lazy_generators in
if lazy_generators = [] && if lazy_generators = [] &&
collector.rules = [] && collector.rules = [] &&
String_map.is_empty collector.aliases then String.Map.is_empty collector.aliases then
add_build_dir_to_keep t ~dir; add_build_dir_to_keep t ~dir;
p.lazy_generators <- f :: lazy_generators p.lazy_generators <- f :: lazy_generators
@ -1507,8 +1507,8 @@ let eval_glob t ~dir re =
match File_tree.find_dir t.file_tree dir with match File_tree.find_dir t.file_tree dir with
| None -> targets | None -> targets
| Some d -> | Some d ->
String_set.union (String_set.of_list targets) (File_tree.Dir.files d) String.Set.union (String.Set.of_list targets) (File_tree.Dir.files d)
|> String_set.to_list |> String.Set.to_list
in in
List.filter files ~f:(Re.execp re) List.filter files ~f:(Re.execp re)
@ -1517,7 +1517,7 @@ module Alias = struct
let get_alias_def build_system t = let get_alias_def build_system t =
let collector = get_collector build_system ~dir:t.dir in let collector = get_collector build_system ~dir:t.dir in
match String_map.find collector.aliases t.name with match String.Map.find collector.aliases t.name with
| None -> | None ->
let x = let x =
{ Dir_status. { Dir_status.
@ -1526,7 +1526,7 @@ module Alias = struct
; actions = [] ; actions = []
} }
in in
collector.aliases <- String_map.add collector.aliases t.name x; collector.aliases <- String.Map.add collector.aliases t.name x;
x x
| Some x -> x | Some x -> x

6
src/build_system.mli
View File

@ -22,7 +22,7 @@ val create
type extra_sub_directories_to_keep = type extra_sub_directories_to_keep =
| All | All
| These of String_set.t | These of String.Set.t
(** Set the rule generators callback. There must be one callback per (** Set the rule generators callback. There must be one callback per
build context name. build context name.
@ -36,7 +36,7 @@ type extra_sub_directories_to_keep =
It is expected that [f] only generate rules whose targets are It is expected that [f] only generate rules whose targets are
descendant of [dir]. *) descendant of [dir]. *)
val set_rule_generators : t -> (dir:Path.t -> string list -> extra_sub_directories_to_keep) String_map.t -> unit val set_rule_generators : t -> (dir:Path.t -> string list -> extra_sub_directories_to_keep) String.Map.t -> unit
(** All other functions in this section must be called inside the rule generator (** All other functions in this section must be called inside the rule generator
callback. *) callback. *)
@ -199,7 +199,7 @@ val all_lib_deps
val all_lib_deps_by_context val all_lib_deps_by_context
: t : t
-> request:(unit, unit) Build.t -> request:(unit, unit) Build.t
-> Build.lib_deps String_map.t -> Build.lib_deps String.Map.t
(** List of all buildable targets *) (** List of all buildable targets *)
val all_targets : t -> Path.t list val all_targets : t -> Path.t list

11
src/configurator/v1.ml
View File

@ -7,7 +7,6 @@ let ( ^/ ) = Filename.concat
exception Fatal_error of string exception Fatal_error of string
module String_map = Stdune.Map.Make(Stdune.String)
module Int_map = Stdune.Map.Make(Stdune.Int) module Int_map = Stdune.Map.Make(Stdune.Int)
let die fmt = let die fmt =
@ -25,7 +24,7 @@ type t =
; c_compiler : string ; c_compiler : string
; stdlib_dir : string ; stdlib_dir : string
; ccomp_type : string ; ccomp_type : string
; ocamlc_config : string String_map.t ; ocamlc_config : string String.Map.t
; ocamlc_config_cmd : string ; ocamlc_config_cmd : string
} }
@ -166,11 +165,11 @@ let run_capture_exn t ~dir cmd =
let run_ok t ~dir cmd = (run t ~dir cmd).exit_code = 0 let run_ok t ~dir cmd = (run t ~dir cmd).exit_code = 0
let get_ocaml_config_var_exn ~ocamlc_config_cmd map var = let get_ocaml_config_var_exn ~ocamlc_config_cmd map var =
match String_map.find map var with match String.Map.find map var with
| None -> die "variable %S not found in the output of `%s`" var ocamlc_config_cmd | None -> die "variable %S not found in the output of `%s`" var ocamlc_config_cmd
| Some s -> s | Some s -> s
let ocaml_config_var t var = String_map.find t.ocamlc_config var let ocaml_config_var t var = String.Map.find t.ocamlc_config var
let ocaml_config_var_exn t var = let ocaml_config_var_exn t var =
get_ocaml_config_var_exn t.ocamlc_config var get_ocaml_config_var_exn t.ocamlc_config var
~ocamlc_config_cmd:t.ocamlc_config_cmd ~ocamlc_config_cmd:t.ocamlc_config_cmd
@ -197,7 +196,7 @@ let create ?dest_dir ?ocamlc ?(log=ignore) name =
; c_compiler = "" ; c_compiler = ""
; stdlib_dir = "" ; stdlib_dir = ""
; ccomp_type = "" ; ccomp_type = ""
; ocamlc_config = String_map.empty ; ocamlc_config = String.Map.empty
; ocamlc_config_cmd ; ocamlc_config_cmd
} }
in in
@ -215,7 +214,7 @@ let create ?dest_dir ?ocamlc ?(log=ignore) name =
in in
let get = get_ocaml_config_var_exn ocamlc_config ~ocamlc_config_cmd in let get = get_ocaml_config_var_exn ocamlc_config ~ocamlc_config_cmd in
let c_compiler = let c_compiler =
match String_map.find ocamlc_config "c_compiler" with match String.Map.find ocamlc_config "c_compiler" with
| Some c_comp -> c_comp ^ " " ^ get "ocamlc_cflags" | Some c_comp -> c_comp ^ " " ^ get "ocamlc_cflags"
| None -> get "bytecomp_c_compiler" | None -> get "bytecomp_c_compiler"
in in

2
src/env.ml
View File

@ -41,7 +41,7 @@ let of_unix arr =
|> List.map ~f:(fun s -> |> List.map ~f:(fun s ->
match String.lsplit2 s ~on:'=' with match String.lsplit2 s ~on:'=' with
| None -> | None ->
Sexp.code_error "Env.of_unix: entry without '=' found in the environ" Exn.code_error "Env.of_unix: entry without '=' found in the environ"
["var", Sexp.To_sexp.string s] ["var", Sexp.To_sexp.string s]
| Some (k, v) -> (k, v)) | Some (k, v) -> (k, v))
|> Map.of_list_multi |> Map.of_list_multi

3
src/errors.ml
View File

@ -1,5 +1,4 @@
exception Fatal_error of string exception Fatal_error of string
exception Code_error of string
exception Already_reported exception Already_reported
let err_buf = Buffer.create 128 let err_buf = Buffer.create 128
@ -14,7 +13,7 @@ let kerrf fmt ~f =
err_ppf fmt err_ppf fmt
let code_errorf fmt = let code_errorf fmt =
kerrf fmt ~f:(fun s -> raise (Code_error s)) kerrf fmt ~f:(fun s -> Stdune.Exn.code_error s [])
let die fmt = let die fmt =
kerrf fmt ~f:(fun s -> raise (Fatal_error s)) kerrf fmt ~f:(fun s -> raise (Fatal_error s))

5
src/errors.mli
View File

@ -12,11 +12,6 @@
(** A fatal error, that should be reported to the user in a nice way *) (** A fatal error, that should be reported to the user in a nice way *)
exception Fatal_error of string exception Fatal_error of string
(* CR-soon diml: replace the [string] argument by [Usexp.t] *)
(** An programming error in the code of jbuilder, that should be reported upstream. The
error message shouldn't try to be developper friendly rather than user friendly. *)
exception Code_error of string
(* CR-soon diml: we won't need this once we can generate rules dynamically *) (* CR-soon diml: we won't need this once we can generate rules dynamically *)
(** Raised for errors that have already been reported to the user and shouldn't be (** Raised for errors that have already been reported to the user and shouldn't be
reported again. This might happen when trying to build a dependency that has already reported again. This might happen when trying to build a dependency that has already

28
src/file_tree.ml
View File

@ -3,8 +3,8 @@ open! Import
module Dir = struct module Dir = struct
type t = type t =
{ path : Path.t { path : Path.t
; files : String_set.t ; files : String.Set.t
; sub_dirs : t String_map.t ; sub_dirs : t String.Map.t
; ignored : bool ; ignored : bool
} }
@ -17,11 +17,11 @@ module Dir = struct
Path.Set.of_string_set t.files ~f:(Path.relative t.path) Path.Set.of_string_set t.files ~f:(Path.relative t.path)
let sub_dir_names t = let sub_dir_names t =
String_map.foldi t.sub_dirs ~init:String_set.empty String.Map.foldi t.sub_dirs ~init:String.Set.empty
~f:(fun s _ acc -> String_set.add acc s) ~f:(fun s _ acc -> String.Set.add acc s)
let sub_dir_paths t = let sub_dir_paths t =
String_map.foldi t.sub_dirs ~init:Path.Set.empty String.Map.foldi t.sub_dirs ~init:Path.Set.empty
~f:(fun s _ acc -> Path.Set.add acc (Path.relative t.path s)) ~f:(fun s _ acc -> Path.Set.add acc (Path.relative t.path s))
let rec fold t ~traverse_ignored_dirs ~init:acc ~f = let rec fold t ~traverse_ignored_dirs ~init:acc ~f =
@ -29,7 +29,7 @@ module Dir = struct
acc acc
else else
let acc = f t acc in let acc = f t acc in
String_map.fold t.sub_dirs ~init:acc ~f:(fun t acc -> String.Map.fold t.sub_dirs ~init:acc ~f:(fun t acc ->
fold t ~traverse_ignored_dirs ~init:acc ~f) fold t ~traverse_ignored_dirs ~init:acc ~f)
end end
@ -59,9 +59,9 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
else else
Left fn) Left fn)
in in
let files = String_set.of_list files in let files = String.Set.of_list files in
let ignored_sub_dirs = let ignored_sub_dirs =
if not ignored && String_set.mem files "jbuild-ignore" then if not ignored && String.Set.mem files "jbuild-ignore" then
let ignore_file = Path.to_string (Path.relative path "jbuild-ignore") in let ignore_file = Path.to_string (Path.relative path "jbuild-ignore") in
let files = let files =
Io.lines_of_file ignore_file Io.lines_of_file ignore_file
@ -75,19 +75,19 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
false false
end end
in in
String_set.of_list (List.filteri ~f:remove_subdirs files) String.Set.of_list (List.filteri ~f:remove_subdirs files)
else else
String_set.empty String.Set.empty
in in
let sub_dirs = let sub_dirs =
List.map sub_dirs ~f:(fun (fn, path) -> List.map sub_dirs ~f:(fun (fn, path) ->
let ignored = let ignored =
ignored ignored
|| String_set.mem ignored_sub_dirs fn || String.Set.mem ignored_sub_dirs fn
|| Path.Set.mem extra_ignored_subtrees path || Path.Set.mem extra_ignored_subtrees path
in in
(fn, walk path ~ignored)) (fn, walk path ~ignored))
|> String_map.of_list_exn |> String.Map.of_list_exn
in in
{ path { path
; files ; files
@ -119,7 +119,7 @@ let files_of t path =
let file_exists t path fn = let file_exists t path fn =
match Path.Map.find t.dirs path with match Path.Map.find t.dirs path with
| None -> false | None -> false
| Some { files; _ } -> String_set.mem files fn | Some { files; _ } -> String.Set.mem files fn
let exists t path = let exists t path =
Path.Map.mem t.dirs path || Path.Map.mem t.dirs path ||
@ -132,5 +132,5 @@ let files_recursively_in t ?(prefix_with=Path.root) path =
Dir.fold dir ~init:Path.Set.empty ~traverse_ignored_dirs:true Dir.fold dir ~init:Path.Set.empty ~traverse_ignored_dirs:true
~f:(fun dir acc -> ~f:(fun dir acc ->
let path = Path.append prefix_with (Dir.path dir) in let path = Path.append prefix_with (Dir.path dir) in
String_set.fold (Dir.files dir) ~init:acc ~f:(fun fn acc -> String.Set.fold (Dir.files dir) ~init:acc ~f:(fun fn acc ->
Path.Set.add acc (Path.relative path fn))) Path.Set.add acc (Path.relative path fn)))

6
src/file_tree.mli
View File

@ -4,11 +4,11 @@ module Dir : sig
type t type t
val path : t -> Path.t val path : t -> Path.t
val files : t -> String_set.t val files : t -> String.Set.t
val file_paths : t -> Path.Set.t val file_paths : t -> Path.Set.t
val sub_dirs : t -> t String_map.t val sub_dirs : t -> t String.Map.t
val sub_dir_paths : t -> Path.Set.t val sub_dir_paths : t -> Path.Set.t
val sub_dir_names : t -> String_set.t val sub_dir_names : t -> String.Set.t
(** Whether this directory is ignored by a [jbuild-ignore] file in (** Whether this directory is ignored by a [jbuild-ignore] file in
one of its ancestor directories. *) one of its ancestor directories. *)

24
src/findlib.ml
View File

@ -74,10 +74,10 @@ module Rules = struct
end end
module Vars = struct module Vars = struct
type t = Rules.t String_map.t type t = Rules.t String.Map.t
let get (t : t) var preds = let get (t : t) var preds =
match String_map.find t var with match String.Map.find t var with
| None -> None | None -> None
| Some rules -> Some (Rules.interpret rules ~preds) | Some rules -> Some (Rules.interpret rules ~preds)
@ -100,7 +100,7 @@ module Config = struct
die "@{<error>Error@}: ocamlfind toolchain %s isn't defined in %a \ die "@{<error>Error@}: ocamlfind toolchain %s isn't defined in %a \
(context: %s)" toolchain Path.pp path context; (context: %s)" toolchain Path.pp path context;
let vars = (Meta.load ~name:"" ~fn:(Path.to_string conf_file)).vars in let vars = (Meta.load ~name:"" ~fn:(Path.to_string conf_file)).vars in
{ vars = String_map.map vars ~f:Rules.of_meta_rules { vars = String.Map.map vars ~f:Rules.of_meta_rules
; preds = Ps.make [toolchain] ; preds = Ps.make [toolchain]
} }
@ -163,7 +163,7 @@ end
type t = type t =
{ stdlib_dir : Path.t { stdlib_dir : Path.t
; path : Path.t list ; path : Path.t list
; builtins : Meta.Simplified.t String_map.t ; builtins : Meta.Simplified.t String.Map.t
; packages : (string, (Package.t, Unavailable_reason.t) result) Hashtbl.t ; packages : (string, (Package.t, Unavailable_reason.t) result) Hashtbl.t
} }
@ -184,7 +184,7 @@ let dummy_package t ~name =
meta_file = Path.relative dir "META" meta_file = Path.relative dir "META"
; name = name ; name = name
; dir = dir ; dir = dir
; vars = String_map.empty ; vars = String.Map.empty
} }
(* Parse a single package from a META file *) (* Parse a single package from a META file *)
@ -217,7 +217,7 @@ let parse_package t ~meta_file ~name ~parent_dir ~vars =
List.for_all exists_if ~f:(fun fn -> List.for_all exists_if ~f:(fun fn ->
Path.exists (Path.relative dir fn)) Path.exists (Path.relative dir fn))
| [] -> | [] ->
if not (String_map.mem t.builtins (root_package_name name)) then if not (String.Map.mem t.builtins (root_package_name name)) then
true true
else else
(* The META files for installed packages are sometimes broken, (* The META files for installed packages are sometimes broken,
@ -244,7 +244,7 @@ let parse_package t ~meta_file ~name ~parent_dir ~vars =
[t.packages] *) [t.packages] *)
let parse_and_acknowledge_meta t ~dir ~meta_file (meta : Meta.Simplified.t) = let parse_and_acknowledge_meta t ~dir ~meta_file (meta : Meta.Simplified.t) =
let rec loop ~dir ~full_name (meta : Meta.Simplified.t) = let rec loop ~dir ~full_name (meta : Meta.Simplified.t) =
let vars = String_map.map meta.vars ~f:Rules.of_meta_rules in let vars = String.Map.map meta.vars ~f:Rules.of_meta_rules in
let dir, res = let dir, res =
parse_package t ~meta_file ~name:full_name ~parent_dir:dir ~vars parse_package t ~meta_file ~name:full_name ~parent_dir:dir ~vars
in in
@ -277,7 +277,7 @@ let find_and_acknowledge_meta t ~fq_name =
else else
loop dirs loop dirs
| [] -> | [] ->
match String_map.find t.builtins root_name with match String.Map.find t.builtins root_name with
| Some meta -> Some (t.stdlib_dir, Path.of_string "<internal>", meta) | Some meta -> Some (t.stdlib_dir, Path.of_string "<internal>", meta)
| None -> None | None -> None
in in
@ -311,13 +311,13 @@ let root_packages t =
|> Array.to_list |> Array.to_list
|> List.filter ~f:(fun name -> |> List.filter ~f:(fun name ->
Path.exists (Path.relative dir (name ^ "/META")))) Path.exists (Path.relative dir (name ^ "/META"))))
|> String_set.of_list |> String.Set.of_list
in in
let pkgs = let pkgs =
String_set.union pkgs String.Set.union pkgs
(String_set.of_list (String_map.keys t.builtins)) (String.Set.of_list (String.Map.keys t.builtins))
in in
String_set.to_list pkgs String.Set.to_list pkgs
let load_all_packages t = let load_all_packages t =
List.iter (root_packages t) ~f:(fun pkg -> List.iter (root_packages t) ~f:(fun pkg ->

8
src/gen_meta.ml
View File

@ -31,7 +31,7 @@ module Pub_name = struct
let to_string t = String.concat ~sep:"." (to_list t) let to_string t = String.concat ~sep:"." (to_list t)
end end
let string_of_deps deps = String_set.to_list deps |> String.concat ~sep:" " let string_of_deps deps = String.Set.to_list deps |> String.concat ~sep:" "
let rule var predicates action value = let rule var predicates action value =
Rule { var; predicates; action; value } Rule { var; predicates; action; value }
@ -81,7 +81,7 @@ let gen_lib pub_name lib ~version =
; requires ~preds lib_deps ; requires ~preds lib_deps
] ]
; archives ~preds lib ; archives ~preds lib
; if String_set.is_empty ppx_rt_deps then ; if String.Set.is_empty ppx_rt_deps then
[] []
else else
[ Comment "This is what jbuilder uses to find out the runtime \ [ Comment "This is what jbuilder uses to find out the runtime \
@ -154,8 +154,8 @@ let gen ~package ~version libs =
in in
let entries = List.concat entries in let entries = List.concat entries in
let subs = let subs =
String_map.of_list_multi sub_pkgs String.Map.of_list_multi sub_pkgs
|> String_map.to_list |> String.Map.to_list
|> List.map ~f:(fun (name, pkgs) -> |> List.map ~f:(fun (name, pkgs) ->
let pkg = loop name pkgs in let pkg = loop name pkgs in
Package { pkg with Package { pkg with

32
src/gen_rules.ml
View File

@ -152,7 +152,7 @@ module Gen(P : Install_rules.Params) = struct
modules modules
end end
let parse_mlds ~dir ~(all_mlds : string String_map.t) ~mlds_written_by_user = let parse_mlds ~dir ~(all_mlds : string String.Map.t) ~mlds_written_by_user =
if Ordered_set_lang.is_standard mlds_written_by_user then if Ordered_set_lang.is_standard mlds_written_by_user then
all_mlds all_mlds
else else
@ -160,7 +160,7 @@ module Gen(P : Install_rules.Params) = struct
Ordered_set_lang.String.eval_unordered Ordered_set_lang.String.eval_unordered
mlds_written_by_user mlds_written_by_user
~parse:(fun ~loc s -> ~parse:(fun ~loc s ->
match String_map.find all_mlds s with match String.Map.find all_mlds s with
| Some s -> | Some s ->
s s
| None -> | None ->
@ -245,7 +245,7 @@ module Gen(P : Install_rules.Params) = struct
fun ~dir -> fun ~dir ->
Hashtbl.find_or_add cache dir ~f:(fun dir -> Hashtbl.find_or_add cache dir ~f:(fun dir ->
match Path.Map.find stanzas_per_dir dir with match Path.Map.find stanzas_per_dir dir with
| None -> String_set.empty | None -> String.Set.empty
| Some { stanzas; src_dir; scope; _ } -> | Some { stanzas; src_dir; scope; _ } ->
(* Interpret a few stanzas in order to determine the list of (* Interpret a few stanzas in order to determine the list of
files generated by the user. *) files generated by the user. *)
@ -268,9 +268,9 @@ module Gen(P : Install_rules.Params) = struct
| Direct _ -> None | Direct _ -> None
| Select s -> Some s.result_fn) | Select s -> Some s.result_fn)
| Documentation _ | Alias _ | Provides _ | Install _ -> []) | Documentation _ | Alias _ | Provides _ | Install _ -> [])
|> String_set.of_list |> String.Set.of_list
in in
String_set.union generated_files String.Set.union generated_files
(SC.source_files sctx ~src_path:src_dir)) (SC.source_files sctx ~src_path:src_dir))
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
@ -279,7 +279,7 @@ module Gen(P : Install_rules.Params) = struct
let guess_modules ~dir ~files = let guess_modules ~dir ~files =
let impl_files, intf_files = let impl_files, intf_files =
String_set.to_list files String.Set.to_list files
|> List.filter_partition_map ~f:(fun fn -> |> List.filter_partition_map ~f:(fun fn ->
(* we aren't using Filename.extension because we want to handle (* we aren't using Filename.extension because we want to handle
filenames such as foo.cppo.ml *) filenames such as foo.cppo.ml *)
@ -314,12 +314,12 @@ module Gen(P : Install_rules.Params) = struct
) )
let guess_mlds ~files = let guess_mlds ~files =
String_set.to_list files String.Set.to_list files
|> List.filter_map ~f:(fun fn -> |> List.filter_map ~f:(fun fn ->
match String.lsplit2 fn ~on:'.' with match String.lsplit2 fn ~on:'.' with
| Some (s, "mld") -> Some (s, fn) | Some (s, "mld") -> Some (s, fn)
| _ -> None) | _ -> None)
|> String_map.of_list_exn |> String.Map.of_list_exn
let mlds_by_dir = let mlds_by_dir =
let cache = Hashtbl.create 32 in let cache = Hashtbl.create 32 in
@ -332,7 +332,7 @@ module Gen(P : Install_rules.Params) = struct
parse_mlds ~dir parse_mlds ~dir
~all_mlds:(mlds_by_dir ~dir) ~all_mlds:(mlds_by_dir ~dir)
~mlds_written_by_user:doc.mld_files ~mlds_written_by_user:doc.mld_files
|> String_map.values |> String.Map.values
|> List.map ~f:(Path.relative dir) |> List.map ~f:(Path.relative dir)
let modules_by_dir = let modules_by_dir =
@ -620,7 +620,7 @@ module Gen(P : Install_rules.Params) = struct
if Library.has_stubs lib then begin if Library.has_stubs lib then begin
let h_files = let h_files =
String_set.to_list files String.Set.to_list files
|> List.filter_map ~f:(fun fn -> |> List.filter_map ~f:(fun fn ->
if String.is_suffix fn ~suffix:".h" then if String.is_suffix fn ~suffix:".h" then
Some (Path.relative dir fn) Some (Path.relative dir fn)
@ -998,9 +998,9 @@ module Gen(P : Install_rules.Params) = struct
(Path.drop_build_context_exn dir)) then (Path.drop_build_context_exn dir)) then
SC.load_dir sctx ~dir:(Path.parent dir)); SC.load_dir sctx ~dir:(Path.parent dir));
match components with match components with
| [] -> These (String_set.of_list [".js"; "_doc"; ".ppx"]) | [] -> These (String.Set.of_list [".js"; "_doc"; ".ppx"])
| [(".js"|"_doc"|".ppx")] -> All | [(".js"|"_doc"|".ppx")] -> All
| _ -> These String_set.empty | _ -> These String.Set.empty
let init () = let init () =
let module Install_rules = let module Install_rules =
@ -1086,8 +1086,8 @@ let gen ~contexts ~build_system
(context.name, ((module M : Gen), stanzas)) (context.name, ((module M : Gen), stanzas))
in in
Fiber.parallel_map contexts ~f:make_sctx >>| fun l -> Fiber.parallel_map contexts ~f:make_sctx >>| fun l ->
let map = String_map.of_list_exn l in let map = String.Map.of_list_exn l in
Build_system.set_rule_generators build_system Build_system.set_rule_generators build_system
(String_map.map map ~f:(fun ((module M : Gen), _) -> M.gen_rules)); (String.Map.map map ~f:(fun ((module M : Gen), _) -> M.gen_rules));
String_map.iter map ~f:(fun ((module M : Gen), _) -> M.init ()); String.Map.iter map ~f:(fun ((module M : Gen), _) -> M.init ());
String_map.map map ~f:snd String.Map.map map ~f:snd

2
src/gen_rules.mli
View File

@ -8,4 +8,4 @@ val gen
-> ?external_lib_deps_mode:bool (* default: false *) -> ?external_lib_deps_mode:bool (* default: false *)
-> ?only_packages:Package.Name.Set.t -> ?only_packages:Package.Name.Set.t
-> Jbuild_load.conf -> Jbuild_load.conf
-> (Path.t * Scope_info.t * Stanzas.t) list String_map.t Fiber.t -> (Path.t * Scope_info.t * Stanzas.t) list String.Map.t Fiber.t

3
src/import.ml
View File

@ -10,9 +10,8 @@ let ksprintf = Printf.ksprintf
let initial_cwd = Sys.getcwd () let initial_cwd = Sys.getcwd ()
module String_set = Set.Make(String)
module String_map = struct module String_map = struct
include Map.Make(String) include String.Map
let pp f fmt t = let pp f fmt t =
Format.pp_print_list (fun fmt (k, v) -> Format.pp_print_list (fun fmt (k, v) ->

4
src/inline_tests.ml
View File

@ -190,7 +190,7 @@ include Sub_system.Register_end_point(
in in
let extra_vars = let extra_vars =
String_map.singleton "library-name" String.Map.singleton "library-name"
(Action.Var_expansion.Strings ([lib.name], Concat)) (Action.Var_expansion.Strings ([lib.name], Concat))
in in
@ -224,7 +224,7 @@ include Sub_system.Register_end_point(
; "intf-files", files Intf ; "intf-files", files Intf
] ]
~init:extra_vars ~init:extra_vars
~f:(fun acc (k, v) -> String_map.add acc k v) ~f:(fun acc (k, v) -> String.Map.add acc k v)
in in
Build.return [] Build.return []
>>> >>>

2
src/install_rules.ml
View File

@ -219,7 +219,7 @@ module Gen(P : Install_params) = struct
let install_file package_path package entries = let install_file package_path package entries =
let entries = let entries =
let files = SC.source_files sctx ~src_path:Path.root in let files = SC.source_files sctx ~src_path:Path.root in
String_set.fold files ~init:entries ~f:(fun fn acc -> String.Set.fold files ~init:entries ~f:(fun fn acc ->
if is_odig_doc_file fn then if is_odig_doc_file fn then
Install.Entry.make Doc (Path.relative ctx.build_dir fn) :: acc Install.Entry.make Doc (Path.relative ctx.build_dir fn) :: acc
else else

44
src/jbuild.ml
View File

@ -36,7 +36,7 @@ let module_name sexp =
| _ -> invalid_module_name name sexp); | _ -> invalid_module_name name sexp);
String.capitalize s String.capitalize s
let module_names sexp = String_set.of_list (list module_name sexp) let module_names sexp = String.Set.of_list (list module_name sexp)
let invalid_lib_name sexp = let invalid_lib_name sexp =
of_sexp_error sexp "invalid library name" of_sexp_error sexp "invalid library name"
@ -304,7 +304,7 @@ module Per_module = struct
| List (_, Atom (_, A "per_module") :: rest) -> begin | List (_, Atom (_, A "per_module") :: rest) -> begin
List.map rest ~f:(fun sexp -> List.map rest ~f:(fun sexp ->
let pp, names = pair a module_names sexp in let pp, names = pair a module_names sexp in
(List.map ~f:Module.Name.of_string (String_set.to_list names), pp)) (List.map ~f:Module.Name.of_string (String.Set.to_list names), pp))
|> of_mapping ~default |> of_mapping ~default
|> function |> function
| Ok t -> t | Ok t -> t
@ -367,8 +367,8 @@ end
module Lib_dep = struct module Lib_dep = struct
type choice = type choice =
{ required : String_set.t { required : String.Set.t
; forbidden : String_set.t ; forbidden : String.Set.t
; file : string ; file : string
} }
@ -386,8 +386,8 @@ module Lib_dep = struct
| List (_, l) as sexp -> | List (_, l) as sexp ->
let rec loop required forbidden = function let rec loop required forbidden = function
| [Atom (_, A "->"); fsexp] -> | [Atom (_, A "->"); fsexp] ->
let common = String_set.inter required forbidden in let common = String.Set.inter required forbidden in
Option.iter (String_set.choose common) ~f:(fun name -> Option.iter (String.Set.choose common) ~f:(fun name ->
of_sexp_errorf sexp of_sexp_errorf sexp
"library %S is both required and forbidden in this clause" "library %S is both required and forbidden in this clause"
name); name);
@ -402,11 +402,11 @@ module Lib_dep = struct
let len = String.length s in let len = String.length s in
if len > 0 && s.[0] = '!' then if len > 0 && s.[0] = '!' then
let s = String.sub s ~pos:1 ~len:(len - 1) in let s = String.sub s ~pos:1 ~len:(len - 1) in
loop required (String_set.add forbidden s) l loop required (String.Set.add forbidden s) l
else else
loop (String_set.add required s) forbidden l loop (String.Set.add required s) forbidden l
in in
loop String_set.empty String_set.empty l loop String.Set.empty String.Set.empty l
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected" | sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
let t = function let t = function
@ -423,9 +423,9 @@ module Lib_dep = struct
let to_lib_names = function let to_lib_names = function
| Direct (_, s) -> [s] | Direct (_, s) -> [s]
| Select s -> | Select s ->
List.fold_left s.choices ~init:String_set.empty ~f:(fun acc x -> List.fold_left s.choices ~init:String.Set.empty ~f:(fun acc x ->
String_set.union acc (String_set.union x.required x.forbidden)) String.Set.union acc (String.Set.union x.required x.forbidden))
|> String_set.to_list |> String.Set.to_list
let direct x = Direct x let direct x = Direct x
@ -443,8 +443,8 @@ module Lib_deps = struct
let t sexp = let t sexp =
let t = list Lib_dep.t sexp in let t = list Lib_dep.t sexp in
let add kind name acc = let add kind name acc =
match String_map.find acc name with match String.Map.find acc name with
| None -> String_map.add acc name kind | None -> String.Map.add acc name kind
| Some kind' -> | Some kind' ->
match kind, kind' with match kind, kind' with
| Required, Required -> | Required, Required ->
@ -461,14 +461,14 @@ module Lib_deps = struct
name name
in in
ignore ( ignore (
List.fold_left t ~init:String_map.empty ~f:(fun acc x -> List.fold_left t ~init:String.Map.empty ~f:(fun acc x ->
match x with match x with
| Lib_dep.Direct (_, s) -> add Required s acc | Lib_dep.Direct (_, s) -> add Required s acc
| Select { choices; _ } -> | Select { choices; _ } ->
List.fold_left choices ~init:acc ~f:(fun acc c -> List.fold_left choices ~init:acc ~f:(fun acc c ->
let acc = String_set.fold c.Lib_dep.required ~init:acc ~f:(add Optional) in let acc = String.Set.fold c.Lib_dep.required ~init:acc ~f:(add Optional) in
String_set.fold c.forbidden ~init:acc ~f:(add Forbidden))) String.Set.fold c.forbidden ~init:acc ~f:(add Forbidden)))
: kind String_map.t); : kind String.Map.t);
t t
let of_pps pps = let of_pps pps =
@ -596,7 +596,7 @@ module Sub_system_info = struct
let () = let () =
match Sub_system_name.Table.get all name with match Sub_system_name.Table.get all name with
| Some _ -> | Some _ ->
Sexp.code_error "Sub_system_info.register: already registered" Exn.code_error "Sub_system_info.register: already registered"
[ "name", Sexp.To_sexp.string (Sub_system_name.to_string name) ]; [ "name", Sexp.To_sexp.string (Sub_system_name.to_string name) ];
| None -> | None ->
Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S)); Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S));
@ -1298,14 +1298,14 @@ module Stanzas = struct
(line_loc x)))) (line_loc x))))
let lib_names ts = let lib_names ts =
List.fold_left ts ~init:String_set.empty ~f:(fun acc (_, _, stanzas) -> List.fold_left ts ~init:String.Set.empty ~f:(fun acc (_, _, stanzas) ->
List.fold_left stanzas ~init:acc ~f:(fun acc -> function List.fold_left stanzas ~init:acc ~f:(fun acc -> function
| Stanza.Library lib -> | Stanza.Library lib ->
let acc = let acc =
match lib.public with match lib.public with
| None -> acc | None -> acc
| Some { name; _ } -> String_set.add acc name | Some { name; _ } -> String.Set.add acc name
in in
String_set.add acc lib.name String.Set.add acc lib.name
| _ -> acc)) | _ -> acc))
end end

6
src/jbuild.mli
View File

@ -95,8 +95,8 @@ end
module Lib_dep : sig module Lib_dep : sig
type choice = type choice =
{ required : String_set.t { required : String.Set.t
; forbidden : String_set.t ; forbidden : String.Set.t
; file : string ; file : string
} }
@ -392,5 +392,5 @@ module Stanzas : sig
-> Scope_info.t -> Scope_info.t
-> Sexp.Ast.t list -> Sexp.Ast.t list
-> t -> t
val lib_names : (_ * _ * t) list -> String_set.t val lib_names : (_ * _ * t) list -> String.Set.t
end end

6
src/jbuild_load.ml
View File

@ -187,7 +187,7 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs -> File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs ->
let path = File_tree.Dir.path dir in let path = File_tree.Dir.path dir in
let files = File_tree.Dir.files dir in let files = File_tree.Dir.files dir in
String_set.fold files ~init:pkgs ~f:(fun fn acc -> String.Set.fold files ~init:pkgs ~f:(fun fn acc ->
match Filename.split_extension fn with match Filename.split_extension fn with
| (pkg, ".opam") when pkg <> "" -> | (pkg, ".opam") when pkg <> "" ->
let version_from_opam_file = let version_from_opam_file =
@ -237,13 +237,13 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
let sub_dirs = File_tree.Dir.sub_dirs dir in let sub_dirs = File_tree.Dir.sub_dirs dir in
let scope = Option.value (Path.Map.find scopes path) ~default:scope in let scope = Option.value (Path.Map.find scopes path) ~default:scope in
let jbuilds = let jbuilds =
if String_set.mem files "jbuild" then if String.Set.mem files "jbuild" then
let jbuild = load ~dir:path ~scope ~ignore_promoted_rules in let jbuild = load ~dir:path ~scope ~ignore_promoted_rules in
jbuild :: jbuilds jbuild :: jbuilds
else else
jbuilds jbuilds
in in
String_map.fold sub_dirs ~init:jbuilds String.Map.fold sub_dirs ~init:jbuilds
~f:(fun dir jbuilds -> walk dir jbuilds scope) ~f:(fun dir jbuilds -> walk dir jbuilds scope)
end end
in in

24
src/lib.ml
View File

@ -600,7 +600,7 @@ let already_in_table (info : Info.t) name x =
List [Sexp.unsafe_atom_of_string "Hidden"; List [Sexp.unsafe_atom_of_string "Hidden";
Path.sexp_of_t path; Sexp.atom reason] Path.sexp_of_t path; Sexp.atom reason]
in in
Sexp.code_error Exn.code_error
"Lib_db.DB: resolver returned name that's already in the table" "Lib_db.DB: resolver returned name that's already in the table"
[ "name" , Sexp.atom name [ "name" , Sexp.atom name
; "returned_lib" , to_sexp (info.src_dir, name) ; "returned_lib" , to_sexp (info.src_dir, name)
@ -768,13 +768,13 @@ and resolve_complex_deps db deps ~allow_private_deps ~stack =
let res, src_fn = let res, src_fn =
match match
List.find_map choices ~f:(fun { required; forbidden; file } -> List.find_map choices ~f:(fun { required; forbidden; file } ->
if String_set.exists forbidden if String.Set.exists forbidden
~f:(available_internal db ~stack) then ~f:(available_internal db ~stack) then
None None
else else
match match
let deps = let deps =
String_set.fold required ~init:[] ~f:(fun x acc -> String.Set.fold required ~init:[] ~f:(fun x acc ->
(Loc.none, x) :: acc) (Loc.none, x) :: acc)
in in
resolve_simple_deps ~allow_private_deps db deps ~stack resolve_simple_deps ~allow_private_deps db deps ~stack
@ -852,11 +852,11 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
(deps, pps, resolved_selects) (deps, pps, resolved_selects)
and closure_with_overlap_checks db ts ~stack = and closure_with_overlap_checks db ts ~stack =
let visited = ref String_map.empty in let visited = ref String.Map.empty in
let res = ref [] in let res = ref [] in
let orig_stack = stack in let orig_stack = stack in
let rec loop t ~stack = let rec loop t ~stack =
match String_map.find !visited t.name with match String.Map.find !visited t.name with
| Some (t', stack') -> | Some (t', stack') ->
if t.unique_id = t'.unique_id then if t.unique_id = t'.unique_id then
Ok () Ok ()
@ -867,7 +867,7 @@ and closure_with_overlap_checks db ts ~stack =
; lib2 = (t , req_by stack ) ; lib2 = (t , req_by stack )
})) }))
| None -> | None ->
visited := String_map.add !visited t.name (t, stack); visited := String.Map.add !visited t.name (t, stack);
(match db with (match db with
| None -> Ok () | None -> Ok ()
| Some db -> | Some db ->
@ -984,7 +984,7 @@ module DB = struct
[ p.name , Found info [ p.name , Found info
; conf.name, Redirect (None, p.name) ; conf.name, Redirect (None, p.name)
]) ])
|> String_map.of_list |> String.Map.of_list
|> function |> function
| Ok x -> x | Ok x -> x
| Error (name, _, _) -> | Error (name, _, _) ->
@ -1008,10 +1008,10 @@ module DB = struct
in in
create () ?parent create () ?parent
~resolve:(fun name -> ~resolve:(fun name ->
match String_map.find map name with match String.Map.find map name with
| None -> Not_found | None -> Not_found
| Some x -> x) | Some x -> x)
~all:(fun () -> String_map.keys map) ~all:(fun () -> String.Map.keys map)
let create_from_findlib ?(external_lib_deps_mode=false) findlib = let create_from_findlib ?(external_lib_deps_mode=false) findlib =
create () create ()
@ -1061,7 +1061,7 @@ module DB = struct
let get_compile_info t ?(allow_overlaps=false) name = let get_compile_info t ?(allow_overlaps=false) name =
match find_even_when_hidden t name with match find_even_when_hidden t name with
| None -> | None ->
Sexp.code_error "Lib.DB.get_compile_info got library that doesn't exist" Exn.code_error "Lib.DB.get_compile_info got library that doesn't exist"
[ "name", Sexp.To_sexp.string name ] [ "name", Sexp.To_sexp.string name ]
| Some lib -> | Some lib ->
let t = Option.some_if (not allow_overlaps) t in let t = Option.some_if (not allow_overlaps) t in
@ -1110,8 +1110,8 @@ end
module Meta = struct module Meta = struct
let to_names ts = let to_names ts =
List.fold_left ts ~init:String_set.empty ~f:(fun acc t -> List.fold_left ts ~init:String.Set.empty ~f:(fun acc t ->
String_set.add acc t.name) String.Set.add acc t.name)
(* For the deprecated method, we need to put all the runtime (* For the deprecated method, we need to put all the runtime
dependencies of the transitive closure. dependencies of the transitive closure.

6
src/lib.mli
View File

@ -336,7 +336,7 @@ end with type lib := t
(** {1 Dependencies for META files} *) (** {1 Dependencies for META files} *)
module Meta : sig module Meta : sig
val requires : t -> String_set.t val requires : t -> String.Set.t
val ppx_runtime_deps : t -> String_set.t val ppx_runtime_deps : t -> String.Set.t
val ppx_runtime_deps_for_deprecated_method : t -> String_set.t val ppx_runtime_deps_for_deprecated_method : t -> String.Set.t
end end

8
src/main.ml
View File

@ -5,7 +5,7 @@ let () = Inline_tests.linkme
type setup = type setup =
{ build_system : Build_system.t { build_system : Build_system.t
; stanzas : (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list String_map.t ; stanzas : (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list String.Map.t
; contexts : Context.t list ; contexts : Context.t list
; packages : Package.t Package.Name.Map.t ; packages : Package.t Package.Name.Map.t
; file_tree : File_tree.t ; file_tree : File_tree.t
@ -122,13 +122,13 @@ let external_lib_deps ?log ~packages () =
| Ok path -> Path.append context.build_dir path | Ok path -> Path.append context.build_dir path
| Error () -> die "Unknown package %S" (Package.Name.to_string pkg)) | Error () -> die "Unknown package %S" (Package.Name.to_string pkg))
in in
let stanzas = Option.value_exn (String_map.find setup.stanzas "default") in let stanzas = Option.value_exn (String.Map.find setup.stanzas "default") in
let internals = Jbuild.Stanzas.lib_names stanzas in let internals = Jbuild.Stanzas.lib_names stanzas in
Path.Map.map Path.Map.map
(Build_system.all_lib_deps setup.build_system (Build_system.all_lib_deps setup.build_system
~request:(Build.paths install_files)) ~request:(Build.paths install_files))
~f:(String_map.filteri ~f:(fun name _ -> ~f:(String.Map.filteri ~f:(fun name _ ->
not (String_set.mem internals name)))) not (String.Set.mem internals name))))
let ignored_during_bootstrap = let ignored_during_bootstrap =
Path.Set.of_list Path.Set.of_list

2
src/main.mli
View File

@ -4,7 +4,7 @@ open Jbuild
type setup = type setup =
{ build_system : Build_system.t { build_system : Build_system.t
; (* Evaluated jbuilds per context names *) ; (* Evaluated jbuilds per context names *)
stanzas : (Path.t * Scope_info.t * Stanzas.t) list String_map.t stanzas : (Path.t * Scope_info.t * Stanzas.t) list String.Map.t
; contexts : Context.t list ; contexts : Context.t list
; packages : Package.t Package.Name.Map.t ; packages : Package.t Package.Name.Map.t
; file_tree : File_tree.t ; file_tree : File_tree.t

4
src/merlin.ml
View File

@ -141,8 +141,8 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
] ]
in in
dot_merlin dot_merlin
|> String_set.of_list |> String.Set.of_list
|> String_set.to_list |> String.Set.to_list
|> List.map ~f:(Printf.sprintf "%s\n") |> List.map ~f:(Printf.sprintf "%s\n")
|> String.concat ~sep:"") |> String.concat ~sep:"")
>>> >>>

10
src/meta.ml
View File

@ -134,7 +134,7 @@ module Simplified = struct
type t = type t =
{ name : string { name : string
; vars : Rules.t String_map.t ; vars : Rules.t String.Map.t
; subs : t list ; subs : t list
} }
@ -150,7 +150,7 @@ let rec simplify t =
List.fold_right t.entries List.fold_right t.entries
~init: ~init:
{ name = t.name { name = t.name
; vars = String_map.empty ; vars = String.Map.empty
; subs = [] ; subs = []
} }
~f:(fun entry (pkg : Simplified.t) -> ~f:(fun entry (pkg : Simplified.t) ->
@ -160,7 +160,7 @@ let rec simplify t =
{ pkg with subs = simplify sub :: pkg.subs } { pkg with subs = simplify sub :: pkg.subs }
| Rule rule -> | Rule rule ->
let rules = let rules =
Option.value (String_map.find pkg.vars rule.var) Option.value (String.Map.find pkg.vars rule.var)
~default:{ set_rules = []; add_rules = [] } ~default:{ set_rules = []; add_rules = [] }
in in
let rules = let rules =
@ -168,7 +168,7 @@ let rec simplify t =
| Set -> { rules with set_rules = rule :: rules.set_rules } | Set -> { rules with set_rules = rule :: rules.set_rules }
| Add -> { rules with add_rules = rule :: rules.add_rules } | Add -> { rules with add_rules = rule :: rules.add_rules }
in in
{ pkg with vars = String_map.add pkg.vars rule.var rules }) { pkg with vars = String.Map.add pkg.vars rule.var rules })
let load ~fn ~name = let load ~fn ~name =
{ name { name
@ -259,7 +259,7 @@ let builtins ~stdlib_dir =
[ compiler_libs; str; unix; bigarray; threads ] [ compiler_libs; str; unix; bigarray; threads ]
in in
List.map libs ~f:(fun t -> t.name, simplify t) List.map libs ~f:(fun t -> t.name, simplify t)
|> String_map.of_list_exn |> String.Map.of_list_exn
let string_of_action = function let string_of_action = function
| Set -> "=" | Set -> "="

4
src/meta.mli
View File

@ -35,7 +35,7 @@ module Simplified : sig
type t = type t =
{ name : string { name : string
; vars : Rules.t String_map.t ; vars : Rules.t String.Map.t
; subs : t list ; subs : t list
} }
@ -46,6 +46,6 @@ val load : fn:string -> name:string -> Simplified.t
(** Builtin META files for libraries distributed with the compiler. For when ocamlfind is (** Builtin META files for libraries distributed with the compiler. For when ocamlfind is
not installed. *) not installed. *)
val builtins : stdlib_dir:Path.t -> Simplified.t String_map.t val builtins : stdlib_dir:Path.t -> Simplified.t String.Map.t
val pp : Format.formatter -> entry list -> unit val pp : Format.formatter -> entry list -> unit

4
src/module.ml
View File

@ -14,8 +14,8 @@ module Name = struct
let pp = Format.pp_print_string let pp = Format.pp_print_string
let pp_quote fmt x = Format.fprintf fmt "%S" x let pp_quote fmt x = Format.fprintf fmt "%S" x
module Set = String_set module Set = String.Set
module Map = String_map module Map = String.Map
module Top_closure = Top_closure.String module Top_closure = Top_closure.String
end end

8
src/ocaml-config/ocaml_config.ml
View File

@ -199,9 +199,7 @@ let split_prog s =
| prog :: args -> Some { prog; args } | prog :: args -> Some { prog; args }
module Vars = struct module Vars = struct
module M = Map.Make(String) type t = string String.Map.t
type t = string M.t
let of_lines lines = let of_lines lines =
let rec loop acc = function let rec loop acc = function
@ -218,10 +216,10 @@ module Vars = struct
Error (Printf.sprintf "Unrecognized line: %S" line) Error (Printf.sprintf "Unrecognized line: %S" line)
in in
loop [] lines >>= fun vars -> loop [] lines >>= fun vars ->
Result.map_error (M.of_list vars) ~f:(fun (var, _, _) -> Result.map_error (String.Map.of_list vars) ~f:(fun (var, _, _) ->
Printf.sprintf "Variable %S present twice." var) Printf.sprintf "Variable %S present twice." var)
let get_opt t var = M.find t var let get_opt t var = String.Map.find t var
let get t var = let get t var =
match get_opt t var with match get_opt t var with

2
src/ocaml-config/ocaml_config.mli
View File

@ -20,7 +20,7 @@ end
(** Represent the parsed but uninterpreted output of [ocamlc -config] *) (** Represent the parsed but uninterpreted output of [ocamlc -config] *)
module Vars : sig module Vars : sig
type t = string Map.Make(String).t type t = string String.Map.t
(** Parse the output of [ocamlc -config] given as a list of lines. *) (** Parse the output of [ocamlc -config] given as a list of lines. *)
val of_lines : string list -> (t, string) Result.t val of_lines : string list -> (t, string) Result.t

2
src/ocamldep.ml
View File

@ -13,7 +13,7 @@ module Dep_graph = struct
match Module.Name.Map.find t.per_module m.name with match Module.Name.Map.find t.per_module m.name with
| Some x -> x | Some x -> x
| None -> | None ->
Sexp.code_error "Ocamldep.Dep_graph.deps_of" Exn.code_error "Ocamldep.Dep_graph.deps_of"
[ "dir", Path.sexp_of_t t.dir [ "dir", Path.sexp_of_t t.dir
; "modules", Sexp.To_sexp.(list Module.Name.t) ; "modules", Sexp.To_sexp.(list Module.Name.t)
(Module.Name.Map.keys t.per_module) (Module.Name.Map.keys t.per_module)

8
src/odoc.ml
View File

@ -434,7 +434,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
let check_mlds_no_dupes ~pkg ~mlds = let check_mlds_no_dupes ~pkg ~mlds =
match match
List.map mlds ~f:(fun mld -> (Path.basename mld, mld)) List.map mlds ~f:(fun mld -> (Path.basename mld, mld))
|> String_map.of_list |> String.Map.of_list
with with
| Ok m -> m | Ok m -> m
| Error (_, p1, p2) -> | Error (_, p1, p2) ->
@ -446,7 +446,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
let setup_package_odoc_rules ~pkg ~mlds ~entry_modules_by_lib = let setup_package_odoc_rules ~pkg ~mlds ~entry_modules_by_lib =
let mlds = check_mlds_no_dupes ~pkg ~mlds in let mlds = check_mlds_no_dupes ~pkg ~mlds in
let mlds = let mlds =
if String_map.mem mlds "index" then if String.Map.mem mlds "index" then
mlds mlds
else else
let entry_modules = entry_modules ~pkg ~entry_modules_by_lib in let entry_modules = entry_modules ~pkg ~entry_modules_by_lib in
@ -454,8 +454,8 @@ module Gen (S : sig val sctx : SC.t end) = struct
SC.add_rule sctx ( SC.add_rule sctx (
Build.write_file gen_mld (default_index entry_modules) Build.write_file gen_mld (default_index entry_modules)
); );
String_map.add mlds "index" gen_mld in String.Map.add mlds "index" gen_mld in
let odocs = List.map (String_map.values mlds) ~f:(fun mld -> let odocs = List.map (String.Map.values mlds) ~f:(fun mld ->
compile_mld compile_mld
(Mld.create mld) (Mld.create mld)
~pkg:pkg.name ~pkg:pkg.name

18
src/ordered_set_lang.ml
View File

@ -102,7 +102,7 @@ module Make(Key : Key)(Value : Value with type key = Key.t) = struct
let x = parse ~loc s in let x = parse ~loc s in
M.singleton x M.singleton x
| Special (loc, name) -> begin | Special (loc, name) -> begin
match String_map.find special_values name with match String.Map.find special_values name with
| Some x -> x | Some x -> x
| None -> Loc.fail loc "undefined symbol %s" name | None -> Loc.fail loc "undefined symbol %s" name
end end
@ -153,14 +153,14 @@ module Make(Key : Key)(Value : Value with type key = Key.t) = struct
standard (* inline common case *) standard (* inline common case *)
else else
Ordered.eval t ~parse Ordered.eval t ~parse
~special_values:(String_map.singleton "standard" standard) ~special_values:(String.Map.singleton "standard" standard)
let eval_unordered t ~parse ~standard = let eval_unordered t ~parse ~standard =
if is_standard t then if is_standard t then
standard (* inline common case *) standard (* inline common case *)
else else
Unordered.eval t ~parse Unordered.eval t ~parse
~special_values:(String_map.singleton "standard" standard) ~special_values:(String.Map.singleton "standard" standard)
end end
let standard = let standard =
@ -215,13 +215,13 @@ module Unexpanded = struct
| Element _ | Element _
| Special _ -> acc | Special _ -> acc
| Include fn -> | Include fn ->
String_set.add acc (f fn) String.Set.add acc (f fn)
| Union l -> | Union l ->
List.fold_left l ~init:acc ~f:loop List.fold_left l ~init:acc ~f:loop
| Diff (l, r) -> | Diff (l, r) ->
loop (loop acc l) r loop (loop acc l) r
in in
loop String_set.empty t.ast loop String.Set.empty t.ast
let expand t ~files_contents ~f = let expand t ~files_contents ~f =
let rec expand (t : ast) : ast_expanded = let rec expand (t : ast) : ast_expanded =
@ -232,14 +232,14 @@ module Unexpanded = struct
| Include fn -> | Include fn ->
let sexp = let sexp =
let fn = f fn in let fn = f fn in
match String_map.find files_contents fn with match String.Map.find files_contents fn with
| Some x -> x | Some x -> x
| None -> | None ->
Sexp.code_error Exn.code_error
"Ordered_set_lang.Unexpanded.expand" "Ordered_set_lang.Unexpanded.expand"
[ "included-file", Quoted_string fn [ "included-file", Quoted_string fn
; "files", Sexp.To_sexp.(list string) ; "files", Sexp.To_sexp.(list string)
(String_map.keys files_contents) (String.Map.keys files_contents)
] ]
in in
parse_general sexp ~f:(fun sexp -> parse_general sexp ~f:(fun sexp ->
@ -254,7 +254,7 @@ end
module String = Make(struct module String = Make(struct
type t = string type t = string
let compare = String.compare let compare = String.compare
module Map = String_map module Map = String.Map
end)(struct end)(struct
type t = string type t = string
type key = string type key = string

6
src/ordered_set_lang.mli
View File

@ -59,16 +59,16 @@ module Unexpanded : sig
val field : ?default:t -> string -> t Sexp.Of_sexp.record_parser val field : ?default:t -> string -> t Sexp.Of_sexp.record_parser
(** List of files needed to expand this set *) (** List of files needed to expand this set *)
val files : t -> f:(String_with_vars.t -> string) -> String_set.t val files : t -> f:(String_with_vars.t -> string) -> String.Set.t
(** Expand [t] using with the given file contents. [file_contents] is a map from (** Expand [t] using with the given file contents. [file_contents] is a map from
filenames to their parsed contents. Every [(:include fn)] in [t] is replaced by filenames to their parsed contents. Every [(:include fn)] in [t] is replaced by
[Map.find files_contents fn]. Every element is converted to a string using [f]. *) [Map.find files_contents fn]. Every element is converted to a string using [f]. *)
val expand val expand
: t : t
-> files_contents:Sexp.Ast.t String_map.t -> files_contents:Sexp.Ast.t String.Map.t
-> f:(String_with_vars.t -> string) -> f:(String_with_vars.t -> string)
-> expanded -> expanded
end with type expanded := t end with type expanded := t
module String : S with type value = string and type 'a map = 'a String_map.t module String : S with type value = string and type 'a map = 'a String.Map.t

20
src/path.ml
View File

@ -59,7 +59,7 @@ module Local = struct
let compare = String.compare let compare = String.compare
module Set = String_set module Set = String.Set
let to_list = let to_list =
let rec loop t acc i j = let rec loop t acc i j =
@ -221,12 +221,12 @@ type t = string
let compare = String.compare let compare = String.compare
module Set = struct module Set = struct
include String_set include String.Set
let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.to_list t) let sexp_of_t t = Sexp.To_sexp.(list string) (String.Set.to_list t)
let of_string_set = map let of_string_set = map
end end
module Map = String_map module Map = String.Map
module Kind = struct module Kind = struct
type t = type t =
@ -290,7 +290,7 @@ let reach t ~from =
match is_local t, is_local from with match is_local t, is_local from with
| false, _ -> t | false, _ -> t
| true, false -> | true, false ->
Sexp.code_error "Path.reach called with invalid combination" Exn.code_error "Path.reach called with invalid combination"
[ "t" , sexp_of_t t [ "t" , sexp_of_t t
; "from", sexp_of_t from ; "from", sexp_of_t from
] ]
@ -300,7 +300,7 @@ let reach_for_running t ~from =
match is_local t, is_local from with match is_local t, is_local from with
| false, _ -> t | false, _ -> t
| true, false -> | true, false ->
Sexp.code_error "Path.reach_for_running called with invalid combination" Exn.code_error "Path.reach_for_running called with invalid combination"
[ "t" , sexp_of_t t [ "t" , sexp_of_t t
; "from", sexp_of_t from ; "from", sexp_of_t from
] ]
@ -325,7 +325,7 @@ let is_descendant t ~of_ =
let append a b = let append a b =
if not (is_local b) then if not (is_local b) then
Sexp.code_error "Path.append called with non-local second path" Exn.code_error "Path.append called with non-local second path"
[ "a", sexp_of_t a [ "a", sexp_of_t a
; "b", sexp_of_t b ; "b", sexp_of_t b
]; ];
@ -391,7 +391,7 @@ let drop_build_context t =
let drop_build_context_exn t = let drop_build_context_exn t =
match extract_build_context t with match extract_build_context t with
| None -> Sexp.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ] | None -> Exn.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ]
| Some (_, t) -> t | Some (_, t) -> t
let drop_optional_build_context t = let drop_optional_build_context t =
@ -424,7 +424,7 @@ let explode_exn t =
else if is_local t then else if is_local t then
String.split t ~on:'/' String.split t ~on:'/'
else else
Sexp.code_error "Path.explode_exn" Exn.code_error "Path.explode_exn"
["path", Sexp.atom_or_quoted_string t] ["path", Sexp.atom_or_quoted_string t]
let exists t = Sys.file_exists (to_string t) let exists t = Sys.file_exists (to_string t)
@ -456,7 +456,7 @@ let extend_basename t ~suffix = t ^ suffix
let insert_after_build_dir_exn = let insert_after_build_dir_exn =
let error a b = let error a b =
Sexp.code_error Exn.code_error
"Path.insert_after_build_dir_exn" "Path.insert_after_build_dir_exn"
[ "path" , Sexp.unsafe_atom_of_string a [ "path" , Sexp.unsafe_atom_of_string a
; "insert", Sexp.unsafe_atom_of_string b ; "insert", Sexp.unsafe_atom_of_string b

2
src/path.mli
View File

@ -42,7 +42,7 @@ val compare : t -> t -> Ordering.t
module Set : sig module Set : sig
include Set.S with type elt = t include Set.S with type elt = t
val sexp_of_t : t Sexp.To_sexp.t val sexp_of_t : t Sexp.To_sexp.t
val of_string_set : String_set.t -> f:(string -> elt) -> t val of_string_set : String.Set.t -> f:(string -> elt) -> t
end end
module Map : Map.S with type key = t module Map : Map.S with type key = t

16
src/process.ml
View File

@ -49,22 +49,22 @@ type purpose =
| Build_job of Path.t list | Build_job of Path.t list
module Temp = struct module Temp = struct
let tmp_files = ref String_set.empty let tmp_files = ref String.Set.empty
let () = let () =
at_exit (fun () -> at_exit (fun () ->
let fns = !tmp_files in let fns = !tmp_files in
tmp_files := String_set.empty; tmp_files := String.Set.empty;
String_set.iter fns ~f:(fun fn -> String.Set.iter fns ~f:(fun fn ->
try Sys.force_remove fn with _ -> ())) try Sys.force_remove fn with _ -> ()))
let create prefix suffix = let create prefix suffix =
let fn = Filename.temp_file prefix suffix in let fn = Filename.temp_file prefix suffix in
tmp_files := String_set.add !tmp_files fn; tmp_files := String.Set.add !tmp_files fn;
fn fn
let destroy fn = let destroy fn =
(try Sys.force_remove fn with Sys_error _ -> ()); (try Sys.force_remove fn with Sys_error _ -> ());
tmp_files := String_set.remove !tmp_files fn tmp_files := String.Set.remove !tmp_files fn
end end
module Fancy = struct module Fancy = struct
@ -142,7 +142,7 @@ module Fancy = struct
Format.fprintf ppf "(internal)" Format.fprintf ppf "(internal)"
| Build_job targets -> | Build_job targets ->
let rec split_paths targets_acc ctxs_acc = function let rec split_paths targets_acc ctxs_acc = function
| [] -> List.rev targets_acc, String_set.(to_list (of_list ctxs_acc)) | [] -> List.rev targets_acc, String.Set.(to_list (of_list ctxs_acc))
| path :: rest -> | path :: rest ->
let add_ctx ctx acc = if ctx = "default" then acc else ctx :: acc in let add_ctx ctx acc = if ctx = "default" then acc else ctx :: acc in
match Utils.analyse_target path with match Utils.analyse_target path with
@ -158,8 +158,8 @@ module Fancy = struct
let target_names, contexts = split_paths [] [] targets in let target_names, contexts = split_paths [] [] targets in
let target_names_grouped_by_prefix = let target_names_grouped_by_prefix =
List.map target_names ~f:Filename.split_extension_after_dot List.map target_names ~f:Filename.split_extension_after_dot
|> String_map.of_list_multi |> String.Map.of_list_multi
|> String_map.to_list |> String.Map.to_list
in in
let pp_comma ppf () = Format.fprintf ppf "," in let pp_comma ppf () = Format.fprintf ppf "," in
let pp_group ppf (prefix, suffixes) = let pp_group ppf (prefix, suffixes) =

12
src/report_error.ml
View File

@ -49,14 +49,14 @@ let report_with_backtrace exn =
else else
Format.fprintf ppf "%s\n" (String.capitalize msg) Format.fprintf ppf "%s\n" (String.capitalize msg)
} }
| Code_error msg -> | Stdune.Exn.Code_error sexp ->
{ p with { p with
backtrace = true backtrace = true
; pp = fun ppf -> ; pp = fun ppf ->
Format.fprintf ppf "@{<error>Internal error, please report upstream \ Format.fprintf ppf "@{<error>Internal error, please report upstream \
including the contents of _build/log.@}\n\ including the contents of _build/log.@}\n\
Description: %s\n" Description: %a\n"
msg Usexp.pp sexp
} }
| Unix.Unix_error (err, func, fname) -> | Unix.Unix_error (err, func, fname) ->
{ p with pp = fun ppf -> { p with pp = fun ppf ->
@ -74,7 +74,7 @@ let report_with_backtrace exn =
Format.fprintf ppf "@{<error>Error@}: exception %s\n" s Format.fprintf ppf "@{<error>Error@}: exception %s\n" s
} }
let reported = ref String_set.empty let reported = ref String.Set.empty
let report exn = let report exn =
let exn, dependency_path = Dep_path.unwrap_exn exn in let exn, dependency_path = Dep_path.unwrap_exn exn in
@ -91,10 +91,10 @@ let report exn =
let s = Buffer.contents err_buf in let s = Buffer.contents err_buf in
(* Hash to avoid keeping huge errors in memory *) (* Hash to avoid keeping huge errors in memory *)
let hash = Digest.string s in let hash = Digest.string s in
if String_set.mem !reported hash then if String.Set.mem !reported hash then
Buffer.clear err_buf Buffer.clear err_buf
else begin else begin
reported := String_set.add !reported hash; reported := String.Set.add !reported hash;
if p.backtrace || !Clflags.debug_backtraces then if p.backtrace || !Clflags.debug_backtraces then
Format.fprintf ppf "Backtrace:\n%s" Format.fprintf ppf "Backtrace:\n%s"
(Printexc.raw_backtrace_to_string backtrace); (Printexc.raw_backtrace_to_string backtrace);

12
src/scope.ml
View File

@ -27,7 +27,7 @@ module DB = struct
| Some scope -> scope | Some scope -> scope
| None -> | None ->
if Path.is_root d || not (Path.is_local d) then if Path.is_root d || not (Path.is_local d) then
Sexp.code_error "Scope.DB.find_by_dir got an invalid path" Exn.code_error "Scope.DB.find_by_dir got an invalid path"
[ "dir" , Path.sexp_of_t dir [ "dir" , Path.sexp_of_t dir
; "context", Sexp.To_sexp.string t.context ; "context", Sexp.To_sexp.string t.context
]; ];
@ -41,7 +41,7 @@ module DB = struct
match Scope_name_map.find t.by_name name with match Scope_name_map.find t.by_name name with
| Some x -> x | Some x -> x
| None -> | None ->
Sexp.code_error "Scope.DB.find_by_name" Exn.code_error "Scope.DB.find_by_name"
[ "name" , Sexp.To_sexp.(option string) name [ "name" , Sexp.To_sexp.(option string) name
; "context", Sexp.To_sexp.string t.context ; "context", Sexp.To_sexp.string t.context
; "names", ; "names",
@ -60,7 +60,7 @@ module DB = struct
Sexp.To_sexp.(pair (option string) Path.sexp_of_t) Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
(scope.name, scope.root) (scope.name, scope.root)
in in
Sexp.code_error "Scope.DB.create got two scopes with the same name" Exn.code_error "Scope.DB.create got two scopes with the same name"
[ "scope1", to_sexp scope1 [ "scope1", to_sexp scope1
; "scope2", to_sexp scope2 ; "scope2", to_sexp scope2
] ]
@ -77,7 +77,7 @@ module DB = struct
match lib.public with match lib.public with
| None -> None | None -> None
| Some p -> Some (p.name, lib.scope_name)) | Some p -> Some (p.name, lib.scope_name))
|> String_map.of_list |> String.Map.of_list
|> function |> function
| Ok x -> x | Ok x -> x
| Error (name, _, _) -> | Error (name, _, _) ->
@ -99,14 +99,14 @@ module DB = struct
Lib.DB.create () Lib.DB.create ()
~parent:installed_libs ~parent:installed_libs
~resolve:(fun name -> ~resolve:(fun name ->
match String_map.find public_libs name with match String.Map.find public_libs name with
| None -> Not_found | None -> Not_found
| Some scope_name -> | Some scope_name ->
let scope = let scope =
Option.value_exn (Scope_name_map.find !by_name_cell scope_name) Option.value_exn (Scope_name_map.find !by_name_cell scope_name)
in in
Redirect (Some scope.db, name)) Redirect (Some scope.db, name))
~all:(fun () -> String_map.keys public_libs) ~all:(fun () -> String.Map.keys public_libs)
in in
let by_name = let by_name =
Scope_name_map.merge scopes_info_by_name libs_by_scope_name Scope_name_map.merge scopes_info_by_name libs_by_scope_name

26
src/sexp.ml
View File

@ -3,12 +3,6 @@ open Import
include (Usexp : module type of struct include Usexp end include (Usexp : module type of struct include Usexp end
with module Loc := Usexp.Loc) with module Loc := Usexp.Loc)
let code_error message vars =
code_errorf "%a" pp
(List (Usexp.atom_or_quoted_string message
:: List.map vars ~f:(fun (name, value) ->
List [Usexp.atom_or_quoted_string name; value])))
let buf_len = 65_536 let buf_len = 65_536
let load ~fname ~mode = let load ~fname ~mode =
@ -77,8 +71,8 @@ module type Combinators = sig
val list : 'a t -> 'a list t val list : 'a t -> 'a list t
val array : 'a t -> 'a array t val array : 'a t -> 'a array t
val option : 'a t -> 'a option t val option : 'a t -> 'a option t
val string_set : String_set.t t val string_set : String.Set.t t
val string_map : 'a t -> 'a String_map.t t val string_map : 'a t -> 'a String.Map.t t
val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t
end end
@ -96,14 +90,14 @@ module To_sexp = struct
let option f = function let option f = function
| None -> List [] | None -> List []
| Some x -> List [f x] | Some x -> List [f x]
let string_set set = list atom (String_set.to_list set) let string_set set = list atom (String.Set.to_list set)
let string_map f map = list (pair atom f) (String_map.to_list map) let string_map f map = list (pair atom f) (String.Map.to_list map)
let record l = let record l =
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
let string_hashtbl f h = let string_hashtbl f h =
string_map f string_map f
(Hashtbl.foldi h ~init:String_map.empty ~f:(fun key data acc -> (Hashtbl.foldi h ~init:String.Map.empty ~f:(fun key data acc ->
String_map.add acc key data)) String.Map.add acc key data))
type field = string * Usexp.t option type field = string * Usexp.t option
@ -181,17 +175,17 @@ module Of_sexp = struct
| List (_, [x]) -> Some (f x) | List (_, [x]) -> Some (f x)
| sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected" | sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
let string_set sexp = String_set.of_list (list string sexp) let string_set sexp = String.Set.of_list (list string sexp)
let string_map f sexp = let string_map f sexp =
match String_map.of_list (list (pair string f) sexp) with match String.Map.of_list (list (pair string f) sexp) with
| Ok x -> x | Ok x -> x
| Error (key, _v1, _v2) -> | Error (key, _v1, _v2) ->
of_sexp_error sexp (sprintf "key %S present multiple times" key) of_sexp_error sexp (sprintf "key %S present multiple times" key)
let string_hashtbl f sexp = let string_hashtbl f sexp =
let map = string_map f sexp in let map = string_map f sexp in
let tbl = Hashtbl.create (String_map.cardinal map + 32) in let tbl = Hashtbl.create (String.Map.cardinal map + 32) in
String_map.iteri map ~f:(Hashtbl.add tbl); String.Map.iteri map ~f:(Hashtbl.add tbl);
tbl tbl
type unparsed_field = type unparsed_field =

6
src/sexp.mli
View File

@ -2,8 +2,6 @@ open Import
include module type of struct include Usexp end with module Loc := Usexp.Loc include module type of struct include Usexp end with module Loc := Usexp.Loc
val code_error : string -> (string * t) list -> _
val load : fname:string -> mode:'a Parser.Mode.t -> 'a val load : fname:string -> mode:'a Parser.Mode.t -> 'a
val load_many_as_one : fname:string -> Ast.t val load_many_as_one : fname:string -> Ast.t
@ -29,10 +27,10 @@ module type Combinators = sig
val array : 'a t -> 'a array t val array : 'a t -> 'a array t
val option : 'a t -> 'a option t val option : 'a t -> 'a option t
val string_set : String_set.t t val string_set : String.Set.t t
(** [atom_set] is a conversion to/from a set of strings representing atoms. *) (** [atom_set] is a conversion to/from a set of strings representing atoms. *)
val string_map : 'a t -> 'a String_map.t t val string_map : 'a t -> 'a String.Map.t t
(** [atom_map conv]: given a conversion [conv] to/from ['a], returns (** [atom_map conv]: given a conversion [conv] to/from ['a], returns
a conversion to/from a map where the keys are atoms and the a conversion to/from a map where the keys are atoms and the
values are of type ['a]. *) values are of type ['a]. *)

9
src/stdune/exn.ml
View File

@ -1,5 +1,7 @@
type t = exn type t = exn
exception Code_error of Usexp.t
external raise : exn -> _ = "%raise" external raise : exn -> _ = "%raise"
external raise_notrace : exn -> _ = "%raise_notrace" external raise_notrace : exn -> _ = "%raise_notrace"
external reraise : exn -> _ = "%reraise" external reraise : exn -> _ = "%reraise"
@ -11,6 +13,13 @@ let protectx x ~f ~finally =
let protect ~f ~finally = protectx () ~f ~finally let protect ~f ~finally = protectx () ~f ~finally
let code_error message vars =
Code_error
(Usexp.List (Usexp.atom_or_quoted_string message
:: List.map vars ~f:(fun (name, value) ->
Usexp.List [Usexp.atom_or_quoted_string name; value])))
|> raise
include include
((struct ((struct
[@@@warning "-32-3"] [@@@warning "-32-3"]

6
src/stdune/exn.mli
View File

@ -1,5 +1,11 @@
(** Exceptions *) (** Exceptions *)
(** An programming error, that should be reported upstream. The error message
shouldn't try to be developer friendly rather than user friendly. *)
exception Code_error of Usexp.t
val code_error : string -> (string * Usexp.t) list -> _
type t = exn type t = exn
external raise : exn -> _ = "%raise" external raise : exn -> _ = "%raise"

2
src/stdune/jbuild
View File

@ -2,4 +2,4 @@
((name stdune) ((name stdune)
(public_name jbuilder.stdune) (public_name jbuilder.stdune)
(synopsis "[Internal] Standard library of Dune") (synopsis "[Internal] Standard library of Dune")
(libraries (caml unix)))) (libraries (caml unix usexp))))

8
src/stdune/string.ml
View File

@ -13,6 +13,11 @@ include StringLabels
let compare a b = Ordering.of_int (String.compare a b) let compare a b = Ordering.of_int (String.compare a b)
module T = struct
type t = StringLabels.t
let compare = compare
end
let capitalize = capitalize_ascii let capitalize = capitalize_ascii
let uncapitalize = uncapitalize_ascii let uncapitalize = uncapitalize_ascii
let uppercase = uppercase_ascii let uppercase = uppercase_ascii
@ -169,3 +174,6 @@ let exists s ~f =
false false
with Exit -> with Exit ->
true true
module Set = Set.Make(T)
module Map = Map.Make(T)

3
src/stdune/string.mli
View File

@ -39,3 +39,6 @@ val longest : string list -> int
val longest_map : 'a list -> f:('a -> string) -> int val longest_map : 'a list -> f:('a -> string) -> int
val exists : t -> f:(char -> bool) -> bool val exists : t -> f:(char -> bool) -> bool
module Set : Set.S with type elt = t
module Map : Map.S with type key = t

2
src/string_with_vars.ml
View File

@ -97,7 +97,7 @@ let iter t ~f = List.iter t.items ~f:(function
| Text _ -> () | Text _ -> ()
| Var (_, v) -> f t.loc v) | Var (_, v) -> f t.loc v)
let vars t = fold t ~init:String_set.empty ~f:(fun acc _ x -> String_set.add acc x) let vars t = fold t ~init:String.Set.empty ~f:(fun acc _ x -> String.Set.add acc x)
let string_of_var syntax v = let string_of_var syntax v =
match syntax with match syntax with

2
src/string_with_vars.mli
View File

@ -32,7 +32,7 @@ val virt : ?quoted: bool -> (string * int * int * int) -> string -> t
val virt_var : ?quoted: bool -> (string * int * int * int) -> string -> t val virt_var : ?quoted: bool -> (string * int * int * int) -> string -> t
val virt_text : (string * int * int * int) -> string -> t val virt_text : (string * int * int * int) -> string -> t
val vars : t -> String_set.t val vars : t -> String.Set.t
(** [vars t] returns the set of all variables in [t]. *) (** [vars t] returns the set of all variables in [t]. *)
val fold : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a val fold : t -> init:'a -> f:('a -> Loc.t -> string -> 'a) -> 'a

40
src/super_context.ml
View File

@ -26,7 +26,7 @@ type t =
; artifacts : Artifacts.t ; artifacts : Artifacts.t
; stanzas_to_consider_for_install : (Path.t * Scope.t * Stanza.t) list ; stanzas_to_consider_for_install : (Path.t * Scope.t * Stanza.t) list
; cxx_flags : string list ; cxx_flags : string list
; vars : Action.Var_expansion.t String_map.t ; vars : Action.Var_expansion.t String.Map.t
; chdir : (Action.t, Action.t) Build.t ; chdir : (Action.t, Action.t) Build.t
; host : t option ; host : t option
; libs_by_package : (Package.t * Lib.Set.t) Package.Name.Map.t ; libs_by_package : (Package.t * Lib.Set.t) Package.Name.Map.t
@ -51,9 +51,9 @@ let installed_libs t = t.installed_libs
let find_scope_by_dir t dir = Scope.DB.find_by_dir t.scopes dir let find_scope_by_dir t dir = Scope.DB.find_by_dir t.scopes dir
let find_scope_by_name t name = Scope.DB.find_by_name t.scopes name let find_scope_by_name t name = Scope.DB.find_by_name t.scopes name
let expand_var_no_root t var = String_map.find t.vars var let expand_var_no_root t var = String.Map.find t.vars var
let expand_vars t ~scope ~dir ?(extra_vars=String_map.empty) s = let expand_vars t ~scope ~dir ?(extra_vars=String.Map.empty) s =
String_with_vars.expand s ~f:(fun _loc -> function String_with_vars.expand s ~f:(fun _loc -> function
| "ROOT" -> Some (Path.reach ~from:dir t.context.build_dir) | "ROOT" -> Some (Path.reach ~from:dir t.context.build_dir)
| "SCOPE_ROOT" -> | "SCOPE_ROOT" ->
@ -62,7 +62,7 @@ let expand_vars t ~scope ~dir ?(extra_vars=String_map.empty) s =
Option.map ~f:(fun e -> Action.Var_expansion.to_string dir e) Option.map ~f:(fun e -> Action.Var_expansion.to_string dir e)
(match expand_var_no_root t var with (match expand_var_no_root t var with
| Some _ as x -> x | Some _ as x -> x
| None -> String_map.find extra_vars var)) | None -> String.Map.find extra_vars var))
let resolve_program t ?hint bin = let resolve_program t ?hint bin =
Artifacts.binary ?hint t.artifacts bin Artifacts.binary ?hint t.artifacts bin
@ -185,7 +185,7 @@ let create
| Words x -> strings x | Words x -> strings x
| Prog_and_args x -> strings (x.prog :: x.args))) | Prog_and_args x -> strings (x.prog :: x.args)))
in in
match String_map.of_list vars with match String.Map.of_list vars with
| Ok x -> x | Ok x -> x
| Error _ -> assert false | Error _ -> assert false
in in
@ -251,7 +251,7 @@ let on_load_dir t ~dir ~f = Build_system.on_load_dir t.build_system ~dir ~f
let source_files t ~src_path = let source_files t ~src_path =
match File_tree.find_dir t.file_tree src_path with match File_tree.find_dir t.file_tree src_path with
| None -> String_set.empty | None -> String.Set.empty
| Some dir -> File_tree.Dir.files dir | Some dir -> File_tree.Dir.files dir
module Libs = struct module Libs = struct
@ -421,18 +421,18 @@ module Action = struct
; (* Static deps from ${...} variables. For instance ${exe:...} *) ; (* Static deps from ${...} variables. For instance ${exe:...} *)
mutable sdeps : Pset.t mutable sdeps : Pset.t
; (* Dynamic deps from ${...} variables. For instance ${read:...} *) ; (* Dynamic deps from ${...} variables. For instance ${read:...} *)
mutable ddeps : (unit, Action.Var_expansion.t) Build.t String_map.t mutable ddeps : (unit, Action.Var_expansion.t) Build.t String.Map.t
} }
let add_lib_dep acc lib kind = let add_lib_dep acc lib kind =
acc.lib_deps <- String_map.add acc.lib_deps lib kind acc.lib_deps <- String.Map.add acc.lib_deps lib kind
let add_fail acc fail = let add_fail acc fail =
acc.failures <- fail :: acc.failures; acc.failures <- fail :: acc.failures;
None None
let add_ddep acc ~key dep = let add_ddep acc ~key dep =
acc.ddeps <- String_map.add acc.ddeps key dep; acc.ddeps <- String.Map.add acc.ddeps key dep;
None None
let path_exp path = Action.Var_expansion.Paths ([path], Concat) let path_exp path = Action.Var_expansion.Paths ([path], Concat)
@ -458,9 +458,9 @@ module Action = struct
~map_exe ~extra_vars t = ~map_exe ~extra_vars t =
let acc = let acc =
{ failures = [] { failures = []
; lib_deps = String_map.empty ; lib_deps = String.Map.empty
; sdeps = Pset.empty ; sdeps = Pset.empty
; ddeps = String_map.empty ; ddeps = String.Map.empty
} }
in in
let open Action.Var_expansion in let open Action.Var_expansion in
@ -550,7 +550,7 @@ module Action = struct
| _ -> | _ ->
match expand_var_no_root sctx var with match expand_var_no_root sctx var with
| Some _ as x -> x | Some _ as x -> x
| None -> String_map.find extra_vars var | None -> String.Map.find extra_vars var
in in
let t = let t =
U.partial_expand t ~dir ~map_exe ~f:(fun loc key -> U.partial_expand t ~dir ~map_exe ~f:(fun loc key ->
@ -584,7 +584,7 @@ module Action = struct
let expand_step2 ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe t = let expand_step2 ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe t =
let open Action.Var_expansion in let open Action.Var_expansion in
U.Partial.expand t ~dir ~map_exe ~f:(fun loc key -> U.Partial.expand t ~dir ~map_exe ~f:(fun loc key ->
match String_map.find dynamic_expansions key with match String.Map.find dynamic_expansions key with
| Some _ as opt -> opt | Some _ as opt -> opt
| None -> | None ->
let _, var = parse_bang key in let _, var = parse_bang key in
@ -601,7 +601,7 @@ module Action = struct
| "^" -> Some (Paths (deps_written_by_user, Split)) | "^" -> Some (Paths (deps_written_by_user, Split))
| _ -> None) | _ -> None)
let run sctx ?(extra_vars=String_map.empty) let run sctx ?(extra_vars=String.Map.empty)
t ~dir ~dep_kind ~targets:targets_written_by_user ~scope t ~dir ~dep_kind ~targets:targets_written_by_user ~scope
: (Path.t list, Action.t) Build.t = : (Path.t list, Action.t) Build.t =
let map_exe = map_exe sctx in let map_exe = map_exe sctx in
@ -667,12 +667,12 @@ module Action = struct
>>> >>>
Build.arr (fun paths -> ((), paths)) Build.arr (fun paths -> ((), paths))
>>> >>>
let ddeps = String_map.to_list forms.ddeps in let ddeps = String.Map.to_list forms.ddeps in
Build.first (Build.all (List.map ddeps ~f:snd)) Build.first (Build.all (List.map ddeps ~f:snd))
>>^ (fun (vals, deps_written_by_user) -> >>^ (fun (vals, deps_written_by_user) ->
let dynamic_expansions = let dynamic_expansions =
List.fold_left2 ddeps vals ~init:String_map.empty List.fold_left2 ddeps vals ~init:String.Map.empty
~f:(fun acc (var, _) value -> String_map.add acc var value) ~f:(fun acc (var, _) value -> String.Map.add acc var value)
in in
let unresolved = let unresolved =
expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe
@ -700,16 +700,16 @@ let expand_and_eval_set t ~scope ~dir ?extra_vars set ~standard =
let open Build.O in let open Build.O in
let f = expand_vars t ~scope ~dir ?extra_vars in let f = expand_vars t ~scope ~dir ?extra_vars in
let parse ~loc:_ s = s in let parse ~loc:_ s = s in
match Ordered_set_lang.Unexpanded.files set ~f |> String_set.to_list with match Ordered_set_lang.Unexpanded.files set ~f |> String.Set.to_list with
| [] -> | [] ->
let set = let set =
Ordered_set_lang.Unexpanded.expand set ~files_contents:String_map.empty ~f Ordered_set_lang.Unexpanded.expand set ~files_contents:String.Map.empty ~f
in in
Build.return (Ordered_set_lang.String.eval set ~standard ~parse) Build.return (Ordered_set_lang.String.eval set ~standard ~parse)
| files -> | files ->
let paths = List.map files ~f:(Path.relative dir) in let paths = List.map files ~f:(Path.relative dir) in
Build.all (List.map paths ~f:Build.read_sexp) Build.all (List.map paths ~f:Build.read_sexp)
>>^ fun sexps -> >>^ fun sexps ->
let files_contents = List.combine files sexps |> String_map.of_list_exn in let files_contents = List.combine files sexps |> String.Map.of_list_exn in
let set = Ordered_set_lang.Unexpanded.expand set ~files_contents ~f in let set = Ordered_set_lang.Unexpanded.expand set ~files_contents ~f in
Ordered_set_lang.String.eval set ~standard ~parse Ordered_set_lang.String.eval set ~standard ~parse

8
src/super_context.mli
View File

@ -56,7 +56,7 @@ val expand_vars
: t : t
-> scope:Scope.t -> scope:Scope.t
-> dir:Path.t -> dir:Path.t
-> ?extra_vars:Action.Var_expansion.t String_map.t -> ?extra_vars:Action.Var_expansion.t String.Map.t
-> String_with_vars.t -> String_with_vars.t
-> string -> string
@ -64,7 +64,7 @@ val expand_and_eval_set
: t : t
-> scope:Scope.t -> scope:Scope.t
-> dir:Path.t -> dir:Path.t
-> ?extra_vars:Action.Var_expansion.t String_map.t -> ?extra_vars:Action.Var_expansion.t String.Map.t
-> Ordered_set_lang.Unexpanded.t -> Ordered_set_lang.Unexpanded.t
-> standard:string list -> standard:string list
-> (unit, string list) Build.t -> (unit, string list) Build.t
@ -114,7 +114,7 @@ val eval_glob : t -> dir:Path.t -> Re.re -> string list
val load_dir : t -> dir:Path.t -> unit val load_dir : t -> dir:Path.t -> unit
val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit
val source_files : t -> src_path:Path.t -> String_set.t val source_files : t -> src_path:Path.t -> String.Set.t
(** [prog_spec t ?hint name] resolve a program. [name] is looked up in the (** [prog_spec t ?hint name] resolve a program. [name] is looked up in the
workspace, if it is not found in the tree is is looked up in the PATH. If it workspace, if it is not found in the tree is is looked up in the PATH. If it
@ -190,7 +190,7 @@ module Action : sig
(** The arrow takes as input the list of actual dependencies *) (** The arrow takes as input the list of actual dependencies *)
val run val run
: t : t
-> ?extra_vars:Action.Var_expansion.t String_map.t -> ?extra_vars:Action.Var_expansion.t String.Map.t
-> Action.Unexpanded.t -> Action.Unexpanded.t
-> dir:Path.t -> dir:Path.t
-> dep_kind:Build.lib_dep_kind -> dep_kind:Build.lib_dep_kind

4
src/syntax.ml
View File

@ -26,14 +26,14 @@ module Versioned_parser = struct
let make l = let make l =
if List.is_empty l then if List.is_empty l then
Sexp.code_error "Syntax.Versioned_parser.make got empty list" []; Exn.code_error "Syntax.Versioned_parser.make got empty list" [];
match match
List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p))) List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
|> Int_map.of_list |> Int_map.of_list
with with
| Ok x -> x | Ok x -> x
| Error _ -> | Error _ ->
Sexp.code_error Exn.code_error
"Syntax.Versioned_parser.make" "Syntax.Versioned_parser.make"
[ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ] [ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]

2
src/top_closure.ml
View File

@ -47,4 +47,4 @@ module Make(Keys : Keys) = struct
end end
module Int = Make(Int_set) module Int = Make(Int_set)
module String = Make(String_set) module String = Make(String.Set)

6
src/watermarks.ml
View File

@ -50,7 +50,7 @@ let make_watermark_map ~name ~version ~commit =
end end
| _ -> err | _ -> err
in in
String_map.of_list_exn String.Map.of_list_exn
[ "NAME" , Ok name [ "NAME" , Ok name
; "VERSION" , Ok version ; "VERSION" , Ok version
; "VERSION_NUM" , Ok version_num ; "VERSION_NUM" , Ok version_num
@ -66,7 +66,7 @@ let make_watermark_map ~name ~version ~commit =
let subst_string s ~fname ~map = let subst_string s ~fname ~map =
let len = String.length s in let len = String.length s in
let longest_var = String.longest (String_map.keys map) in let longest_var = String.longest (String.Map.keys map) in
let loc_of_offset ~ofs ~len = let loc_of_offset ~ofs ~len =
let rec loop lnum bol i = let rec loop lnum bol i =
if i = ofs then if i = ofs then
@ -125,7 +125,7 @@ let subst_string s ~fname ~map =
match s.[i] with match s.[i] with
| '%' -> begin | '%' -> begin
let var = String.sub s ~pos:(start + 2) ~len:(i - start - 3) in let var = String.sub s ~pos:(start + 2) ~len:(i - start - 3) in
match String_map.find map var with match String.Map.find map var with
| None -> in_var ~start:(i - 1) (i + 1) acc | None -> in_var ~start:(i - 1) (i + 1) acc
| Some (Ok repl) -> | Some (Ok repl) ->
let acc = (start, i + 1, repl) :: acc in let acc = (start, i + 1, repl) :: acc in

8
src/workspace.ml
View File

@ -73,7 +73,7 @@ type t =
} }
let t ?x sexps = let t ?x sexps =
let defined_names = ref String_set.empty in let defined_names = ref String.Set.empty in
let merlin_ctx, contexts = let merlin_ctx, contexts =
List.fold_left sexps ~init:(None, []) ~f:(fun (merlin_ctx, ctxs) sexp -> List.fold_left sexps ~init:(None, []) ~f:(fun (merlin_ctx, ctxs) sexp ->
let ctx = let ctx =
@ -104,10 +104,10 @@ let t ?x sexps =
String.contains name '/' || String.contains name '/' ||
String.contains name '\\' then String.contains name '\\' then
of_sexp_errorf sexp "%S is not allowed as a build context name" name; of_sexp_errorf sexp "%S is not allowed as a build context name" name;
if String_set.mem !defined_names name then if String.Set.mem !defined_names name then
of_sexp_errorf sexp "second definition of build context %S" name; of_sexp_errorf sexp "second definition of build context %S" name;
defined_names := String_set.union !defined_names defined_names := String.Set.union !defined_names
(String_set.of_list (Context.all_names ctx)); (String.Set.of_list (Context.all_names ctx));
match ctx, merlin_ctx with match ctx, merlin_ctx with
| Opam { merlin = true; _ }, Some _ -> | Opam { merlin = true; _ }, Some _ ->
of_sexp_errorf sexp "you can only have one context for merlin" of_sexp_errorf sexp "you can only have one context for merlin"

6
test/unit-tests/import_dot_map.mlt
View File

@ -6,15 +6,15 @@ open Jbuilder;;
open Import;; open Import;;
(* Check that [of_alist_multi] groups elements in the right order *) (* Check that [of_alist_multi] groups elements in the right order *)
String_map.of_list_multi String.Map.of_list_multi
[ "a", 1 [ "a", 1
; "b", 1 ; "b", 1
; "a", 2 ; "a", 2
; "a", 3 ; "a", 3
; "b", 2 ; "b", 2
] ]
|> String_map.to_list;; |> String.Map.to_list;;
[%%expect{| [%%expect{|
- : (Jbuilder.Import.String_map.key * int list) list = - : (Jbuilder.Import.String.Map.key * int list) list =
[("a", [1; 2; 3]); ("b", [1; 2])] [("a", [1; 2; 3]); ("b", [1; 2])]
|}] |}]