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

Compare commits

base: robur:2fd3da6ceb2fa10c6bf18ddaf189bb106099a4d4
Branches Tags
robur:main
..
compare: robur:ae8dd4d08d6f590a608d3b746e7665a5a11e6724
Branches Tags
robur:main

No commits in common. "2fd3da6ceb2fa10c6bf18ddaf189bb106099a4d4" and "ae8dd4d08d6f590a608d3b746e7665a5a11e6724" have entirely different histories.
2fd3da6ceb ... ae8dd4d08d

3 changed files with 44 additions and 138 deletions
Show stats Expand all files Collapse all files

7
app/main.ml
View file

@ -62,8 +62,7 @@ let file =
Arg.(required & pos 0 (some file) None & info [ ] ~doc ~docv:"FILE") Arg.(required & pos 0 (some file) None & info [ ] ~doc ~docv:"FILE")
let cmd = let cmd =
let term = Term.(const jump $ setup_log $ transitive $ file $ output_format) in Term.(const jump $ setup_log $ transitive $ file $ output_format),
let info = Cmd.info "opam_graph" ~version:"%%VERSION%%" in Term.info "opam_graph" ~version:"%%VERSION%%"
Cmd.v info term
let () = Cmd.eval cmd |> exit let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

2
opam-graph.opam
View file

@ -9,7 +9,7 @@ license: "ISC"
depends: [ depends: [
"ocaml" {>= "4.08.0"} "ocaml" {>= "4.08.0"}
"dune" {>= "2.0.0"} "dune" {>= "2.0.0"}
"cmdliner" {>= "1.1.0"} "cmdliner"
"fmt" {>= "0.8.7"} "fmt" {>= "0.8.7"}
"logs" "logs"
"opam-core" "opam-core"

173
src/opam_graph.ml
View file

@ -79,7 +79,7 @@ let pp_graph ppf graph =
(Name_set.elements deps)))) (Name_set.elements deps))))
graph.nodes graph.nodes
let dependencies ~transitive (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
@ -115,28 +115,13 @@ type assoc_node = {
name : string; name : string;
uniqueness_postfix : string; uniqueness_postfix : string;
} }
type assoc_graph = (assoc_node * (assoc_node list)) list type assoc_graph = (assoc_node * (assoc_node list)) list
module SMap = Map.Make(String)
type assoc_stats = int SMap.t
let calc_sharing_stats (deps:graph) : assoc_stats =
Name_map.fold (fun _pkg deps acc_stats ->
Name_set.fold (fun dep acc_stats ->
let dep_name = OpamPackage.Name.to_string dep in
acc_stats |> SMap.update dep_name (function
| None -> Some 1
| Some count -> Some (succ count))
) deps acc_stats
) deps.nodes SMap.empty
module Ui = struct module Ui = struct
let dependencies ?(transitive=true) data : assoc_graph = let dependencies ?(transitive=true) data : assoc_graph =
(*> todo can be made more efficient*) (*> todo can be made more efficient*)
let all_direct_deps = dependencies ~transitive:false data in let all_direct_deps = dependencies data in
let root = all_direct_deps.top in let root = all_direct_deps.top in
let root_str = OpamPackage.Name.to_string root let root_str = OpamPackage.Name.to_string root
in in
@ -144,10 +129,9 @@ module Ui = struct
all_direct_deps.nodes all_direct_deps.nodes
|> Name_map.find root |> Name_map.find root
in in
(*> todo can be made more efficient*)
let all_transitive_deps = let all_transitive_deps =
if transitive = false then all_direct_deps else dependencies ~transitive data in
dependencies ~transitive data
in
let direct_deps_w_transitive_deps = let direct_deps_w_transitive_deps =
direct_deps direct_deps
|> Name_set.elements |> Name_set.elements
@ -282,15 +266,7 @@ module Render = struct
.deps-line { .deps-line {
stroke-width: 0.4; stroke-width: 0.4;
stroke: #80746e; stroke: bisque;
}
.deps-node {
fill: #ccc;
}
.deps-root {
fill: black;
} }
.deps-layer2_deps.deps-bg { .deps-layer2_deps.deps-bg {
@ -305,10 +281,6 @@ module Render = struct
transform: scale(1.4); transform: scale(1.4);
} }
.deps-layer2_dep.deps-hitbox:hover + .deps-node {
transform: scale(1.4);
}
|} |}
(* disabled CSS (* disabled CSS
@ -384,16 +356,12 @@ svg {
] [] ] []
] ]
let make_node ?(with_node_class=true) ~pos ~radius ~text ~classes () = let make_node ~pos ~radius ~text ~classes =
let title = make_title ~text in let title = make_title ~text in
(*> 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 classes =
if not with_node_class then classes else
scoped_class "node" :: classes
in
let a = Svg.[ let a = Svg.[
a_class 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)
@ -412,32 +380,19 @@ svg {
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 ]
let make_direct_dep_text dep ~layer2_deps ~(sharing_stats:assoc_stats) = let make_direct_dep_text dep ~layer2_deps =
sprintf sprintf "Direct dependency: %s\nDirect dependencies: %d"
"Direct dependency: %s\n\ dep.name (List.length layer2_deps)
Amount of direct dependencies: %d\n\
Amount of reverse dependencies: %d"
dep.name
(List.length layer2_deps)
(SMap.find_opt dep.name sharing_stats |> Option.value ~default:0)
(*> todo add amount of direct deps?*) let make_direct_deps_nodes ~deps_w_positions =
let make_layer2_dep_text dep ~(sharing_stats:assoc_stats) =
sprintf
"Indirect dependency: %s\n\
Amount of reverse dependencies: %d"
dep
(SMap.find_opt dep sharing_stats |> Option.value ~default:0)
let make_direct_deps_nodes ~deps_w_positions ~(sharing_stats:assoc_stats) =
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 ~sharing_stats and text = make_direct_dep_text dep ~layer2_deps
and classes = [ and classes = [
scoped_class dep.name; scoped_class dep.name;
scoped_class "direct_dep" scoped_class "direct_dep"
] in ] in
make_node ~pos ~radius ~text ~classes () make_node ~pos ~radius ~text ~classes
) )
let make_direct_dep_edge_css dep = let make_direct_dep_edge_css dep =
@ -511,7 +466,7 @@ svg {
in in
Svg.g ~a [ title; make_triangle ~top:pos0 ~left ~right ] Svg.g ~a [ title; make_triangle ~top:pos0 ~left ~right ]
let make_direct_deps_edges ~deps_w_positions ~(sharing_stats:assoc_stats) = let make_direct_deps_edges ~deps_w_positions =
let open Gg in let open Gg in
let n_edges = deps_w_positions |> List.length in let n_edges = deps_w_positions |> List.length in
let svg = let svg =
@ -527,11 +482,7 @@ svg {
let pos0 = V2.(pos0_rel + center) in let pos0 = V2.(pos0_rel + center) in
{ 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 = let text = make_direct_dep_text dep ~layer2_deps in
make_direct_dep_text dep
~layer2_deps
~sharing_stats
in
let classes = [ let classes = [
scoped_class dep.name; scoped_class dep.name;
scoped_class "direct_dep" scoped_class "direct_dep"
@ -554,10 +505,7 @@ svg {
svg, css svg, css
(*goto values might need to be updated to fit new viewbox*) (*goto values might need to be updated to fit new viewbox*)
let make_layer2_nodes_spiral let make_layer2_nodes_spiral ~layer2_deps ~layer2_deps_center =
~layer2_deps
~layer2_deps_center
~(sharing_stats:assoc_stats) =
let open Gg in let open Gg in
let dot_radius = root_radius *. 0.25 in let dot_radius = root_radius *. 0.25 in
layer2_deps |> List.mapi (fun i' layer2_dep -> layer2_deps |> List.mapi (fun i' layer2_dep ->
@ -568,13 +516,12 @@ svg {
let pos_rel = V2.(v pos_radius pos_angle |> of_polar) in let pos_rel = V2.(v pos_radius pos_angle |> of_polar) in
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 = let text = layer2_dep.name in
make_layer2_dep_text layer2_dep.name ~sharing_stats in
let classes = [ let classes = [
scoped_class layer2_dep.name; scoped_class layer2_dep.name;
scoped_class "layer2_dep"; scoped_class "layer2_dep";
] in ] in
make_node ~pos ~radius:dot_radius ~text ~classes () make_node ~pos ~radius:dot_radius ~text ~classes
) )
let grid_pos ~cell_width i = let grid_pos ~cell_width i =
@ -622,34 +569,31 @@ svg {
] in ] in
Svg.g ~a (title :: make_square ~center_pos ~width) Svg.g ~a (title :: make_square ~center_pos ~width)
let make_layer2_nodes_grid let make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center =
~layer2_deps
~layer2_deps_center
~(sharing_stats:assoc_stats) =
let open Gg in let open Gg in
let dot_radius = 0.5 in let dot_radius = 0.5 in
let cell_width = dot_radius *. 2.5 in let cell_width = dot_radius *. 2.5 in
layer2_deps |> List.mapi (fun i layer2_dep -> layer2_deps |> List.mapi (fun i layer2_dep ->
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 = make_layer2_dep_text layer2_dep.name ~sharing_stats in let text = layer2_dep.name in
let classes = [ let classes = [
scoped_class layer2_dep.name; scoped_class layer2_dep.name;
scoped_class "layer2_dep"; scoped_class "layer2_dep";
] in ] 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
~center_pos:pos ~center_pos:pos
~width:cell_width in ~width:cell_width in
[ hitbox_svg; visual_svg ] [ (* hitbox_svg; *)visual_svg ]
) )
|> List.flatten |> List.flatten
let make_layer2_deps ~deps_w_positions ~(sharing_stats:assoc_stats) = let make_layer2_deps ~deps_w_positions =
let open Gg in let open Gg in
deps_w_positions |> List.mapi deps_w_positions |> List.mapi
(fun i ((_dep, direct_dep_pos), layer2_deps) -> (fun i ((dep, direct_dep_pos), layer2_deps) ->
let layer2_deps_center = let layer2_deps_center =
let direct_dep_pos = V2.(v direct_dep_pos.x direct_dep_pos.y) in 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 center = V2.v center.x center.y in
@ -657,12 +601,7 @@ svg {
in in
V2.(mult * (direct_dep_pos - center) + center) V2.(mult * (direct_dep_pos - center) + center)
in in
let nodes = let nodes = make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center in
make_layer2_nodes_grid
~layer2_deps
~layer2_deps_center
~sharing_stats
in
let bg = let bg =
let pos = let pos =
{ x = V2.x layer2_deps_center; y = V2.y layer2_deps_center } { x = V2.x layer2_deps_center; y = V2.y layer2_deps_center }
@ -671,8 +610,9 @@ svg {
and classes = [ and classes = [
scoped_class "layer2_deps"; scoped_class "layer2_deps";
scoped_class "bg"; scoped_class "bg";
scoped_class dep.name
] in ] in
make_node ~with_node_class:false ~pos ~radius ~text ~classes () make_node ~pos ~radius ~text ~classes
in in
let edge = let edge =
let pos0 = direct_dep_pos in let pos0 = direct_dep_pos in
@ -692,7 +632,6 @@ svg {
.deps-direct_dep.%s:hover ~ .deps-direct_dep.%s:hover ~
.deps-node.deps-layer2_dep.%s { .deps-node.deps-layer2_dep.%s {
fill: #5454ff; fill: #5454ff;
filter: brightness(1.0) !important;
} }
|} (scoped_class dep.name) (scoped_class shared_dep) |} (scoped_class dep.name) (scoped_class shared_dep)
) )
@ -724,7 +663,7 @@ svg {
) )
|> merge_css |> merge_css
let make_deps ~(sharing_stats:assoc_stats) (deps:assoc_graph) = let make_deps (deps:assoc_graph) =
let deps_w_positions = let deps_w_positions =
let open Gg in let open Gg in
let len_deps = List.length deps in let len_deps = List.length deps in
@ -738,14 +677,9 @@ svg {
) )
in in
let direct_deps_edges, direct_deps_edges_css = let direct_deps_edges, direct_deps_edges_css =
make_direct_deps_edges make_direct_deps_edges ~deps_w_positions
~deps_w_positions and direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions
~sharing_stats and layer2_deps = make_layer2_deps ~deps_w_positions
and direct_deps_nodes =
make_direct_deps_nodes
~sharing_stats
~deps_w_positions
and layer2_deps = make_layer2_deps ~deps_w_positions ~sharing_stats
and shared_deps_css = make_shared_deps_css ~deps_w_positions and shared_deps_css = make_shared_deps_css ~deps_w_positions
in in
let svg = direct_deps_edges @ direct_deps_nodes @ layer2_deps in let svg = direct_deps_edges @ direct_deps_nodes @ layer2_deps in
@ -761,38 +695,16 @@ svg {
] [ ] [
stop ~a:[ stop ~a:[
a_offset @@ `Percentage 0.; a_offset @@ `Percentage 0.;
a_stop_color "#80746e"; (* "bisque" *) a_stop_color "bisque"
] []; ] [];
stop ~a:[ stop ~a:[
a_offset @@ `Percentage 100.; a_offset @@ `Percentage 100.;
a_stop_color "#80746e"; (* "bisque" *) a_stop_color "bisque"; a_stop_opacity 0.
a_stop_opacity 0.
] [] ] []
] ]
]] ]]
let make_deps_sharing_css (sharing_stats:assoc_stats) = let of_assoc (graph:assoc_graph) : _ output =
let max_count =
(*> todo; would be more correct to use the count of nodes in dep-graph*)
SMap.fold
(fun _pkg count max_count -> max max_count count)
sharing_stats 0
|> float
|> ( *. ) 0.2
in
SMap.fold (fun pkg count acc ->
let pct_count = Float.min 1. (float count /. max_count) in
let css = sprintf "\
.%s.%s {\
filter: brightness(%f);\
}\
" (scoped_class "node") (scoped_class pkg) pct_count
in
css :: acc
) sharing_stats []
|> merge_css
let of_assoc ~(sharing_stats:assoc_stats) (graph:assoc_graph) : _ output =
match graph with match graph with
| [] -> { svg_content = []; svg_attr = []; css = "" } | [] -> { svg_content = []; svg_attr = []; css = "" }
| (root_pkg, direct_deps) :: layer2_deps -> | (root_pkg, direct_deps) :: layer2_deps ->
@ -806,17 +718,15 @@ svg {
scoped_class root_pkg.name; scoped_class root_pkg.name;
scoped_class "root" scoped_class "root"
] in ] in
make_node ~pos ~radius ~text ~classes () make_node ~pos ~radius ~text ~classes
in in
let deps_svgs, deps_css = let deps_svgs, deps_css = make_deps layer2_deps in
make_deps ~sharing_stats layer2_deps in
let deps_sharing_css = make_deps_sharing_css sharing_stats in
let svg_attr = Svg.[ let svg_attr = Svg.[
a_viewBox (0., 0., 100., 100.); a_viewBox (0., 0., 100., 100.);
a_class [ scoped_class "svg-wrap" ]; a_class [ scoped_class "svg-wrap" ];
] in ] 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; deps_sharing_css ] in let css = merge_css [ initial_css; deps_css ] in
{ svg_content; svg_attr; css } { svg_content; svg_attr; css }
let pp ppf html = let pp ppf html =
@ -832,11 +742,8 @@ svg {
let merge_css = String.concat "\n" let merge_css = String.concat "\n"
let of_assoc let of_assoc ?(override_css="") (graph:assoc_graph) : t =
?(override_css="") let svg = Svg.of_assoc graph in
?(sharing_stats:assoc_stats=SMap.empty)
(graph:assoc_graph) : t =
let svg = Svg.of_assoc ~sharing_stats graph in
H.html H.html
(H.head (H.head
(H.title (H.txt "Dependencies")) (H.title (H.txt "Dependencies"))