import labltklabltk

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/labltk@2531 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 83 insertions, 0 deletions

diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml
new file mode 100644
index 0000000000..5a3dd19a26
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtinf_bind.ml
@@ -0,0 +1,83 @@
+(*
+FUNCTION
+ val bind: 
+    any widget -> (modifier list * xEvent) list -> bindAction -> unit
+/FUNCTION
+*)
+let bind widget events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+      	    TkToken (Widget.name widget);
+	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (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"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+  |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val class_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ class arg is not constrained
+*)
+let class_bind clas events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+      	    TkToken clas;
+	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback Widget.dummy 
+      	                           callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback Widget.dummy 
+      	                           callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback Widget.dummy 
+                                   callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+ |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val tag_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ tag name arg is not constrained 
+*)
+
+let tag_bind = class_bind
+
+
+(*
+FUNCTION
+  val break : unit -> unit
+/FUNCTION
+*)
+let break = function () ->
+  tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |];
+  ()