]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gtkMain.ml
updated the binding so that it works well with lablgtk-1.00,
[helm.git] / 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)