ocaml/otherlibs/labltk/builtin/builtini_bind.ml

##ifdef CAMLTK

let cCAMLtoTKxEvent = function
  | Activate -> "Activate"
  | ButtonPress -> "ButtonPress"
  | ButtonPressDetail n -> "ButtonPress-"^string_of_int n
  | ButtonRelease -> "ButtonRelease"
  | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
  | Circulate -> "Circulate"
  | ColorMap -> "Colormap"
  | Configure -> "Configure"
  | Deactivate -> "Deactivate"
  | Destroy -> "Destroy"
  | Enter -> "Enter"
  | Expose -> "Expose"
  | FocusIn -> "FocusIn"
  | FocusOut -> "FocusOut"
  | Gravity -> "Gravity"
  | KeyPress -> "KeyPress"
  | KeyPressDetail s -> "KeyPress-"^s
  | KeyRelease -> "KeyRelease"
  | KeyReleaseDetail s -> "KeyRelease-"^s
  | Leave -> "Leave"
  | Map -> "Map"
  | Motion -> "Motion"
  | Property -> "Property"
  | Reparent -> "Reparent"
  | Unmap -> "Unmap"
  | Visibility -> "Visibility"
  | Virtual s -> "<"^s^">"
;;

let cCAMLtoTKmodifier = function
  | Control -> "Control-"
  | Shift -> "Shift-"
  | Lock -> "Lock-"
  | Button1 -> "Button1-"
  | Button2 -> "Button2-"
  | Button3 -> "Button3-"
  | Button4 -> "Button4-"
  | Button5 -> "Button5-"
  | Double -> "Double-"
  | Triple -> "Triple-"
  | Mod1 -> "Mod1-"
  | Mod2 -> "Mod2-"
  | Mod3 -> "Mod3-"
  | Mod4 -> "Mod4-"
  | Mod5 -> "Mod5-"
  | Meta -> "Meta-"
  | Alt -> "Alt-"
;;

exception IllegalVirtualEvent

(* type event = modifier list * xEvent *)
let cCAMLtoTKevent (ml, xe) =
  match xe with
  | Virtual s ->
      if ml = [] then "<<"^s^">>"
      else raise IllegalVirtualEvent
  | _ ->
      "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml))
      ^ (cCAMLtoTKxEvent xe) ^ ">"
;;

(* type eventSequence == (modifier list * xEvent) list *)
let cCAMLtoTKeventSequence l =
  TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l))

##else

let cCAMLtoTKmodifier : modifier -> string = function
 | `Control -> "Control-"
 | `Shift -> "Shift-"
 | `Lock -> "Lock-"
 | `Button1 -> "Button1-"
 | `Button2 -> "Button2-"
 | `Button3 -> "Button3-"
 | `Button4 -> "Button4-"
 | `Button5 -> "Button5-"
 | `Double -> "Double-"
 | `Triple -> "Triple-"
 | `Mod1 -> "Mod1-"
 | `Mod2 -> "Mod2-"
 | `Mod3 -> "Mod3-"
 | `Mod4 -> "Mod4-"
 | `Mod5 -> "Mod5-"
 | `Meta -> "Meta-"
 | `Alt -> "Alt-"
;;

exception IllegalVirtualEvent

let cCAMLtoTKevent (ev : event) =
  let modified = ref false in
  let rec convert = function
    | `Activate -> "Activate"
    | `ButtonPress -> "ButtonPress"
    | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n
    | `ButtonRelease -> "ButtonRelease"
    | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
    | `Circulate -> "Circulate"
    | `Colormap -> "Colormap"
    | `Configure -> "Configure"
    | `Deactivate -> "Deactivate"
    | `Destroy -> "Destroy"
    | `Enter -> "Enter"
    | `Expose -> "Expose"
    | `FocusIn -> "FocusIn"
    | `FocusOut -> "FocusOut"
    | `Gravity -> "Gravity"
    | `KeyPress -> "KeyPress"
    | `KeyPressDetail s -> "KeyPress-"^s
    | `KeyRelease -> "KeyRelease"
    | `KeyReleaseDetail s -> "KeyRelease-"^s
    | `Leave -> "Leave"
    | `Map -> "Map"
    | `Motion -> "Motion"
    | `Property -> "Property"
    | `Reparent -> "Reparent"
    | `Unmap -> "Unmap"
    | `Visibility -> "Visibility"
    | `Virtual s ->
        if !modified then raise IllegalVirtualEvent else "<"^s^">"
    | `Modified(ml, ev) ->
        modified := true;
        String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml)
        ^ convert ev
  in "<" ^ convert ev ^ ">"
;;

let cCAMLtoTKeventSequence (l : event list) =
  TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l))
;;

##endif