Source file dot_user_info.ml

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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
open Core
open! Import

module String_list = struct
  type t = string list [@@deriving compare, sexp_of]

  include (val Comparator.make ~sexp_of_t ~compare)
end

type dot =
  { label : Set.M(String_list).t
  ; attributes : string String.Map.t
  }
[@@deriving sexp_of]

type t =
  | Dot of dot
  | Info of Info.t
  | Append of
      { prior : t
      ; new_ : t
      }
[@@deriving sexp_of]

let info info = Info info
let append prior new_ = Append { prior; new_ }

let dot ~label ~attributes =
  let label = Set.singleton (module String_list) label in
  Dot { label; attributes }
;;

let rec to_dot = function
  | Info i ->
    { label = Set.singleton (module String_list) [ Info.to_string_hum i ]
    ; attributes = String.Map.empty
    }
  | Dot dot -> dot
  | Append { prior; new_ } ->
    let prior = to_dot prior in
    let new_ = to_dot new_ in
    let label = Set.union prior.label new_.label in
    let attributes =
      Map.merge_skewed
        prior.attributes
        new_.attributes
        ~combine:(fun ~key:_ _left right -> right)
    in
    { label; attributes }
;;

let escape_dot_string s =
  (* https://graphviz.org/doc/info/lang.html *)
  "\"" ^ String.substr_replace_all s ~pattern:"\"" ~with_:"\\\"" ^ "\""
;;

let escape_record_label s =
  (* https://graphviz.org/doc/info/shapes.html *)
  String.concat_map s ~f:(function
    | ('<' | '>' | '{' | '}' | '|' | '\\' | ' ') as c -> "\\" ^ String.of_char c
    | c -> String.of_char c)
;;

let to_string ~name { label; attributes } =
  let label =
    label
    |> Set.to_list
    |> List.map ~f:(fun cols ->
      "{" ^ String.concat (List.map cols ~f:escape_record_label) ~sep:"|" ^ "}")
    |> String.concat ~sep:"|"
    |> fun s -> "{" ^ s ^ "}"
  in
  let attributes =
    attributes
    |> Map.to_alist
    |> List.map ~f:(fun (k, v) ->
      sprintf {| %s=%s|} (escape_dot_string k) (escape_dot_string v))
    |> String.concat ~sep:" "
  in
  sprintf {|  %s [shape=Mrecord label=%s %s]|} name (escape_dot_string label) attributes
;;