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

Opam_graph: UI: Generating css to make hove on direct-dep edges scale direct-dep

Browse source
This commit is contained in:
rand00 2022-01-14 11:07:32 +01:00
parent ad55010752
commit 9623303f9f
1 changed files with 55 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
src/opam_graph.ml
View file

@ -243,13 +243,18 @@ module Render = struct
type t = Tyxml_svg.doc
type output = {
svg : t;
css : string;
}
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 = {|
let initial_css = {|
svg {
width : 100vw;
@ -282,11 +287,12 @@ line {
transform: scale(2);
}
transform-origin: center;
stroke-width: 0.009 !important;
*)
let add_css c c' = String.concat "\n" [ c; c' ]
(*< Note the '.layer2_deps.bg' selector...
https://steveliles.github.io/a_multi_class_union_css_selector.html*)
(* .layer2_deps.bg fills:
@ -356,9 +362,15 @@ line {
make_node ~pos ~radius ~text ~classes
)
let make_direct_dep_edge_css dep = sprintf {|
.direct_dep.edge.%s:hover ~ .direct_dep.node.%s {
transform: scale(2);
}
|} dep dep
let make_direct_deps_edges ~deps_w_positions =
let open Gg in
deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) ->
let svg = deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) ->
let pos1 = pos in
let pos0 =
(*> Note: Need this because of mix of CSS selectors and SVG paint order*)
@ -372,7 +384,15 @@ line {
in
let classes = [ dep.name; "direct_dep" ] in
make_edge ~pos0 ~pos1 ~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
) ""
in
svg, css
let make_layer2_deps ~deps_w_positions =
let open Gg in
@ -433,27 +453,15 @@ line {
((dep, { x; y }), layer2_deps)
)
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 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 svg = direct_deps_edges @ direct_deps_nodes @ layer2_deps in
let css = direct_deps_edges_css in
svg, css
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";
@ -471,8 +479,25 @@ line {
] []
]
]]
let of_assoc (graph:assoc_graph) : output =
match graph with
| [] -> { svg = Tyxml_svg.svg []; css = "" }
| (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
Svg.svg ~a (svg_defs @ (root_svg :: deps_svgs))
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
{ svg; css }
let pp ppf html =
Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html
@ -490,9 +515,9 @@ line {
H.html
(H.head
(H.title (H.txt "Dependencies"))
[H.style [H.Unsafe.data Svg.css]]
[H.style [H.Unsafe.data svg.css]]
)
(H.body [ H.svg [ svg ] ])
(H.body [ H.svg [ svg.svg ] ])
let pp ppf html =
Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html