]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMain.ml
SQL quoting fixed in relation.ml
[helm.git] / 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)