114.29+19
This commit is contained in:
Jeremie Dimino
parent
42680ee945
commit
5f239a349f
13
src/build.ml
13
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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 "(<library-name> <code>) 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 "<library> or (select <module> from <libraries...>) 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"
|
||||
|
|
|
|||
113
src/lib_db.ml
113
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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue