Merge pull request 'Scoping all CSS classes so the viz is (more) compatible with inclusion in existing HTML-doc' (#5) from 20220315_scoping_CSS_classes into main

Reviewed-on: https://git.robur.io/robur/opam-graph/pulls/5
This commit is contained in:
rand 2022-03-16 11:05:45 +00:00
commit ae8dd4d08d

View file

@ -252,30 +252,32 @@ module Render = struct
module Svg = Tyxml_svg module Svg = Tyxml_svg
let scoped_class s = "deps-"^s
(*> goto (*> goto
* change svg width+height to pct again - using vw+vh for development * change svg width+height to pct again - using vw+vh for development
* svg width+height shouldn't be here for compatibility with user css? * svg width+height shouldn't be here for compatibility with user css?
*) *)
let initial_css = {| let initial_css = {|
svg { .deps-svg-wrap {
background : slategrey; background : slategrey;
} }
line { .deps-line {
stroke-width: 0.4; stroke-width: 0.4;
stroke: bisque; stroke: bisque;
} }
.layer2_deps.bg { .deps-layer2_deps.deps-bg {
fill: url(#gradient_01); fill: url(#gradient_01);
} }
.direct_dep.node:hover { .deps-direct_dep.deps-node:hover {
transform: scale(2); transform: scale(2);
} }
.layer2_dep.node:hover { .deps-layer2_dep.deps-node:hover {
transform: scale(1.4); transform: scale(1.4);
} }
@ -329,7 +331,7 @@ svg {
let make_circle ~pos ~radius = let make_circle ~pos ~radius =
Svg.[ Svg.[
circle ~a:[ circle ~a:[
a_class ["node_circle"]; a_class [scoped_class "node_circle"];
a_cx @@ Unit.none pos.x; a_cx @@ Unit.none pos.x;
a_cy @@ Unit.none pos.y; a_cy @@ Unit.none pos.y;
a_r @@ Unit.none radius; a_r @@ Unit.none radius;
@ -359,13 +361,14 @@ svg {
(*> todo; why is this not in Tyxml - browser support missing?*) (*> todo; why is this not in Tyxml - browser support missing?*)
let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in
let a = Svg.[ let a = Svg.[
a_class ("node" :: classes); a_class (scoped_class "node" :: classes);
a_transform_origin @@ sprintf "%f %f" pos.x pos.y; a_transform_origin @@ sprintf "%f %f" pos.x pos.y;
] in ] in
Svg.g ~a (title :: make_circle ~pos ~radius) Svg.g ~a (title :: make_circle ~pos ~radius)
let make_line ~pos0 ~pos1 = let make_line ~pos0 ~pos1 =
Svg.(line ~a:[ Svg.(line ~a:[
a_class [ scoped_class "line" ];
a_x1 @@ Unit.none pos0.x; a_x1 @@ Unit.none pos0.x;
a_y1 @@ Unit.none pos0.y; a_y1 @@ Unit.none pos0.y;
a_x2 @@ Unit.none pos1.x; a_x2 @@ Unit.none pos1.x;
@ -373,7 +376,7 @@ svg {
]) [] ]) []
let make_edge ~pos0 ~pos1 ~text ~classes = let make_edge ~pos0 ~pos1 ~text ~classes =
let a = [ Svg.a_class ("edge" :: classes) ] in let a = Svg.[ a_class (scoped_class "edge" :: classes) ] in
let title = make_title ~text in let title = make_title ~text in
Svg.g ~a [ title; make_line ~pos0 ~pos1 ] Svg.g ~a [ title; make_line ~pos0 ~pos1 ]
@ -385,18 +388,24 @@ svg {
deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) -> deps_w_positions |> List.map (fun ((dep, pos), layer2_deps) ->
let radius = root_radius *. 0.7 let radius = root_radius *. 0.7
and text = make_direct_dep_text dep ~layer2_deps and text = make_direct_dep_text dep ~layer2_deps
and classes = [ dep.name; "direct_dep" ] in and classes = [
scoped_class dep.name;
scoped_class "direct_dep"
] in
make_node ~pos ~radius ~text ~classes make_node ~pos ~radius ~text ~classes
) )
let make_direct_dep_edge_css dep = sprintf {| let make_direct_dep_edge_css dep =
.direct_dep.edge.%s:hover ~ .direct_dep.node.%s { let dep = scoped_class dep in
sprintf {|
.deps-direct_dep.deps-edge.%s:hover ~
.deps-direct_dep.deps-node.%s {
transform: scale(2); transform: scale(2);
} }
.direct_dep.edge.%s:hover ~ .layer2_deps.bg.%s { .deps-direct_dep.deps-edge.%s:hover ~ .deps-layer2_deps.deps-bg.%s {
fill: dimgrey; fill: dimgrey;
} }
.direct_dep.node.%s:hover ~ .layer2_deps.bg.%s { .deps-direct_dep.deps-node.%s:hover ~ .deps-layer2_deps.deps-bg.%s {
fill: dimgrey; fill: dimgrey;
} }
|} dep dep dep dep dep dep |} dep dep dep dep dep dep
@ -424,7 +433,9 @@ svg {
Svg.polygon ~a [] Svg.polygon ~a []
let make_hitbox_direct_dep_edge ~pos0 ~pos1 ~n_edges ~text ~classes = let make_hitbox_direct_dep_edge ~pos0 ~pos1 ~n_edges ~text ~classes =
let a = [ Svg.a_class ("edge" :: "hitbox" :: classes) ] in let a = Svg.[
a_class (scoped_class "edge" :: scoped_class "hitbox" :: classes)
] in
let title = make_title ~text in let title = make_title ~text in
let left, right = let left, right =
let open Gg in let open Gg in
@ -472,7 +483,10 @@ svg {
{ x = V2.x pos0; y = V2.y pos0 }, pos1_rel_angle { x = V2.x pos0; y = V2.y pos0 }, pos1_rel_angle
in in
let text = make_direct_dep_text dep ~layer2_deps in let text = make_direct_dep_text dep ~layer2_deps in
let classes = [ dep.name; "direct_dep" ] in let classes = [
scoped_class dep.name;
scoped_class "direct_dep"
] in
let visual_svg = make_edge ~pos0 ~pos1 ~text ~classes in let visual_svg = make_edge ~pos0 ~pos1 ~text ~classes in
let hitbox_svg = let hitbox_svg =
make_hitbox_direct_dep_edge make_hitbox_direct_dep_edge
@ -503,7 +517,10 @@ svg {
let pos = V2.(layer2_deps_center + pos_rel) in let pos = V2.(layer2_deps_center + pos_rel) in
let pos = { x = V2.x pos; y = V2.y pos } in let pos = { x = V2.x pos; y = V2.y pos } in
let text = layer2_dep.name in let text = layer2_dep.name in
let classes = [ layer2_dep.name; "layer2_dep" ] in let classes = [
scoped_class layer2_dep.name;
scoped_class "layer2_dep";
] in
make_node ~pos ~radius:dot_radius ~text ~classes make_node ~pos ~radius:dot_radius ~text ~classes
) )
@ -547,7 +564,7 @@ svg {
(*> todo; why is this not in Tyxml - browser support missing?*) (*> todo; why is this not in Tyxml - browser support missing?*)
let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in
let a = Svg.[ let a = Svg.[
a_class ("hitbox" :: classes); a_class (scoped_class "hitbox" :: classes);
a_transform_origin @@ sprintf "%f %f" center_pos.x center_pos.y; a_transform_origin @@ sprintf "%f %f" center_pos.x center_pos.y;
] in ] in
Svg.g ~a (title :: make_square ~center_pos ~width) Svg.g ~a (title :: make_square ~center_pos ~width)
@ -560,7 +577,10 @@ svg {
let pos = V2.(layer2_deps_center + grid_pos ~cell_width i) in let pos = V2.(layer2_deps_center + grid_pos ~cell_width i) in
let pos = { x = V2.x pos; y = V2.y pos } in let pos = { x = V2.x pos; y = V2.y pos } in
let text = layer2_dep.name in let text = layer2_dep.name in
let classes = [ layer2_dep.name; "layer2_dep" ] in let classes = [
scoped_class layer2_dep.name;
scoped_class "layer2_dep";
] in
let visual_svg = make_node ~pos ~radius:dot_radius ~text ~classes in let visual_svg = make_node ~pos ~radius:dot_radius ~text ~classes in
let _hitbox_svg = let _hitbox_svg =
make_hitbox_square ~text ~classes make_hitbox_square ~text ~classes
@ -587,7 +607,11 @@ svg {
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center } { x = V2.x layer2_deps_center; y = V2.y layer2_deps_center }
and radius = sqrt (float (List.length layer2_deps) +. 1.) *. 1.15 and radius = sqrt (float (List.length layer2_deps) +. 1.) *. 1.15
and text = "" and text = ""
and classes = [ "layer2_deps"; "bg"; dep.name ] in and classes = [
scoped_class "layer2_deps";
scoped_class "bg";
scoped_class dep.name
] in
make_node ~pos ~radius ~text ~classes make_node ~pos ~radius ~text ~classes
in in
let edge = let edge =
@ -595,7 +619,7 @@ svg {
let pos1 = let pos1 =
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center } in { x = V2.x layer2_deps_center; y = V2.y layer2_deps_center } in
let text = "" in let text = "" in
let classes = [ "layer2_deps" ] in let classes = [ scoped_class "layer2_deps" ] in
make_edge ~pos0 ~pos1 ~text ~classes make_edge ~pos0 ~pos1 ~text ~classes
in in
edge :: bg :: nodes edge :: bg :: nodes
@ -605,10 +629,11 @@ svg {
let make_shared_deps_css_aux ~dep ~shared_deps = let make_shared_deps_css_aux ~dep ~shared_deps =
shared_deps |> Seq.map (fun shared_dep -> shared_deps |> Seq.map (fun shared_dep ->
sprintf {| sprintf {|
.direct_dep.%s:hover ~ .node.layer2_dep.%s { .deps-direct_dep.%s:hover ~
.deps-node.deps-layer2_dep.%s {
fill: #5454ff; fill: #5454ff;
} }
|} dep.name shared_dep |} (scoped_class dep.name) (scoped_class shared_dep)
) )
|> List.of_seq |> List.of_seq
|> merge_css |> merge_css
@ -689,11 +714,17 @@ svg {
and text = and text =
sprintf "%s\nDirect dependencies: %d" sprintf "%s\nDirect dependencies: %d"
root_pkg.name (List.length direct_deps) root_pkg.name (List.length direct_deps)
and classes = [ root_pkg.name; "root" ] in and classes = [
scoped_class root_pkg.name;
scoped_class "root"
] in
make_node ~pos ~radius ~text ~classes make_node ~pos ~radius ~text ~classes
in in
let deps_svgs, deps_css = make_deps layer2_deps in let deps_svgs, deps_css = make_deps layer2_deps in
let svg_attr = [ Svg.a_viewBox (0., 0., 100., 100.) ] in let svg_attr = Svg.[
a_viewBox (0., 0., 100., 100.);
a_class [ scoped_class "svg-wrap" ];
] in
let svg_content = svg_defs @ (root_svg :: deps_svgs) in let svg_content = svg_defs @ (root_svg :: deps_svgs) in
let css = merge_css [ initial_css; deps_css ] in let css = merge_css [ initial_css; deps_css ] in
{ svg_content; svg_attr; css } { svg_content; svg_attr; css }