From 5f239a349fa699c51e72595ed125a8edd550f089 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 25 Jan 2017 15:41:22 +0000 Subject: [PATCH] 114.29+19 --- src/build.ml | 13 ++++- src/build.mli | 10 +++- src/build_system.ml | 4 ++ src/findlib.ml | 41 ++++++++++------ src/findlib.mli | 4 +- src/gen_rules.ml | 85 ++++++++++++++++++++------------- src/import.ml | 6 +++ src/jbuild_types.ml | 43 +++++++++++++++-- src/lib_db.ml | 113 ++++++++++++++++++++++++++++++++++---------- src/lib_db.mli | 14 +++++- 10 files changed, 251 insertions(+), 82 deletions(-) diff --git a/src/build.ml b/src/build.ml index 686bf831..4ee35516 100644 --- a/src/build.ml +++ b/src/build.ml @@ -32,6 +32,7 @@ module Repr = struct | 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 -> ('a, 'a) t end include Repr let repr t = t @@ -49,8 +50,14 @@ let merge_lib_deps a b = let arr f = Arr f let return x = Arr (fun () -> x) -let record_lib_deps ~dir ~kind names = - Record_lib_deps (dir, String_map.of_alist_exn (List.map names ~f:(fun n -> (n, kind)))) +let record_lib_deps ~dir ~kind lib_deps = + Record_lib_deps + (dir, + List.concat_map lib_deps ~f:(function + | Jbuild_types.Lib_dep.Direct s -> [(s, kind)] + | Select { choices; _ } -> + List.map choices ~f:(fun c -> (c.Jbuild_types.Lib_dep.dep, Optional))) + |> String_map.of_alist_exn) module O = struct let ( >>> ) a b = @@ -89,6 +96,8 @@ let paths_glob ~dir re = Paths_glob (dir, re) let vpath vp = Vpath vp let dyn_paths t = Dyn_paths t +let fail x = Fail x + let files_recursively_in ~dir = let ctx_dir, src_dir = match Path.extract_build_context_dir dir with diff --git a/src/build.mli b/src/build.mli index b27b6703..1309ccd1 100644 --- a/src/build.mli +++ b/src/build.mli @@ -45,6 +45,9 @@ val vpath : 'a Vspec.t -> (unit, 'a) t val dyn_paths : ('a, Path.t list) t -> ('a, 'a) t +(** Always fail when executed. We pass a function rather than an exception to get a proper + backtrace *) +val fail : fail -> ('a, 'a) t module Prog_spec : sig type 'a t = @@ -86,7 +89,11 @@ type lib_dep_kind = | Optional | Required -val record_lib_deps : dir:Path.t -> kind:lib_dep_kind -> string list -> ('a, 'a) t +val record_lib_deps + : dir:Path.t + -> kind:lib_dep_kind + -> Jbuild_types.Lib_dep.t list + -> ('a, 'a) t type lib_deps = lib_dep_kind String_map.t @@ -108,6 +115,7 @@ module Repr : sig | 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 -> ('a, 'a) t end val repr : ('a, 'b) t -> ('a, 'b) Repr.t diff --git a/src/build_system.ml b/src/build_system.ml index b6f72406..faf43b17 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -177,6 +177,7 @@ module Build_interpret = struct end | Dyn_paths t -> loop t acc | Record_lib_deps _ -> acc + | Fail _ -> acc in loop t Pset.empty @@ -203,6 +204,7 @@ module Build_interpret = struct | Some others -> Build.merge_lib_deps deps others in Pmap.add acc ~key:dir ~data + | Fail _ -> acc in fun t -> loop t Pmap.empty @@ -223,6 +225,7 @@ module Build_interpret = struct | Paths_glob _ -> acc | Dyn_paths t -> loop t acc | Record_lib_deps _ -> acc + | Fail _ -> acc in fun t -> loop t [] @@ -264,6 +267,7 @@ module Build_interpret = struct all_unit (List.rev_map fns ~f:(wait_for_file bs ~targeting)) >>= fun () -> return x | Record_lib_deps _ -> return x + | Fail { fail } -> fail () in exec t x end diff --git a/src/findlib.ml b/src/findlib.ml index 68d5339e..2e959bb8 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -130,10 +130,14 @@ type package = ; has_headers : bool } +type present_or_absent = + | Present of package + | Absent + type t = { context : Context.t - ; packages : (string, package) Hashtbl.t - ; has_headers : (Path.t, bool ) Hashtbl.t + ; packages : (string, present_or_absent) Hashtbl.t + ; has_headers : (Path.t, bool ) Hashtbl.t } let has_headers t ~dir = @@ -309,8 +313,8 @@ let load_meta t root_name = let deps, missing_deps = List.partition_map deps ~f:(fun name -> match Hashtbl.find t.packages name with - | Some pkg -> Inl pkg - | None -> + | Some (Present pkg) -> Inl pkg + | None | Some Absent -> match String_map.find name packages with | None -> Inr (name, None) | Some pkg -> @@ -342,7 +346,7 @@ let load_meta t root_name = ; ppx_runtime_deps } in - Hashtbl.add t.packages ~key:pkg.name ~data:pkg + Hashtbl.add t.packages ~key:pkg.name ~data:(Present pkg) | _ -> let unknown_deps, hidden_deps = List.partition_map missing_deps ~f:(fun (name, pkg) -> @@ -367,26 +371,30 @@ let load_meta t root_name = let find_exn t name = match Hashtbl.find t.packages name with - | Some x -> x + | Some (Present x) -> x + | Some Absent -> raise (Package_not_found name) | None -> - load_meta t (root_package_name name); - match Hashtbl.find t.packages name with - | Some x -> x - | None -> raise (Package_not_found name) + match load_meta t (root_package_name name) with + | exception (Package_not_found _ as e) -> + Hashtbl.add t.packages ~key:name ~data:Absent; + raise e + | () -> + match Hashtbl.find t.packages name with + | Some (Present x) -> x + | Some Absent -> raise (Package_not_found name) + | None -> assert false let available t name = match find_exn t name with | _ -> true | exception (Package_not_found _) -> false -let closure t names = - let pkgs = List.map names ~f:(find_exn t) in +let closure pkgs = remove_dups_preserve_order (List.concat_map pkgs ~f:(fun pkg -> pkg.requires) @ pkgs) -let closed_ppx_runtime_deps_of t names = - let pkgs = List.map names ~f:(find_exn t) in +let closed_ppx_runtime_deps_of pkgs = remove_dups_preserve_order (List.concat_map pkgs ~f:(fun pkg -> pkg.ppx_runtime_deps)) @@ -408,5 +416,8 @@ let root_packages t = let all_packages t = List.iter (root_packages t) ~f:(fun pkg -> ignore (find_exn t pkg : package)); - Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:pkg ~data:_ acc -> pkg :: acc) + Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:pkg ~data acc -> + match data with + | Present _ -> pkg :: acc + | Absent -> acc) |> List.sort ~cmp:String.compare diff --git a/src/findlib.mli b/src/findlib.mli index b4abff98..a6699269 100644 --- a/src/findlib.mli +++ b/src/findlib.mli @@ -30,5 +30,5 @@ val available : t -> string -> bool val root_package_name : string -> string -val closure : t -> string list -> package list -val closed_ppx_runtime_deps_of : t -> string list -> package list +val closure : package list -> package list +val closed_ppx_runtime_deps_of : package list -> package list diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 3f808570..4f4cd1e2 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -133,39 +133,50 @@ module Gen(P : Params) = struct let load_runtime_deps ~dir ~item = Build.vpath (vruntime_deps ~dir ~item) - let closure ~dir ~dep_kind names = - let internals, externals = Lib_db.split t names in - Build.record_lib_deps ~dir ~kind:dep_kind names - >>> - Build.all - (List.map internals ~f:(fun ((dir, lib) : Lib.Internal.t) -> - load_requires ~dir ~item:lib.name)) - >>^ (fun internal_deps -> - let externals = - List.map (Findlib.closure findlib externals) ~f:(fun pkg -> - Lib.External pkg) - in - Lib.remove_dups_preserve_order - (List.concat (externals :: internal_deps) @ - List.map internals ~f:(fun x -> Lib.Internal x))) + let with_fail ~fail build = + match fail with + | None -> build + | Some f -> Build.fail f >>> build - let closed_ppx_runtime_deps_of ~dir ~dep_kind names = - let internals, externals = Lib_db.split t names in - Build.record_lib_deps ~dir ~kind:dep_kind names - >>> - Build.all - (List.map internals ~f:(fun ((dir, lib) : Lib.Internal.t) -> - load_runtime_deps ~dir ~item:lib.name)) - >>^ (fun libs -> - let externals = - List.map (Findlib.closed_ppx_runtime_deps_of findlib externals) ~f:(fun pkg -> - Lib.External pkg) - in - Lib.remove_dups_preserve_order (List.concat (externals :: libs))) + let closure ~dir ~dep_kind lib_deps = + let internals, externals, fail = Lib_db.interpret_lib_deps t ~dir lib_deps in + with_fail ~fail + (Build.record_lib_deps ~dir ~kind:dep_kind lib_deps + >>> + Build.all + (List.map internals ~f:(fun ((dir, lib) : Lib.Internal.t) -> + load_requires ~dir ~item:lib.name)) + >>^ (fun internal_deps -> + let externals = + List.map (Findlib.closure externals) ~f:(fun pkg -> + Lib.External pkg) + in + Lib.remove_dups_preserve_order + (List.concat (externals :: internal_deps) @ + List.map internals ~f:(fun x -> Lib.Internal x)))) + + let closed_ppx_runtime_deps_of ~dir ~dep_kind lib_deps = + let internals, externals, fail = Lib_db.interpret_lib_deps t ~dir lib_deps in + with_fail ~fail + (Build.record_lib_deps ~dir ~kind:dep_kind lib_deps + >>> + Build.all + (List.map internals ~f:(fun ((dir, lib) : Lib.Internal.t) -> + load_runtime_deps ~dir ~item:lib.name)) + >>^ (fun libs -> + let externals = + List.map (Findlib.closed_ppx_runtime_deps_of externals) + ~f:(fun pkg -> Lib.External pkg) + in + Lib.remove_dups_preserve_order (List.concat (externals :: libs)))) let internal_libs_without_non_installable_optional_ones = internal_libs_without_non_installable_optional_ones t + let select_rules ~dir lib_deps = + List.map (Lib_db.resolve_selects t lib_deps) ~f:(fun (fn, code) -> + Build.return code >>> Build.echo (Path.relative dir fn)) + (* Hides [t] so that we don't resolve things statically *) let t = () let _ = t @@ -183,7 +194,7 @@ module Gen(P : Params) = struct | None -> invalid_arg "Named_artifacts.in_findlib" | Some (pkg, _) -> pkg in - Build.record_lib_deps ~dir ~kind:dep_kind [pkg] + Build.record_lib_deps ~dir ~kind:dep_kind [Direct pkg] >>> (Build.arr (fun () -> in_findlib t name)) @@ -460,7 +471,8 @@ module Gen(P : Params) = struct let compiler = Option.value_exn (Mode.compiler mode ctx) in let libs = Build.fanout - (Lib_db.closure ~dir ~dep_kind ("ppx_driver" :: pp_names)) + (Lib_db.closure ~dir ~dep_kind (Direct "ppx_driver" :: + List.map pp_names ~f:Lib_dep.direct)) (Lib_db.find runner) >>^ (fun (libs, runner) -> let runner_name = Lib.best_name runner in @@ -583,11 +595,12 @@ module Gen(P : Params) = struct in let vrequires = Lib_db.vrequires ~dir ~item in add_rule - (Build.record_lib_deps ~dir ~kind:dep_kind virtual_deps + (Build.record_lib_deps ~dir ~kind:dep_kind (List.map virtual_deps ~f:Lib_dep.direct) >>> Build.fanout (Lib_db.closure ~dir ~dep_kind libraries) - (Lib_db.closed_ppx_runtime_deps_of ~dir ~dep_kind all_pps) + (Lib_db.closed_ppx_runtime_deps_of ~dir ~dep_kind + (List.map all_pps ~f:Lib_dep.direct)) >>> Build.arr (fun (libs, rt_deps) -> Lib.remove_dups_preserve_order (libs @ rt_deps)) @@ -599,7 +612,7 @@ module Gen(P : Params) = struct let vruntime_deps = Lib_db.vruntime_deps ~dir ~item in add_rule (Build.fanout - (Lib_db.closure ~dir ~dep_kind ppx_runtime_libraries) + (Lib_db.closure ~dir ~dep_kind (List.map ppx_runtime_libraries ~f:Lib_dep.direct)) (Lib_db.closed_ppx_runtime_deps_of ~dir ~dep_kind libraries) >>> Build.arr (fun (rt_deps, rt_deps_of_deps) -> @@ -949,6 +962,7 @@ module Gen(P : Params) = struct setup_runtime_deps ~dir ~dep_kind ~item:lib.name ~libraries:lib.libraries ~ppx_runtime_libraries:lib.ppx_runtime_libraries; + List.iter (Lib_db.select_rules ~dir lib.libraries) ~f:add_rule; build_modules ~flags ~dir ~dep_graph ~modules ~requires ~alias_module; Option.iter alias_module ~f:(fun m -> @@ -1098,6 +1112,7 @@ module Gen(P : Params) = struct ~preprocess:exes.preprocess ~virtual_deps:[] in + List.iter (Lib_db.select_rules ~dir exes.libraries) ~f:add_rule; build_modules ~flags ~dir ~dep_graph ~modules ~requires ~alias_module:None; @@ -1379,6 +1394,10 @@ module Gen(P : Params) = struct | Ocamllex conf -> List.map conf.names ~f:(fun name -> name ^ ".ml") | Ocamlyacc conf -> List.concat_map conf.names ~f:(fun name -> [ name ^ ".ml"; name ^ ".mli" ]) + | Library { libraries; _ } | Executables { libraries; _ } -> + List.filter_map libraries ~f:(function + | Direct _ -> None + | Select s -> Some s.result_fn) | _ -> []) |> String_set.of_list in diff --git a/src/import.ml b/src/import.ml index 4db03e0a..bbf0cdb5 100644 --- a/src/import.ml +++ b/src/import.ml @@ -61,6 +61,11 @@ module List = struct match f x with | None -> find_map l ~f | Some _ as res -> res + + let rec find l ~f = + match l with + | [] -> None + | x :: l -> if f x then Some x else find l ~f end module Hashtbl = struct @@ -340,3 +345,4 @@ end = struct let stage t = t end +type fail = { fail : 'a. unit -> 'a } diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 508e0ecd..6699a6fa 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -290,6 +290,38 @@ module Js_of_ocaml = struct { flags; javascript_files }) end +module Lib_dep = struct + type choice = + { dep : string + ; code : string + } + + type t = + | Direct of string + | Select of { result_fn : string; choices : choice list } + + let choice = function + | List [Atom dep; Atom code] -> { dep; code } + | sexp -> of_sexp_error "( ) expected" sexp + + let t = function + | Atom s -> + Direct s + | List (Atom "select" :: m :: Atom "from" :: libs) -> + Select { result_fn = file m + ; choices = List.map libs ~f:choice + } + | sexp -> + of_sexp_error " or (select from ) expected" + sexp + + let to_lib_names = function + | Direct s -> [s] + | Select s -> (List.map s.choices ~f:(fun x -> x.dep)) + + let direct s = Direct s +end + module Library = struct module Kind = struct type t = @@ -310,7 +342,7 @@ module Library = struct ; public_name : string option ; synopsis : string option ; install_c_headers : string list - ; libraries : string list + ; libraries : Lib_dep.t list ; ppx_runtime_libraries : string list ; modes : Mode.t list ; kind : Kind.t @@ -342,7 +374,7 @@ module Library = struct ; field_o "public_name" string ; field_o "synopsis" string ; field "install_c_headers" (list string) ~default:[] - ; field "libraries" (list string) ~default:[] + ; field "libraries" (list Lib_dep.t) ~default:[] ; field "ppx_runtime_libraries" (list string) ~default:[] ; field_modules ; field_oslu "c_flags" @@ -410,6 +442,9 @@ module Library = struct let stubs_archive t ~dir ~ext_lib = Path.relative dir (sprintf "lib%s_stubs%s" t.name ext_lib) + + let all_lib_deps t = + List.map t.virtual_deps ~f:(fun s -> Lib_dep.Direct s) @ t.libraries end module Executables = struct @@ -418,7 +453,7 @@ module Executables = struct ; object_public_name : string option ; synopsis : string option ; link_executables : bool - ; libraries : string list + ; libraries : Lib_dep.t list ; link_flags : string list ; modules : Ordered_set_lang.t ; preprocess : Preprocess_map.t @@ -434,7 +469,7 @@ module Executables = struct ; field_o "object_public_name" string ; field_o "synopsis" string ; field "link_executables" bool ~default:true - ; field "libraries" (list string) ~default:[] + ; field "libraries" (list Lib_dep.t) ~default:[] ; field "link_flags" (list string) ~default:[] ; field_modules ; field_pp "preprocess" diff --git a/src/lib_db.ml b/src/lib_db.ml index 7ab4b601..0754f387 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -2,9 +2,9 @@ open Import open Jbuild_types type t = - { findlib : Findlib.t - ; libs : (string, Lib.t) Hashtbl.t - ; internals_top_sorted : Lib.Internal.t list + { findlib : Findlib.t + ; libs : (string, Lib.t) Hashtbl.t + ; instalable_internal_libs : Lib.Internal.t String_map.t } let find t name = @@ -20,19 +20,13 @@ let find_internal t name = | Some (Internal (dir, lib)) -> Some (dir, lib) | _ -> None -let split t names = - List.partition_map names ~f:(fun name -> - match find_internal t name with - | Some x -> Inl x - | None -> Inr name) - module Local_closure = Top_closure.Make(String)(struct type graph = t type t = Lib.Internal.t let key ((_, lib) : t) = lib.name let deps ((_, lib) : Lib.Internal.t) graph = - List.filter_map lib.libraries ~f:(fun dep -> - find_internal graph dep) + List.concat_map lib.libraries ~f:(fun dep -> + List.filter_map (Lib_dep.to_lib_names dep) ~f:(find_internal graph)) end) let top_sort_internals t = @@ -49,6 +43,30 @@ let top_sort_internals t = (List.map cycle ~f:(fun lib -> Lib.describe (Internal lib)) |> String.concat ~sep:"\n-> ") +module Compute_instalable_internal_libs = struct + let lib_is_installable t ~internal_instalable_libs name = + match find_internal t name with + | Some (_, lib) -> String_map.mem lib.name internal_instalable_libs + | None -> Findlib.available t.findlib name + + let dep_is_installable t ~internal_instalable_libs dep = + match (dep : Lib_dep.t) with + | Direct s -> lib_is_installable t s ~internal_instalable_libs + | Select { choices; _ } -> + List.exists choices ~f:(fun c -> + lib_is_installable t ~internal_instalable_libs c.Lib_dep.dep) + + let compute t = + List.fold_left (top_sort_internals t) ~init:String_map.empty + ~f:(fun acc (dir, lib) -> + if not lib.Library.optional || + List.for_all (Library.all_lib_deps lib) + ~f:(dep_is_installable t ~internal_instalable_libs:acc) then + String_map.add acc ~key:lib.name ~data:(dir, lib) + else + acc) +end + let create findlib stanzas = let libs : (string, Lib.t) Hashtbl.t = Hashtbl.create 1024 in List.iter stanzas ~f:(fun (dir, stanzas) -> @@ -60,18 +78,65 @@ let create findlib stanzas = Option.iter lib.public_name ~f:(fun name -> Hashtbl.add libs ~key:name ~data) | _ -> ())); - let t = { findlib; libs; internals_top_sorted = [] } in - let internals_top_sorted = top_sort_internals t in - { t with internals_top_sorted } + let t = { findlib; libs; instalable_internal_libs = String_map.empty } in + { t with instalable_internal_libs = + Compute_instalable_internal_libs.compute t } let internal_libs_without_non_installable_optional_ones t = - List.fold_left t.internals_top_sorted ~init:String_map.empty - ~f:(fun acc (dir, lib) -> - if not lib.Library.optional || ( - let int_deps, ext_deps = split t (lib.virtual_deps @ lib.libraries) in - List.for_all int_deps ~f:(fun (_, dep) -> String_map.mem dep.Library.name acc) && - List.for_all ext_deps ~f:(Findlib.available t.findlib)) then - String_map.add acc ~key:lib.name ~data:(dir, lib) - else - acc) - |> String_map.values + String_map.values t.instalable_internal_libs + +let find_either t name = + match find t name with + | x -> Inl x + | exception e -> + (* Call [find] again to get a proper backtrace *) + Inr { fail = fun () -> ignore (find t name : Lib.t); raise e } + +let interpret_lib_deps t ~dir lib_deps = + let libs, failures = + List.partition_map lib_deps ~f:(function + | Lib_dep.Direct s -> find_either t s + | Select { result_fn; choices } -> + match + List.find_map choices ~f:(fun s -> + match find_either t s.dep with + | Inl _ as x -> Some x + | Inr _ -> None) + with + | Some res -> res + | None -> + Inr { fail = fun () -> + die "\ +No solution found for the following form in %s: + (select %s from + %s)" + (Path.to_string dir) + result_fn + (String.concat ~sep:"\n " + (List.map choices ~f:(fun c -> c.Lib_dep.dep))) + }) + in + let internals, externals = + List.partition_map libs ~f:(function + | Internal x -> Inl x + | External x -> Inr x) + in + (internals, externals, + match failures with + | [] -> None + | f :: _ -> Some f) + +let resolve_selects t lib_deps = + List.filter_map lib_deps ~f:(function + | Lib_dep.Direct _ -> None + | Select { result_fn; choices } -> + let contents = + match List.find_map choices ~f:(fun s -> + match find_either t s.dep with + | Inl _ -> Some s.code + | Inr _ -> None) + with + | Some code -> code + | None -> "no solution found" + in + Some (result_fn, contents)) diff --git a/src/lib_db.mli b/src/lib_db.mli index 362bb9ae..cdaec544 100644 --- a/src/lib_db.mli +++ b/src/lib_db.mli @@ -1,5 +1,7 @@ (** Where libraries are *) +open Import + type t val create : Findlib.t -> (Path.t * Jbuild_types.Stanza.t list) list -> t @@ -7,6 +9,16 @@ val create : Findlib.t -> (Path.t * Jbuild_types.Stanza.t list) list -> t val find : t -> string -> Lib.t val find_internal : t -> string -> Lib.Internal.t option -val split : t -> string list -> Lib.Internal.t list * string list val internal_libs_without_non_installable_optional_ones : t -> Lib.Internal.t list + +val interpret_lib_deps + : t + -> dir:Path.t + -> Jbuild_types.Lib_dep.t list + -> Lib.Internal.t list * Findlib.package list * fail option + +val resolve_selects + : t + -> Jbuild_types.Lib_dep.t list + -> (string * string) list