(* $Id$ *)

open Gtk

type id
type ('a,'b) t =
 { name: string;
   marshaller: ('b -> GtkArgv.t -> GtkArgv.data list -> unit) }

let enter_callback = ref (fun () -> ())
and exit_callback = ref (fun () -> ())

let stop_emit_ref = ref false
let stop_emit () = stop_emit_ref := true

type saved_state = State of bool
let push_callback () =
  !enter_callback ();
  let old = !stop_emit_ref in
  stop_emit_ref := false;
  State old

let pop_callback (State old) =
  let res = !stop_emit_ref in
  stop_emit_ref := old;
  !exit_callback ();
  res

external connect :
  'a obj -> name:string -> callback:(GtkArgv.t -> unit) -> after:bool -> id
  = "ml_gtk_signal_connect"
external emit_stop_by_name : 'a obj -> name:string -> unit
  = "ml_gtk_signal_emit_stop_by_name"
let connect  ~(sgn : ('a, _) t) ~callback ?(after=false) (obj : 'a obj) =
  let callback argv =
    let old = push_callback () in
    let exn =
      try sgn.marshaller callback argv (GtkArgv.get_args argv); None
      with exn -> Some exn
    in
    if pop_callback old then emit_stop_by_name obj ~name:sgn.name;
    Gaux.may ~f:raise exn
  in
  connect obj ~name:sgn.name ~callback ~after
external disconnect : 'a obj -> id -> unit
  = "ml_gtk_signal_disconnect"
external handler_block : 'a obj -> id -> unit
  = "ml_gtk_signal_handler_block"
external handler_unblock : 'a obj -> id -> unit
  = "ml_gtk_signal_handler_unblock"

let marshal_unit f _ _ = f ()
let marshal_int f _ = function
  | GtkArgv.INT n :: _ -> f n
  | _ -> invalid_arg "GtkSignal.marshal_int"

let emit (obj : 'a obj) ~(sgn : ('a, 'b) t)
    ~(emitter : 'a obj -> name:string -> 'b) =
  emitter obj ~name:sgn.name
external emit_none : 'a obj -> name:string -> unit -> unit
    = "ml_gtk_signal_emit_none"
let emit_unit obj ~sgn = emit obj ~emitter:emit_none ~sgn ()
external emit_int : 'a obj -> name:string -> int -> unit
    = "ml_gtk_signal_emit_int"
let emit_int = emit ~emitter:emit_int