+++ /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