Source file lTerm_buttons_impl.ml
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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
module Make (LiteralIntf: LiteralIntf.Type) = struct
open CamomileLibraryDefault.Camomile
open LTerm_geom
open LTerm_key
open LTerm_mouse
open LTerm_widget_callbacks
let section = Lwt_log.Section.make "lambda-term(buttons_impl)"
class t = LTerm_widget_base_impl.t
let space = Char(UChar.of_char ' ')
class button ?brackets initial_label =
let (bl, br)=
match brackets with
| Some (bl, br)-> LiteralIntf.to_string_exn bl, LiteralIntf.to_string_exn br
| None-> Zed_string.unsafe_of_utf8 "< ",Zed_string.unsafe_of_utf8 " >"
in
let brackets_size = LTerm_text.aval_width (Zed_string.width bl)
+ LTerm_text.aval_width (Zed_string.width br)
in
object(self)
inherit t "button"
method! can_focus = true
val click_callbacks = LTerm_widget_callbacks.create ()
method on_click ?switch f =
register switch click_callbacks f
val mutable size_request = { rows = 1; cols = brackets_size + (LTerm_text.aval_width (Zed_string.width (LiteralIntf.to_string_exn initial_label))) }
method! size_request = size_request
val mutable label = LiteralIntf.to_string_exn initial_label
method label = LiteralIntf.of_string label
method label_zed = label
method set_label text =
let text= LiteralIntf.to_string_exn text in
label <- text;
size_request <- { rows = 1; cols = brackets_size + (LTerm_text.aval_width (Zed_string.width text)) };
self#queue_draw
initializer
self#on_event
(function
| LTerm_event.Key { control = false; meta = false; shift = false; code = Enter } ->
exec_callbacks click_callbacks ();
true
| LTerm_event.Mouse m when m.button = Button1 ->
exec_callbacks click_callbacks ();
true
| _ ->
false)
val mutable focused_style = LTerm_style.none
val mutable unfocused_style = LTerm_style.none
method! update_resources =
let rc = self#resource_class and resources = self#resources in
focused_style <- LTerm_resources.get_style (rc ^ ".focused") resources;
unfocused_style <- LTerm_resources.get_style (rc ^ ".unfocused") resources
method private apply_style ctx focused =
let style =
if focused = (self :> t)
then focused_style
else unfocused_style
in
LTerm_draw.fill_style ctx style
method! draw ctx focused =
let { rows; cols } = LTerm_draw.size ctx in
let width = LTerm_text.aval_width (Zed_string.width label) in
self#apply_style ctx focused;
LTerm_draw.draw_string ctx (rows / 2) ((cols - width - brackets_size) / 2)
(Zed_string.append (Zed_string.append bl label) br)
end
class checkbutton initial_label initial_state = object(self)
inherit button initial_label
val mutable state = initial_state
initializer
self#on_event (fun ev ->
let update () =
state <- not state;
self#queue_draw;
exec_callbacks click_callbacks ();
true
in
match ev with
| LTerm_event.Key { control = false; meta = false; shift = false; code }
when (code = Enter || code = space) -> update ()
| LTerm_event.Mouse m
when m.button = Button1 -> update ()
| _ ->
false);
self#set_resource_class "checkbutton"
method state = state
method! draw ctx focused =
let { rows; _ } = LTerm_draw.size ctx in
let checked = Zed_string.unsafe_of_utf8 (if state then "[x] " else "[ ] ") in
self#apply_style ctx focused;
LTerm_draw.draw_string ctx (rows / 2) 0 (Zed_string.append checked label);
end
class type ['a] radio = object
method on : unit
method off : unit
method id : 'a
end
class ['a] radiogroup = object
val state_change_callbacks = LTerm_widget_callbacks.create ()
method on_state_change ?switch f =
register switch state_change_callbacks f
val mutable state = None
val mutable buttons = []
method state = state
method register_object (button : 'a radio) =
if buttons = [] then button#on else ();
buttons <- button :: buttons;
()
method switch_to some_id =
let switch_button button =
if button#id = some_id
then button#on
else button#off
in
List.iter switch_button buttons;
state <- Some some_id;
exec_callbacks state_change_callbacks state
end
class ['a] radiobutton (group : 'a radiogroup) initial_label (id : 'a) = object(self)
inherit button initial_label
val mutable state = false
initializer
self#on_event
(fun ev ->
let update () =
if state
then ()
else group#switch_to id;
exec_callbacks click_callbacks ();
true
in
match ev with
| LTerm_event.Key { control = false; meta = false; shift = false; code }
when (code = Enter || code = space) -> update ()
| LTerm_event.Mouse m when m.button = Button1 -> update ()
| _ -> false);
self#set_resource_class "radiobutton";
group#register_object (self :> 'a radio)
method! draw ctx focused =
let { rows; _ } = LTerm_draw.size ctx in
let checked = Zed_string.unsafe_of_utf8 (if state then "(o) " else "( ) ") in
self#apply_style ctx focused;
LTerm_draw.draw_string ctx (rows / 2) 0 (Zed_string.append checked self#label_zed);
method state = state
method on =
state <- true;
self#queue_draw
method off =
state <- false;
self#queue_draw
method id = id
end
end