+let dump_environment () =
+ try
+ let oc = open_out environmentfile in
+ output_html (outputhtml ()) (`Msg (`T "Dumping environment ..."));
+ CicEnvironment.dump_to_channel
+ ~callback:(fun uri -> output_html (outputhtml ()) (`Msg (`T uri)))
+ oc;
+ output_html (outputhtml ()) (`Msg (`T "... done!")) ;
+ close_out oc
+ with exc ->
+ output_html (outputhtml ())
+ (`Error (`T (Printf.sprintf
+ "<h1 color=\"red\">Dump failure, uncaught exception:%s</h1>"
+ (Printexc.to_string exc))))
+;;
+let restore_environment () =
+ try
+ let ic = open_in environmentfile in
+ output_html (outputhtml ()) (`Msg (`L [`T "Restoring environment ... " ; `BR]));
+ CicEnvironment.restore_from_channel
+ ~callback:(fun uri -> output_html (outputhtml ()) (`Msg (`L [`T uri ; `BR])))
+ ic;
+ output_html (outputhtml ()) (`Msg (`T "... done!"));
+ close_in ic
+ with exc ->
+ output_html (outputhtml ())
+ (`Error (`T (Printf.sprintf
+ "<h1 color=\"red\">Restore failure, uncaught exception:%s</h1>"
+ (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
+;;
+