12 (* possible children; used to make the menus *)
14 [ "vbox"; "hbox"; "vbutton_box"; "hbutton_box"; "fixed";
15 "frame"; "aspect_frame"; "handle_box"; "event_box";
16 "hseparator"; "vseparator"; "statusbar"; "label"; "notebook";
19 "toggle_button"; "check_button"; "radio_button"; "scrolled_window";
21 "entry"; "spin_button"; "combo"; "clist"; "toolbar"]
24 (*********** selection ***********)
26 let selection = ref ""
27 let window_selection = ref ""
30 (**************** signals class ***************)
32 class tiwidget_signals ~signals =
33 let name_changed : string signal = signals in
36 method after = {< after = true >}
37 method name_changed = name_changed#connect ~after
41 (************* class type ***************)
42 (* the ti<gtkwidget> classes encapsulate the corresponding gtk
43 widget which will be in the gtk-window and a tree item
44 labelled with the name of the widget which will be in the
46 all these classes have the same following interface *)
48 class virtual tiwidget0 = object
49 method virtual widget : GObj.widget
50 method virtual connect_event : GObj.event_signals
51 method virtual parent : tiwidget0 option
52 method virtual set_parent : tiwidget0 -> unit
53 method virtual base : GObj.widget
54 method virtual tree_item : GTree2.tree_item
55 method virtual tree : GTree2.tree
56 method virtual children : (tiwidget0 * Gtk.Tags.pack_type) list
57 method virtual name : string
58 method virtual proplist : (string * prop) list
59 method virtual add_to_proplist : (string * prop) list -> unit
60 method virtual change_name_in_proplist : string -> string -> unit
61 method virtual set_property : string -> string -> unit
62 method virtual forall : callback:(tiwidget0 -> unit) -> unit
63 method virtual remove : tiwidget0 -> unit
64 (* method virtual add_child_with_name : string -> string -> pos:int -> tiwidget0 *)
65 method virtual add_children : ?pos:int -> yywidget_tree -> unit
66 method virtual add_children_wo_undo : ?pos:int -> yywidget_tree -> string
67 method virtual remove_me : unit -> unit
68 method virtual remove_me_without_undo : unit -> unit
69 method virtual emit_code : Format.formatter -> char list -> unit
70 method virtual emit_init_code : Format.formatter -> packing:string -> unit
71 method virtual emit_method_code : Format.formatter -> unit
72 method virtual emit_initializer_code : Format.formatter -> unit
73 method virtual save : Format.formatter -> unit
74 method virtual copy : unit -> unit
75 method virtual connect : tiwidget_signals
76 method virtual disconnect : GtkSignal.id -> bool
77 method virtual child_up : tiwidget0 -> unit
78 method virtual up : unit -> unit
79 method virtual child_down : tiwidget0 -> unit
80 method virtual down : unit -> unit
81 method virtual next : tiwidget0
82 method virtual next_child : tiwidget0 -> tiwidget0
83 method virtual last : tiwidget0
84 method virtual prev : tiwidget0
85 method virtual set_full_menu : bool -> unit
88 class virtual window_and_tree0 = object
89 method virtual tiwin : tiwidget0
90 (* method virtual tree_window : window *)
91 method virtual change_selected : tiwidget0 -> unit
92 method virtual remove_sel : tiwidget0 -> unit
93 method virtual add_param : char
94 method virtual remove_param : char -> unit
95 (* method virtual emit : unit -> unit *)
98 (* forward declaration of function new_widget *)
100 (classe:string -> ?pos:int -> name:string ->parent_tree:GTree2.tree ->
101 ?insert_evbox:bool -> ?listprop:(string * string) list -> window_and_tree0 -> tiwidget0) ref =
102 ref (fun ~classe ?pos ~name ~parent_tree ?insert_evbox ?listprop w -> failwith "new_tiwidget")
105 let widget_map = Hashtbl.create 17
107 (* list of names of radio_buttons (for groups) *)
108 let radio_button_pool = ref []
111 (************* window creation class *************)
112 (* an instance of this class is created for each window opened
113 in radtest. It contains the tree window and the gtk window (tiwin) *)
115 class window_and_tree ~name =
116 let tree_window = GWindow.window ~show:true ~title:(name ^ "-Tree") () in
117 let vbox = GPack.vbox ~spacing:2 ~packing:tree_window#add () in
118 let root_tree = GTree2.tree ~packing:vbox#pack ~selection_mode:`EXTENDED () in
119 let project_tree_item = GTree2.tree_item () in
120 let label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5
121 ~packing:project_tree_item#add () in
125 inherit window_and_tree0
127 (* the params of the window class; because the class clist needs a param
128 I suppose there will be no more than 26 clists in a single window *)
129 val param_list = Array.create 26 false
133 while param_list.(!i) do incr i done;
134 param_list.(!i) <- true;
135 char_of_int (97 + !i)
137 method remove_param c =
138 param_list.(int_of_char c - 97) <- false
140 method private param_list =
142 for i = 25 downto 0 do
143 if Array.unsafe_get param_list i then r := (char_of_int (i+97)) :: !r
147 (* I use magic here because the real initialization is done
148 below in the initializer part. It can't be done here because
149 of the call to self *)
150 val mutable tiwin = (Obj.magic 0 : tiwidget0)
153 method tree_window = tree_window
155 method project_tree_item = project_tree_item
157 (* the selected item in this window *)
158 val mutable selected = (None : tiwidget0 option)
160 (* what to do when a new item is selected.
161 this method is passed to all the tiwidgets (by the select_fun
162 parameter) and they will call it when they are clicked on;
163 she is also called when changing the selection the arrow keys
164 (see in the initializer part) *)
165 method change_selected sel =
168 selected <- Some sel;
169 sel#tree_item#misc#set_state `SELECTED;
170 sel#base#misc#set_state `SELECTED;
173 if sel = old_sel then begin
175 sel#base#misc#set_state `NORMAL;
176 sel#tree_item#misc#set_state `NORMAL
178 old_sel#tree_item#misc#set_state `NORMAL;
179 old_sel#base#misc#set_state `NORMAL;
180 selected <- Some sel;
181 sel#tree_item#misc#set_state `SELECTED;
182 sel#base#misc#set_state `SELECTED;
186 (* the tiwidget tiw is being removed; if it was selected,
187 put the selection to None *)
188 method remove_sel tiw =
190 | Some sel when sel = tiw -> selected <- None
193 (* emits the code corresponding to this window *)
194 method emit c = tiwin#emit_code c self#param_list;
197 tiwin#remove_me_without_undo ();
198 tree_window#destroy ();
201 tiwin <- !new_tiwidget ~classe:"window" ~name ~parent_tree:root_tree
202 (self : #window_and_tree0 :> window_and_tree0);
204 tiwin#connect#name_changed ~callback:
205 (fun n -> label#set_text n; tree_window#set_title (n ^ "-Tree"));
209 tree_window#event#connect#key_press ~callback:
211 let state = GdkEvent.Key.state ev in
212 let keyval = GdkEvent.Key.keyval ev in
213 if keyval = GdkKeysyms._Up then begin
217 if List.mem `CONTROL state then t#up ()
219 self#change_selected t#prev
222 else if keyval = GdkKeysyms._Down then begin
226 if List.mem `CONTROL state then t#down ()
228 self#change_selected t#next
231 GtkSignal.stop_emit ();
239 (***************** class implementation *****************)
240 (* this is the base class of the ti<gtkwidget> hierarchy.
241 all these classes will inherit from tiwidget, but without
242 adding new methods. In this way all the classes have the
243 same interface and we can use them in lists, pass them to
244 functions without caring on the type.
245 All methods needed by any of the classes are defined in
246 tiwidget but if a method is not pertinent in tiwidget
247 it has for implementation:
248 failwith "<name of the method>"
249 the real implementation of the method is done in the
250 class (or classes) in which it is needed (or sometimes
252 Additionally, to workaround some problem with recursive types
253 the type of the (public) methods of tiwidget is defined in
254 tiwidget0 of which tiwidget inherits.
255 The parent_tree parameter is the tree in which the
256 tiwidget#tree_item will be inserted at position :pos.
259 class virtual tiwidget ~name ~parent_tree:(parent_tree : GTree2.tree) ~pos
260 ~widget ?(insert_evbox=true) (parent_window : window_and_tree0) =
264 inherit has_ml_signals
268 let ev = GBin.event_box () in ev#add widget#coerce; Some ev
271 (* used only for windows delete_event *)
272 method connect_event = failwith "tiwidget::connect_event"
274 val widget = widget#coerce
275 method widget = widget
277 val mutable parent = None
278 method set_parent p = parent <- Some p
279 method parent = parent
280 method private sure_parent =
282 | None -> failwith "sure_parent"
287 | None -> widget#coerce
288 | Some ev -> ev#coerce
290 (* this is the name used in new_tiwidget for the creation
291 of an object of this class *)
292 val mutable classe = ""
294 val tree_item = GTree2.tree_item ()
295 method tree_item = tree_item
297 val mutable stree = GTree2.tree ()
300 val label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5 ()
302 val mutable name : string = name
305 (* this is the complete name for the creation of the widget
306 in lablgtk e.g. GPack.vbox; used in emit_init_code *)
307 method private class_name = ""
309 val mutable proplist : (string * prop) list = []
310 method proplist = proplist
311 method private get_mandatory_props = []
313 method add_to_proplist plist = proplist <- proplist @ plist
315 (* for children of a box *)
316 method change_name_in_proplist : string -> string -> unit =
318 method set_property name value_string = try
319 (List.assoc name proplist)#set value_string
320 with Not_found -> Printf.printf "Property not_found %s, %s\n" name value_string;
323 method private get_property name =
324 (List.assoc name proplist)#get
327 (* the proplist with some items removed e.g. the expand... in a box
328 used for saving and emitting code *)
329 method private emit_clean_proplist =
330 List.fold_left ~f:(fun l p -> List.remove_assoc p l)
332 ([ "name"; "expand"; "fill"; "padding" ] @ self#get_mandatory_props)
333 (* method private emit_clean_proplist plist =
334 List.fold_left ~init:plist ~f:
335 (fun pl propname -> List.remove_assoc propname pl)
336 [ "name"; "expand"; "fill"; "padding" ]
339 method private save_clean_proplist =
340 List.fold_left ~f:(fun l p -> List.remove_assoc p l)
341 ~init:proplist ("name" :: self#get_mandatory_props)
342 (* method private save_clean_proplist =
343 List.remove_assoc "name" proplist *)
345 val mutable children : (tiwidget0 * Gtk.Tags.pack_type) list = []
346 method children = children
348 fun ~callback -> List.iter (List.map children ~f:fst) ~f:callback
350 (* encapsulate container#add and container#remove
351 they are here because they depend on the type of the widget:
352 e.g.: gtkbin->add scrolled_window->add_with_viewport box->pack *)
353 method private add = failwith (name ^ "::add")
354 method remove = failwith (name ^ "::remove")
357 (* removes self from his parent;
358 will be different for a window *)
359 method remove_me () =
361 self#save_to_string sref;
362 let pos = list_pos ~item:(self : #tiwidget0 :> tiwidget0)
363 (List.map self#sure_parent#children ~f:fst) in
364 let lexbuf = Lexing.from_string !sref in
365 let node = Load_parser.widget Load_lexer.token lexbuf in
366 add_undo (Add (self#sure_parent#name, node, pos));
367 self#remove_me_without_undo ()
369 method remove_me_without_undo () =
370 (* it should be enough to only recursively remove the children from the
371 name_list and do the tip#remove and tip#tree#remove
373 self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
374 parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
376 | None -> failwith "remove without parent"
377 | Some (tip : #tiwidget0) ->
378 tip#tree#remove tree_item;
379 tip#remove (self : #tiwidget0 :> tiwidget0);
380 name_list := list_remove !name_list ~f:(fun n -> n=name);
381 Hashtbl.remove widget_map name;
385 method private remove_child_by_name name () =
386 let child = fst (List.find children
387 ~f:(fun (ch, _) -> ch#name = name)) in
390 (* for most widgets we make a child with new_tiwidget and then add it
391 to self; for toolbars we use toolbar#insert_button... *)
392 method private make_child = !new_tiwidget
394 (* adds a child and shows his properties;
395 used when adding a child by the menu or DnD *)
396 method private add_child classe ?name ?(undo = true) ?(affich = true) ?(pos = -1) ?(listprop = []) () =
397 let name = match name with
398 | None -> make_new_name classe
400 let child = self#make_child ~classe ~name ~parent_tree:stree parent_window ~pos ~listprop in
401 child#set_parent (self : #tiwidget0 :> tiwidget0);
403 if affich then Propwin.show child;
404 if undo then add_undo (Remove name);
408 (* adds the subtree saved in the Node *)
409 method add_children ?(pos = -1) node =
410 let child_name = self#add_children_wo_undo node ~pos in
411 add_undo (Remove child_name)
413 method add_children_wo_undo ?(pos = -1) (Node (child, children)) =
414 let classe, name, property_list = child in
415 let rname = change_name name in
416 let tc = self#add_child classe ~name:rname ~undo:false ~affich:false ~pos ~listprop:property_list () in
417 List.iter (List.rev children)
418 ~f:(fun c -> tc#add_children_wo_undo c; ());
419 List.iter property_list ~f:(fun (n,v) -> tc#set_property n v);
422 (* only a tiwindow can emit code *)
423 method emit_code = failwith "emit_code"
425 (* some methods for emitting code *)
426 (* this one calculates the expand, fill and padding parameters
428 method private get_packing packing =
430 let prop = List.assoc name proplist in
431 if prop#modified then " ~" ^ name ^ ":" ^ prop#code else ""
434 (aux "expand") ^ (aux "fill") ^ (aux "padding")
435 with Not_found -> "" in
436 if efp = "" then ("~packing:" ^ packing)
437 else ("~packing:(" ^ packing ^ efp ^ ")")
439 (* this one emits the declaration code of the widget *)
440 method emit_init_code formatter ~packing =
441 Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s"
442 name self#class_name;
443 List.iter self#get_mandatory_props
445 Format.fprintf formatter "@ ~%s:%s" name
446 (List.assoc name proplist)#code
448 let packing = self#get_packing packing in
449 if packing <> "" then Format.fprintf formatter "@ %s" packing;
450 self#emit_prop_code formatter;
451 Format.fprintf formatter "@ ()@ in@]@]"
453 (* this one emits the properties which do not have their
454 default value; used by emit_init_code *)
455 method private emit_prop_code formatter =
456 let mandatory = self#get_mandatory_props in
457 List.iter self#emit_clean_proplist ~f:
458 begin fun (name, prop) ->
459 if List.mem name mandatory then () else
460 if prop#modified then
461 Format.fprintf formatter "@ ~%s:%s" prop#name prop#code
464 (* this one emits the method returning this widget *)
465 method emit_method_code formatter =
466 Format.fprintf formatter "@ method %s = %s" name name;
468 (* emits the code in the initializer part for this widget *)
469 method emit_initializer_code _ = ()
471 (* for saving the project to a file. Used also by copy and cut *)
472 method private save_start formatter =
473 Format.fprintf formatter "@\n@[<2><%s name=%s>" classe name;
475 ~f:(fun p -> Format.fprintf formatter
476 "@\n%s=\"%s\"" p (List.assoc p proplist)#get)
477 self#get_mandatory_props
480 method private save_end formatter =
481 Format.fprintf formatter "@]@\n</%s>" classe
483 method save formatter =
484 self#save_start formatter;
485 List.iter self#save_clean_proplist ~f:
487 if prop#modified then
488 Format.fprintf formatter "@\n%s=%s" name prop#save_code);
489 self#forall ~callback:(fun w -> w#save formatter);
490 self#save_end formatter
493 method private save_to_string string_ref =
494 let b = Buffer.create 80 in
495 let f = Format.formatter_of_buffer b in
497 Format.pp_print_flush f ();
498 string_ref := Buffer.contents b
500 method private copy_to_sel selection = self#save_to_string selection
502 method copy () = self#copy_to_sel selection
504 method private cut () =
508 method private paste () =
509 let lexbuf = Lexing.from_string !selection in
510 let node = Load_parser.widget Load_lexer.token lexbuf in
511 self#add_children node
514 (* ML signal used when the name of the widget is changed *)
515 val name_changed : string signal = new signal
516 method connect = new tiwidget_signals ~signals:name_changed
517 method private call_name_changed = name_changed#call
520 (* this is necessary because gtk_tree#remove deletes the tree
521 when removing the last item *)
522 (* suppressed this in gtktree2
524 stree <- GTree2.tree;
525 tree_item#set_subtree stree;
529 (* when full_menu is true we use the menu else the restricted menu *)
530 val mutable full_menu = true
531 method set_full_menu b = full_menu <- b
533 (* the menu for this widget
534 This menu is recalculated when one clicks on the 3rd button.
535 There is nothing to do e.g. when the name of the widget changes,
536 it will change in the menu the next time. *)
537 method private menu ~time = self#restricted_menu ~time
539 (* the restricted menu for this widget
540 used for containers when they are full *)
541 method private restricted_menu ~time =
542 let menu = GMenu.menu () in
543 let mi_remove = GMenu.menu_item ~packing:menu#append ~label:"remove" ()
544 and mi_cut = GMenu.menu_item ~packing:menu#append ~label:"Cut" ()
545 and mi_copy = GMenu.menu_item ~packing:menu#append ~label:"Copy" () in
546 mi_remove#connect#activate ~callback:self#remove_me;
547 mi_copy#connect#activate ~callback:self#copy;
548 mi_cut#connect#activate ~callback:self#cut;
549 menu#popup ~button:3 ~time
551 (* changes all that depends on the name *)
552 method private set_new_name new_name =
553 if test_unique new_name then begin
554 Hashtbl.remove widget_map name;
555 Hashtbl.add widget_map ~key:new_name
556 ~data:(self : #tiwidget0 :> tiwidget0);
557 if (classe = "radio_button") then begin
558 radio_button_pool := new_name ::
559 (list_remove !radio_button_pool ~f:(fun x -> x = name));
561 ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) false)
564 label#set_text new_name;
565 let old_name = name in
567 (* Propwin.change_name old_name new_name; *)
569 new_name :: (list_remove !name_list ~f:(fun n -> n=old_name));
570 begin match self#parent with
572 | Some p -> p#change_name_in_proplist old_name new_name
574 self#call_name_changed new_name;
579 Propwin.update self true;
584 (* moves the present tiw up in his parents' children list *)
585 (* does something only when the parent is a box *)
586 method child_up = fun _ -> ()
588 method up () = match parent with
590 | Some t -> t#child_up (self : #tiwidget0 :> tiwidget0)
592 method child_down = fun _ -> ()
594 method down () = match parent with
596 | Some t -> t#child_down (self : #tiwidget0 :> tiwidget0)
599 (* get the next tiwidget in the tree (used with Down arrow) *)
601 if children <> [] then fst (List.hd children)
604 | None -> raise Not_found
605 | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
608 method next_child child =
609 let _, tl = cut_list ~item:child (List.map ~f:fst children) in
611 | ch :: next :: _ -> next
614 | None -> raise Not_found
615 | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
617 | _ -> failwith "next_child"
619 (* get the last child of the last child ... of our last child.
622 if children = [] then (self : #tiwidget0 :> tiwidget0)
623 else (fst (List.hd (List.rev children)))#last
625 (* get the previous tiwidget in the tree (used with Up arrow) *)
628 | None -> raise Not_found
630 let hd, _ = cut_list ~item:(self : #tiwidget0 :> tiwidget0)
631 (List.map ~f:fst p#children) in
637 Hashtbl.add widget_map ~key:name ~data:(self : #tiwidget0 :> tiwidget0);
638 name_list := name :: !name_list;
639 parent_tree#insert tree_item ~pos;
640 tree_item#set_subtree stree;
641 tree_item#add label#coerce;
644 proplist <- proplist @
646 new prop_string ~name:"name" ~init:name ~set:self#set_new_name;
647 "width", new prop_int ~name:"width" ~init:"-2"
648 ~set:(fun v -> widget#misc#set_geometry ~width:v (); true);
649 "height", new prop_int ~name:"height" ~init:"-2"
650 ~set:(fun v -> widget#misc#set_geometry ~height:v (); true) ];
652 self#add_signal name_changed;
654 tree_item#event#connect#button_press ~callback:
655 (fun ev -> match GdkEvent.get_type ev with
657 if GdkEvent.Button.button ev = 1 then begin
658 parent_window#change_selected
659 (self : #tiwidget0 :> tiwidget0);
661 else if GdkEvent.Button.button ev = 3 then begin
663 then self#menu ~time:(GdkEvent.Button.time ev)
664 else self#restricted_menu ~time:(GdkEvent.Button.time ev);
666 GtkSignal.stop_emit ();