helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMain.ml

   1 (* $Id$ *)
   2
   3 open Gtk
   4
   5 let _ = Callback.register_exception "gtkerror" (Error"")
   6
   7 module Timeout = struct
   8   type id
   9   external add : ms:int -> callback:(GtkArgv.t -> unit) -> id
  10       = "ml_gtk_timeout_add"
  11   let add ~ms ~callback =
  12     add ~ms ~callback:(fun arg -> GtkArgv.set_result arg (`BOOL(callback ())))
  13   external remove : id -> unit = "ml_gtk_timeout_remove"
  14 end
  15
  16 module Main = struct
  17   external init : string array -> string array = "ml_gtk_init"
  18   (* external exit : int -> unit = "ml_gtk_exit" *)
  19   external set_locale : unit -> string = "ml_gtk_set_locale"
  20   (* external main : unit -> unit = "ml_gtk_main" *)
  21   let locale = set_locale ()
  22   let init () =
  23     (* let locale = set_locale () in *)
  24     let argv = init Sys.argv in
  25     Array.blit ~src:argv ~dst:Sys.argv ~len:(Array.length argv)
  26       ~src_pos:0 ~dst_pos:0;
  27     Obj.truncate (Obj.repr Sys.argv) ~len:(Array.length argv);
  28     locale
  29   open Glib
  30   let loops = ref []
  31   let main () =
  32     let loop = (Main.create true) in
  33     loops := loop :: !loops;
  34     while Main.is_running loop do Main.iteration true done;
  35     loops := List.tl !loops
  36   and quit () = Main.quit (List.hd !loops)
  37   external get_version : unit -> int * int * int = "ml_gtk_get_version"
  38   let version = get_version ()
  39
  40   let flush = Gdk.X.flush
  41 end
  42
  43 module Grab = struct
  44   external add : [>`widget] obj -> unit = "ml_gtk_grab_add"
  45   external remove : [>`widget] obj -> unit = "ml_gtk_grab_remove"
  46   external get_current : unit -> widget obj= "ml_gtk_grab_get_current"
  47 end
  48
  49 let _ = Glib.set_warning_handler (fun msg -> raise (Warning msg))
  50 let _ = Glib.set_print_handler (fun msg -> print_string msg)