robur/opam-graph
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Opam_graph: UI: Implemented shared-dependencies marking on hover

Browse source
This commit is contained in:
rand00 2022-01-14 19:23:36 +01:00
parent 9623303f9f
commit 70698c9b66
1 changed files with 76 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

108
src/opam_graph.ml
View file

@ -1,19 +1,19 @@
let sprintf = Printf.sprintf
module Set = OpamPackage.Set
module OSet = 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);
assert (OSet.cardinal switch.selections.sel_pinned = 0);
assert (OSet.cardinal switch.selections.sel_compiler = 0);
assert (OSet.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
assert (OSet.cardinal switch.selections.sel_roots = 1);
OSet.choose switch.selections.sel_roots
module Name_set = OpamPackage.Name.Set
@ -268,30 +268,25 @@ line {
}
.layer2_deps.bg {
fill: ghostwhite;
fill: bisque;
}
.direct_dep.node:hover {
transform: scale(2);
}
.root:hover ~ .node {
transform: scale(1.1);
}
|}
(* disabled CSS
(*> goto generate this and select unique direct-dep pkg equal to self*)
.direct_dep.edge:hover ~ .direct_dep.node {
transform: scale(2);
.root:hover ~ .node {
transform: scale(1.1);
}
transform-origin: center;
stroke-width: 0.009 !important;
*)
let add_css c c' = String.concat "\n" [ c; c' ]
let merge_css cs = String.concat "\n" cs
(*< Note the '.layer2_deps.bg' selector...
https://steveliles.github.io/a_multi_class_union_css_selector.html*)
@ -314,7 +309,6 @@ line {
end
(*goto pass data or preformatted string *)
let make_title ~text =
let s = sprintf "%s" text in
Svg.(title (txt s))
@ -347,17 +341,19 @@ line {
a_y2 @@ Unit.none pos1.y;
]) []
let make_edge ~pos0 ~pos1 ~classes =
let make_edge ~pos0 ~pos1 ~text ~classes =
let a = [ Svg.a_class ("edge" :: classes) ] in
Svg.g ~a [ make_line ~pos0 ~pos1 ]
let title = make_title ~text in
Svg.g ~a [ title; make_line ~pos0 ~pos1 ]
let make_direct_dep_text dep ~layer2_deps =
sprintf "Direct dependency: %s\nDirect dependencies: %d"
dep.name (List.length layer2_deps)
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 text = make_direct_dep_text dep ~layer2_deps
and classes = [ dep.name; "direct_dep" ] in
make_node ~pos ~radius ~text ~classes
)
@ -366,7 +362,14 @@ line {
.direct_dep.edge.%s:hover ~ .direct_dep.node.%s {
transform: scale(2);
}
|} dep dep
.direct_dep.edge.%s:hover ~ .layer2_deps.bg.%s {
fill: dimgrey;
}
.direct_dep.node.%s:hover ~ .layer2_deps.bg.%s {
fill: dimgrey;
}
|} dep dep dep dep dep dep
(*< goto move generation of node-css to some other place*)
let make_direct_deps_edges ~deps_w_positions =
let open Gg in
@ -382,14 +385,15 @@ line {
let pos0 = V2.(pos0_rel + center) in
{ x = V2.x pos0; y = V2.y pos0 }
in
let text = make_direct_dep_text dep ~layer2_deps in
let classes = [ dep.name; "direct_dep" ] in
make_edge ~pos0 ~pos1 ~classes
make_edge ~pos0 ~pos1 ~text ~classes
) in
let css =
deps_w_positions
|> List.fold_left (fun acc_css ((dep, _), _) ->
let css = make_direct_dep_edge_css dep.name in
add_css acc_css css
merge_css [ acc_css; css ]
) ""
in
svg, css
@ -397,7 +401,7 @@ line {
let make_layer2_deps ~deps_w_positions =
let open Gg in
deps_w_positions |> List.mapi
(fun i ((_, direct_dep_pos), layer2_deps) ->
(fun i ((dep, 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
@ -426,20 +430,57 @@ line {
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center }
and radius = sqrt (float (List.length layer2_deps) +. 1.) *. 0.009
and text = ""
and classes = [ "layer2_deps"; "bg" ] in
and classes = [ "layer2_deps"; "bg"; dep.name ] 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 text = "" in
let classes = [ "layer2_deps" ] in
make_edge ~pos0 ~pos1 ~classes
make_edge ~pos0 ~pos1 ~text ~classes
in
edge :: bg :: nodes
)
|> List.flatten
let make_shared_deps_css_aux ~dep ~shared_deps =
shared_deps |> Seq.map (fun shared_dep ->
sprintf {|
.direct_dep.%s:hover ~ .node.layer2_dep.%s {
fill: hotpink;
}
|} dep.name shared_dep
)
|> List.of_seq
|> merge_css
let make_shared_deps_css ~deps_w_positions =
let module SSet = Set.Make(String) in
let sset_of_deps deps =
deps
|> List.map (fun dep -> dep.name)
|> SSet.of_list
in
let layer2_deps_sets =
deps_w_positions |> List.map (fun (_, layer2_deps) ->
layer2_deps |> sset_of_deps
)
in
deps_w_positions |> List.map (fun ((dep, _), layer2_deps) ->
let layer2_deps = sset_of_deps layer2_deps in
let shared_deps =
layer2_deps_sets
|> List.fold_left (fun acc layer2_deps' ->
SSet.(union acc (inter layer2_deps layer2_deps'))
) SSet.empty
|> SSet.to_seq
in
make_shared_deps_css_aux ~dep ~shared_deps
)
|> merge_css
let make_deps (deps:assoc_graph) =
let deps_w_positions =
let open Gg in
@ -454,12 +495,13 @@ line {
)
in
let direct_deps_edges, direct_deps_edges_css =
make_direct_deps_edges ~deps_w_positions in
let direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions in
let layer2_deps = make_layer2_deps ~deps_w_positions
make_direct_deps_edges ~deps_w_positions
and direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions
and layer2_deps = make_layer2_deps ~deps_w_positions
and shared_deps_css = make_shared_deps_css ~deps_w_positions
in
let svg = direct_deps_edges @ direct_deps_nodes @ layer2_deps in
let css = direct_deps_edges_css in
let css = merge_css [ direct_deps_edges_css; shared_deps_css ] in
svg, css
let svg_defs = Svg.[ defs [
@ -496,7 +538,7 @@ line {
let deps_svgs, deps_css = make_deps layer2_deps in
let a = [ Svg.a_viewBox (0., 0., 1., 1.) ] in
let svg = Svg.svg ~a (svg_defs @ (root_svg :: deps_svgs)) in
let css = add_css initial_css deps_css in
let css = merge_css [ initial_css; deps_css ] in
{ svg; css }
let pp ppf html =