diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ba7ce2a --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +_build +*~ +*# + diff --git a/app/dune b/app/dune index 21dd2eb..2fe3b23 100644 --- a/app/dune +++ b/app/dune @@ -1,3 +1,4 @@ (executable (name main) - (libraries cmdliner logs logs.fmt opam-graph)) \ No newline at end of file + (public_name opam_graph) + (libraries cmdliner logs logs.fmt fmt.cli fmt.tty logs.cli opam-graph)) diff --git a/app/main.ml b/app/main.ml index 425b9aa..dfc0c83 100644 --- a/app/main.ml +++ b/app/main.ml @@ -11,13 +11,58 @@ let read_file file = invalid_arg ("Error reading file: " ^ file) with _ -> invalid_arg ("Error opening file " ^ file) -let () = - match Sys.argv with - | [| _ ; file |] -> - let switch = read_file file in - let data = OpamFile.SwitchExport.read_from_string switch in - Opam_graph.dependencies data - | _ -> - print_endline "expecting exactly one argument"; - exit 1 +let jump () transitive file output_format = + let switch = read_file file in + let data = OpamFile.SwitchExport.read_from_string switch in + match output_format with + | `Text -> + let graph = Opam_graph.dependencies ~transitive data in + 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 diff --git a/opam-graph.opam b/opam-graph.opam index e69de29..8ab3aa8 100644 --- a/opam-graph.opam +++ b/opam-graph.opam @@ -0,0 +1,30 @@ +opam-version: "2.0" +maintainer: "Robur " +authors: ["Robur "] +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. +""" diff --git a/src/dune b/src/dune index 0f484b0..54bb00c 100644 --- a/src/dune +++ b/src/dune @@ -1,4 +1,5 @@ (library (name opam_graph) (public_name opam-graph) - (libraries opam-core opam-format)) \ No newline at end of file + (libraries opam-core opam-format dot rresult tyxml gg) + ) diff --git a/src/opam_graph.ml b/src/opam_graph.ml index 471de3e..c83e230 100644 --- a/src/opam_graph.ml +++ b/src/opam_graph.ml @@ -1,16 +1,19 @@ -module Set = OpamPackage.Set + +let sprintf = Printf.sprintf + +module OSet = OpamPackage.Set type package = OpamPackage.t let packages (switch : OpamFile.SwitchExport.t) = - assert (Set.cardinal switch.selections.sel_pinned = 0); - assert (Set.cardinal switch.selections.sel_compiler = 0); - assert (Set.subset switch.selections.sel_roots switch.selections.sel_installed); + assert (OSet.cardinal switch.selections.sel_pinned = 0); + assert (OSet.cardinal switch.selections.sel_compiler = 0); + assert (OSet.subset switch.selections.sel_roots switch.selections.sel_installed); switch.selections.sel_installed let root (switch : OpamFile.SwitchExport.t) = - assert (Set.cardinal switch.selections.sel_roots = 1); - Set.choose switch.selections.sel_roots + assert (OSet.cardinal switch.selections.sel_roots = 1); + OSet.choose switch.selections.sel_roots module Name_set = OpamPackage.Name.Set @@ -18,16 +21,43 @@ let filtered_formula_to_pkgs (_switch : OpamFile.SwitchExport.t) ?(set = Name_set.empty) 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 (* TODO depexts *) (* TODO build / dev packages *) (* TODO constraints (os = "linux") *) let direct_dependencies (switch : OpamFile.SwitchExport.t) pkg = - let opam = opam switch pkg in - let set = filtered_formula_to_pkgs switch (OpamFile.OPAM.depends opam) in - filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam) + 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 ~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 @@ -49,7 +79,7 @@ let pp_graph ppf graph = (Name_set.elements deps)))) graph.nodes -let dependencies (switch : OpamFile.SwitchExport.t) = +let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) = let root_pkg = root switch in let top = root_pkg.OpamPackage.name 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 | None -> graph | 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 = - Name_set.filter (fun name -> - OpamPackage.Set.exists - (fun pkg -> pkg.OpamPackage.name = name) - available) - deps + deps + |> Name_set.filter (fun name -> + OpamPackage.Set.exists + (fun pkg -> pkg.OpamPackage.name = name) + available + ) in let graph = add_node graph x deps in let work = @@ -74,5 +108,621 @@ let dependencies (switch : OpamFile.SwitchExport.t) = in find_deps graph work in - let graph = find_deps graph (Name_set.singleton top) in - Format.printf "%a" pp_graph graph + find_deps graph (Name_set.singleton top) + +(*!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