7 (* the button inherits from widget because it can't accept
9 needs to add the border_width property *)
10 class tibutton ~(widget : #GButton.button) ~name ~parent_tree ~pos
11 ?(insert_evbox=true) parent_window =
14 inherit tiwidget ~name ~widget ~parent_tree ~pos ~insert_evbox
15 parent_window as widget
17 method private class_name = "GButton.button"
19 method private get_mandatory_props = [ "label" ]
23 proplist <- proplist @
24 [ "border_width", new prop_int ~name:"border_width" ~init:"0"
25 ~set:(ftrue button#set_border_width);
27 new prop_string ~name:"label" ~init:name ~set:
29 button#remove (List.hd button#children)#coerce;
30 GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
35 let new_tibutton ~name ?(listprop = []) =
36 let b = GButton.button ~label:name () in
37 b#event#connect#enter_notify
38 ~callback:(fun _ -> GtkSignal.stop_emit (); true);
39 b#event#connect#leave_notify
40 ~callback:(fun _ -> GtkSignal.stop_emit (); true);
41 new tibutton ~widget:b ~name
44 class ticheck_button ~(widget : #GButton.toggle_button) ~name
45 ~parent_tree ~pos ?(insert_evbox=true) parent_window =
48 inherit tiwidget ~name ~widget ~insert_evbox
49 ~parent_tree ~pos parent_window as widget
52 method private class_name = "GButton.check_button"
54 method private get_mandatory_props = [ "label" ]
57 classe <- "check_button";
58 proplist <- proplist @
59 [ "border_width", new prop_int ~name:"border_width" ~init:"0"
60 ~set:(ftrue button#set_border_width);
62 new prop_string ~name:"label" ~init:name ~set:
64 button#remove (List.hd button#children)#coerce;
65 GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
71 let new_ticheck_button ~name ?(listprop = []) =
72 new ticheck_button ~widget:(GButton.check_button ~label:name ()) ~name
76 class titoggle_button ~(widget : #GButton.toggle_button) ~name
77 ~parent_tree ~pos ?(insert_evbox=true) parent_window =
80 inherit tiwidget ~name ~widget ~insert_evbox
81 ~parent_tree ~pos parent_window as widget
83 method private class_name = "GButton.toggle_button"
85 method private get_mandatory_props = [ "label" ]
88 classe <- "toggle_button";
89 proplist <- proplist @
90 [ "border width", new prop_int ~name:"border_width" ~init:"0"
91 ~set:(ftrue button#set_border_width);
93 new prop_string ~name:"label" ~init:name ~set:
95 button#remove (List.hd button#children)#coerce;
96 GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
101 let new_titoggle_button ~name ?(listprop = []) =
102 let b = GButton.toggle_button ~label:name () in
103 (* b#connect#event#enter_notify
104 ~callback:(fun _ -> GtkSignal.stop_emit ());
105 b#connect#event#leave_notify
106 ~callback:(fun _ -> GtkSignal.stop_emit ());
108 new titoggle_button ~name ~widget:b
111 class tiradio_button ~(widget : #GButton.radio_button) ~name:nname
112 ~parent_tree ~pos ?(insert_evbox=true) parent_window =
115 inherit tiwidget ~name:nname ~widget ~insert_evbox
116 ~parent_tree ~pos parent_window as widget
119 new prop_enum_dyn ~values:(fun () -> !radio_button_pool) ~name:"group"
120 ~set:(fun () -> true) ~init:nname
123 method private class_name = "GButton.radio_button"
125 method remove_me_without_undo () =
126 radio_button_pool := list_remove !radio_button_pool
127 ~f:(fun x -> x = name);
128 widget#remove_me_without_undo ()
130 method private get_mandatory_props = [ "label" ]
132 method private emit_clean_proplist =
133 List.remove_assoc "group" widget#emit_clean_proplist
135 method emit_initializer_code formatter =
136 let groupname = group_prop#get in
137 if name <> groupname then
138 Format.fprintf formatter "@ %s#set_group %s#group;" name groupname
141 classe <- "radio_button";
142 radio_button_pool := name :: !radio_button_pool;
144 ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) true)
145 (List.tl !radio_button_pool);
147 proplist <- proplist @
148 [ "border_width", new prop_int ~name:"border_width" ~init:"0"
149 ~set:(ftrue button#set_border_width);
151 new prop_string ~name:"label" ~init:name ~set:
153 button#remove (List.hd button#children)#coerce;
154 GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
161 let new_tiradio_button ~name ?(listprop = []) =
162 let b = GButton.radio_button ~label:name () in
164 b#event#connect#enter_notify
165 ~callback:(fun _ -> b#misc#stop_emit ~name:"enter_notify_event"; true);
166 b#event#connect#leave_notify
167 ~callback:(fun _ -> b#misc#stop_emit ~name:"leave_notify_event"; true);
169 new tiradio_button ~name ~widget:b
174 class tibutton_toolbar ~(widget : #GButton.button) ~name ~parent_tree ~pos
175 ?(insert_evbox=true) parent_window ~toolbar =
178 inherit tibutton ~name ~widget ~parent_tree ~pos ~insert_evbox
179 parent_window as button
181 method private get_mandatory_props =
182 [ "text"; "tooltip"; "tooltip_private" ]
184 method emit_init_code formatter ~packing =
185 Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_button"
187 List.iter self#get_mandatory_props ~f:
189 Format.fprintf formatter "@ ~%s:%s" name
190 (List.assoc name proplist)#code
192 Format.fprintf formatter "@ ()@ in@]@]"
195 proplist <- List.remove_assoc "label" proplist
199 class titoggle_button_toolbar ~(widget : #GButton.toggle_button) ~name
200 ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
203 inherit titoggle_button ~name ~widget ~parent_tree ~pos ~insert_evbox
204 parent_window as button
206 method private get_mandatory_props =
207 [ "text"; "tooltip"; "tooltip_private" ]
209 method emit_init_code formatter ~packing =
210 Format.fprintf formatter
211 "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_toggle_button"
213 List.iter self#get_mandatory_props ~f:
215 Format.fprintf formatter "@ ~%s:%s" name
216 (List.assoc name proplist)#code
218 Format.fprintf formatter "@ ()@ in@]@]"
221 proplist <- List.remove_assoc "label" proplist
225 class tiradio_button_toolbar ~(widget : #GButton.radio_button) ~name
226 ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
229 inherit tiradio_button ~name ~widget ~parent_tree ~pos ~insert_evbox
230 parent_window as button
232 method private get_mandatory_props =
233 [ "text"; "tooltip"; "tooltip_private" ]
235 method emit_init_code formatter ~packing =
236 Format.fprintf formatter
237 "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_radio_button"
239 List.iter self#get_mandatory_props ~f:
241 Format.fprintf formatter "@ ~%s:%s" name
242 (List.assoc name proplist)#code
244 Format.fprintf formatter "@ ()@ in@]@]"
247 proplist <- List.remove_assoc "label" proplist
253 class titoolbar ~(widget : GToolbar2.toolbar2) ~name ~parent_tree ~pos
254 ?(insert_evbox=true) parent_window =
257 inherit ticontainer ~name ~widget ~parent_tree ~pos
258 ~insert_evbox parent_window
260 method private class_name = "GButton.toolbar"
262 method private add child ~pos =
263 children <- children @ [child, `START]
265 method private get_pos child =
266 let rec aux n = function
267 | [] -> failwith "toolbar::get_pos"
268 | (hd, _)::tl -> if hd = child then n else aux (n+1) tl in
271 method private make_child ~classe ?(pos = -1) ~name ~parent_tree
272 ?(insert_evbox = true) ?(listprop = []) parent_window =
275 let t = try List.assoc "text" listprop with Not_found -> "" in
276 let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
277 let ptt = try List.assoc "tooltip_private" listprop
278 with Not_found -> "" in
279 let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
281 [ "text"; "tooltip"; "tooltip_private" ] in
282 let b = toolbar#insert_button ~text:t ~tooltip:tt
283 ~tooltip_private:ptt () in
284 let child = new tibutton_toolbar ~name ~widget:b ~pos:(-1)
285 ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
286 let tp = new prop_string ~name:"text" ~init:t
288 toolbar#set_text v (self#get_pos child); true)
289 and ttp = new prop_string ~name:"tooltip" ~init:tt
291 and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
292 ~set:(fun _ -> true) in
293 child#add_to_proplist
294 [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
297 let t = try List.assoc "text" listprop with Not_found -> "" in
298 let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
299 let ptt = try List.assoc "tooltip_private" listprop
300 with Not_found -> "" in
301 let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
303 [ "text"; "tooltip"; "tooltip_private" ] in
304 let b = toolbar#insert_toggle_button ~text:t ~tooltip:tt
305 ~tooltip_private:ptt () in
306 let child = new titoggle_button_toolbar ~name ~widget:b ~pos:(-1)
307 ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
308 let tp = new prop_string ~name:"text" ~init:t
309 ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
310 and ttp = new prop_string ~name:"tooltip" ~init:tt
312 and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
313 ~set:(fun _ -> true) in
314 child#add_to_proplist
315 [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
318 let t = try List.assoc "text" listprop with Not_found -> "" in
319 let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
320 let ptt = try List.assoc "tooltip_private" listprop
321 with Not_found -> "" in
322 let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
324 [ "text"; "tooltip"; "tooltip_private" ] in
325 let b = toolbar#insert_radio_button ~text:t ~tooltip:tt
326 ~tooltip_private:ptt () in
327 let child = new tiradio_button_toolbar ~name ~widget:b ~pos:(-1)
328 ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
329 let tp = new prop_string ~name:"text" ~init:t
330 ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
331 and ttp = new prop_string ~name:"tooltip" ~init:tt
333 and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
334 ~set:(fun _ -> true) in
335 child#add_to_proplist
336 [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
338 | _ -> failwith "toolbar"
342 method remove child =
343 toolbar#remove (child#base);
344 children <- list_remove ~f:(fun (ch, _) -> ch = child) children;
348 proplist <- proplist @
350 new prop_orientation ~name:"orientation" ~init:"HORIZONTAL"
351 ~set:(ftrue toolbar#set_orientation);
353 new prop_toolbar_style ~name:"style" ~init:"BOTH"
354 ~set:(ftrue toolbar#set_style);
356 new prop_int ~name:"space_size" ~init:"5"
357 ~set:(ftrue toolbar#set_space_size);
359 new prop_toolbar_space_style ~name:"space_style" ~init:"EMPTY"
360 ~set:(ftrue toolbar#set_space_style);
362 new prop_bool ~name:"tooltips" ~init:"true"
363 ~set:(ftrue toolbar#set_tooltips);
365 new prop_relief_style ~name:"button_relief" ~init:"NORMAL"
366 ~set:(ftrue toolbar#set_button_relief)
370 let new_toolbar ~name ?(listprop = []) =
371 new titoolbar ~name ~widget:(GToolbar2.toolbar2 ())