##ifdef CAMLTK

open Widget;;

(* Events and bindings *)
(* Builtin types *)
(* type *)
type xEvent =
  | Activate
  | ButtonPress (* also Button, but we omit it *)
  | ButtonPressDetail of int
  | ButtonRelease
  | ButtonReleaseDetail of int
  | Circulate
  | ColorMap (* not Colormap, avoiding confusion between the Colormap option *)
  | Configure
  | Deactivate
  | Destroy
  | Enter
  | Expose
  | FocusIn
  | FocusOut
  | Gravity
  | KeyPress (* also Key, but we omit it *)
  | KeyPressDetail of string      (* /usr/include/X11/keysymdef.h *)
  | KeyRelease
  | KeyReleaseDetail of string
  | Leave
  | Map
  | Motion
  | Property
  | Reparent
  | Unmap
  | Visibility
  | Virtual of string (* Virtual event. Must be without modifiers *)
;;
(* /type *)

(* type *)
type modifier =
  | Control
  | Shift
  | Lock
  | Button1
  | Button2
  | Button3
  | Button4
  | Button5
  | Double
  | Triple
  | Mod1
  | Mod2
  | Mod3
  | Mod4
  | Mod5
  | Meta
  | Alt
;;
(* /type *)

(* Event structure, passed to bounded functions *)

(* type *)
type eventInfo =
  {
  (* %# : event serial number is unsupported *)
  mutable ev_Above : int;               (* tk: %a *)
  mutable ev_ButtonNumber : int;        (* tk: %b *)
  mutable ev_Count : int;               (* tk: %c *)
  mutable ev_Detail : string;           (* tk: %d *)
  mutable ev_Focus : bool;              (* tk: %f *)
  mutable ev_Height : int;              (* tk: %h *)
  mutable ev_KeyCode : int;             (* tk: %k *)
  mutable ev_Mode : string;             (* tk: %m *)
  mutable ev_OverrideRedirect : bool;   (* tk: %o *)
  mutable ev_Place : string;            (* tk: %p *)
  mutable ev_State : string;            (* tk: %s *)
  mutable ev_Time : int;                (* tk: %t *)
  mutable ev_Width : int;               (* tk: %w *)
  mutable ev_MouseX : int;              (* tk: %x *)
  mutable ev_MouseY : int;              (* tk: %y *)
  mutable ev_Char : string;             (* tk: %A *)
  mutable ev_BorderWidth : int;         (* tk: %B *)
  mutable ev_SendEvent : bool;          (* tk: %E *)
  mutable ev_KeySymString : string;     (* tk: %K *)
  mutable ev_KeySymInt : int;           (* tk: %N *)
  mutable ev_RootWindow : int;          (* tk: %R *)
  mutable ev_SubWindow : int;           (* tk: %S *)
  mutable ev_Type : int;                (* tk: %T *)
  mutable ev_Widget : widget;           (* tk: %W *)
  mutable ev_RootX : int;               (* tk: %X *)
  mutable ev_RootY : int                (* tk: %Y *)
  }
;;
(* /type *)


(* To avoid collision with other constructors (Width, State),
   use Ev_ prefix *)
(* type *)
type eventField =
  | Ev_Above
  | Ev_ButtonNumber
  | Ev_Count
  | Ev_Detail
  | Ev_Focus
  | Ev_Height
  | Ev_KeyCode
  | Ev_Mode
  | Ev_OverrideRedirect
  | Ev_Place
  | Ev_State
  | Ev_Time
  | Ev_Width
  | Ev_MouseX
  | Ev_MouseY
  | Ev_Char
  | Ev_BorderWidth
  | Ev_SendEvent
  | Ev_KeySymString
  | Ev_KeySymInt
  | Ev_RootWindow
  | Ev_SubWindow
  | Ev_Type
  | Ev_Widget
  | Ev_RootX
  | Ev_RootY
;;
(* /type *)

let filleventInfo ev v = function
  | Ev_Above    ->      ev.ev_Above <- int_of_string v
  | Ev_ButtonNumber ->  ev.ev_ButtonNumber <- int_of_string v
  | Ev_Count ->         ev.ev_Count <- int_of_string v
  | Ev_Detail ->        ev.ev_Detail <- v
  | Ev_Focus ->         ev.ev_Focus <- v = "1"
  | Ev_Height ->        ev.ev_Height <- int_of_string v
  | Ev_KeyCode ->       ev.ev_KeyCode <- int_of_string v
  | Ev_Mode ->          ev.ev_Mode <- v
  | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
  | Ev_Place ->         ev.ev_Place <- v
  | Ev_State ->         ev.ev_State <- v
  | Ev_Time ->          ev.ev_Time <- int_of_string v
  | Ev_Width ->         ev.ev_Width <- int_of_string v
  | Ev_MouseX ->        ev.ev_MouseX <- int_of_string v
  | Ev_MouseY ->        ev.ev_MouseY <- int_of_string v
  | Ev_Char ->          ev.ev_Char <- v
  | Ev_BorderWidth ->   ev.ev_BorderWidth <- int_of_string v
  | Ev_SendEvent ->     ev.ev_SendEvent <- v = "1"
  | Ev_KeySymString ->  ev.ev_KeySymString <- v
  | Ev_KeySymInt ->     ev.ev_KeySymInt <- int_of_string v
  | Ev_RootWindow ->    ev.ev_RootWindow <- int_of_string v
  | Ev_SubWindow ->     ev.ev_SubWindow <- int_of_string v
  | Ev_Type ->          ev.ev_Type <- int_of_string v
  | Ev_Widget ->        ev.ev_Widget <- cTKtoCAMLwidget v
  | Ev_RootX ->         ev.ev_RootX <- int_of_string v
  | Ev_RootY ->         ev.ev_RootY <- int_of_string v
;;

let wrapeventInfo f what =
  let ev = {
    ev_Above = 0;
    ev_ButtonNumber = 0;
    ev_Count = 0;
    ev_Detail = "";
    ev_Focus = false;
    ev_Height = 0;
    ev_KeyCode = 0;
    ev_Mode = "";
    ev_OverrideRedirect = false;
    ev_Place = "";
    ev_State = "";
    ev_Time = 0;
    ev_Width = 0;
    ev_MouseX = 0;
    ev_MouseY = 0;
    ev_Char = "";
    ev_BorderWidth = 0;
    ev_SendEvent = false;
    ev_KeySymString = "";
    ev_KeySymInt = 0;
    ev_RootWindow = 0;
    ev_SubWindow = 0;
    ev_Type = 0;
    ev_Widget = Widget.default_toplevel;
    ev_RootX = 0;
    ev_RootY = 0 } in
  function args ->
    let l = ref args in
    List.iter (function field ->
      match !l with
        [] -> ()
      | v::rest -> filleventInfo ev v field; l:=rest)
      what;
    f ev
;;

let rec writeeventField = function
  | [] -> ""
  | field::rest ->
    begin
    match field with
    | Ev_Above ->     " %a"
    | Ev_ButtonNumber ->" %b"
    | Ev_Count ->     " %c"
    | Ev_Detail ->    " %d"
    | Ev_Focus ->     " %f"
    | Ev_Height ->    " %h"
    | Ev_KeyCode ->   " %k"
    | Ev_Mode ->      " %m"
    | Ev_OverrideRedirect -> " %o"
    | Ev_Place ->     " %p"
    | Ev_State ->     " %s"
    | Ev_Time ->      " %t"
    | Ev_Width ->     " %w"
    | Ev_MouseX ->    " %x"
    | Ev_MouseY ->    " %y"
    (* Quoting is done by Tk *)
    | Ev_Char ->      " %A"
    | Ev_BorderWidth -> " %B"
    | Ev_SendEvent -> " %E"
    | Ev_KeySymString -> " %K"
    | Ev_KeySymInt -> " %N"
    | Ev_RootWindow ->" %R"
    | Ev_SubWindow -> " %S"
    | Ev_Type ->      " %T"
    | Ev_Widget ->" %W"
    | Ev_RootX ->     " %X"
    | Ev_RootY ->     " %Y"
    end
    ^ writeeventField rest
;;

##else

open Widget;;

(* Events and bindings *)
(* Builtin types *)

(* type *)
type event = [
  | `Activate
  | `ButtonPress (* also Button, but we omit it *)
  | `ButtonPressDetail of int
  | `ButtonRelease
  | `ButtonReleaseDetail of int
  | `Circulate
  | `Colormap
  | `Configure
  | `Deactivate
  | `Destroy
  | `Enter
  | `Expose
  | `FocusIn
  | `FocusOut
  | `Gravity
  | `KeyPress (* also Key, but we omit it *)
  | `KeyPressDetail of string      (* /usr/include/X11/keysymdef.h *)
  | `KeyRelease
  | `KeyReleaseDetail of string
  | `Leave
  | `Map
  | `Motion
  | `Property
  | `Reparent
  | `Unmap
  | `Visibility
  | `Virtual of string  (* Virtual event. Must be without modifiers *)
  | `Modified of modifier list * event
]

and modifier = [
  | `Control
  | `Shift
  | `Lock
  | `Button1
  | `Button2
  | `Button3
  | `Button4
  | `Button5
  | `Double
  | `Triple
  | `Mod1
  | `Mod2
  | `Mod3
  | `Mod4
  | `Mod5
  | `Meta
  | `Alt
]
;;
(* /type *)

(* Event structure, passed to bounded functions *)

(* type *)
type eventInfo = {
  (* %# : event serial number is unsupported *)
    mutable ev_Above : int;               (* tk: %a *)
    mutable ev_ButtonNumber : int;        (* tk: %b *)
    mutable ev_Count : int;               (* tk: %c *)
    mutable ev_Detail : string;           (* tk: %d *)
    mutable ev_Focus : bool;              (* tk: %f *)
    mutable ev_Height : int;              (* tk: %h *)
    mutable ev_KeyCode : int;             (* tk: %k *)
    mutable ev_Mode : string;             (* tk: %m *)
    mutable ev_OverrideRedirect : bool;   (* tk: %o *)
    mutable ev_Place : string;            (* tk: %p *)
    mutable ev_State : string;            (* tk: %s *)
    mutable ev_Time : int;                (* tk: %t *)
    mutable ev_Width : int;               (* tk: %w *)
    mutable ev_MouseX : int;              (* tk: %x *)
    mutable ev_MouseY : int;              (* tk: %y *)
    mutable ev_Char : string;             (* tk: %A *)
    mutable ev_BorderWidth : int;         (* tk: %B *)
    mutable ev_SendEvent : bool;          (* tk: %E *)
    mutable ev_KeySymString : string;     (* tk: %K *)
    mutable ev_KeySymInt : int;           (* tk: %N *)
    mutable ev_RootWindow : int;          (* tk: %R *)
    mutable ev_SubWindow : int;           (* tk: %S *)
    mutable ev_Type : int;                (* tk: %T *)
    mutable ev_Widget : any widget;       (* tk: %W *)
    mutable ev_RootX : int;               (* tk: %X *)
    mutable ev_RootY : int                (* tk: %Y *)
  }
;;
(* /type *)


(* To avoid collision with other constructors (Width, State),
   use Ev_ prefix *)
(* type *)
type eventField = [
  | `Above
  | `ButtonNumber
  | `Count
  | `Detail
  | `Focus
  | `Height
  | `KeyCode
  | `Mode
  | `OverrideRedirect
  | `Place
  | `State
  | `Time
  | `Width
  | `MouseX
  | `MouseY
  | `Char
  | `BorderWidth
  | `SendEvent
  | `KeySymString
  | `KeySymInt
  | `RootWindow
  | `SubWindow
  | `Type
  | `Widget
  | `RootX
  | `RootY
]
;;
(* /type *)

let filleventInfo ev v : eventField -> unit = function
  | `Above    ->        ev.ev_Above <- int_of_string v
  | `ButtonNumber ->    ev.ev_ButtonNumber <- int_of_string v
  | `Count ->           ev.ev_Count <- int_of_string v
  | `Detail ->          ev.ev_Detail <- v
  | `Focus ->           ev.ev_Focus <- v = "1"
  | `Height ->          ev.ev_Height <- int_of_string v
  | `KeyCode ->         ev.ev_KeyCode <- int_of_string v
  | `Mode ->            ev.ev_Mode <- v
  | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1"
  | `Place ->           ev.ev_Place <- v
  | `State ->           ev.ev_State <- v
  | `Time ->            ev.ev_Time <- int_of_string v
  | `Width ->           ev.ev_Width <- int_of_string v
  | `MouseX ->          ev.ev_MouseX <- int_of_string v
  | `MouseY ->          ev.ev_MouseY <- int_of_string v
  | `Char ->            ev.ev_Char <- v
  | `BorderWidth ->     ev.ev_BorderWidth <- int_of_string v
  | `SendEvent ->       ev.ev_SendEvent <- v = "1"
  | `KeySymString ->    ev.ev_KeySymString <- v
  | `KeySymInt ->       ev.ev_KeySymInt <- int_of_string v
  | `RootWindow ->      ev.ev_RootWindow <- int_of_string v
  | `SubWindow ->       ev.ev_SubWindow <- int_of_string v
  | `Type ->            ev.ev_Type <- int_of_string v
  | `Widget ->          ev.ev_Widget <- cTKtoCAMLwidget v
  | `RootX ->           ev.ev_RootX <- int_of_string v
  | `RootY ->           ev.ev_RootY <- int_of_string v
;;

let wrapeventInfo f (what : eventField list) =
  let ev = {
    ev_Above = 0;
    ev_ButtonNumber = 0;
    ev_Count = 0;
    ev_Detail = "";
    ev_Focus = false;
    ev_Height = 0;
    ev_KeyCode = 0;
    ev_Mode = "";
    ev_OverrideRedirect = false;
    ev_Place = "";
    ev_State = "";
    ev_Time = 0;
    ev_Width = 0;
    ev_MouseX = 0;
    ev_MouseY = 0;
    ev_Char = "";
    ev_BorderWidth = 0;
    ev_SendEvent = false;
    ev_KeySymString = "";
    ev_KeySymInt = 0;
    ev_RootWindow = 0;
    ev_SubWindow = 0;
    ev_Type = 0;
    ev_Widget = forget_type default_toplevel;
    ev_RootX = 0;
    ev_RootY = 0 } in
     function args ->
       let l = ref args in
       List.iter what ~f:
         begin fun field ->
           match !l with
           | [] -> ()
           | v :: rest -> filleventInfo ev v field; l := rest
         end;
       f ev
;;

let rec writeeventField : eventField list -> string = function
  | [] -> ""
  | field :: rest ->
    begin
    match field with
    | `Above ->     " %a"
    | `ButtonNumber ->" %b"
    | `Count ->     " %c"
    | `Detail ->    " %d"
    | `Focus ->     " %f"
    | `Height ->    " %h"
    | `KeyCode ->   " %k"
    | `Mode ->      " %m"
    | `OverrideRedirect -> " %o"
    | `Place ->     " %p"
    | `State ->     " %s"
    | `Time ->      " %t"
    | `Width ->     " %w"
    | `MouseX ->    " %x"
    | `MouseY ->    " %y"
    (* Quoting is done by Tk *)
    | `Char ->      " %A"
    | `BorderWidth -> " %B"
    | `SendEvent -> " %E"
    | `KeySymString -> " %K"
    | `KeySymInt -> " %N"
    | `RootWindow ->" %R"
    | `SubWindow -> " %S"
    | `Type ->      " %T"
    | `Widget ->    " %W"
    | `RootX ->     " %X"
    | `RootY ->     " %Y"
    end
    ^ writeeventField rest
;;

##endif