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

Get rid of Vfile 

replace it by just memoize
This commit is contained in:
Jérémie Dimino 2017-05-14 08:48:22 +01:00
parent f5192122f8
commit e73fd90b65
9 changed files with 94 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
src/build.ml
View File

@ -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]

18
src/build.mli
View File

@ -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

36
src/build_interpret.ml
View File

@ -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
}

13
src/build_interpret.mli
View File

@ -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

96
src/build_system.ml
View File

@ -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)

17
src/ocamldep.ml
View File

@ -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

75
src/super_context.ml
View File

@ -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

78
src/vfile_kind.ml
View File

@ -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

31
src/vfile_kind.mli
View File

@ -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