/src/visualiser/visualiser.ml

 1open Logger
 2open Msg
 3open Thread
 4open Printf
 5open Fvar
 6
 7class visualiser (e : Dom.element) t0 t1 m0 m1 =
 8object (self)
 9  val threads = Hashtbl.create 10
10
11  method w  = float_of_int (e#_get_offsetWidth - 4) (* would be nice if this were froc-ed *)
12
13  method set_msg_loc msg msg_elt s t0 t1 =
14  let d = t1 -. t0 in
15  let w = self#w in
16  let ts = Msg.timestamp msg in
17  let l = ((ts -. s) *. w) /. d in
18  ignore (msg_elt#_get_style#_set_left (string_of_int (int_of_float l)))
19
20  method set_fun_loc f msg_elt fs fe ts t0 t1 =
21  let fs = if fs < 0. then m0#get else fs in
22  let fe = if fe < 0. then m1#get else fe in 
23  let d = t1 -. t0 in
24  let w = self#w in
25  let l = ((fs -. ts) *. w) /. d in
26  let wi = ((fe -. fs) *. w) /. d in
27  ignore (msg_elt#_get_style#_set_left (string_of_int (int_of_float l)));
28  ignore (msg_elt#_get_style#_set_width (string_of_int (int_of_float wi)))
29
30  method set_thread_loc thread_elt ts tf t0 t1 =
31  let ts = if ts < 0. then m0#get else ts in
32  let tf = if tf < 0. then m1#get else tf in
33  let d = t1 -. t0 in
34  let w = self#w in
35  let l = ((ts -. t0) *. w) /. d in
36  let r = ((tf -. t0) *. w) /. d in
37  ignore (thread_elt#_get_style#_set_left (string_of_int (int_of_float l)));
38  ignore (thread_elt#_get_style#_set_width (string_of_int (int_of_float (r -. l))))
39
40  method create_event_div (thread_elt : Dom.element) classname title =
41  let msg_elt = (Dom.document#createElement "div" : Dom.element) in
42  ignore (msg_elt#_set_className classname);
43  ignore (msg_elt#_set_title title);
44  ignore (thread_elt#appendChild msg_elt);
45  msg_elt
46
47  method render_msg (thread_elt : Dom.element) thread = function
48    | E_msg m ->
49      let div = self#create_event_div thread_elt "msg" (Msg.desc m) in
50      m#set_froc_loc (Froc.lift3 (self#set_msg_loc m div) thread#start#b t0 t1)
51    | E_fn f ->
52      let div = self#create_event_div thread_elt "fn" f#name in
53      f#set_froc_loc (Froc.lift5 (self#set_fun_loc f div) f#start#b f#finish#b thread#start#b t0 t1)
54    | Dummy -> ()
55
56  method render_thread id thread =
57  let thread_elt = (Dom.document#createElement "div" : Dom.element) in
58  ignore (thread_elt#_set_className "thread");
59  ignore (thread_elt#_get_style#_set_top (string_of_int (25 * thread#index)));
60  ignore (Froc.lift4 (self#set_thread_loc thread_elt) thread#start#b thread#finish#b t0 t1);
61  ignore (e#appendChild thread_elt);
62  thread_elt
63
64  method add_to_thread msg =
65  (*debug (sprintf "event of type %s" (Msg.ty msg));*)
66  let tid = Msg.threadId msg in
67  (if not (Hashtbl.mem threads tid) then 
68    begin
69      let thread = new thread tid in
70      Hashtbl.add threads tid (thread);
71      let thread_elt = self#render_thread tid thread in
72      thread#msgs#lift (self#render_msg thread_elt thread)
73    end);
74  let thread = Hashtbl.find threads tid in
75  thread#parse_msg msg;
76  let ts = Msg.timestamp msg in
77  if ts >= 0. then
78    begin
79      if ts < m0#get or m0#get = (-1.) then m0#set ts;
80      if ts > m1#get or m1#get = (-1.) then m1#set ts;
81    end;
82end
83
84let init (elt : Dom.element) t0 t1 m0 m1 =
85  let v = new visualiser elt t0 t1 m0 m1 in
86  v