]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkSignal.ml
- DoubleTypeInference.does_not_occur exposed
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / gtkSignal.ml
1 (* $Id$ *)
2
3 open Gtk
4
5 type id
6 type ('a,'b) t =
7  { name: string;
8    marshaller: ('b -> GtkArgv.t -> GtkArgv.data list -> unit) }
9
10 let enter_callback = ref (fun () -> ())
11 and exit_callback = ref (fun () -> ())
12
13 let stop_emit_ref = ref false
14 let stop_emit () = stop_emit_ref := true
15
16 type saved_state = State of bool
17 let push_callback () =
18   !enter_callback ();
19   let old = !stop_emit_ref in
20   stop_emit_ref := false;
21   State old
22
23 let pop_callback (State old) =
24   let res = !stop_emit_ref in
25   stop_emit_ref := old;
26   !exit_callback ();
27   res
28
29 external connect :
30   'a obj -> name:string -> callback:(GtkArgv.t -> unit) -> after:bool -> id
31   = "ml_gtk_signal_connect"
32 external emit_stop_by_name : 'a obj -> name:string -> unit
33   = "ml_gtk_signal_emit_stop_by_name"
34 let connect  ~(sgn : ('a, _) t) ~callback ?(after=false) (obj : 'a obj) =
35   let callback argv =
36     let old = push_callback () in
37     let exn =
38       try sgn.marshaller callback argv (GtkArgv.get_args argv); None
39       with exn -> Some exn
40     in
41     if pop_callback old then emit_stop_by_name obj ~name:sgn.name;
42     Gaux.may ~f:raise exn
43   in
44   connect obj ~name:sgn.name ~callback ~after
45 external disconnect : 'a obj -> id -> unit
46   = "ml_gtk_signal_disconnect"
47 external handler_block : 'a obj -> id -> unit
48   = "ml_gtk_signal_handler_block"
49 external handler_unblock : 'a obj -> id -> unit
50   = "ml_gtk_signal_handler_unblock"
51
52 let marshal_unit f _ _ = f ()
53 let marshal_int f _ = function
54   | GtkArgv.INT n :: _ -> f n
55   | _ -> invalid_arg "GtkSignal.marshal_int"
56
57 let emit (obj : 'a obj) ~(sgn : ('a, 'b) t)
58     ~(emitter : 'a obj -> name:string -> 'b) =
59   emitter obj ~name:sgn.name
60 external emit_none : 'a obj -> name:string -> unit -> unit
61     = "ml_gtk_signal_emit_none"
62 let emit_unit obj ~sgn = emit obj ~emitter:emit_none ~sgn ()
63 external emit_int : 'a obj -> name:string -> int -> unit
64     = "ml_gtk_signal_emit_int"
65 let emit_int = emit ~emitter:emit_int