package inuit

  1. Overview
  2. Docs

Source file inuit_trace.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
external reraise : exn -> 'a = "%reraise"

type 'flags trace = {
  cursor: 'flags Inuit_cursor.cursor;
  depth: int;
}

let null = { cursor = Inuit_cursor.null; depth = 0 }

let initial ?(depth=3) k = { cursor = Inuit_cursor.sub k; depth }

let sub t =
  if Inuit_cursor.is_closed t.cursor then null
  else {
    cursor = Inuit_cursor.shift_indent (Inuit_cursor.sub t.cursor) (+1);
    depth = if t.depth = 0 then 3 else t.depth - 1;
  }

let button_text opened =
  if opened then "[-]" else "[+]"

(*let enter name printer_arg printer_res f t arg =*)

let display_result t time_ms msg =
  if time_ms > 0.1 then
    Inuit_cursor.printf t "%s (in %.02f ms)" msg time_ms
  else
    Inuit_cursor.text t msg

let call name printer_arg printer_res f t arg =
  if Inuit_cursor.is_closed t.cursor then f t arg else (
    Inuit_cursor.text t.cursor "\n";
    let button = Inuit_cursor.sub t.cursor in
    let opened = ref (t.depth > 0) in
    Inuit_cursor.printf t.cursor " %s(%s) = " name (printer_arg arg);
    let result = Inuit_cursor.sub t.cursor in
    Inuit_cursor.text result "...";
    let t' = sub t in
    let render () =
      Inuit_cursor.clear t'.cursor;
      let time = Sys.time () in
      match f (if !opened then t' else null) arg with
      | value ->
        let dtime = (Sys.time () -. time) *. 1000.0 in
        Inuit_cursor.clear result;
        display_result result dtime (printer_res value);
        value
      | exception exn ->
        let dtime = (Sys.time () -. time) *. 1000.0 in
        Inuit_cursor.clear result;
        display_result result dtime (Printexc.to_string exn);
        reraise exn
    in
    let _ =
      Inuit_cursor.link button "%s" (button_text !opened) @@ fun k ->
      opened := not !opened;
      Inuit_cursor.clear k;
      Inuit_cursor.text k (button_text !opened);
      ignore (render ())
    in
    render ()
  )

let fix name print_arg print_res f =
  let rec fix t =
    if Inuit_cursor.is_closed t.cursor then
      let rec fix' arg = f fix' arg in fix'
    else
      call name print_arg print_res (fun t -> f (fix t)) t
  in
  fix