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

Opam_graph: Passing out svg attributes and content to outer Html.svg node - fixes UI too

Browse source
This commit is contained in:
rand00 2022-01-26 18:06:23 +01:00
parent 0a875c2e35
commit 07d81a6073
1 changed files with 20 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
src/opam_graph.ml
View file

@ -242,9 +242,12 @@ module Render = struct
module Svg = struct module Svg = struct
type t = Tyxml_svg.doc type t = Tyxml_svg.doc
type 'a elt = 'a Tyxml_svg.elt
type 'a attr = 'a Tyxml_svg.attrib
type output = { type ('a, 'b) output = {
svg : t; svg_content : 'a elt list;
svg_attr : 'b attr list;
css : string; css : string;
} }
@ -257,8 +260,6 @@ module Render = struct
let initial_css = {| let initial_css = {|
svg { svg {
width : 100vw;
height : 100vh;
background : slategrey; background : slategrey;
} }
@ -282,6 +283,11 @@ line {
|} |}
(* disabled CSS (* disabled CSS
svg {
width : 100vw;
height : 100vh;
}
.layer2_deps.bg { .layer2_deps.bg {
fill: bisque; fill: bisque;
} }
@ -675,9 +681,9 @@ line {
] ]
]] ]]
let of_assoc (graph:assoc_graph) : output = let of_assoc (graph:assoc_graph) : _ output =
match graph with match graph with
| [] -> { svg = Tyxml_svg.svg []; css = "" } | [] -> { svg_content = []; svg_attr = []; css = "" }
| (root_pkg, direct_deps) :: layer2_deps -> | (root_pkg, direct_deps) :: layer2_deps ->
let root_svg = let root_svg =
let pos = center let pos = center
@ -689,10 +695,10 @@ line {
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 a = [ Svg.a_viewBox (0., 0., 1., 1.) ] in let svg_attr = [ Svg.a_viewBox (0., 0., 1., 1.) ] in
let svg = Svg.svg ~a (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; css } { svg_content; svg_attr; css }
let pp ppf html = let pp ppf html =
Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html
@ -705,14 +711,16 @@ line {
type t = H.doc type t = H.doc
let of_assoc (graph:assoc_graph) : t = let merge_css = String.concat "\n"
let of_assoc ?(override_css="") (graph:assoc_graph) : t =
let svg = Svg.of_assoc graph in let svg = Svg.of_assoc graph in
H.html H.html
(H.head (H.head
(H.title (H.txt "Dependencies")) (H.title (H.txt "Dependencies"))
[H.style [H.Unsafe.data svg.css]] [H.style [H.Unsafe.data @@ merge_css [ svg.css; override_css ]]]
) )
(H.body [ H.svg [ svg.svg ] ]) (H.body [ H.svg ~a:svg.svg_attr svg.svg_content ])
let pp ppf html = let pp ppf html =
Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html