##ifdef CAMLTK

(* type *)
type bindAction =
 | BindSet of eventField list *  (eventInfo -> unit)
 | BindSetBreakable of eventField list *  (eventInfo -> unit)
 | BindRemove
 | BindExtend of eventField list *  (eventInfo -> unit)
(* /type *)

(*
FUNCTION
 val bind:
    widget -> (modifier list * xEvent) list -> bindAction -> unit
/FUNCTION
*)
let bind widget eventsequence action =
  tkCommand [| TkToken "bind";
               TkToken (Widget.name widget);
               cCAMLtoTKeventSequence eventsequence;
               begin match action with
                 BindRemove -> TkToken ""
               | BindSet (what, f) ->
                   let cbId = register_callback widget (wrapeventInfo f what)
                   in
                   TkToken ("camlcb " ^ cbId ^ (writeeventField what))
               | BindSetBreakable (what, f) ->
                   let cbId = register_callback widget (wrapeventInfo f what)
                   in
                   TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
                            " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0")
               |  BindExtend (what, f) ->
                   let cbId = register_callback widget (wrapeventInfo f what)
                   in
                   TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
               end |]
;;

(* FUNCTION
(* unsafe *)
 val bind_class :
    string -> (modifier list * xEvent) list -> bindAction -> unit
(* /unsafe *)
/FUNCTION class arg is not constrained *)

let bind_class clas eventsequence action =
  tkCommand [| TkToken "bind";
               TkToken clas;
               cCAMLtoTKeventSequence eventsequence;
               begin match action with
                 BindRemove -> TkToken ""
               | BindSet (what, f) ->
                   let cbId = register_callback Widget.dummy
                       (wrapeventInfo f what) in
                   TkToken ("camlcb " ^ cbId ^ (writeeventField what))
               | BindSetBreakable (what, f) ->
                   let cbId = register_callback Widget.dummy
                       (wrapeventInfo f what) in
                   TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
                            " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" )
               | BindExtend (what, f) ->
                   let cbId = register_callback Widget.dummy
                       (wrapeventInfo f what) in
                   TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
               end |]
;;

(* FUNCTION
(* unsafe *)
  val bind_tag :
     string -> (modifier list * xEvent) list -> bindAction -> unit
(* /unsafe *)
/FUNCTION *)

let bind_tag = bind_class
;;

(*
FUNCTION
  val break : unit -> unit
/FUNCTION
*)
let break = function () ->
  Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1"
;;

(* Legacy functions *)
let tag_bind = bind_tag;;
let class_bind = bind_class;;

##else

let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
    ?action ?on:widget name =
  let widget = match widget with None -> Widget.dummy | Some w -> coe w in
  tkCommand
    [| TkToken "bind";
       TkToken name;
       cCAMLtoTKeventSequence events;
       begin match action with None -> TkToken ""
       | Some f ->
           let cbId =
             register_callback widget ~callback: (wrapeventInfo f fields) in
           let cb = if extend then "+camlcb " else "camlcb " in
           let cb = cb ^ cbId ^ writeeventField fields in
           let cb =
             if breakable then
               cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
               ^ " ; set BreakBindingsSequence 0"
             else cb in
           TkToken cb
       end
     |]
;;

let bind ~events ?extend ?breakable ?fields ?action widget =
  bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
    (Widget.name widget)
;;

let bind_tag = bind_class
;;

(*
FUNCTION
  val break : unit -> unit
/FUNCTION
*)
let break = function () ->
  tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
;;

##endif