474 lines
14 KiB
OCaml
474 lines
14 KiB
OCaml
|
|
let sprintf = Printf.sprintf
|
|
|
|
module Set = OpamPackage.Set
|
|
|
|
type package = OpamPackage.t
|
|
|
|
let packages (switch : OpamFile.SwitchExport.t) =
|
|
assert (Set.cardinal switch.selections.sel_pinned = 0);
|
|
assert (Set.cardinal switch.selections.sel_compiler = 0);
|
|
assert (Set.subset switch.selections.sel_roots switch.selections.sel_installed);
|
|
switch.selections.sel_installed
|
|
|
|
let root (switch : OpamFile.SwitchExport.t) =
|
|
assert (Set.cardinal switch.selections.sel_roots = 1);
|
|
Set.choose switch.selections.sel_roots
|
|
|
|
module Name_set = OpamPackage.Name.Set
|
|
|
|
let filtered_formula_to_pkgs (_switch : OpamFile.SwitchExport.t)
|
|
?(set = Name_set.empty) formula =
|
|
OpamFormula.fold_left (fun acc (name, _) -> Name_set.add name acc) set formula
|
|
|
|
let opam_file (switch : OpamFile.SwitchExport.t) pkg_name =
|
|
OpamPackage.Name.Map.find pkg_name switch.overlays
|
|
|
|
(* TODO depexts *)
|
|
(* TODO build / dev packages *)
|
|
(* TODO constraints (os = "linux") *)
|
|
let direct_dependencies (switch : OpamFile.SwitchExport.t) pkg =
|
|
let pkg_opam_file = opam_file switch pkg in
|
|
let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends pkg_opam_file) in
|
|
filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts pkg_opam_file)
|
|
|
|
let transitive_dependencies (switch : OpamFile.SwitchExport.t) pkg =
|
|
let available = switch.selections.sel_installed in
|
|
let rec aux pkg seen_pkgs =
|
|
let opam = opam_file switch pkg in
|
|
let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends opam) in
|
|
let set = filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam) in
|
|
let transitive_set =
|
|
let filtered_set =
|
|
set
|
|
|> Name_set.filter (fun name ->
|
|
OpamPackage.Set.exists
|
|
(fun pkg -> pkg.OpamPackage.name = name)
|
|
available
|
|
&& not (Name_set.mem name seen_pkgs)
|
|
)
|
|
in
|
|
let seen_pkgs = Name_set.union seen_pkgs filtered_set
|
|
in
|
|
filtered_set
|
|
|> Name_set.elements
|
|
|> List.concat_map (fun pkg -> aux pkg seen_pkgs |> Name_set.elements)
|
|
|> Name_set.of_list
|
|
in
|
|
Name_set.union set transitive_set
|
|
in
|
|
aux pkg Name_set.empty
|
|
|
|
module Name_map = OpamPackage.Name.Map
|
|
|
|
type graph = {
|
|
nodes : Name_set.t Name_map.t ;
|
|
top : OpamPackage.Name.t ;
|
|
}
|
|
|
|
let add_node graph pkg edges =
|
|
let nodes = Name_map.add pkg edges graph.nodes in
|
|
{ graph with nodes }
|
|
|
|
let pp_graph ppf graph =
|
|
Name_map.iter (fun pkg deps ->
|
|
let top = if pkg = graph.top then "ROOT " else "" in
|
|
Format.fprintf ppf "%s%s: %s@."
|
|
top (OpamPackage.Name.to_string pkg)
|
|
(String.concat ", " (List.map OpamPackage.Name.to_string
|
|
(Name_set.elements deps))))
|
|
graph.nodes
|
|
|
|
let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) =
|
|
let available = switch.selections.sel_installed in
|
|
let root_pkg = root switch in
|
|
let top = root_pkg.OpamPackage.name in
|
|
let graph = { top ; nodes = Name_map.empty } in
|
|
let available = switch.selections.sel_installed in
|
|
let rec find_deps graph work =
|
|
match Name_set.choose_opt work with
|
|
| None -> graph
|
|
| Some x ->
|
|
let deps = match transitive with
|
|
| true -> transitive_dependencies switch x
|
|
| false -> direct_dependencies switch x
|
|
in
|
|
let deps =
|
|
deps
|
|
|> Name_set.filter (fun name ->
|
|
OpamPackage.Set.exists
|
|
(fun pkg -> pkg.OpamPackage.name = name)
|
|
available
|
|
)
|
|
in
|
|
let graph = add_node graph x deps in
|
|
let work =
|
|
Name_set.diff
|
|
(Name_set.union (Name_set.remove x work) deps)
|
|
(Name_set.of_list (Name_map.keys graph.nodes))
|
|
in
|
|
find_deps graph work
|
|
in
|
|
find_deps graph (Name_set.singleton top)
|
|
|
|
(*!Note the first entry is seen as the root node*)
|
|
type assoc_node = {
|
|
name : string;
|
|
uniqueness_postfix : string;
|
|
}
|
|
type assoc_graph = (assoc_node * (assoc_node list)) list
|
|
|
|
module Ui = struct
|
|
|
|
let dependencies ?(transitive=true) data : assoc_graph =
|
|
(*> todo can be made more efficient*)
|
|
let all_direct_deps = dependencies data in
|
|
let root = all_direct_deps.top in
|
|
let root_str = OpamPackage.Name.to_string root
|
|
in
|
|
let direct_deps =
|
|
all_direct_deps.nodes
|
|
|> Name_map.find root
|
|
in
|
|
(*> todo can be made more efficient*)
|
|
let all_transitive_deps =
|
|
dependencies ~transitive data in
|
|
let direct_deps_w_transitive_deps =
|
|
direct_deps
|
|
|> Name_set.elements
|
|
|> List.map (fun direct_dep ->
|
|
let transitive_deps =
|
|
all_transitive_deps.nodes
|
|
|> Name_map.find_opt direct_dep
|
|
|> (function
|
|
| None -> Name_set.empty
|
|
| Some v -> v)
|
|
|> Name_set.elements
|
|
|> List.map OpamPackage.Name.to_string
|
|
in
|
|
let direct_dep = OpamPackage.Name.to_string direct_dep in
|
|
direct_dep, transitive_deps
|
|
)
|
|
in
|
|
let uniquified_deps =
|
|
direct_deps_w_transitive_deps
|
|
|> List.mapi (fun i (direct_dep, transitive_deps) ->
|
|
let direct_dep_node = {
|
|
name = direct_dep;
|
|
uniqueness_postfix = sprintf "%d" i;
|
|
}
|
|
and unique_transitive_deps =
|
|
transitive_deps
|
|
|> List.mapi (fun i' transitive_dep ->
|
|
let uniqueness_postfix = sprintf "%d.%d" i i' in
|
|
{ name = transitive_dep; uniqueness_postfix }
|
|
)
|
|
in
|
|
direct_dep_node, unique_transitive_deps
|
|
)
|
|
in
|
|
let unique_direct_deps = uniquified_deps |> List.map fst in
|
|
let root_node = { name = root_str; uniqueness_postfix = "" }
|
|
in
|
|
(root_node, unique_direct_deps) :: uniquified_deps
|
|
|
|
end
|
|
|
|
module Render = struct
|
|
|
|
module Dot = struct
|
|
|
|
type t = Odot.graph
|
|
|
|
let of_graph (graph:graph) : t =
|
|
let open Odot in
|
|
let stmt_list =
|
|
Name_map.fold (fun pkg deps acc ->
|
|
let stmt =
|
|
let pkg_id = Double_quoted_id (OpamPackage.Name.to_string pkg) in
|
|
let pkg_point = Edge_node_id (pkg_id, None) in
|
|
let deps_points =
|
|
Name_set.elements deps
|
|
|> List.map (fun p ->
|
|
let id = Double_quoted_id (OpamPackage.Name.to_string p) in
|
|
Edge_node_id (id, None)
|
|
)
|
|
in
|
|
let edge = pkg_point, deps_points, [] in
|
|
Stmt_edge edge
|
|
in
|
|
stmt :: acc
|
|
) graph.nodes []
|
|
in
|
|
{ strict = false; (*todo test params*)
|
|
kind = Digraph;
|
|
id = None;
|
|
stmt_list }
|
|
|
|
let id_of_assoc_node node =
|
|
sprintf "%s_%s" node.name node.uniqueness_postfix
|
|
|
|
let of_assoc (graph:assoc_graph) : t =
|
|
let open Odot in
|
|
let stmt_list =
|
|
graph
|
|
|> List.fold_left (fun acc (pkg, deps) ->
|
|
let stmt =
|
|
let pkg_id = Double_quoted_id (id_of_assoc_node pkg) in
|
|
let pkg_point = Edge_node_id (pkg_id, None) in
|
|
let deps_points =
|
|
deps
|
|
|> List.map (fun pkg ->
|
|
let id = Double_quoted_id (id_of_assoc_node pkg) in
|
|
Edge_node_id (id, None)
|
|
)
|
|
in
|
|
let edge = pkg_point, deps_points, [] in
|
|
Stmt_edge edge
|
|
in
|
|
stmt :: acc
|
|
) []
|
|
in
|
|
{ strict = false; (*todo test params*)
|
|
kind = Digraph;
|
|
id = None;
|
|
stmt_list }
|
|
|
|
let pp ppf dot =
|
|
Format.fprintf ppf "%s" (Odot.string_of_graph dot)
|
|
|
|
end
|
|
|
|
module Svg = struct
|
|
|
|
type t = Tyxml_svg.doc
|
|
|
|
module Svg = Tyxml_svg
|
|
|
|
(*> goto
|
|
* change svg width+height to pct again - using vw+vh for development
|
|
* svg width+height shouldn't be here for compatibility with user css?
|
|
*)
|
|
let css = {|
|
|
|
|
svg {
|
|
width : 100vw;
|
|
height : 100vh;
|
|
background : slategrey;
|
|
}
|
|
|
|
line {
|
|
stroke-width: 0.004;
|
|
stroke: bisque;
|
|
}
|
|
|
|
.layer2_deps.bg {
|
|
fill: ghostwhite;
|
|
}
|
|
|
|
|}
|
|
|
|
(*< Note the '.layer2_deps.bg' selector...
|
|
https://steveliles.github.io/a_multi_class_union_css_selector.html*)
|
|
(* .layer2_deps.bg fills:
|
|
OCaml: a_fill @@ `Color ("url(#gradient_01)", None);
|
|
CSS: fill: url(#gradient_01);
|
|
*)
|
|
|
|
type position = {
|
|
x : float;
|
|
y : float;
|
|
}
|
|
|
|
let center = { x = 0.5; y = 0.5 }
|
|
let root_radius = 0.015
|
|
|
|
module Unit = struct
|
|
|
|
let none size = size, None
|
|
|
|
end
|
|
|
|
(*goto pass data or preformatted string *)
|
|
let make_title ~text =
|
|
let s = sprintf "%s" text in
|
|
Svg.(title (txt s))
|
|
|
|
let make_circle ~pos ~radius =
|
|
Svg.[
|
|
circle ~a:[
|
|
a_class ["node_circle"];
|
|
a_cx @@ Unit.none pos.x;
|
|
a_cy @@ Unit.none pos.y;
|
|
a_r @@ Unit.none radius;
|
|
] []
|
|
]
|
|
|
|
let make_node ~pos ~radius ~text ~classes =
|
|
let title = make_title ~text in
|
|
let a = [ Svg.a_class ("node" :: classes) ] in
|
|
Svg.g ~a (title :: make_circle ~pos ~radius)
|
|
|
|
let make_line ~pos0 ~pos1 =
|
|
Svg.(line ~a:[
|
|
a_x1 @@ Unit.none pos0.x;
|
|
a_y1 @@ Unit.none pos0.y;
|
|
a_x2 @@ Unit.none pos1.x;
|
|
a_y2 @@ Unit.none pos1.y;
|
|
]) []
|
|
|
|
let make_edge ~pos0 ~pos1 ~classes =
|
|
let a = [ Svg.a_class ("edge" :: classes) ] in
|
|
Svg.g ~a [ make_line ~pos0 ~pos1 ]
|
|
|
|
let make_direct_deps_nodes ~deps_w_positions =
|
|
deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) ->
|
|
let radius = root_radius *. 0.7
|
|
and text =
|
|
sprintf "Direct dependency: %s\nDependencies: %d"
|
|
(*< goto choose between transitive/direct*)
|
|
dep.name (List.length layer2_deps)
|
|
and classes = [ dep.name; "direct_dep" ] in
|
|
make_node ~pos ~radius ~text ~classes
|
|
)
|
|
|
|
let make_direct_deps_edges ~deps_w_positions =
|
|
deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) ->
|
|
let pos0 = center in
|
|
let pos1 = pos in
|
|
let classes = [ dep.name; "direct_dep" ] in
|
|
make_edge ~pos0 ~pos1 ~classes
|
|
)
|
|
|
|
let make_layer2_deps ~deps_w_positions =
|
|
let open Gg in
|
|
deps_w_positions |> List.mapi
|
|
(fun i ((_, direct_dep_pos), layer2_deps) ->
|
|
let layer2_deps_center =
|
|
let direct_dep_pos = V2.(v direct_dep_pos.x direct_dep_pos.y) in
|
|
let center = V2.v center.x center.y in
|
|
let mult = if i mod 2 = 0 then 2.14 else 1.5
|
|
in
|
|
V2.(mult * (direct_dep_pos - center) + center)
|
|
in
|
|
let dot_radius = root_radius *. 0.2
|
|
in
|
|
let nodes =
|
|
layer2_deps |> List.mapi (fun i' layer2_dep ->
|
|
let i' = float i' +. 5.5 in
|
|
let pos_radius = sqrt i' *. 0.012 -. 0.024 in
|
|
let angle_diff = sqrt i' *. Float.two_pi *. 0.055 in
|
|
let pos_angle = i' *. angle_diff in
|
|
let pos_rel = V2.(v pos_radius pos_angle |> of_polar) in
|
|
let pos = V2.(layer2_deps_center + pos_rel) in
|
|
let pos = { x = V2.x pos; y = V2.y pos } in
|
|
let text = layer2_dep.name in
|
|
let classes = [ layer2_dep.name; "layer2_dep" ] in
|
|
make_node ~pos ~radius:dot_radius ~text ~classes
|
|
)
|
|
in
|
|
let bg =
|
|
let pos =
|
|
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center }
|
|
and radius = float (List.length layer2_deps) *. 0.003
|
|
and text = ""
|
|
and classes = [ "layer2_deps"; "bg" ] in
|
|
make_node ~pos ~radius ~text ~classes
|
|
in
|
|
let edge =
|
|
let pos0 = direct_dep_pos in
|
|
let pos1 =
|
|
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center } in
|
|
let classes = [ "layer2_deps" ] in
|
|
make_edge ~pos0 ~pos1 ~classes
|
|
in
|
|
edge :: bg :: nodes
|
|
)
|
|
|> List.flatten
|
|
|
|
(*goto define both direct and layer2 deps here
|
|
* all nodes should be laid out in the same list
|
|
* could visualize layer2-deps as a spiral of dots
|
|
* so there is a visual order
|
|
* so they can be sorted too - e.g. by how many deps they have
|
|
*)
|
|
let make_deps (deps:assoc_graph) =
|
|
let deps_w_positions =
|
|
let open Gg in
|
|
let len_deps = List.length deps in
|
|
let diff_angle = Float.two_pi /. float len_deps in
|
|
deps |> List.mapi (fun i (dep, layer2_deps) ->
|
|
let angle = diff_angle *. float i in
|
|
let dist_center = 0.2 in
|
|
let x = cos angle *. dist_center +. center.x
|
|
and y = sin angle *. dist_center +. center.y in
|
|
((dep, { x; y }), layer2_deps)
|
|
)
|
|
in
|
|
let direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions in
|
|
let direct_deps_edges = make_direct_deps_edges ~deps_w_positions in
|
|
let layer2_deps = make_layer2_deps ~deps_w_positions
|
|
in
|
|
direct_deps_edges @ direct_deps_nodes @ layer2_deps
|
|
|
|
let of_assoc (graph:assoc_graph) : t =
|
|
match graph with
|
|
| [] -> Tyxml_svg.svg []
|
|
| (root_pkg, direct_deps) :: layer2_deps ->
|
|
let root_svg =
|
|
let pos = center
|
|
and radius = root_radius
|
|
and text =
|
|
sprintf "%s\nDirect dependencies: %d"
|
|
root_pkg.name (List.length direct_deps)
|
|
and classes = [ root_pkg.name; "root" ] in
|
|
make_node ~pos ~radius ~text ~classes
|
|
in
|
|
let deps_svgs = make_deps layer2_deps in
|
|
let a = [ Svg.a_viewBox (0., 0., 1., 1.) ] in
|
|
let svg_defs =Svg.[ defs [
|
|
radialGradient ~a:[
|
|
a_id "gradient_01";
|
|
a_cx @@ Unit.none 0.5;
|
|
a_cy @@ Unit.none 0.5;
|
|
a_r @@ Unit.none 0.5;
|
|
] [
|
|
stop ~a:[
|
|
a_offset @@ `Percentage 0.;
|
|
a_stop_color "bisque"
|
|
] [];
|
|
stop ~a:[
|
|
a_offset @@ `Percentage 100.;
|
|
a_stop_color "bisque"; a_stop_opacity 0.
|
|
] []
|
|
]
|
|
]]
|
|
in
|
|
Svg.svg ~a (svg_defs @ deps_svgs @ [ root_svg ])
|
|
|
|
let pp ppf html =
|
|
Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html
|
|
|
|
end
|
|
|
|
module Html = struct
|
|
|
|
module H = Tyxml_html
|
|
|
|
type t = H.doc
|
|
|
|
let of_assoc (graph:assoc_graph) : t =
|
|
let svg = Svg.of_assoc graph in
|
|
H.html
|
|
(H.head
|
|
(H.title (H.txt "Dependencies"))
|
|
[H.style [H.Unsafe.data Svg.css]]
|
|
)
|
|
(H.body [ H.svg [ svg ] ])
|
|
|
|
let pp ppf html =
|
|
Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html
|
|
|
|
end
|
|
|
|
end
|