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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
module Dispatch_control = struct
type t = {
mutable propagation_stopped : bool;
mutable default_prevented : bool;
}
let create () = { propagation_stopped = false; default_prevented = false }
let stop_propagation t = t.propagation_stopped <- true
let propagation_stopped t = t.propagation_stopped
let prevent_default t = t.default_prevented <- true
let default_prevented t = t.default_prevented
end
module Key = struct
type t = { data : Input.Key.event; ctl : Dispatch_control.t }
let of_input data = { data; ctl = Dispatch_control.create () }
let data t = t.data
let stop_propagation t = Dispatch_control.stop_propagation t.ctl
let propagation_stopped t = Dispatch_control.propagation_stopped t.ctl
let prevent_default t = Dispatch_control.prevent_default t.ctl
let default_prevented t = Dispatch_control.default_prevented t.ctl
let equal a b = Input.Key.equal_event a.data b.data
let pp ppf t = Input.Key.pp_event ppf t.data
end
module Paste = struct
type t = { text : string; ctl : Dispatch_control.t }
let of_text text = { text; ctl = Dispatch_control.create () }
let text t = t.text
let stop_propagation t = Dispatch_control.stop_propagation t.ctl
let propagation_stopped t = Dispatch_control.propagation_stopped t.ctl
let prevent_default t = Dispatch_control.prevent_default t.ctl
let default_prevented t = Dispatch_control.default_prevented t.ctl
let equal a b = String.equal a.text b.text
let pp ppf t = Format.fprintf ppf "Paste(%S)" t.text
end
module Mouse = struct
type button = Left | Middle | Right | Button of int
let equal_button a b =
match (a, b) with
| Left, Left | Middle, Middle | Right, Right -> true
| Button a, Button b -> Int.equal a b
| _ -> false
let pp_button ppf = function
| Left -> Format.pp_print_string ppf "Left"
| Middle -> Format.pp_print_string ppf "Middle"
| Right -> Format.pp_print_string ppf "Right"
| Button n -> Format.fprintf ppf "Button(%d)" n
type modifier = Input.Key.modifier = {
ctrl : bool;
alt : bool;
shift : bool;
super : bool;
hyper : bool;
meta : bool;
caps_lock : bool;
num_lock : bool;
}
let no_modifier = Input.Key.no_modifier
let equal_modifier = Input.Key.equal_modifier
let pp_modifier = Input.Key.pp_modifier
type scroll_direction = Input.Mouse.scroll_direction =
| Scroll_up
| Scroll_down
| Scroll_left
| Scroll_right
let equal_scroll_direction = Input.Mouse.equal_scroll_direction
let pp_scroll_direction = Input.Mouse.pp_scroll_direction
type kind =
| Down of { button : button }
| Up of { button : button; is_dragging : bool }
| Move
| Drag of { button : button; is_dragging : bool }
| Drag_end of { button : button }
| Drop of { button : button; source : int option }
| Over of { source : int option }
| Out
| Scroll of { direction : scroll_direction; delta : int }
let pp_button_drag ppf name button is_dragging =
if is_dragging then
Format.fprintf ppf "%s(%a, dragging)" name pp_button button
else Format.fprintf ppf "%s(%a)" name pp_button button
let pp_kind ppf = function
| Down { button } -> Format.fprintf ppf "Down(%a)" pp_button button
| Up { button; is_dragging } -> pp_button_drag ppf "Up" button is_dragging
| Move -> Format.pp_print_string ppf "Move"
| Drag { button; is_dragging } ->
pp_button_drag ppf "Drag" button is_dragging
| Drag_end { button } -> Format.fprintf ppf "Drag_end(%a)" pp_button button
| Drop { button; source = Some s } ->
Format.fprintf ppf "Drop(%a, source=%d)" pp_button button s
| Drop { button; source = None } ->
Format.fprintf ppf "Drop(%a)" pp_button button
| Over { source = Some s } -> Format.fprintf ppf "Over(source=%d)" s
| Over { source = None } -> Format.pp_print_string ppf "Over"
| Out -> Format.pp_print_string ppf "Out"
| Scroll { direction; delta } ->
Format.fprintf ppf "Scroll(%a, %d)" Input.Mouse.pp_scroll_direction
direction delta
let equal_kind a b =
match (a, b) with
| Down a, Down b -> equal_button a.button b.button
| Up a, Up b ->
equal_button a.button b.button && Bool.equal a.is_dragging b.is_dragging
| Move, Move -> true
| Drag a, Drag b ->
equal_button a.button b.button && Bool.equal a.is_dragging b.is_dragging
| Drag_end a, Drag_end b -> equal_button a.button b.button
| Drop a, Drop b ->
equal_button a.button b.button
&& Option.equal Int.equal a.source b.source
| Over a, Over b -> Option.equal Int.equal a.source b.source
| Out, Out -> true
| Scroll a, Scroll b ->
equal_scroll_direction a.direction b.direction
&& Int.equal a.delta b.delta
| _ -> false
type t = {
kind : kind;
x : int;
y : int;
modifiers : modifier;
target : int option;
ctl : Dispatch_control.t;
}
let make ~x ~y ~modifiers ?target kind =
{ kind; x; y; modifiers; target; ctl = Dispatch_control.create () }
let kind t = t.kind
let x t = t.x
let y t = t.y
let modifiers t = t.modifiers
let target t = t.target
let stop_propagation t = Dispatch_control.stop_propagation t.ctl
let propagation_stopped t = Dispatch_control.propagation_stopped t.ctl
let prevent_default t = Dispatch_control.prevent_default t.ctl
let default_prevented t = Dispatch_control.default_prevented t.ctl
let equal a b =
equal_kind a.kind b.kind && Int.equal a.x b.x && Int.equal a.y b.y
&& equal_modifier a.modifiers b.modifiers
&& Option.equal Int.equal a.target b.target
let pp ppf t = Format.fprintf ppf "%a(%d, %d)" pp_kind t.kind t.x t.y
end
type key = Key.t
type paste = Paste.t
type mouse = Mouse.t