+ (Printexc.to_string exc))))
+;;
+
+(* HTML simulator (first in its kind) *)
+
+type log_msg =
+ [ `T of string
+ | `L of log_msg list
+ | `BR
+ ]
+;;
+
+class logger ~width ~height ~packing ~show () =
+ let scrolled_window =
+ GBin.scrolled_window ~packing ~show () in
+ let vadj = scrolled_window#vadjustment in
+ let tv =
+ GText.view ~editable:false ~cursor_visible:false
+ ~width ~height ~packing:(scrolled_window#add) () in
+ let green =
+ tv#buffer#create_tag
+ [`FOREGROUND_SET true ;
+ `FOREGROUND_GDK
+ (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "green"))] in
+ let red =
+ tv#buffer#create_tag
+ [`FOREGROUND_SET true ;
+ `FOREGROUND_GDK
+ (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "red"))] in
+ object
+ method log (m : [`Msg of log_msg | `Error of log_msg]) =
+ let process_msg tags =
+ let rec aux =
+ function
+ `T s -> tv#buffer#insert ~tags s
+ | `L l -> List.iter aux l
+ | `BR -> tv#buffer#insert ~tags "\n"
+ in
+ aux
+ in
+ begin
+ match m with
+ `Msg m -> process_msg [green] m
+ | `Error m -> process_msg [red] m
+ end ;
+ vadj#set_value (vadj#upper)
+ end