1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
let list_bind f x =
List.map f x |> List.concat
let pp_option f (name, v) =
Fmt.pf f "%s=%S" name v
let fix_escaping s =
if not (String.contains s '&') then s
else (
let b = Buffer.create (String.length s * 2) in
let rec aux i =
match String.index_from_opt s i '&' with
| None -> Buffer.add_substring b s i (String.length s - i)
| Some j ->
Buffer.add_substring b s i (j - i);
Buffer.add_string b "&";
aux (j + 1)
in
aux 0;
Buffer.contents b
)
let limit_str len s =
if String.length s <= len then s
else String.sub s 0 (len - 3) ^ "..."
let node f ?style ?shape ?bg ?url ?tooltip i label =
let url = Option.map fix_escaping url in
let tooltip = Option.map (limit_str 4096) tooltip in
let attrs = [
"label", Some label;
"fillcolor", bg;
"style", style;
"shape", shape;
"URL", url;
"tooltip", tooltip;
"target", (if url = None then None else Some "_top");
] |> list_bind (function
| _, None -> []
| k, Some v -> [k, v]
)
in
Fmt.pf f "n%d [%a]@," i Fmt.(list ~sep:(unit ",") pp_option) attrs
let pp_options f = function
| [] -> ()
| items ->
Fmt.pf f " [%a]"
(Fmt.list ~sep:(Fmt.unit ",") pp_option) items
let edge f ?style ?color a b =
let styles = [
"style", style;
"color", color;
] |> list_bind (function
| _, None -> []
| k, Some v -> [k, v]
)
in
Fmt.pf f "n%d -> n%d%a@," a b pp_options styles
let begin_cluster f i =
Fmt.pf f "subgraph cluster_%d {@," i
let end_cluster f =
Fmt.pf f "}@,"