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

whitespace cleanups, removed removal of warnings

Browse source
This commit is contained in:
Hannes Mehnert 2022-01-27 12:58:39 +01:00
parent 82f99de39c
commit 2bd5d0eae3
2 changed files with 47 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/dune
View file

@ -2,5 +2,4 @@
(name opam_graph) (name opam_graph)
(public_name opam-graph) (public_name opam-graph)
(libraries opam-core opam-format dot rresult tyxml gg) (libraries opam-core opam-format dot rresult tyxml gg)
(flags (:standard (-w -27-26)))
) )

96
src/opam_graph.ml
View file

@ -34,7 +34,7 @@ let direct_dependencies (switch : OpamFile.SwitchExport.t) pkg =
let transitive_dependencies (switch : OpamFile.SwitchExport.t) pkg = let transitive_dependencies (switch : OpamFile.SwitchExport.t) pkg =
let available = switch.selections.sel_installed in let available = switch.selections.sel_installed in
let rec aux pkg seen_pkgs = let rec aux pkg seen_pkgs =
let opam = opam_file switch pkg in 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
let set = filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam) in let set = filtered_formula_to_pkgs switch ~set (OpamFile.OPAM.depopts opam) in
@ -80,7 +80,6 @@ let pp_graph ppf graph =
graph.nodes graph.nodes
let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) = let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) =
let available = switch.selections.sel_installed in
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
@ -90,7 +89,7 @@ let dependencies ?(transitive=false) (switch : OpamFile.SwitchExport.t) =
| None -> graph | None -> graph
| Some x -> | Some x ->
let deps = match transitive with let deps = match transitive with
| true -> transitive_dependencies switch x | true -> transitive_dependencies switch x
| false -> direct_dependencies switch x | false -> direct_dependencies switch x
in in
let deps = let deps =
@ -117,7 +116,7 @@ type assoc_node = {
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 Ui = struct module Ui = struct
let dependencies ?(transitive=true) data : assoc_graph = let dependencies ?(transitive=true) data : assoc_graph =
@ -126,7 +125,7 @@ module Ui = struct
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
let direct_deps = let direct_deps =
all_direct_deps.nodes all_direct_deps.nodes
|> Name_map.find root |> Name_map.find root
in in
@ -144,7 +143,7 @@ module Ui = struct
| None -> Name_set.empty | None -> Name_set.empty
| Some v -> v) | Some v -> v)
|> Name_set.elements |> Name_set.elements
|> List.map OpamPackage.Name.to_string |> List.map OpamPackage.Name.to_string
in in
let direct_dep = OpamPackage.Name.to_string direct_dep in let direct_dep = OpamPackage.Name.to_string direct_dep in
direct_dep, transitive_deps direct_dep, transitive_deps
@ -174,7 +173,7 @@ module Ui = struct
end end
module Render = struct module Render = struct
module Dot = struct module Dot = struct
@ -189,7 +188,7 @@ module Render = struct
let pkg_point = Edge_node_id (pkg_id, None) in let pkg_point = Edge_node_id (pkg_id, None) in
let deps_points = let deps_points =
Name_set.elements deps Name_set.elements deps
|> List.map (fun p -> |> List.map (fun p ->
let id = Double_quoted_id (OpamPackage.Name.to_string p) in let id = Double_quoted_id (OpamPackage.Name.to_string p) in
Edge_node_id (id, None) Edge_node_id (id, None)
) )
@ -207,7 +206,7 @@ module Render = struct
let id_of_assoc_node node = let id_of_assoc_node node =
sprintf "%s_%s" node.name node.uniqueness_postfix sprintf "%s_%s" node.name node.uniqueness_postfix
let of_assoc (graph:assoc_graph) : t = let of_assoc (graph:assoc_graph) : t =
let open Odot in let open Odot in
let stmt_list = let stmt_list =
@ -218,7 +217,7 @@ module Render = struct
let pkg_point = Edge_node_id (pkg_id, None) in let pkg_point = Edge_node_id (pkg_id, None) in
let deps_points = let deps_points =
deps deps
|> List.map (fun pkg -> |> List.map (fun pkg ->
let id = Double_quoted_id (id_of_assoc_node pkg) in let id = Double_quoted_id (id_of_assoc_node pkg) in
Edge_node_id (id, None) Edge_node_id (id, None)
) )
@ -227,7 +226,7 @@ module Render = struct
Stmt_edge edge Stmt_edge edge
in in
stmt :: acc stmt :: acc
) [] ) []
in in
{ strict = false; (*todo test params*) { strict = false; (*todo test params*)
kind = Digraph; kind = Digraph;
@ -282,8 +281,8 @@ line {
|} |}
(* disabled CSS (* disabled CSS
svg { svg {
width : 100vw; width : 100vw;
height : 100vh; height : 100vh;
} }
@ -300,23 +299,23 @@ svg {
stroke-width: 0.009 !important; stroke-width: 0.009 !important;
*) *)
(*< Note the '.layer2_deps.bg' selector... (*< Note the '.layer2_deps.bg' selector...
https://steveliles.github.io/a_multi_class_union_css_selector.html*) https://steveliles.github.io/a_multi_class_union_css_selector.html*)
(* .layer2_deps.bg fills: (* .layer2_deps.bg fills:
OCaml: a_fill @@ `Color ("url(#gradient_01)", None); OCaml: a_fill @@ `Color ("url(#gradient_01)", None);
CSS: fill: url(#gradient_01); CSS: fill: url(#gradient_01);
*) *)
let merge_css cs = String.concat "\n" cs let merge_css cs = String.concat "\n" cs
type position = { type position = {
x : float; x : float;
y : float; y : float;
} }
let center = { x = 0.5; y = 0.5 } let center = { x = 0.5; y = 0.5 }
let root_radius = 0.015 let root_radius = 0.015
module Unit = struct module Unit = struct
let none size = size, None let none size = size, None
@ -330,7 +329,7 @@ svg {
let make_circle ~pos ~radius = let make_circle ~pos ~radius =
Svg.[ Svg.[
circle ~a:[ circle ~a:[
a_class ["node_circle"]; a_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;
@ -345,7 +344,7 @@ svg {
let pos = V2.(center_pos - center_displacement) in let pos = V2.(center_pos - center_displacement) in
Svg.[ Svg.[
rect ~a:[ rect ~a:[
(* a_stroke @@ `Color ("black", None); (* a_stroke @@ `Color ("black", None);
* a_stroke_width @@ Unit.none 0.001; *) * a_stroke_width @@ Unit.none 0.001; *)
a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*) a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*)
a_x @@ Unit.none @@ V2.x pos; a_x @@ Unit.none @@ V2.x pos;
@ -354,7 +353,7 @@ svg {
a_height @@ Unit.none width; a_height @@ Unit.none width;
] [] ] []
] ]
let make_node ~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?*)
@ -378,14 +377,14 @@ 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 = let make_direct_dep_text dep ~layer2_deps =
sprintf "Direct dependency: %s\nDirect dependencies: %d" sprintf "Direct dependency: %s\nDirect dependencies: %d"
dep.name (List.length layer2_deps) dep.name (List.length layer2_deps)
let make_direct_deps_nodes ~deps_w_positions = let make_direct_deps_nodes ~deps_w_positions =
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 = [ dep.name; "direct_dep" ] in
make_node ~pos ~radius ~text ~classes make_node ~pos ~radius ~text ~classes
) )
@ -400,7 +399,7 @@ svg {
.direct_dep.node.%s:hover ~ .layer2_deps.bg.%s { .direct_dep.node.%s:hover ~ .layer2_deps.bg.%s {
fill: dimgrey; fill: dimgrey;
} }
|} dep dep dep dep dep dep |} dep dep dep dep dep dep
(*< goto move generation of node-css to some other place*) (*< goto move generation of node-css to some other place*)
(*disabled css: (*disabled css:
@ -410,7 +409,7 @@ svg {
} }
*) *)
let make_triangle ~top ~left ~right = let make_triangle ~top ~left ~right =
let a = Svg.[ let a = Svg.[
a_points [ a_points [
@ -419,26 +418,26 @@ svg {
right.x, right.y; right.x, right.y;
]; ];
a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*) a_fill @@ `Color ("rgba(0,0,0,0)", None); (*goto control with css*)
(* a_stroke @@ `Color ("black", None); (* a_stroke @@ `Color ("black", None);
* a_stroke_width @@ Unit.none 0.002; *) * a_stroke_width @@ Unit.none 0.002; *)
] in ] in
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 ("edge" :: "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
let n_edges = float (max 1 n_edges) in let n_edges = float (max 1 n_edges) in
let diff_angle = Float.two_pi /. 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 _pos0, pos1 = V2.(v pos0.x pos0.y, v pos1.x pos1.y) in
let center = V2.v center.x center.y in let center = V2.v center.x center.y in
let pos1_rel = V2.(pos1 - center) in let pos1_rel = V2.(pos1 - center) in
let height_triangle = let height_triangle =
let radius_pos1_rel, _ = V2.(to_polar pos1_rel |> to_tuple) in let radius_pos1_rel, _ = V2.(to_polar pos1_rel |> to_tuple) in
radius_pos1_rel *. 1.2 in radius_pos1_rel *. 1.2 in
let bottom_width = let bottom_width =
if diff_angle < Float.pi_div_2 then if diff_angle < Float.pi_div_2 then
sin diff_angle *. height_triangle (*Note: Scaling sin by ~ circle-radius*) sin diff_angle *. height_triangle (*Note: Scaling sin by ~ circle-radius*)
else else
height_triangle height_triangle
@ -455,14 +454,14 @@ svg {
{ x = V2.x right; y = V2.y right } { x = V2.x right; y = V2.y right }
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 = 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 =
deps_w_positions |> List.concat_map (fun ((dep, pos), layer2_deps) -> deps_w_positions |> List.concat_map (fun ((dep, pos), layer2_deps) ->
let pos1 = pos in let pos1 = pos in
let pos0, pos0_angle = let pos0, _pos0_angle =
(*> Note: Need this because of mix of CSS selectors and SVG paint order*) (*> Note: Need this because of mix of CSS selectors and SVG paint order*)
let center = V2.v center.x center.y in let center = V2.v center.x center.y in
let pos1 = V2.v pos1.x pos1.y in let pos1 = V2.v pos1.x pos1.y in
@ -499,7 +498,7 @@ svg {
let pos_radius = sqrt i' *. 0.007 -. 0.005 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 angle_diff = sqrt i' *. Float.two_pi *. 0.005 +. 0.6 in
let pos_angle = i' *. angle_diff in let pos_angle = i' *. angle_diff in
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 = layer2_dep.name in let text = layer2_dep.name in
@ -555,7 +554,6 @@ svg {
let make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center = let make_layer2_nodes_grid ~layer2_deps ~layer2_deps_center =
let open Gg in let open Gg in
let n_layer2_deps = List.length layer2_deps in
let dot_radius = 0.005 in let dot_radius = 0.005 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 ->
@ -564,8 +562,8 @@ svg {
let text = layer2_dep.name in let text = layer2_dep.name in
let classes = [ layer2_dep.name; "layer2_dep" ] in let classes = [ layer2_dep.name; "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
~center_pos:pos ~center_pos:pos
~width:cell_width in ~width:cell_width in
[ (* hitbox_svg; *)visual_svg ] [ (* hitbox_svg; *)visual_svg ]
@ -614,10 +612,10 @@ svg {
) )
|> List.of_seq |> List.of_seq
|> merge_css |> merge_css
let make_shared_deps_css ~deps_w_positions = let make_shared_deps_css ~deps_w_positions =
let module SSet = Set.Make(String) in let module SSet = Set.Make(String) in
let sset_of_deps deps = let sset_of_deps deps =
deps deps
|> List.map (fun dep -> dep.name) |> List.map (fun dep -> dep.name)
|> SSet.of_list |> SSet.of_list
@ -639,7 +637,7 @@ svg {
make_shared_deps_css_aux ~dep ~shared_deps make_shared_deps_css_aux ~dep ~shared_deps
) )
|> merge_css |> merge_css
let make_deps (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
@ -654,15 +652,15 @@ svg {
) )
in in
let direct_deps_edges, direct_deps_edges_css = let direct_deps_edges, direct_deps_edges_css =
make_direct_deps_edges ~deps_w_positions make_direct_deps_edges ~deps_w_positions
and direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions and direct_deps_nodes = make_direct_deps_nodes ~deps_w_positions
and layer2_deps = make_layer2_deps ~deps_w_positions and layer2_deps = make_layer2_deps ~deps_w_positions
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
let css = merge_css [ direct_deps_edges_css; shared_deps_css ] in let css = merge_css [ direct_deps_edges_css; shared_deps_css ] in
svg, css svg, css
let svg_defs = Svg.[ defs [ let svg_defs = Svg.[ defs [
radialGradient ~a:[ radialGradient ~a:[
a_id "gradient_01"; a_id "gradient_01";
@ -704,15 +702,15 @@ svg {
Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html Format.fprintf ppf "%a@." (Tyxml_svg.pp ()) html
end end
module Html = struct module Html = struct
module H = Tyxml_html module H = Tyxml_html
type t = H.doc type t = H.doc
let merge_css = String.concat "\n" let merge_css = String.concat "\n"
let of_assoc ?(override_css="") (graph:assoc_graph) : t = 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
@ -724,7 +722,7 @@ svg {
let pp ppf html = let pp ppf html =
Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html Format.fprintf ppf "%a@." (Tyxml_html.pp ()) html
end end
end end