ocaml/otherlibs/labltk/builtin/canvas_bind.ml

##ifdef CAMLTK

let bind widget tag eventsequence action =
  tkCommand [| 
    cCAMLtoTKwidget widget_canvas_table widget;
    TkToken "bind";
    cCAMLtoTKtagOrId tag;
    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 
 |]
;;

##else

let bind ~events
    ?(extend = false) ?(breakable = false) ?(fields = [])
    ?action widget tag =
  tkCommand
    [| cCAMLtoTKwidget widget;
       TkToken "bind";
       cCAMLtoTKtagOrId tag;
       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
     |]
;;

##endif