From 648b2b2990036129fd6d395e587c81d5c43befcd Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 15 May 2017 14:46:23 +0100 Subject: [PATCH] Revert some changes: - Make targets explicit b7ad08df84f85429c978ec855d40b2fd4c3e213b. - Get rid of Vfile e73fd90b65c912045a22245ece86978f2d88b15a. Without vfile we need some new concepts to avoid parsing the requires file multiple times and with vfile it's annoying to specify the dependencies by hand. Will leave that for future work. Just use memoize where it make sense, for instance when we read the result from only the current directory (for instance the ocamldep stuff). --- src/alias.ml | 2 +- src/arg_spec.ml | 10 +++ src/arg_spec.mli | 6 +- src/build.ml | 94 +++++++++++++++------------ src/build.mli | 23 +++++-- src/build_interpret.ml | 64 +++++++++++++++++- src/build_interpret.mli | 17 ++++- src/build_system.ml | 99 ++++++++++++++++++++++------ src/gen_rules.ml | 109 ++++++++++++++++--------------- src/js_of_ocaml_rules.ml | 99 ++++++++++++++-------------- src/js_of_ocaml_rules.mli | 10 +-- src/merlin.ml | 7 +- src/module_compilation.ml | 7 +- src/ocamldep.ml | 4 +- src/super_context.ml | 132 +++++++++++++++++++++----------------- src/super_context.mli | 3 +- src/vfile_kind.ml | 78 ++++++++++++++++++++++ src/vfile_kind.mli | 31 +++++++++ 18 files changed, 539 insertions(+), 256 deletions(-) create mode 100644 src/vfile_kind.ml create mode 100644 src/vfile_kind.mli diff --git a/src/alias.ml b/src/alias.ml index 795b78ae..6caa2055 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -101,7 +101,7 @@ let rules store ~prefixes ~tree = Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; deps } acc -> let open Build.O in let rule = - Build_interpret.Rule.make ~targets:[alias.file] + Build_interpret.Rule.make (Build.path_set deps >>> Build.create_file alias.file) in diff --git a/src/arg_spec.ml b/src/arg_spec.ml index 4cf1b97b..73c35ffe 100644 --- a/src/arg_spec.ml +++ b/src/arg_spec.ml @@ -10,6 +10,7 @@ type 'a t = | Deps of Path.t list | Dep_rel of Path.t * string | Deps_rel of Path.t * string list + | Target of Path.t | Path of Path.t | Paths of Path.t list | Dyn of ('a -> nothing t) @@ -26,6 +27,13 @@ let rec add_deps ts set = | S ts -> add_deps ts set | _ -> set) +let rec add_targets ts acc = + List.fold_left ts ~init:acc ~f:(fun acc t -> + match t with + | Target fn -> fn :: acc + | S ts -> add_targets ts acc + | _ -> acc) + let expand ~dir ts x = let dyn_deps = ref Path.Set.empty in let add_dep path = dyn_deps := Path.Set.add path !dyn_deps in @@ -49,6 +57,7 @@ let expand ~dir ts x = | Paths fns -> List.map fns ~f:(Path.reach ~from:dir) | S ts -> List.concat_map ts ~f:loop_dyn + | Target _ -> die "Target not allowed under Dyn" | Dyn _ -> assert false in let rec loop = function @@ -59,6 +68,7 @@ let expand ~dir ts x = | (Dep fn | Path fn) -> [Path.reach fn ~from:dir] | (Deps fns | Paths fns) -> List.map fns ~f:(Path.reach ~from:dir) | S ts -> List.concat_map ts ~f:loop + | Target fn -> [Path.reach fn ~from:dir] | Dyn f -> loop_dyn (f x) in let l = List.concat_map ts ~f:loop in diff --git a/src/arg_spec.mli b/src/arg_spec.mli index 7d99bdc3..b36ce6d6 100644 --- a/src/arg_spec.mli +++ b/src/arg_spec.mli @@ -8,10 +8,12 @@ type 'a t = | Deps of Path.t list | Dep_rel of Path.t * string | Deps_rel of Path.t * string list + | Target of Path.t | Path of Path.t | Paths of Path.t list | Dyn of ('a -> nothing t) -val add_deps : _ t list -> Path.Set.t -> Path.Set.t -val expand : dir:Path.t -> 'a t list -> 'a -> string list * Path.Set.t +val add_deps : _ t list -> Path.Set.t -> Path.Set.t +val add_targets : _ t list -> Path.t list -> Path.t list +val expand : dir:Path.t -> 'a t list -> 'a -> string list * Path.Set.t diff --git a/src/build.ml b/src/build.ml index 86f52b9b..810e4cbe 100644 --- a/src/build.ml +++ b/src/build.ml @@ -2,6 +2,10 @@ open Import module Pset = Path.Set +module Vspec = struct + type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t +end + module Prog_spec = struct type 'a t = | Dep of Path.t @@ -21,6 +25,8 @@ let merge_lib_dep_kind a b = module Repr = struct type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t + | Targets : Path.t list -> ('a, 'a) t + | Store_vfile : 'a Vspec.t -> ('a, Action.t) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t @@ -32,6 +38,7 @@ module Repr = struct | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t | Contents : Path.t -> ('a, string) t | Lines_of : Path.t -> ('a, string list) t + | Vpath : 'a Vspec.t -> (unit, 'a) t | Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t | Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t | Fail : fail -> (_, _) t @@ -118,6 +125,7 @@ let path p = Paths (Pset.singleton p) let paths ps = Paths (Pset.of_list ps) let path_set ps = Paths ps let paths_glob ~dir re = Paths_glob (dir, re) +let vpath vp = Vpath vp let dyn_paths t = Dyn_paths t let contents p = Contents p @@ -136,24 +144,14 @@ let file_exists_opt p t = ~then_:(t >>^ fun x -> Some x) ~else_:(arr (fun _ -> None)) -let fail x = Fail x +let fail ?targets x = + match targets with + | None -> Fail x + | Some l -> Targets l >>> Fail x -let memoize ~name t = +let memoize name t = Memo { name; t; state = Unevaluated } -let read_sexp path of_sexp = - memoize ~name:(Path.to_string path) - (contents path - >>^ fun s -> - let lb = Lexing.from_string s in - lb.lex_curr_p <- - { pos_fname = Path.to_string path - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - of_sexp (Sexp_lexer.single lb)) - let files_recursively_in ~dir ~file_tree = let prefix_with, dir = match Path.extract_build_context_dir dir with @@ -162,6 +160,8 @@ let files_recursively_in ~dir ~file_tree = in path_set (File_tree.files_recursively_in file_tree dir ~prefix_with) +let store_vfile spec = Store_vfile spec + let get_prog (prog : _ Prog_spec.t) = match prog with | Dep p -> path p >>> arr (fun _ -> p) @@ -177,9 +177,17 @@ let prog_and_args ~dir prog args = >>> arr fst)) -let run ~context ?(dir=context.Context.build_dir) ?stdout_to +let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[]) prog args = + let extra_targets = + match stdout_to with + | None -> extra_targets + | Some fn -> fn :: extra_targets + in + let targets = Arg_spec.add_targets args extra_targets in prog_and_args ~dir prog args + >>> + Targets targets >>^ (fun (prog, args) -> let action : Action.Mini_shexp.t = Run (prog, args) in let action = @@ -193,48 +201,50 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ; action }) -let action ~context ?(dir=context.Context.build_dir) action = - return { Action. context = Some context; dir; action } +let action ~context ?(dir=context.Context.build_dir) ~targets action = + Targets targets + >>^ fun () -> + { Action. context = Some context; dir; action } -let action_dyn ~context ?(dir=context.Context.build_dir) () = - arr (fun action -> - { Action. context = Some context; dir; action }) +let action_dyn ~context ?(dir=context.Context.build_dir) ~targets () = + Targets targets + >>^ fun action -> + { Action. context = Some context; dir; action } -let action_context_independent ?(dir=Path.root) action = - return { Action. context = None; dir; action } +let action_context_independent ?(dir=Path.root) ~targets action = + Targets targets + >>^ fun () -> + { Action. context = None; dir; action } let update_file fn s = - action_context_independent (Update_file (fn, s)) + action_context_independent ~targets:[fn] (Update_file (fn, s)) let update_file_dyn fn = - arr (fun s -> - { Action. - context = None - ; dir = Path.root - ; action = Update_file (fn, s) - }) - -let write_sexp path to_sexp = - arr (fun x -> Sexp.to_string (to_sexp x)) - >>> - update_file_dyn path + Targets [fn] + >>^ fun s -> + { Action. + context = None + ; dir = Path.root + ; action = Update_file (fn, s) + } let copy ~src ~dst = path src >>> - action_context_independent (Copy (src, dst)) + action_context_independent ~targets:[dst] (Copy (src, dst)) let symlink ~src ~dst = path src >>> - action_context_independent (Symlink (src, dst)) + action_context_independent ~targets:[dst] (Symlink (src, dst)) let create_file fn = - action_context_independent (Create_file fn) + action_context_independent ~targets:[fn] (Create_file fn) let and_create_file fn = - arr (fun (action : Action.t) -> - { action with - action = Progn [action.action; Create_file fn] - }) + Targets [fn] + >>^ fun (action : Action.t) -> + { action with + action = Progn [action.action; Create_file fn] + } (* {[ diff --git a/src/build.mli b/src/build.mli index 344e8f66..2a35aaa2 100644 --- a/src/build.mli +++ b/src/build.mli @@ -8,6 +8,12 @@ val arr : ('a -> 'b) -> ('a, 'b) t val return : 'a -> (unit, 'a) t +module Vspec : sig + type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t +end + +val store_vfile : 'a Vspec.t -> ('a, Action.t) t + module O : sig val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t val ( ^>> ) : ('a -> 'b) -> ('b, 'c) t -> ('a, 'c) t @@ -32,9 +38,7 @@ val paths : Path.t list -> ('a, 'a) t val path_set : Path.Set.t -> ('a, 'a) t val paths_glob : dir:Path.t -> Re.re -> ('a, 'a) t val files_recursively_in : dir:Path.t -> file_tree:File_tree.t -> ('a, 'a) t - -val read_sexp : Path.t -> 'a Sexp.Of_sexp.t -> (unit, 'a) t -val write_sexp : Path.t -> 'a Sexp.To_sexp.t -> ('a, Action.t) t +val vpath : 'a Vspec.t -> (unit, 'a) t val dyn_paths : ('a, Path.t list) t -> ('a, 'a) t @@ -59,11 +63,11 @@ val file_exists_opt : Path.t -> ('a, 'b) t -> ('a, 'b option) t (** Always fail when executed. We pass a function rather than an exception to get a proper backtrace *) -val fail : fail -> (_, _) t +val fail : ?targets:Path.t list -> fail -> (_, _) t -(** [memoize ~name t] is an arrow that behaves like [t] except that its +(** [memoize name t] is an arrow that behaves like [t] except that its result is computed only once. *) -val memoize : name:string -> (unit, 'a) t -> (unit, 'a) t +val memoize : string -> (unit, 'a) t -> (unit, 'a) t module Prog_spec : sig type 'a t = @@ -75,6 +79,7 @@ val run : context:Context.t -> ?dir:Path.t (* default: context.build_dir *) -> ?stdout_to:Path.t + -> ?extra_targets:Path.t list -> 'a Prog_spec.t -> 'a Arg_spec.t list -> ('a, Action.t) t @@ -82,17 +87,20 @@ val run val action : context:Context.t -> ?dir:Path.t (* default: context.build_dir *) + -> targets:Path.t list -> Action.Mini_shexp.t -> (unit, Action.t) t val action_dyn : context:Context.t -> ?dir:Path.t (* default: context.build_dir *) + -> targets:Path.t list -> unit -> (Action.Mini_shexp.t, Action.t) t val action_context_independent : ?dir:Path.t (* default: Path.root *) + -> targets:Path.t list -> Action.Mini_shexp.t -> (unit, Action.t) t @@ -129,6 +137,8 @@ val record_lib_deps_simple : dir:Path.t -> lib_deps -> ('a, 'a) t module Repr : sig type ('a, 'b) t = | Arr : ('a -> 'b) -> ('a, 'b) t + | Targets : Path.t list -> ('a, 'a) t + | Store_vfile : 'a Vspec.t -> ('a, Action.t) t | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t @@ -139,6 +149,7 @@ module Repr : sig | If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t | Contents : Path.t -> ('a, string) t | Lines_of : Path.t -> ('a, string list) t + | Vpath : 'a Vspec.t -> (unit, 'a) t | Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t | Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t | Fail : fail -> (_, _) t diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 67ccc1b3..c205284f 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -3,11 +3,28 @@ open Build.Repr module Pset = Path.Set module Pmap = Path.Map +module Vspec = Build.Vspec + +module Target = struct + type t = + | Normal of Path.t + | Vfile : _ Vspec.t -> t + + let path = function + | Normal p -> p + | Vfile (Vspec.T (p, _)) -> p + + let paths ts = + List.fold_left ts ~init:Pset.empty ~f:(fun acc t -> + Pset.add (path t) acc) +end let rule_deps t ~all_targets_by_dir = let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc -> match t with | Arr _ -> acc + | Targets _ -> acc + | Store_vfile _ -> acc | Compose (a, b) -> loop a (loop b acc) | First t -> loop t acc | Second t -> loop t acc @@ -33,6 +50,7 @@ let rule_deps t ~all_targets_by_dir = end end | Dyn_paths t -> loop t acc + | Vpath (Vspec.T (p, _)) -> Pset.add p acc | Contents p -> Pset.add p acc | Lines_of p -> Pset.add p acc | Record_lib_deps _ -> acc @@ -45,6 +63,7 @@ let static_action_deps t ~all_targets_by_dir = let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc -> match t with | Arr _ -> acc + | Targets _ -> acc | Compose (a, b) -> loop a (loop b acc) | First t -> loop t acc | Second t -> loop t acc @@ -59,6 +78,7 @@ let static_action_deps t ~all_targets_by_dir = Re.execp re (Path.basename path)) |> Pset.union acc end + | Vpath _ -> acc | If_file_exists (_, state) -> loop (get_if_file_exists_exn state) acc | Dyn_paths t -> loop t acc | Contents _ -> acc @@ -66,6 +86,7 @@ let static_action_deps t ~all_targets_by_dir = | Record_lib_deps _ -> acc | Fail _ -> acc | Memo m -> loop m.t acc + | Store_vfile _ -> acc in loop (Build.repr t) Pset.empty @@ -74,12 +95,15 @@ let lib_deps = = fun t acc -> match t with | Arr _ -> acc + | Targets _ -> acc + | Store_vfile _ -> acc | Compose (a, b) -> loop a (loop b acc) | First t -> loop t acc | Second t -> loop t acc | Split (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc) | Paths _ -> acc + | Vpath _ -> acc | Paths_glob _ -> acc | Dyn_paths t -> loop t acc | Contents _ -> acc @@ -98,16 +122,50 @@ let lib_deps = in fun t -> loop (Build.repr t) Pmap.empty +let targets = + let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc -> + match t with + | Arr _ -> acc + | Targets targets -> + List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc) + | Store_vfile spec -> Vfile spec :: acc + | Compose (a, b) -> loop a (loop b acc) + | First t -> loop t acc + | Second t -> loop t acc + | Split (a, b) -> loop a (loop b acc) + | Fanout (a, b) -> loop a (loop b acc) + | Paths _ -> acc + | Vpath _ -> acc + | Paths_glob _ -> acc + | Dyn_paths t -> loop t acc + | Contents _ -> acc + | Lines_of _ -> acc + | Record_lib_deps _ -> acc + | Fail _ -> acc + | If_file_exists (_, state) -> begin + match !state with + | Decided _ -> code_errorf "Build_interpret.targets got decided if_file_exists" + | Undecided (a, b) -> + match loop a [], loop b [] with + | [], [] -> acc + | _ -> + code_errorf "Build_interpret.targets: cannot have targets \ + under a [if_file_exists]" + end + | Memo m -> loop m.t acc + in + fun t -> loop (Build.repr t) [] + module Rule = struct type t = { build : (unit, Action.t) Build.t - ; targets : Path.Set.t + ; targets : Target.t list ; sandbox : bool } - let make ?(sandbox=false) ~targets build = + let make ?(sandbox=false) build = { build - ; targets = Path.Set.of_list targets + ; targets = targets build ; sandbox } end diff --git a/src/build_interpret.mli b/src/build_interpret.mli index d58e4752..4947c808 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -1,13 +1,22 @@ open! Import +module Target : sig + type t = + | Normal of Path.t + | Vfile : _ Build.Vspec.t -> t + + val path : t -> Path.t + val paths : t list -> Path.Set.t +end + module Rule : sig type t = { build : (unit, Action.t) Build.t - ; targets : Path.Set.t + ; targets : Target.t list ; sandbox : bool } - val make : ?sandbox:bool -> targets:Path.t list -> (unit, Action.t) Build.t -> t + val make : ?sandbox:bool -> (unit, Action.t) Build.t -> t end (* must be called first *) @@ -24,3 +33,7 @@ val static_action_deps val lib_deps : (_, _) Build.t -> Build.lib_deps Path.Map.t + +val targets + : (_, _) Build.t + -> Target.t list diff --git a/src/build_system.ml b/src/build_system.ml index 7e36954a..58d03fa8 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -3,6 +3,7 @@ open Future module Pset = Path.Set module Pmap = Path.Map +module Vspec = Build.Vspec module Exec_status = struct module Starting = struct @@ -27,9 +28,36 @@ module Rule = struct } end +module File_kind = struct + type 'a t = + | Ignore_contents : unit t + | Sexp_file : 'a Vfile_kind.t -> 'a t + + let eq : type a b. a t -> b t -> (a, b) eq option = fun a b -> + match a, b with + | Ignore_contents, Ignore_contents -> Some Eq + | Sexp_file a , Sexp_file b -> Vfile_kind.eq a b + | _ -> None + + let eq_exn a b = Option.value_exn (eq a b) +end + +module File_spec = struct + type 'a t = + { rule : Rule.t (* Rule which produces it *) + ; mutable kind : 'a File_kind.t + ; mutable data : 'a option + } + + type packed = T : _ t -> packed + + let create rule kind = + T { rule; kind; data = None } +end + type t = { (* File specification by targets *) - files : (Path.t, Rule.t) Hashtbl.t + files : (Path.t, File_spec.packed) Hashtbl.t ; contexts : Context.t list ; (* Table from target to digest of [(deps, targets, action)] *) trace : (Path.t, Digest.t) Hashtbl.t @@ -106,8 +134,8 @@ module Build_error = struct let rec build_path acc targeting ~seen = assert (not (Pset.mem targeting seen)); let seen = Pset.add targeting seen in - let rule = find_file_exn t targeting in - match rule.exec with + let (File_spec.T file) = find_file_exn t targeting in + match file.rule.exec with | Not_started _ -> assert false | Running { for_file; _ } | Starting { for_file } -> if for_file = targeting then @@ -128,10 +156,10 @@ let wait_for_file t fn ~targeting = return () else die "file unavailable: %s" (Path.to_string fn) - | Some rule -> - match rule.exec with + | Some (File_spec.T file) -> + match file.rule.exec with | Not_started f -> - rule.exec <- Starting { for_file = targeting }; + file.rule.exec <- Starting { for_file = targeting }; let future = with_exn_handler (fun () -> f ~targeting:fn) ~handler:(fun exn backtrace -> @@ -139,7 +167,7 @@ let wait_for_file t fn ~targeting = | Build_error.E _ -> reraise exn | exn -> Build_error.raise t exn ~targeting:fn ~backtrace) in - rule.exec <- Running { for_file = targeting; future }; + file.rule.exec <- Running { for_file = targeting; future }; future | Running { future; _ } -> future | Starting _ -> @@ -149,8 +177,8 @@ let wait_for_file t fn ~targeting = if fn = targeting then acc else - let rule = find_file_exn t targeting in - match rule.exec with + let (File_spec.T file) = find_file_exn t targeting in + match file.rule.exec with | Not_started _ | Running _ -> assert false | Starting { for_file } -> build_loop acc for_file @@ -160,15 +188,37 @@ let wait_for_file t fn ~targeting = (String.concat ~sep:"\n--> " (List.map loop ~f:Path.to_string)) +module Target = Build_interpret.Target + +let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn kind -> + match Hashtbl.find t.files fn with + | None -> die "no rule found for %s" (Path.to_string fn) + | Some (File_spec.T file) -> + let Eq = File_kind.eq_exn kind file.kind in + file + +let vfile_to_string (type a) (module K : Vfile_kind.S with type t = a) fn x = + K.to_string fn x + module Build_exec = struct open Build.Repr - let exec t x = + let exec bs t x = let dyn_deps = ref Pset.empty in let rec exec : type a b. (a, b) t -> a -> b = fun t x -> match t with | Arr f -> f x + | Targets _ -> x + | Store_vfile (Vspec.T (fn, kind)) -> + let file = get_file bs fn (Sexp_file kind) in + assert (file.data = None); + file.data <- Some x; + { Action. + context = None + ; dir = Path.root + ; action = Update_file (fn, vfile_to_string kind fn x) + } | Compose (a, b) -> exec a x |> exec b | First t -> @@ -190,6 +240,9 @@ module Build_exec = struct | Paths_glob _ -> x | Contents p -> read_file (Path.to_string p) | Lines_of p -> lines_of_file (Path.to_string p) + | Vpath (Vspec.T (fn, kind)) -> + let file : b File_spec.t = get_file bs fn (Sexp_file kind) in + Option.value_exn file.data | Dyn_paths t -> let fns = exec t x in dyn_deps := Pset.union !dyn_deps (Pset.of_list fns); @@ -213,13 +266,17 @@ module Build_exec = struct (action, !dyn_deps) end -let add_rule t fn rule ~allow_override = +let add_spec t fn spec ~allow_override = if not allow_override && Hashtbl.mem t.files fn then die "multiple rules generated for %s" (Path.to_string fn); - Hashtbl.add t.files ~key:fn ~data:rule + Hashtbl.add t.files ~key:fn ~data:spec -let create_file_rules t targets rule ~allow_override = - Pset.iter targets ~f:(fun fn -> add_rule t fn rule ~allow_override) +let create_file_specs t targets rule ~allow_override = + List.iter targets ~f:(function + | Target.Normal fn -> + add_spec t fn (File_spec.create rule Ignore_contents) ~allow_override + | Target.Vfile (Vspec.T (fn, kind)) -> + add_spec t fn (File_spec.create rule (Sexp_file kind)) ~allow_override) module Pre_rule = Build_interpret.Rule @@ -276,7 +333,8 @@ let make_local_parent_dirs t paths ~map_path = let sandbox_dir = Path.of_string "_build/.sandbox" let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = - let { Pre_rule. build; targets; sandbox } = pre_rule in + let { Pre_rule. build; targets = target_specs; sandbox } = pre_rule in + let targets = Target.paths target_specs in let rule_deps = Build_interpret.rule_deps build ~all_targets_by_dir in let static_deps = Build_interpret.static_action_deps build ~all_targets_by_dir in @@ -310,7 +368,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = (wait_for_deps t static_deps ~targeting) (wait_for_deps t rule_deps ~targeting >>= fun () -> - let action, dyn_deps = Build_exec.exec build () in + let action, dyn_deps = Build_exec.exec t build () in wait_for_deps t ~targeting (Pset.diff dyn_deps static_deps) >>| fun () -> (action, dyn_deps)) @@ -421,7 +479,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = ; exec } in - create_file_rules t targets rule ~allow_override + create_file_specs t target_specs rule ~allow_override let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir = List.iter t.contexts ~f:(fun (ctx : Context.t) -> @@ -440,7 +498,7 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir = This allows to keep generated files in tarballs. Maybe we should allow it on a case-by-case basis though. *) - compile_rule t (Pre_rule.make build ~targets:[ctx_path]) + compile_rule t (Pre_rule.make build) ~all_targets_by_dir ~allow_override:true)) @@ -494,7 +552,8 @@ let create ~contexts ~file_tree ~rules = in let all_other_targets = List.fold_left rules ~init:Pset.empty ~f:(fun acc { Pre_rule.targets; _ } -> - Pset.union acc targets) + List.fold_left targets ~init:acc ~f:(fun acc target -> + Pset.add (Target.path target) acc)) in let all_targets_by_dir = lazy ( Pset.elements (Pset.union all_copy_targets all_other_targets) @@ -566,7 +625,7 @@ let rules_for_files t paths = List.filter_map paths ~f:(fun path -> match Hashtbl.find t.files path with | None -> None - | Some rule -> Some (path, rule)) + | Some (File_spec.T { rule; _ }) -> Some (path, rule)) module File_closure = Top_closure.Make(Path) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 318ff448..152fcee6 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -63,11 +63,6 @@ module Gen(P : Params) = struct | Native -> ["-cclib"; "-l" ^ stubs_name] in SC.add_rule sctx - ~targets: - (target - :: match mode with - | Byte -> [] - | Native -> [lib_archive lib ~dir ~ext:ctx.ext_lib]) (Build.fanout (dep_graph >>> Build.arr (fun dep_graph -> @@ -80,8 +75,12 @@ module Gen(P : Params) = struct (SC.expand_and_eval_set ~dir lib.c_library_flags ~standard:[]) >>> Build.run ~context:ctx (Dep compiler) + ~extra_targets:( + match mode with + | Byte -> [] + | Native -> [lib_archive lib ~dir ~ext:ctx.ext_lib]) [ Ocaml_flags.get flags mode - ; A "-a"; A "-o"; Path target + ; A "-a"; A "-o"; Target target ; As stubs_flags ; Dyn (fun (_, cclibs) -> S (List.map cclibs ~f:(fun flag -> @@ -109,7 +108,7 @@ module Gen(P : Params) = struct let build_c_file (lib : Library.t) ~dir ~requires ~h_files c_name = let src = Path.relative dir (c_name ^ ".c") in let dst = Path.relative dir (c_name ^ ctx.ext_obj) in - SC.add_rule sctx ~targets:[dst] + SC.add_rule sctx (Build.paths h_files >>> Build.fanout @@ -129,7 +128,7 @@ module Gen(P : Params) = struct S [ Lib.c_include_flags libs ; As (List.concat_map c_flags ~f:(fun f -> ["-ccopt"; f])) ]) - ; A "-o"; Path dst + ; A "-o"; Target dst ; Dep src ]); dst @@ -137,7 +136,7 @@ module Gen(P : Params) = struct let build_cxx_file (lib : Library.t) ~dir ~requires ~h_files c_name = let src = Path.relative dir (c_name ^ ".cpp") in let dst = Path.relative dir (c_name ^ ctx.ext_obj) in - SC.add_rule sctx ~targets:[dst] + SC.add_rule sctx (Build.paths h_files >>> Build.fanout @@ -158,7 +157,7 @@ module Gen(P : Params) = struct S [ Lib.c_include_flags libs ; As cxx_flags ]) - ; A "-o"; Path dst + ; A "-o"; Target dst ; A "-c"; Dep src ]); dst @@ -232,8 +231,7 @@ module Gen(P : Params) = struct let dep_graph = Ocamldep.rules sctx ~dir ~item:lib.name ~modules ~alias_module in Option.iter alias_module ~f:(fun m -> - let target = Path.relative dir m.impl.name in - SC.add_rule sctx ~targets:[target] + SC.add_rule sctx (Build.return (String_map.values (String_map.remove m.name modules) |> List.map ~f:(fun (m : Module.t) -> @@ -242,7 +240,7 @@ module Gen(P : Params) = struct main_module_name m.name m.name (Module.real_unit_name m)) |> String.concat ~sep:"\n") - >>> Build.update_file_dyn target)); + >>> Build.update_file_dyn (Path.relative dir m.impl.name))); let requires, real_requires = SC.Libs.requires sctx ~dir ~dep_kind ~item:lib.name @@ -295,10 +293,11 @@ module Gen(P : Params) = struct | Some _ -> () | None -> let ocamlmklib ~sandbox ~custom ~targets = - SC.add_rule sctx ~sandbox ~targets + SC.add_rule sctx ~sandbox (SC.expand_and_eval_set ~dir lib.c_library_flags ~standard:[] >>> Build.run ~context:ctx + ~extra_targets:targets (Dep ctx.ocamlmklib) [ As (Utils.g ()) ; if custom then A "-custom" else As [] @@ -330,8 +329,9 @@ module Gen(P : Params) = struct List.iter Mode.all ~f:(fun mode -> build_lib lib ~flags ~dir ~mode ~modules ~dep_graph); (* Build *.cma.js *) - (let src = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in - Js_of_ocaml_rules.build_cm sctx ~dir ~src ~js_of_ocaml:lib.buildable.js_of_ocaml); + SC.add_rules sctx ( + let src = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in + Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml:lib.buildable.js_of_ocaml ~src); if ctx.natdynlink_supported then Option.iter ctx.ocamlopt ~f:(fun ocamlopt -> @@ -343,7 +343,7 @@ module Gen(P : Params) = struct [ Ocaml_flags.get flags Native ; A "-shared"; A "-linkall" ; A "-I"; Path dir - ; A "-o"; Path dst + ; A "-o"; Target dst ; Dep src ] in @@ -355,7 +355,7 @@ module Gen(P : Params) = struct else build in - SC.add_rule sctx build ~targets:[dst] + SC.add_rule sctx build ); let flags = @@ -383,33 +383,32 @@ module Gen(P : Params) = struct in let dep_graph = Ml_kind.Dict.get dep_graph Impl in let exe = Path.relative dir (name ^ exe_ext) in - let top_closed_cm_files = - dep_graph - >>^ fun dep_graph -> - Ocamldep.names_to_top_closed_cm_files - ~dir - ~dep_graph - ~modules - ~mode - [String.capitalize_ascii name] - in - SC.add_rule sctx ~targets:[exe] - (Build.fanout + let libs_and_cm = + Build.fanout (requires >>> Build.dyn_paths (Build.arr (Lib.archive_files ~mode ~ext_lib:ctx.ext_lib))) - top_closed_cm_files - >>> + (dep_graph + >>> Build.arr (fun dep_graph -> + Ocamldep.names_to_top_closed_cm_files + ~dir + ~dep_graph + ~modules + ~mode + [String.capitalize_ascii name])) + in + SC.add_rule sctx + (libs_and_cm >>> Build.run ~context:ctx (Dep compiler) [ Ocaml_flags.get flags mode - ; A "-o"; Path exe + ; A "-o"; Target exe ; As link_flags ; Dyn (fun (libs, _) -> Lib.link_flags libs ~mode) ; Dyn (fun (_, cm_files) -> Deps cm_files) ]); if mode = Mode.Byte then - Js_of_ocaml_rules.build_exe sctx ~dir ~js_of_ocaml ~src:exe - ~requires ~top_closed_cm_files + let rules = Js_of_ocaml_rules.build_exe sctx ~dir ~js_of_ocaml ~src:exe in + SC.add_rules sctx (List.map rules ~f:(fun r -> libs_and_cm >>> r)) let executables_rules (exes : Executables.t) ~dir ~all_modules ~package_context = let dep_kind = Build.Required in @@ -467,7 +466,7 @@ module Gen(P : Params) = struct let user_rule (rule : Rule.t) ~dir ~package_context = let targets = List.map rule.targets ~f:(Path.relative dir) in - SC.add_rule sctx ~targets + SC.add_rule sctx (SC.Deps.interpret sctx ~dir rule.deps >>> SC.Action.run @@ -495,7 +494,7 @@ module Gen(P : Params) = struct let digest_path = Alias.file_with_digest_suffix alias ~digest in Alias.add_deps (SC.aliases sctx) alias [digest_path]; let deps = SC.Deps.interpret sctx ~dir alias_conf.deps in - SC.add_rule sctx ~targets:[digest_path] + SC.add_rule sctx (match alias_conf.action with | None -> deps @@ -503,15 +502,14 @@ module Gen(P : Params) = struct Build.create_file digest_path | Some action -> deps - >>> - SC.Action.run - sctx - action - ~dir - ~dep_kind:Required - ~deps:(SC.Deps.only_plain_files sctx ~dir alias_conf.deps) - ~targets:[] - ~package_context + >>> SC.Action.run + sctx + action + ~dir + ~dep_kind:Required + ~targets:[] + ~deps:(SC.Deps.only_plain_files sctx ~dir alias_conf.deps) + ~package_context >>> Build.and_create_file digest_path) @@ -561,9 +559,10 @@ module Gen(P : Params) = struct | Reason -> "re") intf.name impl_fname; let dir = Path.append ctx.build_dir dir in - let src = Path.relative dir intf.name in - let dst = Path.relative dir impl_fname in - SC.add_rule sctx ~targets:[dst] (Build.copy ~src ~dst); + SC.add_rule sctx + (Build.copy + ~src:(Path.relative dir intf.name) + ~dst:(Path.relative dir impl_fname)); { intf with name = impl_fname } in String_map.merge impls intfs ~f:(fun name impl intf -> let impl = @@ -621,7 +620,8 @@ module Gen(P : Params) = struct |> Merlin.add_rules sctx ~dir:ctx_dir let () = List.iter (SC.stanzas sctx) ~f:rules - let () = Js_of_ocaml_rules.setup_separate_compilation_rules sctx + let () = + SC.add_rules sctx (Js_of_ocaml_rules.setup_separate_compilation_rules sctx) (* +-----------------------------------------------------------------+ | META | @@ -713,7 +713,7 @@ module Gen(P : Params) = struct >>^ List.map ~f:Lib.best_name | _ -> Build.arr (fun _ -> [])) in - SC.add_rule sctx ~targets:[meta_path] + SC.add_rule sctx (Build.fanout meta template >>^ (fun ((meta : Meta.t), template) -> let buf = Buffer.create 1024 in @@ -830,7 +830,7 @@ module Gen(P : Params) = struct let dst = Path.append install_dir (Install.Entry.relative_installed_path entry ~package) in - SC.add_rule ~targets:[dst] sctx (Build.symlink ~src:entry.src ~dst); + SC.add_rule sctx (Build.symlink ~src:entry.src ~dst); { entry with src = dst }) let install_file package_path package = @@ -872,7 +872,7 @@ module Gen(P : Params) = struct Path.relative (Path.append ctx.build_dir package_path) (package ^ ".install") in let entries = local_install_rules entries ~package in - SC.add_rule sctx ~targets:[fn] + SC.add_rule sctx (Build.path_set (Install.files entries) >>^ (fun () -> Install.gen_install_file entries) @@ -896,8 +896,7 @@ module Gen(P : Params) = struct if is_default then begin let src_install_alias = Alias.install ~dir:src_path in let src_install_file = Path.relative src_path install_fn in - SC.add_rule sctx ~targets:[src_install_file] - (Build.copy ~src:ctx_install_file ~dst:src_install_file); + SC.add_rule sctx (Build.copy ~src:ctx_install_file ~dst:src_install_file); Alias.add_deps (SC.aliases sctx) src_install_alias [src_install_file] end) end diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index eb462e2a..f69a6caa 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -1,5 +1,4 @@ open Import -open Build.O module SC = Super_context @@ -28,45 +27,42 @@ let runtime_file ~sctx ~dir fname = "js_of_ocaml-compiler") | Ok f -> Arg_spec.Dep f -let js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep = +let js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target = let jsoo = SC.resolve_program sctx ~hint:install_jsoo_hint "js_of_ocaml" in let runtime = runtime_file ~sctx ~dir "runtime.js" in - SC.add_rule sctx ~targets:[target] - (dep - >>> - Build.run ~context:(SC.context sctx) ~dir - jsoo - [ Arg_spec.As flags - ; Arg_spec.A "-o"; Path target - ; Arg_spec.A "--no-runtime"; runtime - ; spec - ]) + Build.run ~context:(SC.context sctx) ~dir + jsoo + [ Arg_spec.As flags + ; Arg_spec.A "-o"; Target target + ; Arg_spec.A "--no-runtime"; runtime + ; spec + ] -let standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files ~target ~requires = +let standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files ~target = let spec = Arg_spec.S - [ Arg_spec.Dyn (fun libs -> Arg_spec.Deps (Lib.jsoo_runtime_files libs)) + [ Arg_spec.Dyn (fun (libs,_) -> Arg_spec.Deps (Lib.jsoo_runtime_files libs)) ; Arg_spec.Deps javascript_files ] in let flags = Ordered_set_lang.eval_with_standard flags ~standard:(standard ()) in let flags = "--runtime-only" :: flags in - js_of_ocaml_rule ~sctx ~dir ~flags ~target ~spec ~dep:requires + js_of_ocaml_rule ~sctx ~dir ~flags ~target ~spec -let exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ~requires = +let exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target = let spec = Arg_spec.S - [ Arg_spec.Dyn (fun libs -> Arg_spec.Deps (Lib.jsoo_runtime_files libs)) + [ Arg_spec.Dyn (fun (libs,_) -> Arg_spec.Deps (Lib.jsoo_runtime_files libs)) ; Arg_spec.Deps javascript_files ; Arg_spec.Dep src ] in let flags = Ordered_set_lang.eval_with_standard flags ~standard:(standard ()) in - js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:requires + js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target -let link_rule ~sctx ~dir ~runtime ~target ~requires ~top_closed_cm_files = +let link_rule ~sctx ~dir ~runtime ~target = let ctx = SC.context sctx in - let get_all (libs, cm) = + let get_all (libs,cm) = (* Special case for the stdlib because it is not referenced in the META *) let stdlib = Lib.External (Findlib.stdlib_with_archives ctx.findlib) in let all_libs = @@ -84,31 +80,29 @@ let link_rule ~sctx ~dir ~runtime ~target ~requires ~top_closed_cm_files = Arg_spec.Deps (List.concat [all_libs;all_other_modules]) in let jsoo_link = SC.resolve_program sctx ~hint:install_jsoo_hint "jsoo_link" in - SC.add_rule sctx ~targets:[target] - (Build.fanout requires top_closed_cm_files - >>> - Build.run ~context:(SC.context sctx) ~dir - jsoo_link - [ Arg_spec.A "-o"; Path target - ; Arg_spec.Dep runtime - ; Arg_spec.As (sourcemap ()) - ; Arg_spec.Dyn get_all - ]) + Build.run ~context:(SC.context sctx) ~dir + jsoo_link + [ Arg_spec.A "-o"; Target target + ; Arg_spec.Dep runtime + ; Arg_spec.As (sourcemap ()) + ; Arg_spec.Dyn get_all + ] let build_cm sctx ~dir ~js_of_ocaml ~src = - if separate_compilation_enabled () then begin - let target = Path.extend_basename src ~suffix:".js" in + if separate_compilation_enabled () + then let target = Path.extend_basename src ~suffix:".js" in let spec = Arg_spec.Dep src in let flags = Ordered_set_lang.eval_with_standard js_of_ocaml.Jbuild_types.Js_of_ocaml.flags ~standard:(standard ()) in - js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:(Build.return ()) - end + [ js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ] + else [] let setup_separate_compilation_rules sctx = - if separate_compilation_enabled () then begin + if separate_compilation_enabled () + then let ctx = SC.context sctx in let all_pkg = List.map @@ -123,25 +117,28 @@ let setup_separate_compilation_rules sctx = let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in pkg.Findlib.name, pkg.dir, archives) in - List.iter all_pkg ~f:(fun (pkg_name, pkg_dir, archives) -> - List.iter archives ~f:(fun name -> - let src = Path.relative pkg_dir name in - let target = in_build_dir ~ctx [ pkg_name; sprintf "%s.js" name] in - let dir = in_build_dir ~ctx [ pkg_name ] in - let spec = Arg_spec.Dep src in - let flags = standard () in - js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:(Build.return ()))) - end + List.concat_map all_pkg + ~f:(fun (pkg_name,pkg_dir,archives) -> + List.map archives ~f:(fun name -> + let src = Path.relative pkg_dir name in + let target = in_build_dir ~ctx [ pkg_name; sprintf "%s.js" name] in + let dir = in_build_dir ~ctx [ pkg_name ] in + let spec = Arg_spec.Dep src in + let flags = standard () in + js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target + )) + else [] -let build_exe sctx ~dir ~js_of_ocaml ~src ~requires ~top_closed_cm_files = +let build_exe sctx ~dir ~js_of_ocaml ~src = let {Jbuild_types.Js_of_ocaml.javascript_files; flags} = js_of_ocaml in let javascript_files = List.map javascript_files ~f:(Path.relative dir) in let mk_target ext = Path.extend_basename src ~suffix:ext in let target = mk_target ".js" in let standalone_runtime = mk_target ".runtime.js" in - if separate_compilation_enabled () then begin - link_rule ~sctx ~dir ~runtime:standalone_runtime ~target ~requires ~top_closed_cm_files; - standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files - ~target:standalone_runtime ~requires - end else - exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ~requires + if separate_compilation_enabled () then + [ link_rule ~sctx ~dir ~runtime:standalone_runtime ~target + ; standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files + ~target:standalone_runtime + ] + else + [ exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ] diff --git a/src/js_of_ocaml_rules.mli b/src/js_of_ocaml_rules.mli index 20df018d..a454db2a 100644 --- a/src/js_of_ocaml_rules.mli +++ b/src/js_of_ocaml_rules.mli @@ -7,17 +7,17 @@ val build_cm -> dir:Path.t -> js_of_ocaml:Js_of_ocaml.t -> src:Path.t - -> unit + -> (unit, Action.t) Build.t list val build_exe : Super_context.t -> dir:Path.t -> js_of_ocaml:Js_of_ocaml.t -> src:Path.t - -> requires:(unit, Lib.t list) Build.t - -> top_closed_cm_files:(unit, Path.t list) Build.t - -> unit + -> (Lib.t list * Path.t list, Action.t) Build.t list -val setup_separate_compilation_rules : Super_context.t -> unit +val setup_separate_compilation_rules + : Super_context.t + -> (unit, Action.t) Build.t list diff --git a/src/merlin.ml b/src/merlin.ml index 34880ba9..7e2650be 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -30,12 +30,11 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) = match Path.extract_build_context dir with | Some (_, remaindir) -> let path = Path.relative remaindir ".merlin" in - let merlin_exists = Path.relative dir ".merlin-exists" in - SC.add_rule sctx ~targets:[merlin_exists] + SC.add_rule sctx (Build.path path >>> - Build.update_file merlin_exists ""); - SC.add_rule sctx ~targets:[path] ( + Build.update_file (Path.relative dir ".merlin-exists") ""); + SC.add_rule sctx ( requires >>^ (fun libs -> let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in diff --git a/src/module_compilation.ml b/src/module_compilation.ml index 88b739ba..7f4b59ca 100644 --- a/src/module_compilation.ml +++ b/src/module_compilation.ml @@ -71,12 +71,13 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~(dep_graph:Ocamldep.dep_gra let fn = Option.value_exn (Module.cmt_file m ~dir ml_kind) in (fn :: extra_targets, A "-bin-annot") in - SC.add_rule sctx ?sandbox ~targets:(dst :: extra_targets) + SC.add_rule sctx ?sandbox (Build.paths extra_deps >>> other_cm_files >>> requires >>> Build.dyn_paths (Build.arr (lib_dependencies ~cm_kind)) >>> Build.run ~context:ctx (Dep compiler) + ~extra_targets [ Ocaml_flags.get_for_cm flags ~cm_kind ; cmt_args ; Dyn Lib.include_flags @@ -87,7 +88,7 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~(dep_graph:Ocamldep.dep_gra ; (match alias_module with | None -> S [] | Some (m : Module.t) -> As ["-open"; m.name]) - ; A "-o"; Path dst + ; A "-o"; Target dst ; A "-c"; Ml_kind.flag ml_kind; Dep src ]))) @@ -98,7 +99,7 @@ let build_module sctx ?sandbox ~dynlink ~js_of_ocaml ~flags m ~dir ~dep_graph ~m ~alias_module); (* Build *.cmo.js *) let src = Module.cm_file m ~dir Cm_kind.Cmo in - Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml ~src + SC.add_rules sctx (Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml ~src) let build_modules sctx ~dynlink ~js_of_ocaml ~flags ~dir ~dep_graph ~modules ~requires ~alias_module = String_map.iter diff --git a/src/ocamldep.ml b/src/ocamldep.ml index 4e72e5cb..ef9b0156 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -59,10 +59,10 @@ let rules sctx ~ml_kind ~dir ~item ~modules ~alias_module = Path.relative dir (sprintf "%s.depends%s.ocamldep-output" item suffix) in let ctx = SC.context sctx in - SC.add_rule sctx ~targets:[ocamldep_output] + SC.add_rule sctx (Build.run ~context:ctx (Dep ctx.ocamldep) [A "-modules"; S files] ~stdout_to:ocamldep_output); - Build.memoize ~name:(Path.to_string ocamldep_output) + Build.memoize (Path.to_string ocamldep_output) (Build.lines_of ocamldep_output >>^ parse_deps ~dir ~modules ~alias_module) diff --git a/src/super_context.ml b/src/super_context.ml index 1cbeb913..e502dbde 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -21,6 +21,7 @@ type t = ; mutable rules : Build_interpret.Rule.t list ; stanzas_to_consider_for_install : (Path.t * Stanza.t) list ; mutable known_targets_by_src_dir_so_far : String_set.t Path.Map.t + ; libs_vfile : (module Vfile_kind.S with type t = Lib.t list) ; cxx_flags : string list ; vars : string String_map.t ; ppx_dir : Path.t @@ -97,6 +98,19 @@ let create List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; _ } -> List.map stanzas ~f:(fun s -> (ctx_dir, s))) in + let module Libs_vfile = + Vfile_kind.Make_full + (struct type t = Lib.t list end) + (struct + open Sexp.To_sexp + let t _dir l = list string (List.map l ~f:Lib.best_name) + end) + (struct + open Sexp.Of_sexp + let t dir sexp = + List.map (list string sexp) ~f:(Lib_db.find_exn libs ~from:dir) + end) + in let artifacts = Artifacts.create context (List.map stanzas ~f:(fun (d : Dir_with_jbuild.t) -> (d.ctx_dir, d.stanzas))) @@ -146,6 +160,7 @@ let create ; rules = [] ; stanzas_to_consider_for_install ; known_targets_by_src_dir_so_far = Path.Map.empty + ; libs_vfile = (module Libs_vfile) ; artifacts ; cxx_flags ; vars @@ -153,13 +168,13 @@ let create ; ppx_dir = Path.of_string (sprintf "_build/.ppx/%s" context.name) } -let add_rule t ?sandbox ~targets build = - let rule = Build_interpret.Rule.make ?sandbox ~targets build in +let add_rule t ?sandbox build = + let rule = Build_interpret.Rule.make ?sandbox build in t.rules <- rule :: t.rules; t.known_targets_by_src_dir_so_far <- - Path.Set.fold rule.targets ~init:t.known_targets_by_src_dir_so_far - ~f:(fun path acc -> - match Path.extract_build_context path with + List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far + ~f:(fun acc target -> + match Path.extract_build_context (Build_interpret.Target.path target) with | None -> acc | Some (_, path) -> let dir = Path.parent path in @@ -171,6 +186,9 @@ let add_rule t ?sandbox ~targets build = in Path.Map.add acc ~key:dir ~data:files) +let add_rules t ?sandbox builds = + List.iter builds ~f:(add_rule t ?sandbox) + let sources_and_targets_known_so_far t ~src_path = let sources = match File_tree.find_dir t.file_tree src_path with @@ -188,22 +206,19 @@ module Libs = struct let find t ~from name = find t.libs ~from name - let requires_file ~dir ~item = - Path.relative dir (item ^ ".requires.sexp") - - let load_deps t ~dir fn = - Build.read_sexp fn (fun sexp -> - Sexp.Of_sexp.(list string) sexp - |> List.map ~f:(fun name -> Lib_db.find_exn t.libs ~from:dir name)) + let vrequires t ~dir ~item = + let fn = Path.relative dir (item ^ ".requires.sexp") in + Build.Vspec.T (fn, t.libs_vfile) let load_requires t ~dir ~item = - load_deps t ~dir (requires_file ~dir ~item) + Build.vpath (vrequires t ~dir ~item) - let runtime_deps_file ~dir ~item = - Path.relative dir (item ^ ".runtime-deps.sexp") + let vruntime_deps t ~dir ~item = + let fn = Path.relative dir (item ^ ".runtime-deps.sexp") in + Build.Vspec.T (fn, t.libs_vfile) let load_runtime_deps t ~dir ~item = - load_deps t ~dir (runtime_deps_file ~dir ~item) + Build.vpath (vruntime_deps t ~dir ~item) let with_fail ~fail build = match fail with @@ -252,21 +267,18 @@ module Libs = struct List.iter (Lib_db.resolve_selects t.libs ~from:dir lib_deps) ~f:(fun { dst_fn; src_fn } -> let src = Path.relative dir src_fn in let dst = Path.relative dir dst_fn in - add_rule t ~targets:[dst] + add_rule t (Build.path src >>> - Build.action_context_independent + Build.action_context_independent ~targets:[dst] (Copy_and_add_line_directive (src, dst)))) - let write_deps fn = - Build.write_sexp fn (fun l -> Sexp.To_sexp.(list string) (List.map l ~f:Lib.best_name)) - let real_requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps = let all_pps = List.map (Preprocess_map.pps preprocess) ~f:Pp.to_string in - let requires_file = requires_file ~dir ~item in - add_rule t ~targets:[requires_file] + let vrequires = vrequires t ~dir ~item in + add_rule t (Build.record_lib_deps ~dir ~kind:dep_kind (List.map virtual_deps ~f:Lib_dep.direct) >>> Build.fanout @@ -277,8 +289,8 @@ module Libs = struct Build.arr (fun (libs, rt_deps) -> Lib.remove_dups_preserve_order (libs @ rt_deps)) >>> - write_deps requires_file); - load_deps t ~dir requires_file + Build.store_vfile vrequires); + Build.vpath vrequires let requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps = let real_requires = @@ -302,8 +314,8 @@ module Libs = struct (requires, real_requires) let setup_runtime_deps t ~dir ~dep_kind ~item ~libraries ~ppx_runtime_libraries = - let runtime_deps_file = runtime_deps_file ~dir ~item in - add_rule t ~targets:[runtime_deps_file] + let vruntime_deps = vruntime_deps t ~dir ~item in + add_rule t (Build.fanout (closure t ~dir ~dep_kind (List.map ppx_runtime_libraries ~f:Lib_dep.direct)) (closed_ppx_runtime_deps_of t ~dir ~dep_kind libraries) @@ -311,7 +323,7 @@ module Libs = struct Build.arr (fun (rt_deps, rt_deps_of_deps) -> Lib.remove_dups_preserve_order (rt_deps @ rt_deps_of_deps)) >>> - write_deps runtime_deps_file) + Build.store_vfile vruntime_deps) end module Deps = struct @@ -355,17 +367,24 @@ end module Pkg_version = struct open Build.O - let spec_file sctx (p : Package.t) = - Path.relative (Path.append sctx.context.build_dir p.path) - (sprintf "%s.version.sexp" p.name) + module V = Vfile_kind.Make(struct type t = string option end) + (functor (C : Sexp.Combinators) -> struct + let t = C.option C.string + end) - let read sctx p = Build.read_sexp (spec_file sctx p) Sexp.Of_sexp.(option string) + let spec sctx (p : Package.t) = + let fn = + Path.relative (Path.append sctx.context.build_dir p.path) + (sprintf "%s.version.sexp" p.name) + in + Build.Vspec.T (fn, (module V)) + + let read sctx p = Build.vpath (spec sctx p) let set sctx p get = - let fn = spec_file sctx p in - add_rule sctx ~targets:[fn] - (get >>> Build.write_sexp fn Sexp.To_sexp.(option string)); - Build.read_sexp fn Sexp.Of_sexp.(option string) + let spec = spec sctx p in + add_rule sctx (get >>> Build.store_vfile spec); + Build.vpath spec end module Action = struct @@ -491,7 +510,7 @@ module Action = struct U.expand sctx.context dir t ~f:(expand_var sctx ~artifacts ~targets ~deps)) >>> - Build.action_dyn () ~context:sctx.context ~dir + Build.action_dyn () ~context:sctx.context ~dir ~targets in match forms.failures with | [] -> build @@ -580,13 +599,13 @@ module PP = struct | Some _ -> libs in - add_rule sctx ~targets:[target] + add_rule sctx (libs >>> Build.dyn_paths (Build.arr (Lib.archive_files ~mode ~ext_lib:ctx.ext_lib)) >>> Build.run ~context:ctx (Dep compiler) - [ A "-o" ; Path target + [ A "-o" ; Target target ; Dyn (Lib.link_flags ~mode) ]) @@ -624,37 +643,32 @@ module PP = struct let setup_reason_rules sctx ~dir (m : Module.t) = let ctx = sctx.context in let refmt = resolve_program sctx "refmt" ~hint:"opam install reason" in - let refmt src target = + let rule src target = let src_path = Path.relative dir src in - let target = Path.relative dir target in - add_rule sctx ~targets:[target] - (Build.run ~context:ctx refmt - [ A "--print" - ; A "binary" - ; Dep src_path ] - ~stdout_to:target) - in + Build.run ~context:ctx refmt + [ A "--print" + ; A "binary" + ; Dep src_path ] + ~stdout_to:(Path.relative dir target) in let impl = match m.impl.syntax with | OCaml -> m.impl | Reason -> let ml = Module.File.to_ocaml m.impl in - refmt m.impl.name ml.name; - ml - in + add_rule sctx (rule m.impl.name ml.name); + ml in let intf = Option.map m.intf ~f:(fun f -> match f.syntax with | OCaml -> f | Reason -> let mli = Module.File.to_ocaml f in - refmt f.name mli.name; - mli) - in + add_rule sctx (rule f.name mli.name); + mli) in { m with impl ; intf } - (* Generate rules to build the .pp files and return a new module map - where all filenames point to the .pp files *) + (* Generate rules to build the .pp files and return a new module map where all filenames + point to the .pp files *) let pped_modules sctx ~dir ~dep_kind ~modules ~preprocess ~preprocessor_deps ~lib_name ~package_context = let preprocessor_deps = Deps.interpret sctx ~dir preprocessor_deps in @@ -664,7 +678,7 @@ module PP = struct | No_preprocessing -> m | Action action -> pped_module m ~dir ~f:(fun _kind src dst -> - add_rule sctx ~targets:[dst] + add_rule sctx (preprocessor_deps >>> Build.path src @@ -683,7 +697,7 @@ module PP = struct | Pps { pps; flags } -> let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in pped_module m ~dir ~f:(fun kind src dst -> - add_rule sctx ~targets:[dst] + add_rule sctx (preprocessor_deps >>> Build.run ~context:sctx.context @@ -691,7 +705,7 @@ module PP = struct [ As flags ; A "--dump-ast" ; As (cookie_library_name lib_name) - ; A "-o"; Path dst + ; A "-o"; Target dst ; Ml_kind.ppx_driver_flag kind; Dep src ]) ) diff --git a/src/super_context.mli b/src/super_context.mli index 2c2f31ea..3223c1f3 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -42,7 +42,8 @@ val cxx_flags : t -> string list val expand_var_no_root : t -> string -> string option val expand_vars : t -> dir:Path.t -> String_with_vars.t -> string -val add_rule : t -> ?sandbox:bool -> targets:Path.t list -> (unit, Action.t) Build.t -> unit +val add_rule : t -> ?sandbox:bool -> (unit, Action.t) Build.t -> unit +val add_rules : t -> ?sandbox:bool -> (unit, Action.t) Build.t list -> unit val rules : t -> Build_interpret.Rule.t list val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml new file mode 100644 index 00000000..3a3092c3 --- /dev/null +++ b/src/vfile_kind.ml @@ -0,0 +1,78 @@ +open Import + +module Id = struct + type 'a tag = .. + + module type S = sig + type t + type 'a tag += X : t tag + end + + type 'a t = (module S with type t = 'a) + + let create (type a) () = + let module M = struct + type t = a + type 'a tag += X : t tag + end in + (module M : S with type t = a) + + let eq (type a) (type b) + (module A : S with type t = a) + (module B : S with type t = b) + : (a, b) eq option = + match A.X with + | B.X -> Some Eq + | _ -> None +end + +module type S = sig + type t + + val id : t Id.t + + val load : Path.t -> t + val to_string : Path.t -> t -> string +end + +type 'a t = (module S with type t = 'a) + +let eq (type a) (type b) + (module A : S with type t = a) + (module B : S with type t = b) = + Id.eq A.id B.id + +module Make_full + (T : sig type t end) + (To_sexp : sig val t : Path.t -> T.t -> Sexp.t end) + (Of_sexp : sig val t : Path.t -> Sexp.Ast.t -> T.t end) + : S with type t = T.t = +struct + type t = T.t + + let id = Id.create () + + let to_string path x = To_sexp.t path x |> Sexp.to_string + + let load path = + Of_sexp.t path (Sexp_load.single (Path.to_string path)) +end + + +module Make + (T : sig type t end) + (F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end) + : S with type t = T.t = +struct + module Of_sexp = struct + include F(Sexp.Of_sexp) + let t _ sexp = t sexp + end + module To_sexp = struct + include F(Sexp.To_sexp) + let t _ x = t x + end + + include Make_full(T)(To_sexp)(Of_sexp) +end + diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli new file mode 100644 index 00000000..447b910d --- /dev/null +++ b/src/vfile_kind.mli @@ -0,0 +1,31 @@ +open Import + +module Id : sig + type 'a t + + val eq : 'a t -> 'b t -> ('a, 'b) eq option +end + +module type S = sig + type t + + val id : t Id.t + + val load : Path.t -> t + val to_string : Path.t -> t -> string +end + +type 'a t = (module S with type t = 'a) + +val eq : 'a t -> 'b t -> ('a, 'b) eq option + +module Make + (T : sig type t end) + (F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end) + : S with type t = T.t + +module Make_full + (T : sig type t end) + (To_sexp : sig val t : Path.t -> T.t -> Sexp.t end) + (Of_sexp : sig val t : Path.t -> Sexp.Ast.t -> T.t end) + : S with type t = T.t