From e73fd90b65c912045a22245ece86978f2d88b15a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Sun, 14 May 2017 08:48:22 +0100 Subject: [PATCH] Get rid of Vfile replace it by just memoize --- src/build.ml | 45 +++++++++++-------- src/build.mli | 18 +++----- src/build_interpret.ml | 36 +++------------- src/build_interpret.mli | 13 +----- src/build_system.ml | 96 ++++++++--------------------------------- src/ocamldep.ml | 17 ++------ src/super_context.ml | 75 +++++++++++++------------------- src/vfile_kind.ml | 78 --------------------------------- src/vfile_kind.mli | 31 ------------- 9 files changed, 94 insertions(+), 315 deletions(-) delete mode 100644 src/vfile_kind.ml delete mode 100644 src/vfile_kind.mli diff --git a/src/build.ml b/src/build.ml index 810e4cbe..ffbca685 100644 --- a/src/build.ml +++ b/src/build.ml @@ -2,10 +2,6 @@ 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 @@ -25,8 +21,7 @@ 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 + | Targets : Path.Set.t -> ('a, 'a) 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 @@ -38,7 +33,6 @@ 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 @@ -125,7 +119,6 @@ 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 @@ -147,11 +140,24 @@ let file_exists_opt p t = let fail ?targets x = match targets with | None -> Fail x - | Some l -> Targets l >>> Fail x + | Some l -> Targets (Pset.of_list 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 @@ -160,8 +166,6 @@ 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) @@ -187,7 +191,7 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[]) let targets = Arg_spec.add_targets args extra_targets in prog_and_args ~dir prog args >>> - Targets targets + Targets (Pset.of_list targets) >>^ (fun (prog, args) -> let action : Action.Mini_shexp.t = Run (prog, args) in let action = @@ -202,17 +206,17 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[]) }) let action ~context ?(dir=context.Context.build_dir) ~targets action = - Targets targets + Targets (Pset.of_list targets) >>^ fun () -> { Action. context = Some context; dir; action } let action_dyn ~context ?(dir=context.Context.build_dir) ~targets () = - Targets targets + Targets (Pset.of_list targets) >>^ fun action -> { Action. context = Some context; dir; action } let action_context_independent ?(dir=Path.root) ~targets action = - Targets targets + Targets (Pset.of_list targets) >>^ fun () -> { Action. context = None; dir; action } @@ -220,7 +224,7 @@ let update_file fn s = action_context_independent ~targets:[fn] (Update_file (fn, s)) let update_file_dyn fn = - Targets [fn] + Targets (Pset.singleton fn) >>^ fun s -> { Action. context = None @@ -228,6 +232,11 @@ let update_file_dyn fn = ; action = Update_file (fn, s) } +let write_sexp path to_sexp = + arr (fun x -> Sexp.to_string (to_sexp x)) + >>> + update_file_dyn path + let copy ~src ~dst = path src >>> action_context_independent ~targets:[dst] (Copy (src, dst)) @@ -240,7 +249,7 @@ let create_file fn = action_context_independent ~targets:[fn] (Create_file fn) let and_create_file fn = - Targets [fn] + Targets (Pset.singleton 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 2a35aaa2..9616efff 100644 --- a/src/build.mli +++ b/src/build.mli @@ -8,12 +8,6 @@ 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 @@ -38,7 +32,9 @@ 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 vpath : 'a Vspec.t -> (unit, '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 dyn_paths : ('a, Path.t list) t -> ('a, 'a) t @@ -65,9 +61,9 @@ val file_exists_opt : Path.t -> ('a, 'b) t -> ('a, 'b option) t backtrace *) 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 : string -> (unit, 'a) t -> (unit, 'a) t +val memoize : name:string -> (unit, 'a) t -> (unit, 'a) t module Prog_spec : sig type 'a t = @@ -137,8 +133,7 @@ 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 + | Targets : Path.Set.t -> ('a, 'a) 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 @@ -149,7 +144,6 @@ 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 e4d2a3cb..ee647f45 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -3,35 +3,18 @@ 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 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 | Split (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc) | Paths fns -> Pset.union fns acc - | Vpath (Vspec.T (fn, _)) -> Pset.add fn acc | Paths_glob (dir, re) -> begin match Pmap.find dir (Lazy.force all_targets_by_dir) with | None -> acc @@ -72,14 +55,12 @@ let lib_deps = 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 @@ -99,19 +80,16 @@ let lib_deps = 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 -> + let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = 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 + | Targets targets -> Pset.union acc targets | 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 @@ -122,20 +100,20 @@ let targets = match !state with | Decided _ -> code_errorf "Build_interpret.targets got decided if_file_exists" | Undecided (a, b) -> - match loop a [], loop b [] with - | [], [] -> acc - | _ -> + if Pset.is_empty (loop a Pset.empty) && Pset.is_empty (loop b Pset.empty) then + acc + else 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) [] + fun t -> loop (Build.repr t) Pset.empty module Rule = struct type t = { build : (unit, Action.t) Build.t - ; targets : Target.t list + ; targets : Path.Set.t ; sandbox : bool } diff --git a/src/build_interpret.mli b/src/build_interpret.mli index ba3d9c68..f44ce610 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -1,18 +1,9 @@ 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 : Target.t list + ; targets : Path.Set.t ; sandbox : bool } @@ -30,4 +21,4 @@ val lib_deps val targets : (_, _) Build.t - -> Target.t list + -> Path.Set.t diff --git a/src/build_system.ml b/src/build_system.ml index 9d3d96d9..707ecf2f 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -3,7 +3,6 @@ open Future module Pset = Path.Set module Pmap = Path.Map -module Vspec = Build.Vspec module Exec_status = struct module Starting = struct @@ -27,36 +26,9 @@ 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, File_spec.packed) Hashtbl.t + files : (Path.t, Rule.t) Hashtbl.t ; contexts : Context.t list ; (* Table from target to digest of [(deps, targets, action)] *) trace : (Path.t, Digest.t) Hashtbl.t @@ -133,8 +105,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 (File_spec.T file) = find_file_exn t targeting in - match file.rule.exec with + let rule = find_file_exn t targeting in + match rule.exec with | Not_started _ -> assert false | Running { for_file; _ } | Starting { for_file } -> if for_file = targeting then @@ -155,10 +127,10 @@ let wait_for_file t fn ~targeting = return () else die "file unavailable: %s" (Path.to_string fn) - | Some (File_spec.T file) -> - match file.rule.exec with + | Some rule -> + match rule.exec with | Not_started f -> - file.rule.exec <- Starting { for_file = targeting }; + rule.exec <- Starting { for_file = targeting }; let future = with_exn_handler (fun () -> f ~targeting:fn) ~handler:(fun exn backtrace -> @@ -166,7 +138,7 @@ let wait_for_file t fn ~targeting = | Build_error.E _ -> reraise exn | exn -> Build_error.raise t exn ~targeting:fn ~backtrace) in - file.rule.exec <- Running { for_file = targeting; future }; + rule.exec <- Running { for_file = targeting; future }; future | Running { future; _ } -> future | Starting _ -> @@ -176,8 +148,8 @@ let wait_for_file t fn ~targeting = if fn = targeting then acc else - let (File_spec.T file) = find_file_exn t targeting in - match file.rule.exec with + let rule = find_file_exn t targeting in + match rule.exec with | Not_started _ | Running _ -> assert false | Starting { for_file } -> build_loop acc for_file @@ -187,37 +159,16 @@ 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 bs t x = + let exec 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 -> @@ -239,9 +190,6 @@ 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); @@ -265,17 +213,13 @@ module Build_exec = struct (action, !dyn_deps) end -let add_spec t fn spec ~allow_override = +let add_rule t fn rule ~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:spec + Hashtbl.add t.files ~key:fn ~data:rule -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) +let create_file_rules t targets rule ~allow_override = + Pset.iter targets ~f:(fun fn -> add_rule t fn rule ~allow_override) module Pre_rule = Build_interpret.Rule @@ -332,9 +276,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 = target_specs; sandbox } = pre_rule in + let { Pre_rule. build; targets; sandbox } = pre_rule in let deps = Build_interpret.deps build ~all_targets_by_dir in - let targets = Target.paths target_specs in if !Clflags.debug_rules then begin let f set = @@ -363,7 +306,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = make_local_parent_dirs t targets ~map_path:(fun x -> x); wait_for_deps t deps ~targeting >>= fun () -> - let action, dyn_deps = Build_exec.exec t build () in + let action, dyn_deps = Build_exec.exec build () in wait_for_deps t ~targeting (Pset.diff dyn_deps deps) >>= fun () -> let all_deps = Pset.union deps dyn_deps in @@ -471,7 +414,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = ; exec } in - create_file_specs t target_specs rule ~allow_override + create_file_rules t targets 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) -> @@ -544,8 +487,7 @@ let create ~contexts ~file_tree ~rules = in let all_other_targets = List.fold_left rules ~init:Pset.empty ~f:(fun acc { Pre_rule.targets; _ } -> - List.fold_left targets ~init:acc ~f:(fun acc target -> - Pset.add (Target.path target) acc)) + Pset.union acc targets) in let all_targets_by_dir = lazy ( Pset.elements (Pset.union all_copy_targets all_other_targets) @@ -617,7 +559,7 @@ let rules_for_files t paths = List.filter_map paths ~f:(fun path -> match Hashtbl.find t.files path with | None -> None - | Some (File_spec.T { rule; _ }) -> Some (path, rule)) + | Some rule -> Some (path, rule)) module File_closure = Top_closure.Make(Path) diff --git a/src/ocamldep.ml b/src/ocamldep.ml index b9a43f59..9fe12095 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -44,19 +44,10 @@ let parse_deps ~dir lines ~modules ~alias_module = die "`ocamldep` in %s returned %s several times" (Path.to_string dir) unit -module Ocamldep_vfile = - Vfile_kind.Make - (struct type t = string list String_map.t end) - (functor (C : Sexp.Combinators) -> struct - open C - let t = string_map (list string) - end) - let rules sctx ~ml_kind ~dir ~item ~modules ~alias_module = let suffix = Ml_kind.suffix ml_kind in - let vdepends = - let fn = Path.relative dir (sprintf "%s.depends%s.sexp" item suffix) in - Build.Vspec.T (fn, (module Ocamldep_vfile)) + let depends_file = + Path.relative dir (sprintf "%s.depends%s.sexp" item suffix) in let files = List.filter_map (String_map.values modules) ~f:(fun m -> Module.file ~dir m ml_kind) @@ -77,8 +68,8 @@ let rules sctx ~ml_kind ~dir ~item ~modules ~alias_module = SC.add_rule sctx (Build.lines_of ocamldep_output >>^ parse_deps ~dir ~modules ~alias_module - >>> Build.store_vfile vdepends); - Build.vpath vdepends + >>> Build.write_sexp depends_file Sexp.To_sexp.(string_map (list string))); + Build.read_sexp depends_file Sexp.Of_sexp.(string_map (list string)) module Dep_closure = Top_closure.Make(String)(struct diff --git a/src/super_context.ml b/src/super_context.ml index e502dbde..04d1cecd 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -21,7 +21,6 @@ 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 @@ -98,19 +97,6 @@ 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))) @@ -160,7 +146,6 @@ 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 @@ -172,9 +157,9 @@ 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 <- - 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 + 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 | None -> acc | Some (_, path) -> let dir = Path.parent path in @@ -206,19 +191,22 @@ module Libs = struct let find t ~from name = find t.libs ~from name - let vrequires t ~dir ~item = - let fn = Path.relative dir (item ^ ".requires.sexp") in - Build.Vspec.T (fn, t.libs_vfile) + 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 load_requires t ~dir ~item = - Build.vpath (vrequires t ~dir ~item) + load_deps t ~dir (requires_file ~dir ~item) - let vruntime_deps t ~dir ~item = - let fn = Path.relative dir (item ^ ".runtime-deps.sexp") in - Build.Vspec.T (fn, t.libs_vfile) + let runtime_deps_file ~dir ~item = + Path.relative dir (item ^ ".runtime-deps.sexp") let load_runtime_deps t ~dir ~item = - Build.vpath (vruntime_deps t ~dir ~item) + load_deps t ~dir (runtime_deps_file ~dir ~item) let with_fail ~fail build = match fail with @@ -273,11 +261,14 @@ module Libs = struct 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 vrequires = vrequires t ~dir ~item in + let requires_file = requires_file ~dir ~item in add_rule t (Build.record_lib_deps ~dir ~kind:dep_kind (List.map virtual_deps ~f:Lib_dep.direct) >>> @@ -289,8 +280,8 @@ module Libs = struct Build.arr (fun (libs, rt_deps) -> Lib.remove_dups_preserve_order (libs @ rt_deps)) >>> - Build.store_vfile vrequires); - Build.vpath vrequires + write_deps requires_file); + load_deps t ~dir requires_file let requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps = let real_requires = @@ -314,7 +305,7 @@ module Libs = struct (requires, real_requires) let setup_runtime_deps t ~dir ~dep_kind ~item ~libraries ~ppx_runtime_libraries = - let vruntime_deps = vruntime_deps t ~dir ~item in + let runtime_deps_file = runtime_deps_file ~dir ~item in add_rule t (Build.fanout (closure t ~dir ~dep_kind (List.map ppx_runtime_libraries ~f:Lib_dep.direct)) @@ -323,7 +314,7 @@ module Libs = struct Build.arr (fun (rt_deps, rt_deps_of_deps) -> Lib.remove_dups_preserve_order (rt_deps @ rt_deps_of_deps)) >>> - Build.store_vfile vruntime_deps) + write_deps runtime_deps_file) end module Deps = struct @@ -367,24 +358,16 @@ end module Pkg_version = struct open Build.O - module V = Vfile_kind.Make(struct type t = string option end) - (functor (C : Sexp.Combinators) -> struct - let t = C.option C.string - end) + let spec_file sctx (p : Package.t) = + Path.relative (Path.append sctx.context.build_dir p.path) + (sprintf "%s.version.sexp" p.name) - 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 read sctx p = Build.read_sexp (spec_file sctx p) Sexp.Of_sexp.(option string) let set sctx p get = - let spec = spec sctx p in - add_rule sctx (get >>> Build.store_vfile spec); - Build.vpath spec + let fn = spec_file sctx p in + add_rule sctx (get >>> Build.write_sexp fn Sexp.To_sexp.(option string)); + Build.read_sexp fn Sexp.Of_sexp.(option string) end module Action = struct diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml deleted file mode 100644 index 3a3092c3..00000000 --- a/src/vfile_kind.ml +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index 447b910d..00000000 --- a/src/vfile_kind.mli +++ /dev/null @@ -1,31 +0,0 @@ -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