add support for dependencies from monorepo, with x-orb-dependencies

This commit is contained in:
Hannes Mehnert 2022-12-27 22:31:35 +01:00
parent 337eb3ba61
commit c4e78e7124

View file

@ -85,26 +85,99 @@ let pp_graph ppf graph =
(Name_set.elements deps)))) (Name_set.elements deps))))
graph.nodes graph.nodes
let deps_of_opam =
let open OpamParserTypes.FullPos in
let ( let* ) = Result.bind in
let extract_pkg = function
| { pelem = String s ; _ } -> Ok (OpamPackage.Name.of_string s)
| _ -> Error (`Msg "expected a string")
in
let extract_list = function
| { pelem = List { pelem = deps ; _ } ; _ } ->
List.fold_left (fun acc d ->
let* acc = acc in
let* dep = extract_pkg d in
Ok (Name_set.add dep acc))
(Ok Name_set.empty) deps
| _ -> Error (`Msg "expected a list of strings")
in
let extract_deps = function
| { pelem = List { pelem = [ name ; deps ] ; _ } ; _ } ->
let* name = extract_pkg name in
let* deps = extract_list deps in
Ok (name, deps)
| { pelem = List { pelem = _lbody ; _ } ; _ } ->
Error (`Msg "expected exactly two strings")
| _ -> Error (`Msg "expected a pair of strings")
in
function
| { pelem = List { pelem = lbody ; _ } ; _ } ->
let* data =
List.fold_left (fun acc v ->
let* acc = acc in
let* deps = extract_deps v in
Ok (deps :: acc))
(Ok []) lbody
in
Ok (List.rev data)
| _ -> Error (`Msg "expected a list")
let retrieve_deps switch top =
let orb_deps = "x-orb-dependencies" in
let pkg_opam_file = opam_file switch top in
match OpamFile.OPAM.extended pkg_opam_file orb_deps deps_of_opam with
| None -> None
| Some Error `Msg _msg -> None
| Some Ok data ->
Some
(List.fold_left (fun acc (name, deps) ->
Name_map.add name deps acc)
Name_map.empty data)
let dependencies ~transitive (switch : OpamFile.SwitchExport.t) = let dependencies ~transitive (switch : OpamFile.SwitchExport.t) =
let root_pkg = root switch in let root_pkg = root switch in
let top = root_pkg.OpamPackage.name in let top = root_pkg.OpamPackage.name in
let graph = { top ; nodes = Name_map.empty } in let graph = { top ; nodes = Name_map.empty } in
let dep_map = retrieve_deps switch top in
let available = switch.selections.sel_installed in let available = switch.selections.sel_installed in
let rec find_deps graph work = let rec find_deps graph work =
match Name_set.choose_opt work with match Name_set.choose_opt work with
| None -> graph | None -> graph
| Some x -> | Some x ->
let deps = match transitive with let deps =
match dep_map with
| None ->
let deps =
match transitive with
| true -> transitive_dependencies switch x | true -> transitive_dependencies switch x
| false -> direct_dependencies switch x | false -> direct_dependencies switch x
in in
let deps =
deps deps
|> Name_set.filter (fun name -> |> Name_set.filter (fun name ->
OpamPackage.Set.exists OpamPackage.Set.exists
(fun pkg -> pkg.OpamPackage.name = name) (fun pkg -> pkg.OpamPackage.name = name)
available available
) )
| Some map ->
let rec find_it seen work acc =
match Name_set.choose_opt work with
| None -> acc
| Some x ->
let seen = Name_set.add x seen
and work = Name_set.remove x work
in
match Name_map.find_opt x map with
| None -> find_it seen work acc
| Some deps ->
let work =
if transitive then
Name_set.union deps work
else
work
in
find_it seen work (Name_set.union deps acc)
in
find_it Name_set.empty (Name_set.singleton x) Name_set.empty
in in
let graph = add_node graph x deps in let graph = add_node graph x deps in
let work = let work =