helm/DEVEL/lablgtk/lablgtk_20001129-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 init () =
  22     let locale = set_locale () in
  23     let argv = init Sys.argv in
  24     Array.blit ~src:argv ~dst:Sys.argv ~len:(Array.length argv)
  25       ~src_pos:0 ~dst_pos:0;
  26     Obj.truncate (Obj.repr Sys.argv) ~len:(Array.length argv);
  27     locale
  28   open Glib
  29   let loops = ref []
  30   let main () =
  31     let loop = (Main.create true) in
  32     loops := loop :: !loops;
  33     while Main.is_running loop do Main.iteration true done;
  34     loops := List.tl !loops
  35   and quit () = Main.quit (List.hd !loops)
  36   external get_version : unit -> int * int * int = "ml_gtk_get_version"
  37   let version = get_version ()
  38
  39   let flush = Gdk.X.flush
  40 end
  41
  42 module Grab = struct
  43   external add : [>`widget] obj -> unit = "ml_gtk_grab_add"
  44   external remove : [>`widget] obj -> unit = "ml_gtk_grab_remove"
  45   external get_current : unit -> widget obj= "ml_gtk_grab_get_current"
  46 end
  47
  48 let _ = Glib.set_warning_handler (fun msg -> raise (Warning msg))
  49 let _ = Glib.set_print_handler (fun msg -> print_string msg)