114.29+19
This commit is contained in:
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
|
| Vpath : 'a Vspec.t -> (unit, 'a) t
|
||||||
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
|
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
|
||||||
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
|
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
|
||||||
|
| Fail : fail -> ('a, 'a) t
|
||||||
end
|
end
|
||||||
include Repr
|
include Repr
|
||||||
let repr t = t
|
let repr t = t
|
||||||
|
@ -49,8 +50,14 @@ let merge_lib_deps a b =
|
||||||
let arr f = Arr f
|
let arr f = Arr f
|
||||||
let return x = Arr (fun () -> x)
|
let return x = Arr (fun () -> x)
|
||||||
|
|
||||||
let record_lib_deps ~dir ~kind names =
|
let record_lib_deps ~dir ~kind lib_deps =
|
||||||
Record_lib_deps (dir, String_map.of_alist_exn (List.map names ~f:(fun n -> (n, kind))))
|
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
|
module O = struct
|
||||||
let ( >>> ) a b =
|
let ( >>> ) a b =
|
||||||
|
@ -89,6 +96,8 @@ let paths_glob ~dir re = Paths_glob (dir, re)
|
||||||
let vpath vp = Vpath vp
|
let vpath vp = Vpath vp
|
||||||
let dyn_paths t = Dyn_paths t
|
let dyn_paths t = Dyn_paths t
|
||||||
|
|
||||||
|
let fail x = Fail x
|
||||||
|
|
||||||
let files_recursively_in ~dir =
|
let files_recursively_in ~dir =
|
||||||
let ctx_dir, src_dir =
|
let ctx_dir, src_dir =
|
||||||
match Path.extract_build_context_dir dir with
|
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
|
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
|
module Prog_spec : sig
|
||||||
type 'a t =
|
type 'a t =
|
||||||
|
@ -86,7 +89,11 @@ type lib_dep_kind =
|
||||||
| Optional
|
| Optional
|
||||||
| Required
|
| 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
|
type lib_deps = lib_dep_kind String_map.t
|
||||||
|
|
||||||
|
@ -108,6 +115,7 @@ module Repr : sig
|
||||||
| Vpath : 'a Vspec.t -> (unit, 'a) t
|
| Vpath : 'a Vspec.t -> (unit, 'a) t
|
||||||
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
|
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
|
||||||
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
|
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
|
||||||
|
| Fail : fail -> ('a, 'a) t
|
||||||
end
|
end
|
||||||
|
|
||||||
val repr : ('a, 'b) t -> ('a, 'b) Repr.t
|
val repr : ('a, 'b) t -> ('a, 'b) Repr.t
|
||||||
|
|
|
@ -177,6 +177,7 @@ module Build_interpret = struct
|
||||||
end
|
end
|
||||||
| Dyn_paths t -> loop t acc
|
| Dyn_paths t -> loop t acc
|
||||||
| Record_lib_deps _ -> acc
|
| Record_lib_deps _ -> acc
|
||||||
|
| Fail _ -> acc
|
||||||
in
|
in
|
||||||
loop t Pset.empty
|
loop t Pset.empty
|
||||||
|
|
||||||
|
@ -203,6 +204,7 @@ module Build_interpret = struct
|
||||||
| Some others -> Build.merge_lib_deps deps others
|
| Some others -> Build.merge_lib_deps deps others
|
||||||
in
|
in
|
||||||
Pmap.add acc ~key:dir ~data
|
Pmap.add acc ~key:dir ~data
|
||||||
|
| Fail _ -> acc
|
||||||
in
|
in
|
||||||
fun t -> loop t Pmap.empty
|
fun t -> loop t Pmap.empty
|
||||||
|
|
||||||
|
@ -223,6 +225,7 @@ module Build_interpret = struct
|
||||||
| Paths_glob _ -> acc
|
| Paths_glob _ -> acc
|
||||||
| Dyn_paths t -> loop t acc
|
| Dyn_paths t -> loop t acc
|
||||||
| Record_lib_deps _ -> acc
|
| Record_lib_deps _ -> acc
|
||||||
|
| Fail _ -> acc
|
||||||
in
|
in
|
||||||
fun t -> loop t []
|
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 () ->
|
all_unit (List.rev_map fns ~f:(wait_for_file bs ~targeting)) >>= fun () ->
|
||||||
return x
|
return x
|
||||||
| Record_lib_deps _ -> return x
|
| Record_lib_deps _ -> return x
|
||||||
|
| Fail { fail } -> fail ()
|
||||||
in
|
in
|
||||||
exec t x
|
exec t x
|
||||||
end
|
end
|
||||||
|
|
|
@ -130,10 +130,14 @@ type package =
|
||||||
; has_headers : bool
|
; has_headers : bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type present_or_absent =
|
||||||
|
| Present of package
|
||||||
|
| Absent
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ context : Context.t
|
{ context : Context.t
|
||||||
; packages : (string, package) Hashtbl.t
|
; packages : (string, present_or_absent) Hashtbl.t
|
||||||
; has_headers : (Path.t, bool ) Hashtbl.t
|
; has_headers : (Path.t, bool ) Hashtbl.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let has_headers t ~dir =
|
let has_headers t ~dir =
|
||||||
|
@ -309,8 +313,8 @@ let load_meta t root_name =
|
||||||
let deps, missing_deps =
|
let deps, missing_deps =
|
||||||
List.partition_map deps ~f:(fun name ->
|
List.partition_map deps ~f:(fun name ->
|
||||||
match Hashtbl.find t.packages name with
|
match Hashtbl.find t.packages name with
|
||||||
| Some pkg -> Inl pkg
|
| Some (Present pkg) -> Inl pkg
|
||||||
| None ->
|
| None | Some Absent ->
|
||||||
match String_map.find name packages with
|
match String_map.find name packages with
|
||||||
| None -> Inr (name, None)
|
| None -> Inr (name, None)
|
||||||
| Some pkg ->
|
| Some pkg ->
|
||||||
|
@ -342,7 +346,7 @@ let load_meta t root_name =
|
||||||
; ppx_runtime_deps
|
; ppx_runtime_deps
|
||||||
}
|
}
|
||||||
in
|
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 =
|
let unknown_deps, hidden_deps =
|
||||||
List.partition_map missing_deps ~f:(fun (name, pkg) ->
|
List.partition_map missing_deps ~f:(fun (name, pkg) ->
|
||||||
|
@ -367,26 +371,30 @@ let load_meta t root_name =
|
||||||
|
|
||||||
let find_exn t name =
|
let find_exn t name =
|
||||||
match Hashtbl.find t.packages name with
|
match Hashtbl.find t.packages name with
|
||||||
| Some x -> x
|
| Some (Present x) -> x
|
||||||
|
| Some Absent -> raise (Package_not_found name)
|
||||||
| None ->
|
| None ->
|
||||||
load_meta t (root_package_name name);
|
match load_meta t (root_package_name name) with
|
||||||
match Hashtbl.find t.packages name with
|
| exception (Package_not_found _ as e) ->
|
||||||
| Some x -> x
|
Hashtbl.add t.packages ~key:name ~data:Absent;
|
||||||
| None -> raise (Package_not_found name)
|
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 =
|
let available t name =
|
||||||
match find_exn t name with
|
match find_exn t name with
|
||||||
| _ -> true
|
| _ -> true
|
||||||
| exception (Package_not_found _) -> false
|
| exception (Package_not_found _) -> false
|
||||||
|
|
||||||
let closure t names =
|
let closure pkgs =
|
||||||
let pkgs = List.map names ~f:(find_exn t) in
|
|
||||||
remove_dups_preserve_order
|
remove_dups_preserve_order
|
||||||
(List.concat_map pkgs ~f:(fun pkg -> pkg.requires)
|
(List.concat_map pkgs ~f:(fun pkg -> pkg.requires)
|
||||||
@ pkgs)
|
@ pkgs)
|
||||||
|
|
||||||
let closed_ppx_runtime_deps_of t names =
|
let closed_ppx_runtime_deps_of pkgs =
|
||||||
let pkgs = List.map names ~f:(find_exn t) in
|
|
||||||
remove_dups_preserve_order
|
remove_dups_preserve_order
|
||||||
(List.concat_map pkgs ~f:(fun pkg -> pkg.ppx_runtime_deps))
|
(List.concat_map pkgs ~f:(fun pkg -> pkg.ppx_runtime_deps))
|
||||||
|
|
||||||
|
@ -408,5 +416,8 @@ let root_packages t =
|
||||||
let all_packages t =
|
let all_packages t =
|
||||||
List.iter (root_packages t) ~f:(fun pkg ->
|
List.iter (root_packages t) ~f:(fun pkg ->
|
||||||
ignore (find_exn t pkg : package));
|
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
|
|> List.sort ~cmp:String.compare
|
||||||
|
|
|
@ -30,5 +30,5 @@ val available : t -> string -> bool
|
||||||
|
|
||||||
val root_package_name : string -> string
|
val root_package_name : string -> string
|
||||||
|
|
||||||
val closure : t -> string list -> package list
|
val closure : package list -> package list
|
||||||
val closed_ppx_runtime_deps_of : t -> string 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 =
|
let load_runtime_deps ~dir ~item =
|
||||||
Build.vpath (vruntime_deps ~dir ~item)
|
Build.vpath (vruntime_deps ~dir ~item)
|
||||||
|
|
||||||
let closure ~dir ~dep_kind names =
|
let with_fail ~fail build =
|
||||||
let internals, externals = Lib_db.split t names in
|
match fail with
|
||||||
Build.record_lib_deps ~dir ~kind:dep_kind names
|
| None -> build
|
||||||
>>>
|
| Some f -> Build.fail f >>> build
|
||||||
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 closed_ppx_runtime_deps_of ~dir ~dep_kind names =
|
let closure ~dir ~dep_kind lib_deps =
|
||||||
let internals, externals = Lib_db.split t names in
|
let internals, externals, fail = Lib_db.interpret_lib_deps t ~dir lib_deps in
|
||||||
Build.record_lib_deps ~dir ~kind:dep_kind names
|
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) ->
|
Build.all
|
||||||
load_runtime_deps ~dir ~item:lib.name))
|
(List.map internals ~f:(fun ((dir, lib) : Lib.Internal.t) ->
|
||||||
>>^ (fun libs ->
|
load_requires ~dir ~item:lib.name))
|
||||||
let externals =
|
>>^ (fun internal_deps ->
|
||||||
List.map (Findlib.closed_ppx_runtime_deps_of findlib externals) ~f:(fun pkg ->
|
let externals =
|
||||||
Lib.External pkg)
|
List.map (Findlib.closure externals) ~f:(fun pkg ->
|
||||||
in
|
Lib.External pkg)
|
||||||
Lib.remove_dups_preserve_order (List.concat (externals :: libs)))
|
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 =
|
let internal_libs_without_non_installable_optional_ones =
|
||||||
internal_libs_without_non_installable_optional_ones t
|
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 *)
|
(* Hides [t] so that we don't resolve things statically *)
|
||||||
let t = ()
|
let t = ()
|
||||||
let _ = t
|
let _ = t
|
||||||
|
@ -183,7 +194,7 @@ module Gen(P : Params) = struct
|
||||||
| None -> invalid_arg "Named_artifacts.in_findlib"
|
| None -> invalid_arg "Named_artifacts.in_findlib"
|
||||||
| Some (pkg, _) -> pkg
|
| Some (pkg, _) -> pkg
|
||||||
in
|
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))
|
(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 compiler = Option.value_exn (Mode.compiler mode ctx) in
|
||||||
let libs =
|
let libs =
|
||||||
Build.fanout
|
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)
|
(Lib_db.find runner)
|
||||||
>>^ (fun (libs, runner) ->
|
>>^ (fun (libs, runner) ->
|
||||||
let runner_name = Lib.best_name runner in
|
let runner_name = Lib.best_name runner in
|
||||||
|
@ -583,11 +595,12 @@ module Gen(P : Params) = struct
|
||||||
in
|
in
|
||||||
let vrequires = Lib_db.vrequires ~dir ~item in
|
let vrequires = Lib_db.vrequires ~dir ~item in
|
||||||
add_rule
|
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
|
Build.fanout
|
||||||
(Lib_db.closure ~dir ~dep_kind libraries)
|
(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) ->
|
Build.arr (fun (libs, rt_deps) ->
|
||||||
Lib.remove_dups_preserve_order (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
|
let vruntime_deps = Lib_db.vruntime_deps ~dir ~item in
|
||||||
add_rule
|
add_rule
|
||||||
(Build.fanout
|
(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)
|
(Lib_db.closed_ppx_runtime_deps_of ~dir ~dep_kind libraries)
|
||||||
>>>
|
>>>
|
||||||
Build.arr (fun (rt_deps, rt_deps_of_deps) ->
|
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
|
setup_runtime_deps ~dir ~dep_kind ~item:lib.name
|
||||||
~libraries:lib.libraries
|
~libraries:lib.libraries
|
||||||
~ppx_runtime_libraries:lib.ppx_runtime_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;
|
build_modules ~flags ~dir ~dep_graph ~modules ~requires ~alias_module;
|
||||||
Option.iter alias_module ~f:(fun m ->
|
Option.iter alias_module ~f:(fun m ->
|
||||||
|
@ -1098,6 +1112,7 @@ module Gen(P : Params) = struct
|
||||||
~preprocess:exes.preprocess
|
~preprocess:exes.preprocess
|
||||||
~virtual_deps:[]
|
~virtual_deps:[]
|
||||||
in
|
in
|
||||||
|
List.iter (Lib_db.select_rules ~dir exes.libraries) ~f:add_rule;
|
||||||
|
|
||||||
build_modules ~flags ~dir ~dep_graph ~modules ~requires ~alias_module:None;
|
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")
|
| Ocamllex conf -> List.map conf.names ~f:(fun name -> name ^ ".ml")
|
||||||
| Ocamlyacc conf -> List.concat_map conf.names ~f:(fun name ->
|
| Ocamlyacc conf -> List.concat_map conf.names ~f:(fun name ->
|
||||||
[ name ^ ".ml"; name ^ ".mli" ])
|
[ 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
|
|> String_set.of_list
|
||||||
in
|
in
|
||||||
|
|
|
@ -61,6 +61,11 @@ module List = struct
|
||||||
match f x with
|
match f x with
|
||||||
| None -> find_map l ~f
|
| None -> find_map l ~f
|
||||||
| Some _ as res -> res
|
| 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
|
end
|
||||||
|
|
||||||
module Hashtbl = struct
|
module Hashtbl = struct
|
||||||
|
@ -340,3 +345,4 @@ end = struct
|
||||||
let stage t = t
|
let stage t = t
|
||||||
end
|
end
|
||||||
|
|
||||||
|
type fail = { fail : 'a. unit -> 'a }
|
||||||
|
|
|
@ -290,6 +290,38 @@ module Js_of_ocaml = struct
|
||||||
{ flags; javascript_files })
|
{ flags; javascript_files })
|
||||||
end
|
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 Library = struct
|
||||||
module Kind = struct
|
module Kind = struct
|
||||||
type t =
|
type t =
|
||||||
|
@ -310,7 +342,7 @@ module Library = struct
|
||||||
; public_name : string option
|
; public_name : string option
|
||||||
; synopsis : string option
|
; synopsis : string option
|
||||||
; install_c_headers : string list
|
; install_c_headers : string list
|
||||||
; libraries : string list
|
; libraries : Lib_dep.t list
|
||||||
; ppx_runtime_libraries : string list
|
; ppx_runtime_libraries : string list
|
||||||
; modes : Mode.t list
|
; modes : Mode.t list
|
||||||
; kind : Kind.t
|
; kind : Kind.t
|
||||||
|
@ -342,7 +374,7 @@ module Library = struct
|
||||||
; field_o "public_name" string
|
; field_o "public_name" string
|
||||||
; field_o "synopsis" string
|
; field_o "synopsis" string
|
||||||
; field "install_c_headers" (list string) ~default:[]
|
; 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 "ppx_runtime_libraries" (list string) ~default:[]
|
||||||
; field_modules
|
; field_modules
|
||||||
; field_oslu "c_flags"
|
; field_oslu "c_flags"
|
||||||
|
@ -410,6 +442,9 @@ module Library = struct
|
||||||
|
|
||||||
let stubs_archive t ~dir ~ext_lib =
|
let stubs_archive t ~dir ~ext_lib =
|
||||||
Path.relative dir (sprintf "lib%s_stubs%s" t.name 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
|
end
|
||||||
|
|
||||||
module Executables = struct
|
module Executables = struct
|
||||||
|
@ -418,7 +453,7 @@ module Executables = struct
|
||||||
; object_public_name : string option
|
; object_public_name : string option
|
||||||
; synopsis : string option
|
; synopsis : string option
|
||||||
; link_executables : bool
|
; link_executables : bool
|
||||||
; libraries : string list
|
; libraries : Lib_dep.t list
|
||||||
; link_flags : string list
|
; link_flags : string list
|
||||||
; modules : Ordered_set_lang.t
|
; modules : Ordered_set_lang.t
|
||||||
; preprocess : Preprocess_map.t
|
; preprocess : Preprocess_map.t
|
||||||
|
@ -434,7 +469,7 @@ module Executables = struct
|
||||||
; field_o "object_public_name" string
|
; field_o "object_public_name" string
|
||||||
; field_o "synopsis" string
|
; field_o "synopsis" string
|
||||||
; field "link_executables" bool ~default:true
|
; 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 "link_flags" (list string) ~default:[]
|
||||||
; field_modules
|
; field_modules
|
||||||
; field_pp "preprocess"
|
; field_pp "preprocess"
|
||||||
|
|
113
src/lib_db.ml
113
src/lib_db.ml
|
@ -2,9 +2,9 @@ open Import
|
||||||
open Jbuild_types
|
open Jbuild_types
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ findlib : Findlib.t
|
{ findlib : Findlib.t
|
||||||
; libs : (string, Lib.t) Hashtbl.t
|
; libs : (string, Lib.t) Hashtbl.t
|
||||||
; internals_top_sorted : Lib.Internal.t list
|
; instalable_internal_libs : Lib.Internal.t String_map.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let find t name =
|
let find t name =
|
||||||
|
@ -20,19 +20,13 @@ let find_internal t name =
|
||||||
| Some (Internal (dir, lib)) -> Some (dir, lib)
|
| Some (Internal (dir, lib)) -> Some (dir, lib)
|
||||||
| _ -> None
|
| _ -> 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
|
module Local_closure = Top_closure.Make(String)(struct
|
||||||
type graph = t
|
type graph = t
|
||||||
type t = Lib.Internal.t
|
type t = Lib.Internal.t
|
||||||
let key ((_, lib) : t) = lib.name
|
let key ((_, lib) : t) = lib.name
|
||||||
let deps ((_, lib) : Lib.Internal.t) graph =
|
let deps ((_, lib) : Lib.Internal.t) graph =
|
||||||
List.filter_map lib.libraries ~f:(fun dep ->
|
List.concat_map lib.libraries ~f:(fun dep ->
|
||||||
find_internal graph dep)
|
List.filter_map (Lib_dep.to_lib_names dep) ~f:(find_internal graph))
|
||||||
end)
|
end)
|
||||||
|
|
||||||
let top_sort_internals t =
|
let top_sort_internals t =
|
||||||
|
@ -49,6 +43,30 @@ let top_sort_internals t =
|
||||||
(List.map cycle ~f:(fun lib -> Lib.describe (Internal lib))
|
(List.map cycle ~f:(fun lib -> Lib.describe (Internal lib))
|
||||||
|> String.concat ~sep:"\n-> ")
|
|> 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 create findlib stanzas =
|
||||||
let libs : (string, Lib.t) Hashtbl.t = Hashtbl.create 1024 in
|
let libs : (string, Lib.t) Hashtbl.t = Hashtbl.create 1024 in
|
||||||
List.iter stanzas ~f:(fun (dir, stanzas) ->
|
List.iter stanzas ~f:(fun (dir, stanzas) ->
|
||||||
|
@ -60,18 +78,65 @@ let create findlib stanzas =
|
||||||
Option.iter lib.public_name ~f:(fun name ->
|
Option.iter lib.public_name ~f:(fun name ->
|
||||||
Hashtbl.add libs ~key:name ~data)
|
Hashtbl.add libs ~key:name ~data)
|
||||||
| _ -> ()));
|
| _ -> ()));
|
||||||
let t = { findlib; libs; internals_top_sorted = [] } in
|
let t = { findlib; libs; instalable_internal_libs = String_map.empty } in
|
||||||
let internals_top_sorted = top_sort_internals t in
|
{ t with instalable_internal_libs =
|
||||||
{ t with internals_top_sorted }
|
Compute_instalable_internal_libs.compute t }
|
||||||
|
|
||||||
let internal_libs_without_non_installable_optional_ones t =
|
let internal_libs_without_non_installable_optional_ones t =
|
||||||
List.fold_left t.internals_top_sorted ~init:String_map.empty
|
String_map.values t.instalable_internal_libs
|
||||||
~f:(fun acc (dir, lib) ->
|
|
||||||
if not lib.Library.optional || (
|
let find_either t name =
|
||||||
let int_deps, ext_deps = split t (lib.virtual_deps @ lib.libraries) in
|
match find t name with
|
||||||
List.for_all int_deps ~f:(fun (_, dep) -> String_map.mem dep.Library.name acc) &&
|
| x -> Inl x
|
||||||
List.for_all ext_deps ~f:(Findlib.available t.findlib)) then
|
| exception e ->
|
||||||
String_map.add acc ~key:lib.name ~data:(dir, lib)
|
(* Call [find] again to get a proper backtrace *)
|
||||||
else
|
Inr { fail = fun () -> ignore (find t name : Lib.t); raise e }
|
||||||
acc)
|
|
||||||
|> String_map.values
|
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 *)
|
(** Where libraries are *)
|
||||||
|
|
||||||
|
open Import
|
||||||
|
|
||||||
type t
|
type t
|
||||||
|
|
||||||
val create : Findlib.t -> (Path.t * Jbuild_types.Stanza.t list) list -> 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 : t -> string -> Lib.t
|
||||||
|
|
||||||
val find_internal : t -> string -> Lib.Internal.t option
|
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 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