Source file node_to_dot.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
open! Core

let print_node out ~name ~kind ~height ~user_info =
  let default = For_analyzer.Dot_user_info.default ~name ~kind ~height in
  let info =
    match user_info with
    | None -> default
    | Some user_info -> For_analyzer.Dot_user_info.append default user_info
  in
  fprintf
    out
    "%s\n"
    (For_analyzer.Dot_user_info.to_string ~name (For_analyzer.Dot_user_info.to_dot info))
;;

let save_dot ~emit_bind_edges out ts =
  let node_name =
    if am_running_test
    then fun _ -> "n###"
    else fun id -> "n" ^ For_analyzer.Node_id.to_string id
  in
  fprintf out "digraph G {\n";
  fprintf out "  rankdir = BT\n";
  let seen = For_analyzer.Node_id.Hash_set.create () in
  let bind_edges = ref [] in
  For_analyzer.traverse
    ts
    ~add_node:
      (fun
        ~id
        ~kind
        ~cutoff:_
        ~children
        ~bind_children
        ~user_info
        ~recomputed_at:_
        ~changed_at:_
        ~height
        ->
    let name = node_name id in
    Hash_set.add seen id;
    print_node out ~name ~kind ~height ~user_info;
    List.iter children ~f:(fun child_id ->
      fprintf out "  %s -> %s\n" (node_name child_id) name);
    List.iter bind_children ~f:(fun bind_child_id ->
      bind_edges := (bind_child_id, id) :: !bind_edges));
  if emit_bind_edges
  then
    List.iter !bind_edges ~f:(fun (bind_child_id, id) ->
      if Hash_set.mem seen bind_child_id
      then
        fprintf out "  %s -> %s [style=dashed]\n" (node_name id) (node_name bind_child_id));
  fprintf out "}\n%!"
;;

let save_dot_to_file ~emit_bind_edges file ts =
  Out_channel.with_file file ~f:(fun out -> save_dot ~emit_bind_edges out ts)
;;