Initial commit

1 files changed, 91 insertions, 0 deletions

diff --git a/gui.ml b/gui.ml
new file mode 100644
index 0000000..97063eb
--- /dev/null
+++ b/gui.ml
@@ -0,0 +1,91 @@
+
+type debuglog_type = [`read | `write | `status]
+
+class mainwin () =
+  (* main window layout *)
+  let g_win = GWindow.window ~wm_name:"Serika" ~wm_class:"serika" ~position:`CENTER () in
+  let _ = g_win#connect#destroy GMain.Main.quit in
+  let _ = g_win#set_default_width 640 and _ = g_win#set_default_height 480 in
+  let g_vbox = GPack.vbox ~packing:g_win#add () in
+  let g_tabs = GPack.notebook ~packing:g_vbox#add () in
+  
+  (* debug tab *)
+  let g_debug_tbl = GPack.table ~rows:2 ~columns:2 () in
+  let g_debug_scroll = GBin.scrolled_window ~vpolicy:`ALWAYS ~hpolicy:`AUTOMATIC ~packing:(g_debug_tbl#attach ~left:0 ~top:0 ~right:2 ~expand:`BOTH) () in
+  let g_debug = GText.view ~editable:false ~wrap_mode:`CHAR ~packing:g_debug_scroll#add () in
+  let g_debug_cmd = GEdit.entry ~activates_default:true ~packing:(g_debug_tbl#attach ~left:0 ~top:1 ~expand:`X) () in
+  let g_debug_send = GButton.button ~label:"_Send command" ~use_mnemonic:true ~packing:(g_debug_tbl#attach ~left:1 ~top:1 ~expand:`NONE) () in
+  let _ = g_tabs#append_page ~tab_label:((GMisc.label ~text:"Debug" ())#coerce) g_debug_tbl#coerce in
+  let _ = g_debug_cmd#connect#activate (fun () -> ignore (g_debug_send#misc#activate ())) in
+
+  (* status bar *)
+  let g_status = GMisc.statusbar ~packing:(g_vbox#pack ~expand:false) () in
+  let g_statuscontext = g_status#new_context ~name:"Meh" in
+  let g_bandwidth = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:70 ~text:"0.0 kB" () in
+  let g_cmd_count = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~width:25 ~text:"0" () in
+
+  (* coloring and marking for the debug textview *)
+  let _ = g_debug#buffer#create_tag ~name:"read"   [`FOREGROUND "#cc6666"] in
+  let _ = g_debug#buffer#create_tag ~name:"write"  [`FOREGROUND "#6666cc"] in
+  let _ = g_debug#buffer#create_tag ~name:"prefix" [`WEIGHT `LIGHT] in
+  let _ = g_debug#buffer#create_mark ~name:"end" ~left_gravity:false g_debug#buffer#end_iter in
+
+  (* the object *)
+  object (self)
+    val mutable bandwidth = 0
+    val mutable cmd_count = 0
+    val mutable laststatusmsg = g_statuscontext#push "Welcome to Serika!"
+
+    method show = g_win#show ()
+
+    method set_debug_docmd f =
+      ignore (g_debug_send#connect#clicked (fun () ->
+        f (g_debug_cmd#text)
+      ))
+
+    method statusmsg str =
+      let msg = g_statuscontext#push str in
+      g_statuscontext#remove laststatusmsg;
+      laststatusmsg <- msg;
+      self#add_debuglog `status str
+
+    method add_bandwidth s =
+      bandwidth <- bandwidth+s;
+      g_bandwidth#set_text (Printf.sprintf "%.1f kB" ((float bandwidth) /. 1024.0))
+
+    method incr_cmd_count =
+      cmd_count <- cmd_count+1;
+      g_cmd_count#set_text (string_of_int cmd_count)
+
+    method add_debuglog (t : debuglog_type) str =
+      let tm = Unix.localtime (Unix.time ()) in
+      let time = Printf.sprintf "[%02d:%02d:%02d] " tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
+      let tags, prefix = match t with
+      | `read   -> (["read"],   "< ")
+      | `write  -> (["write"],  "> ")
+      | `status -> ([],         "= ") in
+      let buf = g_debug#buffer in
+      buf#insert ~iter:buf#end_iter ~tag_names:["prefix"] (time ^ prefix);
+      buf#insert ~iter:buf#end_iter ~tag_names:tags str;
+      buf#insert ~iter:buf#end_iter "\n";
+      g_debug#scroll_mark_onscreen (`NAME "end")
+
+    method set_throttled sec (cb : (unit -> unit)) =
+      let togo = ref sec in
+      g_debug_send#misc#set_sensitive false;
+      let secfunc () =
+        togo := !togo - 1;
+        if !togo < 1 then (
+          g_debug_send#misc#set_sensitive true;
+          cb ();
+          false
+        ) else (
+          g_statuscontext#flash ~delay:1000 ("Throttled. Waiting "
+            ^(string_of_int !togo)^" seconds before continuing...");
+          true
+        )
+      in
+      ignore (GMain.Timeout.add ~ms:1000 ~callback:secfunc)
+
+  end
+