|
Packit |
bd2e5d |
##ifdef CAMLTK
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* type *)
|
|
Packit |
bd2e5d |
type bindAction =
|
|
Packit |
bd2e5d |
| BindSet of eventField list * (eventInfo -> unit)
|
|
Packit |
bd2e5d |
| BindSetBreakable of eventField list * (eventInfo -> unit)
|
|
Packit |
bd2e5d |
| BindRemove
|
|
Packit |
bd2e5d |
| BindExtend of eventField list * (eventInfo -> unit)
|
|
Packit |
bd2e5d |
(* /type *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(*
|
|
Packit |
bd2e5d |
FUNCTION
|
|
Packit |
bd2e5d |
val bind:
|
|
Packit |
bd2e5d |
widget -> (modifier list * xEvent) list -> bindAction -> unit
|
|
Packit |
bd2e5d |
/FUNCTION
|
|
Packit |
bd2e5d |
*)
|
|
Packit |
bd2e5d |
let bind widget eventsequence action =
|
|
Packit |
bd2e5d |
tkCommand [| TkToken "bind";
|
|
Packit |
bd2e5d |
TkToken (Widget.name widget);
|
|
Packit |
bd2e5d |
cCAMLtoTKeventSequence eventsequence;
|
|
Packit |
bd2e5d |
begin match action with
|
|
Packit |
bd2e5d |
BindRemove -> TkToken ""
|
|
Packit |
bd2e5d |
| BindSet (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback widget (wrapeventInfo f what)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
TkToken ("camlcb " ^ cbId ^ (writeeventField what))
|
|
Packit |
bd2e5d |
| BindSetBreakable (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback widget (wrapeventInfo f what)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
|
|
Packit |
bd2e5d |
" ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0")
|
|
Packit |
bd2e5d |
| BindExtend (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback widget (wrapeventInfo f what)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
|
|
Packit |
bd2e5d |
end |]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* FUNCTION
|
|
Packit |
bd2e5d |
(* unsafe *)
|
|
Packit |
bd2e5d |
val bind_class :
|
|
Packit |
bd2e5d |
string -> (modifier list * xEvent) list -> bindAction -> unit
|
|
Packit |
bd2e5d |
(* /unsafe *)
|
|
Packit |
bd2e5d |
/FUNCTION class arg is not constrained *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind_class clas eventsequence action =
|
|
Packit |
bd2e5d |
tkCommand [| TkToken "bind";
|
|
Packit |
bd2e5d |
TkToken clas;
|
|
Packit |
bd2e5d |
cCAMLtoTKeventSequence eventsequence;
|
|
Packit |
bd2e5d |
begin match action with
|
|
Packit |
bd2e5d |
BindRemove -> TkToken ""
|
|
Packit |
bd2e5d |
| BindSet (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback Widget.dummy
|
|
Packit |
bd2e5d |
(wrapeventInfo f what) in
|
|
Packit |
bd2e5d |
TkToken ("camlcb " ^ cbId ^ (writeeventField what))
|
|
Packit |
bd2e5d |
| BindSetBreakable (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback Widget.dummy
|
|
Packit |
bd2e5d |
(wrapeventInfo f what) in
|
|
Packit |
bd2e5d |
TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
|
|
Packit |
bd2e5d |
" ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" )
|
|
Packit |
bd2e5d |
| BindExtend (what, f) ->
|
|
Packit |
bd2e5d |
let cbId = register_callback Widget.dummy
|
|
Packit |
bd2e5d |
(wrapeventInfo f what) in
|
|
Packit |
bd2e5d |
TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
|
|
Packit |
bd2e5d |
end |]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* FUNCTION
|
|
Packit |
bd2e5d |
(* unsafe *)
|
|
Packit |
bd2e5d |
val bind_tag :
|
|
Packit |
bd2e5d |
string -> (modifier list * xEvent) list -> bindAction -> unit
|
|
Packit |
bd2e5d |
(* /unsafe *)
|
|
Packit |
bd2e5d |
/FUNCTION *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind_tag = bind_class
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(*
|
|
Packit |
bd2e5d |
FUNCTION
|
|
Packit |
bd2e5d |
val break : unit -> unit
|
|
Packit |
bd2e5d |
/FUNCTION
|
|
Packit |
bd2e5d |
*)
|
|
Packit |
bd2e5d |
let break = function () ->
|
|
Packit |
bd2e5d |
Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1"
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* Legacy functions *)
|
|
Packit |
bd2e5d |
let tag_bind = bind_tag;;
|
|
Packit |
bd2e5d |
let class_bind = bind_class;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
##else
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
|
|
Packit |
bd2e5d |
?action ?on:widget name =
|
|
Packit |
bd2e5d |
let widget = match widget with None -> Widget.dummy | Some w -> coe w in
|
|
Packit |
bd2e5d |
tkCommand
|
|
Packit |
bd2e5d |
[| TkToken "bind";
|
|
Packit |
bd2e5d |
TkToken name;
|
|
Packit |
bd2e5d |
cCAMLtoTKeventSequence events;
|
|
Packit |
bd2e5d |
begin match action with None -> TkToken ""
|
|
Packit |
bd2e5d |
| Some f ->
|
|
Packit |
bd2e5d |
let cbId =
|
|
Packit |
bd2e5d |
register_callback widget ~callback: (wrapeventInfo f fields) in
|
|
Packit |
bd2e5d |
let cb = if extend then "+camlcb " else "camlcb " in
|
|
Packit |
bd2e5d |
let cb = cb ^ cbId ^ writeeventField fields in
|
|
Packit |
bd2e5d |
let cb =
|
|
Packit |
bd2e5d |
if breakable then
|
|
Packit |
bd2e5d |
cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
|
|
Packit |
bd2e5d |
^ " ; set BreakBindingsSequence 0"
|
|
Packit |
bd2e5d |
else cb in
|
|
Packit |
bd2e5d |
TkToken cb
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
|]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind ~events ?extend ?breakable ?fields ?action widget =
|
|
Packit |
bd2e5d |
bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
|
|
Packit |
bd2e5d |
(Widget.name widget)
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let bind_tag = bind_class
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(*
|
|
Packit |
bd2e5d |
FUNCTION
|
|
Packit |
bd2e5d |
val break : unit -> unit
|
|
Packit |
bd2e5d |
/FUNCTION
|
|
Packit |
bd2e5d |
*)
|
|
Packit |
bd2e5d |
let break = function () ->
|
|
Packit |
bd2e5d |
tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
|
|
Packit |
bd2e5d |
;;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
##endif
|