Opam_graph: UI: Implemented shared-dependencies marking on hover
This commit is contained in:
rand00
parent
9623303f9f
commit
70698c9b66
1 changed files with 76 additions and 34 deletions
|
|
@ -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 =
|
||||
|
|
|
|||
Loading…
Reference in a new issue