1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
##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 ~callback:(wrapeventInfo f what) in
TkToken ("camlcb " ^ cbId ^ (writeeventField what))
| BindSetBreakable (what, f) ->
let cbId = register_callback widget ~callback:(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 ~callback:(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
|
