l4/pkg/ocaml/contrib/otherlibs/labltk/builtin/builtinf_bind.ml

   1 ##ifdef CAMLTK
   2
   3 (* type *)
   4 type bindAction =
   5  | BindSet of eventField list *  (eventInfo -> unit)
   6  | BindSetBreakable of eventField list *  (eventInfo -> unit)
   7  | BindRemove
   8  | BindExtend of eventField list *  (eventInfo -> unit)
   9 (* /type *)
  10
  11 (*
  12 FUNCTION
  13  val bind:
  14     widget -> (modifier list * xEvent) list -> bindAction -> unit
  15 /FUNCTION
  16 *)
  17 let bind widget eventsequence action =
  18   tkCommand [| TkToken "bind";
  19                TkToken (Widget.name widget);
  20                cCAMLtoTKeventSequence eventsequence;
  21                begin match action with
  22                  BindRemove -> TkToken ""
  23                | BindSet (what, f) ->
  24                    let cbId = register_callback widget (wrapeventInfo f what)
  25                    in
  26                    TkToken ("camlcb " ^ cbId ^ (writeeventField what))
  27                | BindSetBreakable (what, f) ->
  28                    let cbId = register_callback widget (wrapeventInfo f what)
  29                    in
  30                    TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^
  31                             " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0")
  32                |  BindExtend (what, f) ->
  33                    let cbId = register_callback widget (wrapeventInfo f what)
  34                    in
  35                    TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
  36                end |]
  37 ;;
  38
  39 (* FUNCTION
  40 (* unsafe *)
  41  val bind_class :
  42     string -> (modifier list * xEvent) list -> bindAction -> unit
  43 (* /unsafe *)
  44 /FUNCTION class arg is not constrained *)
  45
  46 let bind_class clas eventsequence action =
  47   tkCommand [| TkToken "bind";
  48                TkToken clas;
  49                cCAMLtoTKeventSequence eventsequence;
  50                begin match action with
  51                  BindRemove -> TkToken ""
  52                | BindSet (what, f) ->
  53                    let cbId = register_callback Widget.dummy
  54                        (wrapeventInfo f what) in
  55                    TkToken ("camlcb " ^ cbId ^ (writeeventField what))
  56                | BindSetBreakable (what, f) ->
  57                    let cbId = register_callback Widget.dummy
  58                        (wrapeventInfo f what) in
  59                    TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
  60                             " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" )
  61                | BindExtend (what, f) ->
  62                    let cbId = register_callback Widget.dummy
  63                        (wrapeventInfo f what) in
  64                    TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
  65                end |]
  66 ;;
  67
  68 (* FUNCTION
  69 (* unsafe *)
  70   val bind_tag :
  71      string -> (modifier list * xEvent) list -> bindAction -> unit
  72 (* /unsafe *)
  73 /FUNCTION *)
  74
  75 let bind_tag = bind_class
  76 ;;
  77
  78 (*
  79 FUNCTION
  80   val break : unit -> unit
  81 /FUNCTION
  82 *)
  83 let break = function () ->
  84   Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1"
  85 ;;
  86
  87 (* Legacy functions *)
  88 let tag_bind = bind_tag;;
  89 let class_bind = bind_class;;
  90
  91 ##else
  92
  93 let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
  94     ?action ?on:widget name =
  95   let widget = match widget with None -> Widget.dummy | Some w -> coe w in
  96   tkCommand
  97     [| TkToken "bind";
  98        TkToken name;
  99        cCAMLtoTKeventSequence events;
 100        begin match action with None -> TkToken ""
 101        | Some f ->
 102            let cbId =
 103              register_callback widget ~callback: (wrapeventInfo f fields) in
 104            let cb = if extend then "+camlcb " else "camlcb " in
 105            let cb = cb ^ cbId ^ writeeventField fields in
 106            let cb =
 107              if breakable then
 108                cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
 109                ^ " ; set BreakBindingsSequence 0"
 110              else cb in
 111            TkToken cb
 112        end
 113      |]
 114 ;;
 115
 116 let bind ~events ?extend ?breakable ?fields ?action widget =
 117   bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
 118     (Widget.name widget)
 119 ;;
 120
 121 let bind_tag = bind_class
 122 ;;
 123
 124 (*
 125 FUNCTION
 126   val break : unit -> unit
 127 /FUNCTION
 128 *)
 129 let break = function () ->
 130   tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
 131 ;;
 132
 133 ##endif