--- /dev/null
+(* $Id$ *)
+
+open Gaux
+open Gtk
+open GObj
+open GContainer
+
+open Utils
+open Common
+open Property
+
+(* possible children; used to make the menus *)
+let widget_add_list =
+ [ "vbox"; "hbox"; "vbutton_box"; "hbutton_box"; "fixed";
+ "frame"; "aspect_frame"; "handle_box"; "event_box";
+ "hseparator"; "vseparator"; "statusbar"; "label"; "notebook";
+ "color_selection";
+ "button";
+ "toggle_button"; "check_button"; "radio_button"; "scrolled_window";
+
+ "entry"; "spin_button"; "combo"; "clist"; "toolbar"]
+
+
+(*********** selection ***********)
+
+let selection = ref ""
+let window_selection = ref ""
+
+
+(**************** signals class ***************)
+
+class tiwidget_signals ~signals =
+ let name_changed : string signal = signals in
+ object
+ val after = false
+ method after = {< after = true >}
+ method name_changed = name_changed#connect ~after
+ end
+
+
+(************* class type ***************)
+(* the ti<gtkwidget> classes encapsulate the corresponding gtk
+ widget which will be in the gtk-window and a tree item
+ labelled with the name of the widget which will be in the
+ tree-window.
+ all these classes have the same following interface *)
+
+class virtual tiwidget0 = object
+ method virtual widget : GObj.widget
+ method virtual connect_event : GObj.event_signals
+ method virtual parent : tiwidget0 option
+ method virtual set_parent : tiwidget0 -> unit
+ method virtual base : GObj.widget
+ method virtual tree_item : GTree2.tree_item
+ method virtual tree : GTree2.tree
+ method virtual children : (tiwidget0 * Gtk.Tags.pack_type) list
+ method virtual name : string
+ method virtual proplist : (string * prop) list
+ method virtual add_to_proplist : (string * prop) list -> unit
+ method virtual change_name_in_proplist : string -> string -> unit
+ method virtual set_property : string -> string -> unit
+ method virtual forall : callback:(tiwidget0 -> unit) -> unit
+ method virtual remove : tiwidget0 -> unit
+(* method virtual add_child_with_name : string -> string -> pos:int -> tiwidget0 *)
+ method virtual add_children : ?pos:int -> yywidget_tree -> unit
+ method virtual add_children_wo_undo : ?pos:int -> yywidget_tree -> string
+ method virtual remove_me : unit -> unit
+ method virtual remove_me_without_undo : unit -> unit
+ method virtual emit_code : Format.formatter -> char list -> unit
+ method virtual emit_init_code : Format.formatter -> packing:string -> unit
+ method virtual emit_method_code : Format.formatter -> unit
+ method virtual emit_initializer_code : Format.formatter -> unit
+ method virtual save : Format.formatter -> unit
+ method virtual copy : unit -> unit
+ method virtual connect : tiwidget_signals
+ method virtual disconnect : GtkSignal.id -> bool
+ method virtual child_up : tiwidget0 -> unit
+ method virtual up : unit -> unit
+ method virtual child_down : tiwidget0 -> unit
+ method virtual down : unit -> unit
+ method virtual next : tiwidget0
+ method virtual next_child : tiwidget0 -> tiwidget0
+ method virtual last : tiwidget0
+ method virtual prev : tiwidget0
+ method virtual set_full_menu : bool -> unit
+end
+
+class virtual window_and_tree0 = object
+ method virtual tiwin : tiwidget0
+(* method virtual tree_window : window *)
+ method virtual change_selected : tiwidget0 -> unit
+ method virtual remove_sel : tiwidget0 -> unit
+ method virtual add_param : char
+ method virtual remove_param : char -> unit
+(* method virtual emit : unit -> unit *)
+end
+
+(* forward declaration of function new_widget *)
+let new_tiwidget :
+ (classe:string -> ?pos:int -> name:string ->parent_tree:GTree2.tree ->
+ ?insert_evbox:bool -> ?listprop:(string * string) list -> window_and_tree0 -> tiwidget0) ref =
+ ref (fun ~classe ?pos ~name ~parent_tree ?insert_evbox ?listprop w -> failwith "new_tiwidget")
+
+
+let widget_map = Hashtbl.create 17
+
+(* list of names of radio_buttons (for groups) *)
+let radio_button_pool = ref []
+
+
+(************* window creation class *************)
+(* an instance of this class is created for each window opened
+ in radtest. It contains the tree window and the gtk window (tiwin) *)
+
+class window_and_tree ~name =
+ let tree_window = GWindow.window ~show:true ~title:(name ^ "-Tree") () in
+ let vbox = GPack.vbox ~spacing:2 ~packing:tree_window#add () in
+ let root_tree = GTree2.tree ~packing:vbox#pack ~selection_mode:`EXTENDED () in
+ let project_tree_item = GTree2.tree_item () in
+ let label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5
+ ~packing:project_tree_item#add () in
+
+ object(self)
+
+ inherit window_and_tree0
+
+(* the params of the window class; because the class clist needs a param
+ I suppose there will be no more than 26 clists in a single window *)
+ val param_list = Array.create 26 false
+
+ method add_param =
+ let i = ref 0 in
+ while param_list.(!i) do incr i done;
+ param_list.(!i) <- true;
+ char_of_int (97 + !i)
+
+ method remove_param c =
+ param_list.(int_of_char c - 97) <- false
+
+ method private param_list =
+ let r = ref [] in
+ for i = 25 downto 0 do
+ if Array.unsafe_get param_list i then r := (char_of_int (i+97)) :: !r
+ done;
+ !r
+
+(* I use magic here because the real initialization is done
+ below in the initializer part. It can't be done here because
+ of the call to self *)
+ val mutable tiwin = (Obj.magic 0 : tiwidget0)
+
+ method tiwin = tiwin
+ method tree_window = tree_window
+
+ method project_tree_item = project_tree_item
+
+(* the selected item in this window *)
+ val mutable selected = (None : tiwidget0 option)
+
+(* what to do when a new item is selected.
+ this method is passed to all the tiwidgets (by the select_fun
+ parameter) and they will call it when they are clicked on;
+ she is also called when changing the selection the arrow keys
+ (see in the initializer part) *)
+ method change_selected sel =
+ match selected with
+ | None ->
+ selected <- Some sel;
+ sel#tree_item#misc#set_state `SELECTED;
+ sel#base#misc#set_state `SELECTED;
+ Propwin.show sel
+ | Some old_sel ->
+ if sel = old_sel then begin
+ selected <- None;
+ sel#base#misc#set_state `NORMAL;
+ sel#tree_item#misc#set_state `NORMAL
+ end else begin
+ old_sel#tree_item#misc#set_state `NORMAL;
+ old_sel#base#misc#set_state `NORMAL;
+ selected <- Some sel;
+ sel#tree_item#misc#set_state `SELECTED;
+ sel#base#misc#set_state `SELECTED;
+ Propwin.show sel
+ end
+
+(* the tiwidget tiw is being removed; if it was selected,
+ put the selection to None *)
+ method remove_sel tiw =
+ match selected with
+ | Some sel when sel = tiw -> selected <- None
+ | _ -> ()
+
+(* emits the code corresponding to this window *)
+ method emit c = tiwin#emit_code c self#param_list;
+
+ method delete () =
+ tiwin#remove_me_without_undo ();
+ tree_window#destroy ();
+
+ initializer
+ tiwin <- !new_tiwidget ~classe:"window" ~name ~parent_tree:root_tree
+ (self : #window_and_tree0 :> window_and_tree0);
+
+ tiwin#connect#name_changed ~callback:
+ (fun n -> label#set_text n; tree_window#set_title (n ^ "-Tree"));
+
+ Propwin.show tiwin;
+
+ tree_window#event#connect#key_press ~callback:
+ begin fun ev ->
+ let state = GdkEvent.Key.state ev in
+ let keyval = GdkEvent.Key.keyval ev in
+ if keyval = GdkKeysyms._Up then begin
+ match selected with
+ | None -> ()
+ | Some t ->
+ if List.mem `CONTROL state then t#up ()
+ else try
+ self#change_selected t#prev
+ with Not_found -> ()
+ end
+ else if keyval = GdkKeysyms._Down then begin
+ match selected with
+ | None -> ()
+ | Some t ->
+ if List.mem `CONTROL state then t#down ()
+ else try
+ self#change_selected t#next
+ with Not_found -> ()
+ end;
+ GtkSignal.stop_emit ();
+ true
+ end;
+ ()
+ end
+
+
+
+(***************** class implementation *****************)
+(* this is the base class of the ti<gtkwidget> hierarchy.
+ all these classes will inherit from tiwidget, but without
+ adding new methods. In this way all the classes have the
+ same interface and we can use them in lists, pass them to
+ functions without caring on the type.
+ All methods needed by any of the classes are defined in
+ tiwidget but if a method is not pertinent in tiwidget
+ it has for implementation:
+ failwith "<name of the method>"
+ the real implementation of the method is done in the
+ class (or classes) in which it is needed (or sometimes
+ in tiwidget anyway).
+ Additionally, to workaround some problem with recursive types
+ the type of the (public) methods of tiwidget is defined in
+ tiwidget0 of which tiwidget inherits.
+ The parent_tree parameter is the tree in which the
+ tiwidget#tree_item will be inserted at position :pos.
+*)
+
+class virtual tiwidget ~name ~parent_tree:(parent_tree : GTree2.tree) ~pos
+ ~widget ?(insert_evbox=true) (parent_window : window_and_tree0) =
+object(self)
+
+ inherit tiwidget0
+ inherit has_ml_signals
+
+ val evbox =
+ if insert_evbox then
+ let ev = GBin.event_box () in ev#add widget#coerce; Some ev
+ else None
+
+(* used only for windows delete_event *)
+ method connect_event = failwith "tiwidget::connect_event"
+
+ val widget = widget#coerce
+ method widget = widget
+
+ val mutable parent = None
+ method set_parent p = parent <- Some p
+ method parent = parent
+ method private sure_parent =
+ match parent with
+ | None -> failwith "sure_parent"
+ | Some p -> p
+
+ method base =
+ match evbox with
+ | None -> widget#coerce
+ | Some ev -> ev#coerce
+
+(* this is the name used in new_tiwidget for the creation
+ of an object of this class *)
+ val mutable classe = ""
+
+ val tree_item = GTree2.tree_item ()
+ method tree_item = tree_item
+
+ val mutable stree = GTree2.tree ()
+ method tree = stree
+
+ val label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5 ()
+
+ val mutable name : string = name
+ method name = name
+
+(* this is the complete name for the creation of the widget
+ in lablgtk e.g. GPack.vbox; used in emit_init_code *)
+ method private class_name = ""
+
+ val mutable proplist : (string * prop) list = []
+ method proplist = proplist
+ method private get_mandatory_props = []
+
+ method add_to_proplist plist = proplist <- proplist @ plist
+
+(* for children of a box *)
+ method change_name_in_proplist : string -> string -> unit =
+ fun _ _ -> ()
+ method set_property name value_string = try
+ (List.assoc name proplist)#set value_string
+ with Not_found -> Printf.printf "Property not_found %s, %s\n" name value_string;
+ flush stdout
+
+ method private get_property name =
+ (List.assoc name proplist)#get
+
+
+(* the proplist with some items removed e.g. the expand... in a box
+ used for saving and emitting code *)
+ method private emit_clean_proplist =
+ List.fold_left ~f:(fun l p -> List.remove_assoc p l)
+ ~init:proplist
+ ([ "name"; "expand"; "fill"; "padding" ] @ self#get_mandatory_props)
+(* method private emit_clean_proplist plist =
+ List.fold_left ~init:plist ~f:
+ (fun pl propname -> List.remove_assoc propname pl)
+ [ "name"; "expand"; "fill"; "padding" ]
+*)
+
+ method private save_clean_proplist =
+ List.fold_left ~f:(fun l p -> List.remove_assoc p l)
+ ~init:proplist ("name" :: self#get_mandatory_props)
+(* method private save_clean_proplist =
+ List.remove_assoc "name" proplist *)
+
+ val mutable children : (tiwidget0 * Gtk.Tags.pack_type) list = []
+ method children = children
+ method forall =
+ fun ~callback -> List.iter (List.map children ~f:fst) ~f:callback
+
+(* encapsulate container#add and container#remove
+ they are here because they depend on the type of the widget:
+ e.g.: gtkbin->add scrolled_window->add_with_viewport box->pack *)
+ method private add = failwith (name ^ "::add")
+ method remove = failwith (name ^ "::remove")
+
+
+(* removes self from his parent;
+ will be different for a window *)
+ method remove_me () =
+ let sref = ref "" in
+ self#save_to_string sref;
+ let pos = list_pos ~item:(self : #tiwidget0 :> tiwidget0)
+ (List.map self#sure_parent#children ~f:fst) in
+ let lexbuf = Lexing.from_string !sref in
+ let node = Load_parser.widget Load_lexer.token lexbuf in
+ add_undo (Add (self#sure_parent#name, node, pos));
+ self#remove_me_without_undo ()
+
+ method remove_me_without_undo () =
+(* it should be enough to only recursively remove the children from the
+ name_list and do the tip#remove and tip#tree#remove
+ only for self *)
+ self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
+ parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
+ match parent with
+ | None -> failwith "remove without parent"
+ | Some (tip : #tiwidget0) ->
+ tip#tree#remove tree_item;
+ tip#remove (self : #tiwidget0 :> tiwidget0);
+ name_list := list_remove !name_list ~f:(fun n -> n=name);
+ Hashtbl.remove widget_map name;
+ Propwin.remove name
+
+(* used for undo *)
+ method private remove_child_by_name name () =
+ let child = fst (List.find children
+ ~f:(fun (ch, _) -> ch#name = name)) in
+ child#remove_me ()
+
+(* for most widgets we make a child with new_tiwidget and then add it
+ to self; for toolbars we use toolbar#insert_button... *)
+ method private make_child = !new_tiwidget
+
+(* adds a child and shows his properties;
+ used when adding a child by the menu or DnD *)
+ method private add_child classe ?name ?(undo = true) ?(affich = true) ?(pos = -1) ?(listprop = []) () =
+ let name = match name with
+ | None -> make_new_name classe
+ | Some n -> n in
+ let child = self#make_child ~classe ~name ~parent_tree:stree parent_window ~pos ~listprop in
+ child#set_parent (self : #tiwidget0 :> tiwidget0);
+ self#add child ~pos;
+ if affich then Propwin.show child;
+ if undo then add_undo (Remove name);
+ child
+
+
+(* adds the subtree saved in the Node *)
+ method add_children ?(pos = -1) node =
+ let child_name = self#add_children_wo_undo node ~pos in
+ add_undo (Remove child_name)
+
+ method add_children_wo_undo ?(pos = -1) (Node (child, children)) =
+ let classe, name, property_list = child in
+ let rname = change_name name in
+ let tc = self#add_child classe ~name:rname ~undo:false ~affich:false ~pos ~listprop:property_list () in
+ List.iter (List.rev children)
+ ~f:(fun c -> tc#add_children_wo_undo c; ());
+ List.iter property_list ~f:(fun (n,v) -> tc#set_property n v);
+ rname
+
+(* only a tiwindow can emit code *)
+ method emit_code = failwith "emit_code"
+
+(* some methods for emitting code *)
+(* this one calculates the expand, fill and padding parameters
+ of a box child *)
+ method private get_packing packing =
+ let aux name =
+ let prop = List.assoc name proplist in
+ if prop#modified then " ~" ^ name ^ ":" ^ prop#code else ""
+ in
+ let efp = try
+ (aux "expand") ^ (aux "fill") ^ (aux "padding")
+ with Not_found -> "" in
+ if efp = "" then ("~packing:" ^ packing)
+ else ("~packing:(" ^ packing ^ efp ^ ")")
+
+(* this one emits the declaration code of the widget *)
+ method emit_init_code formatter ~packing =
+ Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s"
+ name self#class_name;
+ List.iter self#get_mandatory_props
+ ~f:begin fun name ->
+ Format.fprintf formatter "@ ~%s:%s" name
+ (List.assoc name proplist)#code
+ end;
+ let packing = self#get_packing packing in
+ if packing <> "" then Format.fprintf formatter "@ %s" packing;
+ self#emit_prop_code formatter;
+ Format.fprintf formatter "@ ()@ in@]@]"
+
+(* this one emits the properties which do not have their
+ default value; used by emit_init_code *)
+ method private emit_prop_code formatter =
+ let mandatory = self#get_mandatory_props in
+ List.iter self#emit_clean_proplist ~f:
+ begin fun (name, prop) ->
+ if List.mem name mandatory then () else
+ if prop#modified then
+ Format.fprintf formatter "@ ~%s:%s" prop#name prop#code
+ end
+
+(* this one emits the method returning this widget *)
+ method emit_method_code formatter =
+ Format.fprintf formatter "@ method %s = %s" name name;
+
+(* emits the code in the initializer part for this widget *)
+ method emit_initializer_code _ = ()
+
+(* for saving the project to a file. Used also by copy and cut *)
+ method private save_start formatter =
+ Format.fprintf formatter "@\n@[<2><%s name=%s>" classe name;
+ List.iter
+ ~f:(fun p -> Format.fprintf formatter
+ "@\n%s=\"%s\"" p (List.assoc p proplist)#get)
+ self#get_mandatory_props
+
+
+ method private save_end formatter =
+ Format.fprintf formatter "@]@\n</%s>" classe
+
+ method save formatter =
+ self#save_start formatter;
+ List.iter self#save_clean_proplist ~f:
+ (fun (name, prop) ->
+ if prop#modified then
+ Format.fprintf formatter "@\n%s=%s" name prop#save_code);
+ self#forall ~callback:(fun w -> w#save formatter);
+ self#save_end formatter
+
+
+ method private save_to_string string_ref =
+ let b = Buffer.create 80 in
+ let f = Format.formatter_of_buffer b in
+ self#save f;
+ Format.pp_print_flush f ();
+ string_ref := Buffer.contents b
+
+ method private copy_to_sel selection = self#save_to_string selection
+
+ method copy () = self#copy_to_sel selection
+
+ method private cut () =
+ self#copy ();
+ self#remove_me ()
+
+ method private paste () =
+ let lexbuf = Lexing.from_string !selection in
+ let node = Load_parser.widget Load_lexer.token lexbuf in
+ self#add_children node
+
+
+(* ML signal used when the name of the widget is changed *)
+ val name_changed : string signal = new signal
+ method connect = new tiwidget_signals ~signals:name_changed
+ method private call_name_changed = name_changed#call
+
+
+(* this is necessary because gtk_tree#remove deletes the tree
+ when removing the last item *)
+(* suppressed this in gtktree2
+ method new_tree () =
+ stree <- GTree2.tree;
+ tree_item#set_subtree stree;
+ tree_item#expand ()
+*)
+
+(* when full_menu is true we use the menu else the restricted menu *)
+ val mutable full_menu = true
+ method set_full_menu b = full_menu <- b
+
+(* the menu for this widget
+ This menu is recalculated when one clicks on the 3rd button.
+ There is nothing to do e.g. when the name of the widget changes,
+ it will change in the menu the next time. *)
+ method private menu ~time = self#restricted_menu ~time
+
+(* the restricted menu for this widget
+ used for containers when they are full *)
+ method private restricted_menu ~time =
+ let menu = GMenu.menu () in
+ let mi_remove = GMenu.menu_item ~packing:menu#append ~label:"remove" ()
+ and mi_cut = GMenu.menu_item ~packing:menu#append ~label:"Cut" ()
+ and mi_copy = GMenu.menu_item ~packing:menu#append ~label:"Copy" () in
+ mi_remove#connect#activate ~callback:self#remove_me;
+ mi_copy#connect#activate ~callback:self#copy;
+ mi_cut#connect#activate ~callback:self#cut;
+ menu#popup ~button:3 ~time
+
+(* changes all that depends on the name *)
+ method private set_new_name new_name =
+ if test_unique new_name then begin
+ Hashtbl.remove widget_map name;
+ Hashtbl.add widget_map ~key:new_name
+ ~data:(self : #tiwidget0 :> tiwidget0);
+ if (classe = "radio_button") then begin
+ radio_button_pool := new_name ::
+ (list_remove !radio_button_pool ~f:(fun x -> x = name));
+ List.iter
+ ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) false)
+ !radio_button_pool
+ end;
+ label#set_text new_name;
+ let old_name = name in
+ name <- new_name;
+(* Propwin.change_name old_name new_name; *)
+ name_list :=
+ new_name :: (list_remove !name_list ~f:(fun n -> n=old_name));
+ begin match self#parent with
+ | None -> ()
+ | Some p -> p#change_name_in_proplist old_name new_name
+ end;
+ self#call_name_changed new_name;
+ true
+ end
+ else begin
+ message_name ();
+ Propwin.update self true;
+ false
+ end
+
+
+(* moves the present tiw up in his parents' children list *)
+(* does something only when the parent is a box *)
+ method child_up = fun _ -> ()
+
+ method up () = match parent with
+ | None -> ()
+ | Some t -> t#child_up (self : #tiwidget0 :> tiwidget0)
+
+ method child_down = fun _ -> ()
+
+ method down () = match parent with
+ | None -> ()
+ | Some t -> t#child_down (self : #tiwidget0 :> tiwidget0)
+
+
+(* get the next tiwidget in the tree (used with Down arrow) *)
+ method next =
+ if children <> [] then fst (List.hd children)
+ else begin
+ match parent with
+ | None -> raise Not_found
+ | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
+ end
+
+ method next_child child =
+ let _, tl = cut_list ~item:child (List.map ~f:fst children) in
+ match tl with
+ | ch :: next :: _ -> next
+ | ch :: [] -> begin
+ match parent with
+ | None -> raise Not_found
+ | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
+ end
+ | _ -> failwith "next_child"
+
+(* get the last child of the last child ... of our last child.
+ Used by prev. *)
+ method last =
+ if children = [] then (self : #tiwidget0 :> tiwidget0)
+ else (fst (List.hd (List.rev children)))#last
+
+(* get the previous tiwidget in the tree (used with Up arrow) *)
+ method prev =
+ match parent with
+ | None -> raise Not_found
+ | Some p ->
+ let hd, _ = cut_list ~item:(self : #tiwidget0 :> tiwidget0)
+ (List.map ~f:fst p#children) in
+ match hd with
+ | [] -> p
+ | h :: _ -> h#last
+
+ initializer
+ Hashtbl.add widget_map ~key:name ~data:(self : #tiwidget0 :> tiwidget0);
+ name_list := name :: !name_list;
+ parent_tree#insert tree_item ~pos;
+ tree_item#set_subtree stree;
+ tree_item#add label#coerce;
+ tree_item#expand ();
+
+ proplist <- proplist @
+ [ "name",
+ new prop_string ~name:"name" ~init:name ~set:self#set_new_name;
+ "width", new prop_int ~name:"width" ~init:"-2"
+ ~set:(fun v -> widget#misc#set_geometry ~width:v (); true);
+ "height", new prop_int ~name:"height" ~init:"-2"
+ ~set:(fun v -> widget#misc#set_geometry ~height:v (); true) ];
+
+ self#add_signal name_changed;
+
+ tree_item#event#connect#button_press ~callback:
+ (fun ev -> match GdkEvent.get_type ev with
+ | `BUTTON_PRESS ->
+ if GdkEvent.Button.button ev = 1 then begin
+ parent_window#change_selected
+ (self : #tiwidget0 :> tiwidget0);
+ end
+ else if GdkEvent.Button.button ev = 3 then begin
+ if full_menu
+ then self#menu ~time:(GdkEvent.Button.time ev)
+ else self#restricted_menu ~time:(GdkEvent.Button.time ev);
+ end;
+ GtkSignal.stop_emit ();
+ true
+ | _ -> false);
+ ()
+end
+
projects / helm.git / blobdiff