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