Merge pull request 'New rendering formats: UI for Builder-web and graphviz' (#2) from 20220105_adding_ocamldot_output_support into main
Reviewed-on: https://git.robur.io/robur/opam-graph/pulls/2
This commit is contained in:
commit
b4f8db5309
6 changed files with 761 additions and 30 deletions
4
.gitignore
vendored
Normal file
4
.gitignore
vendored
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
_build
|
||||||
|
*~
|
||||||
|
*#
|
||||||
|
|
3
app/dune
3
app/dune
|
@ -1,3 +1,4 @@
|
||||||
(executable
|
(executable
|
||||||
(name main)
|
(name main)
|
||||||
(libraries cmdliner logs logs.fmt opam-graph))
|
(public_name opam_graph)
|
||||||
|
(libraries cmdliner logs logs.fmt fmt.cli fmt.tty logs.cli opam-graph))
|
||||||
|
|
59
app/main.ml
59
app/main.ml
|
@ -11,13 +11,58 @@ let read_file file =
|
||||||
invalid_arg ("Error reading file: " ^ file)
|
invalid_arg ("Error reading file: " ^ file)
|
||||||
with _ -> invalid_arg ("Error opening file " ^ file)
|
with _ -> invalid_arg ("Error opening file " ^ file)
|
||||||
|
|
||||||
let () =
|
let jump () transitive file output_format =
|
||||||
match Sys.argv with
|
|
||||||
| [| _ ; file |] ->
|
|
||||||
let switch = read_file file in
|
let switch = read_file file in
|
||||||
let data = OpamFile.SwitchExport.read_from_string switch in
|
let data = OpamFile.SwitchExport.read_from_string switch in
|
||||||
Opam_graph.dependencies data
|
match output_format with
|
||||||
| _ ->
|
| `Text ->
|
||||||
print_endline "expecting exactly one argument";
|
let graph = Opam_graph.dependencies ~transitive data in
|
||||||
exit 1
|
Format.printf "%a" Opam_graph.pp_graph graph
|
||||||
|
| `Dot ->
|
||||||
|
let graph = Opam_graph.dependencies ~transitive data in
|
||||||
|
let dot = Opam_graph.Render.Dot.of_graph graph in
|
||||||
|
Format.printf "%a" Opam_graph.Render.Dot.pp dot
|
||||||
|
| `Dot_ui ->
|
||||||
|
let graph = Opam_graph.Ui.dependencies ~transitive data in
|
||||||
|
let dot = Opam_graph.Render.Dot.of_assoc graph in
|
||||||
|
Format.printf "%a" Opam_graph.Render.Dot.pp dot
|
||||||
|
| `Html ->
|
||||||
|
let graph = Opam_graph.Ui.dependencies ~transitive data in
|
||||||
|
let html = Opam_graph.Render.Html.of_assoc graph in
|
||||||
|
Format.printf "%a" Opam_graph.Render.Html.pp html
|
||||||
|
|
||||||
|
let setup_log style_renderer level =
|
||||||
|
Fmt_tty.setup_std_outputs ?style_renderer ();
|
||||||
|
Logs.set_level level;
|
||||||
|
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
|
||||||
|
|
||||||
|
open Cmdliner
|
||||||
|
|
||||||
|
let setup_log =
|
||||||
|
Term.(const setup_log
|
||||||
|
$ Fmt_cli.style_renderer ()
|
||||||
|
$ Logs_cli.level ())
|
||||||
|
|
||||||
|
let transitive =
|
||||||
|
let doc = "Transitive dependencies" in
|
||||||
|
Arg.(value & flag & info [ "transitive" ] ~doc)
|
||||||
|
|
||||||
|
let formats = [ "html", `Html ; "dot", `Dot ; "dot-ui", `Dot_ui ; "text", `Text ]
|
||||||
|
|
||||||
|
let output_format =
|
||||||
|
let doc =
|
||||||
|
let formats_str =
|
||||||
|
formats |> List.map fst |> String.concat ", "
|
||||||
|
in
|
||||||
|
Printf.sprintf "Output format. Can be one of: %s." formats_str in
|
||||||
|
Arg.(value & opt (Arg.enum formats) `Text & info [ "output-format" ] ~doc)
|
||||||
|
|
||||||
|
let file =
|
||||||
|
let doc = "The opam switch export to graph" in
|
||||||
|
Arg.(required & pos 0 (some file) None & info [ ] ~doc ~docv:"FILE")
|
||||||
|
|
||||||
|
let cmd =
|
||||||
|
Term.(const jump $ setup_log $ transitive $ file $ output_format),
|
||||||
|
Term.info "opam_graph" ~version:"%%VERSION%%"
|
||||||
|
|
||||||
|
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
|
||||||
|
|
|
@ -0,0 +1,30 @@
|
||||||
|
opam-version: "2.0"
|
||||||
|
maintainer: "Robur <team@robur.coop>"
|
||||||
|
authors: ["Robur <team@robur.coop>"]
|
||||||
|
homepage: "https://git.robur.io/robur/opam-graph"
|
||||||
|
dev-repo: "git+https://git.robur.io/robur/opam-graph.git"
|
||||||
|
bug-reports: "https://github.com/roburio/opam-graph/issues"
|
||||||
|
license: "ISC"
|
||||||
|
|
||||||
|
depends: [
|
||||||
|
"ocaml" {>= "4.08.0"}
|
||||||
|
"dune" {>= "2.0.0"}
|
||||||
|
"cmdliner"
|
||||||
|
"fmt" {>= "0.8.7"}
|
||||||
|
"logs"
|
||||||
|
"opam-core"
|
||||||
|
"opam-format"
|
||||||
|
"ocamldot"
|
||||||
|
"rresult"
|
||||||
|
"tyxml"
|
||||||
|
"gg"
|
||||||
|
]
|
||||||
|
build: [
|
||||||
|
["dune" "subst"] {dev}
|
||||||
|
["dune" "build" "-p" name "-j" jobs]
|
||||||
|
]
|
||||||
|
|
||||||
|
synopsis: "Graphing dependencies of opam packages"
|
||||||
|
description: """
|
||||||
|
This package outputs graphs (in svg and dot) of opam packages.
|
||||||
|
"""
|
3
src/dune
3
src/dune
|
@ -1,4 +1,5 @@
|
||||||
(library
|
(library
|
||||||
(name opam_graph)
|
(name opam_graph)
|
||||||
(public_name opam-graph)
|
(public_name opam-graph)
|
||||||
(libraries opam-core opam-format))
|
(libraries opam-core opam-format dot rresult tyxml gg)
|
||||||
|
)
|
||||||
|
|
|
@ -1,16 +1,19 @@
|
||||||
module Set = OpamPackage.Set
|
|
||||||
|
let sprintf = Printf.sprintf
|
||||||
|
|
||||||
|
module OSet = OpamPackage.Set
|
||||||
|
|
||||||
type package = OpamPackage.t
|
type package = OpamPackage.t
|
||||||
|
|
||||||
let packages (switch : OpamFile.SwitchExport.t) =
|
let packages (switch : OpamFile.SwitchExport.t) =
|
||||||
assert (Set.cardinal switch.selections.sel_pinned = 0);
|
assert (OSet.cardinal switch.selections.sel_pinned = 0);
|
||||||
assert (Set.cardinal switch.selections.sel_compiler = 0);
|
assert (OSet.cardinal switch.selections.sel_compiler = 0);
|
||||||
assert (Set.subset switch.selections.sel_roots switch.selections.sel_installed);
|
assert (OSet.subset switch.selections.sel_roots switch.selections.sel_installed);
|
||||||
switch.selections.sel_installed
|
switch.selections.sel_installed
|
||||||
|
|
||||||
let root (switch : OpamFile.SwitchExport.t) =
|
let root (switch : OpamFile.SwitchExport.t) =
|
||||||
assert (Set.cardinal switch.selections.sel_roots = 1);
|
assert (OSet.cardinal switch.selections.sel_roots = 1);
|
||||||
Set.choose switch.selections.sel_roots
|
OSet.choose switch.selections.sel_roots
|
||||||
|
|
||||||
module Name_set = OpamPackage.Name.Set
|
module Name_set = OpamPackage.Name.Set
|
||||||
|
|
||||||
|
@ -18,16 +21,43 @@ let filtered_formula_to_pkgs (_switch : OpamFile.SwitchExport.t)
|
||||||
?(set = Name_set.empty) formula =
|
?(set = Name_set.empty) formula =
|
||||||
OpamFormula.fold_left (fun acc (name, _) -> Name_set.add name acc) set formula
|
OpamFormula.fold_left (fun acc (name, _) -> Name_set.add name acc) set formula
|
||||||
|
|
||||||
let opam (switch : OpamFile.SwitchExport.t) pkg_name =
|
let opam_file (switch : OpamFile.SwitchExport.t) pkg_name =
|
||||||
OpamPackage.Name.Map.find pkg_name switch.overlays
|
OpamPackage.Name.Map.find pkg_name switch.overlays
|
||||||
|
|
||||||
(* TODO depexts *)
|
(* TODO depexts *)
|
||||||
(* TODO build / dev packages *)
|
(* TODO build / dev packages *)
|
||||||
(* TODO constraints (os = "linux") *)
|
(* TODO constraints (os = "linux") *)
|
||||||
let direct_dependencies (switch : OpamFile.SwitchExport.t) pkg =
|
let direct_dependencies (switch : OpamFile.SwitchExport.t) pkg =
|
||||||
let opam = opam switch pkg in
|
let pkg_opam_file = opam_file switch pkg in
|
||||||
|
let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends pkg_opam_file) in
|
||||||
|
filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts pkg_opam_file)
|
||||||
|
|
||||||
|
let transitive_dependencies (switch : OpamFile.SwitchExport.t) pkg =
|
||||||
|
let available = switch.selections.sel_installed in
|
||||||
|
let rec aux pkg seen_pkgs =
|
||||||
|
let opam = opam_file switch pkg in
|
||||||
let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends opam) in
|
let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends opam) in
|
||||||
filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam)
|
let set = filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam) in
|
||||||
|
let transitive_set =
|
||||||
|
let filtered_set =
|
||||||
|
set
|
||||||
|
|> Name_set.filter (fun name ->
|
||||||
|
OpamPackage.Set.exists
|
||||||
|
(fun pkg -> pkg.OpamPackage.name = name)
|
||||||
|
available
|
||||||
|
&& not (Name_set.mem name seen_pkgs)
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let seen_pkgs = Name_set.union seen_pkgs filtered_set
|
||||||
|
in
|
||||||
|
filtered_set
|
||||||
|
|> Name_set.elements
|
||||||
|
|> List.concat_map (fun pkg -> aux pkg seen_pkgs |> Name_set.elements)
|
||||||
|
|> Name_set.of_list
|
||||||
|
in
|
||||||
|
Name_set.union set transitive_set
|
||||||
|
in
|
||||||
|
aux pkg Name_set.empty
|
||||||
|
|
||||||
module Name_map = OpamPackage.Name.Map
|
module Name_map = OpamPackage.Name.Map
|
||||||
|
|
||||||
|
@ -49,7 +79,7 @@ let pp_graph ppf graph =
|
||||||
(Name_set.elements deps))))
|
(Name_set.elements deps))))
|
||||||
graph.nodes
|
graph.nodes
|
||||||
|
|
||||||
let dependencies (switch : OpamFile.SwitchExport.t) =
|
let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) =
|
||||||
let root_pkg = root switch in
|
let root_pkg = root switch in
|
||||||
let top = root_pkg.OpamPackage.name in
|
let top = root_pkg.OpamPackage.name in
|
||||||
let graph = { top ; nodes = Name_map.empty } in
|
let graph = { top ; nodes = Name_map.empty } in
|
||||||
|
@ -58,13 +88,17 @@ let dependencies (switch : OpamFile.SwitchExport.t) =
|
||||||
match Name_set.choose_opt work with
|
match Name_set.choose_opt work with
|
||||||
| None -> graph
|
| None -> graph
|
||||||
| Some x ->
|
| Some x ->
|
||||||
let deps = direct_dependencies switch x in
|
let deps = match transitive with
|
||||||
|
| true -> transitive_dependencies switch x
|
||||||
|
| false -> direct_dependencies switch x
|
||||||
|
in
|
||||||
let deps =
|
let deps =
|
||||||
Name_set.filter (fun name ->
|
deps
|
||||||
|
|> Name_set.filter (fun name ->
|
||||||
OpamPackage.Set.exists
|
OpamPackage.Set.exists
|
||||||
(fun pkg -> pkg.OpamPackage.name = name)
|
(fun pkg -> pkg.OpamPackage.name = name)
|
||||||
available)
|
available
|
||||||
deps
|
)
|
||||||
in
|
in
|
||||||
let graph = add_node graph x deps in
|
let graph = add_node graph x deps in
|
||||||
let work =
|
let work =
|
||||||
|
@ -74,5 +108,621 @@ let dependencies (switch : OpamFile.SwitchExport.t) =
|
||||||
in
|
in
|
||||||
find_deps graph work
|
find_deps graph work
|
||||||
in
|
in
|
||||||
let graph = find_deps graph (Name_set.singleton top) in
|
find_deps graph (Name_set.singleton top)
|
||||||
Format.printf "%a" pp_graph graph
|
|
||||||
|
(*!Note the first entry is seen as the root node*)
|
||||||
|
type assoc_node = {
|
||||||
|
name : string;
|
||||||
|
uniqueness_postfix : string;
|
||||||
|
}
|
||||||
|
type assoc_graph = (assoc_node * (assoc_node list)) list
|
||||||
|
|
||||||
|
module Ui = struct
|
||||||
|
|
||||||
|
let dependencies ?(transitive=true) data : assoc_graph =
|
||||||
|
(*> todo can be made more efficient*)
|
||||||
|
let all_direct_deps = dependencies data in
|
||||||
|
let root = all_direct_deps.top in
|
||||||
|
let root_str = OpamPackage.Name.to_string root
|
||||||
|
in
|
||||||
|
let direct_deps =
|
||||||
|
all_direct_deps.nodes
|
||||||
|
|> Name_map.find root
|
||||||
|
in
|
||||||
|
(*> todo can be made more efficient*)
|
||||||
|
let all_transitive_deps =
|
||||||
|
dependencies ~transitive data in
|
||||||
|
let direct_deps_w_transitive_deps =
|
||||||
|
direct_deps
|
||||||
|
|> Name_set.elements
|
||||||
|
|> List.map (fun direct_dep ->
|
||||||
|
let transitive_deps =
|
||||||
|
all_transitive_deps.nodes
|
||||||
|
|> Name_map.find_opt direct_dep
|
||||||
|
|> (function
|
||||||
|
| None -> Name_set.empty
|
||||||
|
| Some v -> v)
|
||||||
|
|> Name_set.elements
|
||||||
|
|> List.map OpamPackage.Name.to_string
|
||||||
|
in
|
||||||
|
let direct_dep = OpamPackage.Name.to_string direct_dep in
|
||||||
|
direct_dep, transitive_deps
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let uniquified_deps =
|
||||||
|
direct_deps_w_transitive_deps
|
||||||
|
|> List.mapi (fun i (direct_dep, transitive_deps) ->
|
||||||
|
let direct_dep_node = {
|
||||||
|
name = direct_dep;
|
||||||
|
uniqueness_postfix = sprintf "%d" i;
|
||||||
|
}
|
||||||
|
and unique_transitive_deps =
|
||||||
|
transitive_deps
|
||||||
|
|> List.mapi (fun i' transitive_dep ->
|
||||||
|
let uniqueness_postfix = sprintf "%d.%d" i i' in
|
||||||
|
{ name = transitive_dep; uniqueness_postfix }
|
||||||
|
)
|
||||||
|
in
|
||||||
|
direct_dep_node, unique_transitive_deps
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let unique_direct_deps = uniquified_deps |> List.map fst in
|
||||||
|
let root_node = { name = root_str; uniqueness_postfix = "" }
|
||||||
|
in
|
||||||
|
(root_node, unique_direct_deps) :: uniquified_deps
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Render = struct
|
||||||
|
|
||||||
|
module Dot = struct
|
||||||
|
|
||||||
|
type t = Odot.graph
|
||||||
|
|
||||||
|
let of_graph (graph:graph) : t =
|
||||||
|
let open Odot in
|
||||||
|
let stmt_list =
|
||||||
|
Name_map.fold (fun pkg deps acc ->
|
||||||
|
let stmt =
|
||||||
|
let pkg_id = Double_quoted_id (OpamPackage.Name.to_string pkg) in
|
||||||
|
let pkg_point = Edge_node_id (pkg_id, None) in
|
||||||
|
let deps_points =
|
||||||
|
Name_set.elements deps
|
||||||
|
|> List.map (fun p ->
|
||||||
|
let id = Double_quoted_id (OpamPackage.Name.to_string p) in
|
||||||
|
Edge_node_id (id, None)
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let edge = pkg_point, deps_points, [] in
|
||||||
|
Stmt_edge edge
|
||||||
|
in
|
||||||
|
stmt :: acc
|
||||||
|
) graph.nodes []
|
||||||
|
in
|
||||||
|
{ strict = false; (*todo test params*)
|
||||||
|
kind = Digraph;
|
||||||
|
id = None;
|
||||||
|
stmt_list }
|
||||||
|
|
||||||
|
let id_of_assoc_node node =
|
||||||
|
sprintf "%s_%s" node.name node.uniqueness_postfix
|
||||||
|
|
||||||
|
let of_assoc (graph:assoc_graph) : t =
|
||||||
|
let open Odot in
|
||||||
|
let stmt_list =
|
||||||
|
graph
|
||||||
|
|> List.fold_left (fun acc (pkg, deps) ->
|
||||||
|
let stmt =
|
||||||
|
let pkg_id = Double_quoted_id (id_of_assoc_node pkg) in
|
||||||
|
let pkg_point = Edge_node_id (pkg_id, None) in
|
||||||
|
let deps_points =
|
||||||
|
deps
|
||||||
|
|> List.map (fun pkg ->
|
||||||
|
let id = Double_quoted_id (id_of_assoc_node pkg) in
|
||||||
|
Edge_node_id (id, None)
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let edge = pkg_point, deps_points, [] in
|
||||||
|
Stmt_edge edge
|
||||||
|
in
|
||||||
|
stmt :: acc
|
||||||
|
) []
|
||||||
|
in
|
||||||
|
{ strict = false; (*todo test params*)
|
||||||
|
kind = Digraph;
|
||||||
|
id = None;
|
||||||
|
stmt_list }
|
||||||
|
|
||||||
|
let pp ppf dot =
|
||||||
|
Format.fprintf ppf "%s" (Odot.string_of_graph dot)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Svg = struct
|
||||||
|
|
||||||
|
type t = Tyxml_svg.doc
|
||||||
|
type 'a elt = 'a Tyxml_svg.elt
|
||||||
|
type 'a attr = 'a Tyxml_svg.attrib
|
||||||
|
|
||||||
|
type ('a, 'b) output = {
|
||||||
|
svg_content : 'a elt list;
|
||||||
|
svg_attr : 'b attr list;
|
||||||
|
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 initial_css = {|
|
||||||
|
|
||||||
|
svg {
|
||||||
|
background : slategrey;
|
||||||
|
}
|
||||||
|
|
||||||
|
line {
|
||||||
|
stroke-width: 0.004;
|
||||||
|
stroke: bisque;
|
||||||
|
}
|
||||||
|
|
||||||
|
.layer2_deps.bg {
|
||||||
|
fill: url(#gradient_01);
|
||||||
|
}
|
||||||
|
|
||||||
|
.direct_dep.node:hover {
|
||||||
|
transform: scale(2);
|
||||||
|
}
|
||||||
|
|
||||||
|
.layer2_dep.node:hover {
|
||||||
|
transform: scale(1.4);
|
||||||
|
}
|
||||||
|
|
||||||
|
|}
|
||||||
|
|
||||||
|
(* disabled CSS
|
||||||
|
svg {
|
||||||
|
width : 100vw;
|
||||||
|
height : 100vh;
|
||||||
|
}
|
||||||
|
|
||||||
|
.layer2_deps.bg {
|
||||||
|
fill: bisque;
|
||||||
|
}
|
||||||
|
|
||||||
|
.root:hover ~ .node {
|
||||||
|
transform: scale(1.1);
|
||||||
|
}
|
||||||
|
|
||||||
|
transform-origin: center;
|
||||||
|
stroke-width: 0.009 !important;
|
||||||
|
*)
|
||||||
|
|
||||||
|
(*< Note the '.layer2_deps.bg' selector...
|
||||||
|
https://steveliles.github.io/a_multi_class_union_css_selector.html*)
|
||||||
|
(* .layer2_deps.bg fills:
|
||||||
|
OCaml: a_fill @@ `Color ("url(#gradient_01)", None);
|
||||||
|
CSS: fill: url(#gradient_01);
|
||||||
|
*)
|
||||||
|
|
||||||
|
let merge_css cs = String.concat "\n" cs
|
||||||
|
|
||||||
|
type position = {
|
||||||
|
x : float;
|
||||||
|
y : float;
|
||||||
|
}
|
||||||
|
|
||||||
|
let center = { x = 0.5; y = 0.5 }
|
||||||
|
let root_radius = 0.015
|
||||||
|
|
||||||
|
module Unit = struct
|
||||||
|
|
||||||
|
let none size = size, None
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
let make_title ~text =
|
||||||
|
let s = sprintf "%s" text in
|
||||||
|
Svg.(title (txt s))
|
||||||
|
|
||||||
|
let make_circle ~pos ~radius =
|
||||||
|
Svg.[
|
||||||
|
circle ~a:[
|
||||||
|
a_class ["node_circle"];
|
||||||
|
a_cx @@ Unit.none pos.x;
|
||||||
|
a_cy @@ Unit.none pos.y;
|
||||||
|
a_r @@ Unit.none radius;
|
||||||
|
] []
|
||||||
|
]
|
||||||
|
|
||||||
|
let make_square ~center_pos ~width =
|
||||||
|
let open Gg in
|
||||||
|
let center_pos = V2.v center_pos.x center_pos.y in
|
||||||
|
let diagonal = V2.v width width in
|
||||||
|
let center_displacement = V2.half diagonal in
|
||||||
|
let pos = V2.(center_pos - center_displacement) in
|
||||||
|
Svg.[
|
||||||
|
rect ~a:[
|
||||||
|
(* a_stroke @@ `Color ("black", None);
|
||||||
|
* a_stroke_width @@ Unit.none 0.001; *)
|
||||||
|
a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*)
|
||||||
|
a_x @@ Unit.none @@ V2.x pos;
|
||||||
|
a_y @@ Unit.none @@ V2.y pos;
|
||||||
|
a_width @@ Unit.none width;
|
||||||
|
a_height @@ Unit.none width;
|
||||||
|
] []
|
||||||
|
]
|
||||||
|
|
||||||
|
let make_node ~pos ~radius ~text ~classes =
|
||||||
|
let title = make_title ~text in
|
||||||
|
(*> todo; why is this not in Tyxml - browser support missing?*)
|
||||||
|
let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in
|
||||||
|
let a = Svg.[
|
||||||
|
a_class ("node" :: classes);
|
||||||
|
a_transform_origin @@ sprintf "%f %f" pos.x pos.y;
|
||||||
|
] in
|
||||||
|
Svg.g ~a (title :: make_circle ~pos ~radius)
|
||||||
|
|
||||||
|
let make_line ~pos0 ~pos1 =
|
||||||
|
Svg.(line ~a:[
|
||||||
|
a_x1 @@ Unit.none pos0.x;
|
||||||
|
a_y1 @@ Unit.none pos0.y;
|
||||||
|
a_x2 @@ Unit.none pos1.x;
|
||||||
|
a_y2 @@ Unit.none pos1.y;
|
||||||
|
]) []
|
||||||
|
|
||||||
|
let make_edge ~pos0 ~pos1 ~text ~classes =
|
||||||
|
let a = [ Svg.a_class ("edge" :: classes) ] in
|
||||||
|
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 = make_direct_dep_text dep ~layer2_deps
|
||||||
|
and classes = [ dep.name; "direct_dep" ] in
|
||||||
|
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);
|
||||||
|
}
|
||||||
|
.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*)
|
||||||
|
|
||||||
|
(*disabled css:
|
||||||
|
(*> problem: selected other following children as well*)
|
||||||
|
.layer2_dep.hitbox.%s:hover ~ .layer2_dep.node.%s {
|
||||||
|
transform: scale(1.4);
|
||||||
|
}
|
||||||
|
|
||||||
|
*)
|
||||||
|
|
||||||
|
let make_triangle ~top ~left ~right =
|
||||||
|
let a = Svg.[
|
||||||
|
a_points [
|
||||||
|
top.x, top.y;
|
||||||
|
left.x, left.y;
|
||||||
|
right.x, right.y;
|
||||||
|
];
|
||||||
|
a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*)
|
||||||
|
(* a_stroke @@ `Color ("black", None);
|
||||||
|
* a_stroke_width @@ Unit.none 0.002; *)
|
||||||
|
] in
|
||||||
|
Svg.polygon ~a []
|
||||||
|
|
||||||
|
let make_hitbox_direct_dep_edge ~pos0 ~pos1 ~n_edges ~text ~classes =
|
||||||
|
let a = [ Svg.a_class ("edge" :: "hitbox" :: classes) ] in
|
||||||
|
let title = make_title ~text in
|
||||||
|
let left, right =
|
||||||
|
let open Gg in
|
||||||
|
let n_edges = float (max 1 n_edges) in
|
||||||
|
let diff_angle = Float.two_pi /. n_edges in
|
||||||
|
let _pos0, pos1 = V2.(v pos0.x pos0.y, v pos1.x pos1.y) in
|
||||||
|
let center = V2.v center.x center.y in
|
||||||
|
let pos1_rel = V2.(pos1 - center) in
|
||||||
|
let height_triangle =
|
||||||
|
let radius_pos1_rel, _ = V2.(to_polar pos1_rel |> to_tuple) in
|
||||||
|
radius_pos1_rel *. 1.2 in
|
||||||
|
let bottom_width =
|
||||||
|
if diff_angle < Float.pi_div_2 then
|
||||||
|
sin diff_angle *. height_triangle (*Note: Scaling sin by ~ circle-radius*)
|
||||||
|
else
|
||||||
|
height_triangle
|
||||||
|
in
|
||||||
|
let normal_pos1 = V2.(ortho pos1_rel / norm pos1_rel) in
|
||||||
|
let normal'_pos1 = V2.(-1. * normal_pos1) in
|
||||||
|
let right_leg = V2.((0.5 *. bottom_width) * normal_pos1) in
|
||||||
|
let left_leg = V2.((0.5 *. bottom_width) * normal'_pos1) in
|
||||||
|
let pos1_unit = V2.(pos1_rel / norm pos1_rel) in
|
||||||
|
let pos1_extended = V2.(height_triangle * pos1_unit + center) in
|
||||||
|
let right = V2.(right_leg + pos1_extended)
|
||||||
|
and left = V2.(left_leg + pos1_extended) in
|
||||||
|
{ x = V2.x left; y = V2.y left },
|
||||||
|
{ x = V2.x right; y = V2.y right }
|
||||||
|
in
|
||||||
|
Svg.g ~a [ title; make_triangle ~top:pos0 ~left ~right ]
|
||||||
|
|
||||||
|
let make_direct_deps_edges ~deps_w_positions =
|
||||||
|
let open Gg in
|
||||||
|
let n_edges = deps_w_positions |> List.length in
|
||||||
|
let svg =
|
||||||
|
deps_w_positions |> List.concat_map (fun ((dep, pos), layer2_deps) ->
|
||||||
|
let pos1 = pos in
|
||||||
|
let pos0, _pos0_angle =
|
||||||
|
(*> Note: Need this because of mix of CSS selectors and SVG paint order*)
|
||||||
|
let center = V2.v center.x center.y in
|
||||||
|
let pos1 = V2.v pos1.x pos1.y in
|
||||||
|
let pos1_rel = V2.(pos1 - center) in
|
||||||
|
let pos1_rel_angle = V2.angle pos1_rel in
|
||||||
|
let pos0_rel = V2.(v root_radius pos1_rel_angle |> of_polar) in
|
||||||
|
let pos0 = V2.(pos0_rel + center) in
|
||||||
|
{ x = V2.x pos0; y = V2.y pos0 }, pos1_rel_angle
|
||||||
|
in
|
||||||
|
let text = make_direct_dep_text dep ~layer2_deps in
|
||||||
|
let classes = [ dep.name; "direct_dep" ] in
|
||||||
|
let visual_svg = make_edge ~pos0 ~pos1 ~text ~classes in
|
||||||
|
let hitbox_svg =
|
||||||
|
make_hitbox_direct_dep_edge
|
||||||
|
~pos0 ~pos1 ~n_edges ~text ~classes
|
||||||
|
in
|
||||||
|
[ visual_svg; hitbox_svg ]
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let css =
|
||||||
|
deps_w_positions
|
||||||
|
|> List.fold_left (fun acc_css ((dep, _), _) ->
|
||||||
|
let css = make_direct_dep_edge_css dep.name in
|
||||||
|
merge_css [ acc_css; css ]
|
||||||
|
) ""
|
||||||
|
in
|
||||||
|
svg, css
|
||||||
|
|
||||||
|
let make_layer2_nodes_spiral ~layer2_deps ~layer2_deps_center =
|
||||||
|
let open Gg in
|
||||||
|
let dot_radius = root_radius *. 0.25 in
|
||||||
|
layer2_deps |> List.mapi (fun i' layer2_dep ->
|
||||||
|
let i' = float i' +. 5.5 in
|
||||||
|
let pos_radius = sqrt i' *. 0.007 -. 0.005 in
|
||||||
|
let angle_diff = sqrt i' *. Float.two_pi *. 0.005 +. 0.6 in
|
||||||
|
let pos_angle = i' *. angle_diff in
|
||||||
|
let pos_rel = V2.(v pos_radius pos_angle |> of_polar) in
|
||||||
|
let pos = V2.(layer2_deps_center + pos_rel) in
|
||||||
|
let pos = { x = V2.x pos; y = V2.y pos } in
|
||||||
|
let text = layer2_dep.name in
|
||||||
|
let classes = [ layer2_dep.name; "layer2_dep" ] in
|
||||||
|
make_node ~pos ~radius:dot_radius ~text ~classes
|
||||||
|
)
|
||||||
|
|
||||||
|
(*goto implement as iterative search*)
|
||||||
|
let grid_pos ~cell_width i =
|
||||||
|
let open Gg in
|
||||||
|
let north = V2.v 0. cell_width in
|
||||||
|
let west = V2.ortho north in
|
||||||
|
let south = V2.ortho west in
|
||||||
|
let east = V2.ortho south
|
||||||
|
in
|
||||||
|
let rec aux i' len_side consumed_side dir pos_acc =
|
||||||
|
if i = i' then pos_acc else (
|
||||||
|
match dir with
|
||||||
|
| `East ->
|
||||||
|
if consumed_side = len_side then
|
||||||
|
aux i' len_side 0 `South pos_acc
|
||||||
|
else
|
||||||
|
aux (succ i') len_side (succ consumed_side) dir V2.(east + pos_acc)
|
||||||
|
| `South ->
|
||||||
|
if consumed_side = len_side then
|
||||||
|
aux i' len_side 0 `West pos_acc
|
||||||
|
else
|
||||||
|
aux (succ i') len_side (succ consumed_side) dir V2.(south + pos_acc)
|
||||||
|
| `West ->
|
||||||
|
if consumed_side = len_side then
|
||||||
|
aux i' len_side 0 `North pos_acc
|
||||||
|
else
|
||||||
|
aux (succ i') len_side (succ consumed_side) dir V2.(west + pos_acc)
|
||||||
|
| `North ->
|
||||||
|
if consumed_side = len_side then
|
||||||
|
(*> Note special case of jumping to next 'level'*)
|
||||||
|
aux (succ i') (len_side +2) 1 `East V2.(north + pos_acc)
|
||||||
|
else
|
||||||
|
aux (succ i') len_side (succ consumed_side) dir V2.(north + pos_acc)
|
||||||
|
)
|
||||||
|
in
|
||||||
|
aux 0 0 0 `East V2.(v 0. 0.)
|
||||||
|
|
||||||
|
let make_hitbox_square ~center_pos ~width ~text ~classes =
|
||||||
|
let title = make_title ~text in
|
||||||
|
(*> todo; why is this not in Tyxml - browser support missing?*)
|
||||||
|
let a_transform_origin = Svg.Unsafe.string_attrib "transform-origin" in
|
||||||
|
let a = Svg.[
|
||||||
|
a_class ("hitbox" :: classes);
|
||||||
|
a_transform_origin @@ sprintf "%f %f" center_pos.x center_pos.y;
|
||||||
|
] in
|
||||||
|
Svg.g ~a (title :: make_square ~center_pos ~width)
|
||||||
|
|
||||||
|
let make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center =
|
||||||
|
let open Gg in
|
||||||
|
let dot_radius = 0.005 in
|
||||||
|
let cell_width = dot_radius *. 2.5 in
|
||||||
|
layer2_deps |> List.mapi (fun i layer2_dep ->
|
||||||
|
let pos = V2.(layer2_deps_center + grid_pos ~cell_width i) in
|
||||||
|
let pos = { x = V2.x pos; y = V2.y pos } in
|
||||||
|
let text = layer2_dep.name in
|
||||||
|
let classes = [ layer2_dep.name; "layer2_dep" ] in
|
||||||
|
let visual_svg = make_node ~pos ~radius:dot_radius ~text ~classes in
|
||||||
|
let _hitbox_svg =
|
||||||
|
make_hitbox_square ~text ~classes
|
||||||
|
~center_pos:pos
|
||||||
|
~width:cell_width in
|
||||||
|
[ (* hitbox_svg; *)visual_svg ]
|
||||||
|
)
|
||||||
|
|> List.flatten
|
||||||
|
|
||||||
|
let make_layer2_deps ~deps_w_positions =
|
||||||
|
let open Gg in
|
||||||
|
deps_w_positions |> List.mapi
|
||||||
|
(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
|
||||||
|
let mult = if i mod 2 = 0 then 2.14 else 1.5
|
||||||
|
in
|
||||||
|
V2.(mult * (direct_dep_pos - center) + center)
|
||||||
|
in
|
||||||
|
let nodes = make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center in
|
||||||
|
let bg =
|
||||||
|
let pos =
|
||||||
|
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center }
|
||||||
|
and radius = sqrt (float (List.length layer2_deps) +. 1.) *. 0.0115
|
||||||
|
and text = ""
|
||||||
|
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 ~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: #5454ff;
|
||||||
|
}
|
||||||
|
|} 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
|
||||||
|
let len_deps = List.length deps in
|
||||||
|
let diff_angle = Float.two_pi /. float len_deps in
|
||||||
|
deps |> List.mapi (fun i (dep, layer2_deps) ->
|
||||||
|
let angle = diff_angle *. float i in
|
||||||
|
let dist_center = 0.2 in
|
||||||
|
let x = cos angle *. dist_center +. center.x
|
||||||
|
and y = sin angle *. dist_center +. center.y in
|
||||||
|
((dep, { x; y }), layer2_deps)
|
||||||
|
)
|
||||||
|
in
|
||||||
|
let direct_deps_edges, direct_deps_edges_css =
|
||||||
|
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 = merge_css [ direct_deps_edges_css; shared_deps_css ] in
|
||||||
|
svg, css
|
||||||
|
|
||||||
|
let svg_defs = Svg.[ defs [
|
||||||
|
radialGradient ~a:[
|
||||||
|
a_id "gradient_01";
|
||||||
|
a_cx @@ Unit.none 0.5;
|
||||||
|
a_cy @@ Unit.none 0.5;
|
||||||
|
a_r @@ Unit.none 0.5;
|
||||||
|
] [
|
||||||
|
stop ~a:[
|
||||||
|
a_offset @@ `Percentage 0.;
|
||||||
|
a_stop_color "bisque"
|
||||||
|
] [];
|
||||||
|
stop ~a:[
|
||||||
|
a_offset @@ `Percentage 100.;
|
||||||
|
a_stop_color "bisque"; a_stop_opacity 0.
|
||||||
|
] []
|
||||||
|
]
|
||||||
|
]]
|
||||||
|
|
||||||
|
let of_assoc (graph:assoc_graph) : _ output =
|
||||||
|
match graph with
|
||||||
|
| [] -> { svg_content = []; svg_attr = []; 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
|
||||||
|
let deps_svgs, deps_css = make_deps layer2_deps in
|
||||||
|
let svg_attr = [ Svg.a_viewBox (0., 0., 1., 1.) ] in
|
||||||
|
let svg_content = svg_defs @ (root_svg :: deps_svgs) in
|
||||||
|
let css = merge_css [ initial_css; deps_css ] in
|
||||||
|
{ svg_content; svg_attr; css }
|
||||||
|
|
||||||
|
let pp ppf html =
|
||||||
|
Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Html = struct
|
||||||
|
|
||||||
|
module H = Tyxml_html
|
||||||
|
|
||||||
|
type t = H.doc
|
||||||
|
|
||||||
|
let merge_css = String.concat "\n"
|
||||||
|
|
||||||
|
let of_assoc ?(override_css="") (graph:assoc_graph) : t =
|
||||||
|
let svg = Svg.of_assoc graph in
|
||||||
|
H.html
|
||||||
|
(H.head
|
||||||
|
(H.title (H.txt "Dependencies"))
|
||||||
|
[H.style [H.Unsafe.data @@ merge_css [ svg.css; override_css ]]]
|
||||||
|
)
|
||||||
|
(H.body [ H.svg ~a:svg.svg_attr svg.svg_content ])
|
||||||
|
|
||||||
|
let pp ppf html =
|
||||||
|
Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
end
|
||||||
|
|
Loading…
Reference in a new issue