From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- ide/utils/config_file.ml | 2 - ide/utils/configwin.ml | 4 +- ide/utils/configwin.mli | 8 +- ide/utils/configwin_ihm.ml | 460 +++++++++++++++++++++++----------------- ide/utils/configwin_messages.ml | 2 +- ide/utils/configwin_types.ml | 4 +- 6 files changed, 272 insertions(+), 208 deletions(-) (limited to 'ide/utils') diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml index d972639f..921d3d9c 100644 --- a/ide/utils/config_file.ml +++ b/ide/utils/config_file.ml @@ -23,8 +23,6 @@ (* *) (*********************************************************************************) -(* $Id: config_file.ml 10348 2007-12-06 17:36:14Z aspiwack $ *) - (* TODO *) (* section comments *) (* better obsoletes: no "{}", line cuts *) diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index 05bf54eb..3ff60799 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -27,8 +27,8 @@ type parameter_kind = Configwin_types.parameter_kind type configuration_structure = Configwin_types.configuration_structure = - Section of string * parameter_kind list - | Section_list of string * configuration_structure list + Section of string * GtkStock.id option * parameter_kind list + | Section_list of string * GtkStock.id option * configuration_structure list type return_button = Configwin_types.return_button = diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index bbfb7a04..c5fbf39a 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -32,10 +32,10 @@ type parameter_kind;; (** This type represents the structure of the configuration window. *) type configuration_structure = - | Section of string * parameter_kind list - (** label of the section, parameters *) - | Section_list of string * configuration_structure list - (** label of the section, list of the sub sections *) + | Section of string * GtkStock.id option * parameter_kind list + (** label of the section, icon, parameters *) + | Section_list of string * GtkStock.id option * configuration_structure list + (** label of the section, icon, list of the sub sections *) ;; (** To indicate what button pushed the user when the window is closed. *) diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index 3833acfa..9ddc90ef 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -29,6 +29,12 @@ open Configwin_types module O = Config_file +class type widget = + object + method box : GObj.widget + method apply : unit -> unit + end + let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" let debug = false @@ -320,17 +326,17 @@ class ['a] list_selection_box in let _ = dbg "list_selection_box: connecting wb_add" in (* connect the functions to the buttons *) - ignore (wb_add#connect#clicked f_add); + ignore (wb_add#connect#clicked ~callback:f_add); let _ = dbg "list_selection_box: connecting wb_remove" in - ignore (wb_remove#connect#clicked f_remove); + ignore (wb_remove#connect#clicked ~callback:f_remove); let _ = dbg "list_selection_box: connecting wb_up" in - ignore (wb_up#connect#clicked (fun () -> self#up_selected)); + ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected)); ( match f_edit_opt with None -> () | Some f -> let _ = dbg "list_selection_box: connecting wb_edit" in - ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f)) + ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f)) ); (* connect the selection and deselection of items in the clist *) let f_select ~row ~column ~event = @@ -350,9 +356,9 @@ class ['a] list_selection_box in (* connect the select and deselect events *) let _ = dbg "list_selection_box: connecting select_row" in - ignore(wlist#connect#select_row f_select); + ignore(wlist#connect#select_row ~callback:f_select); let _ = dbg "list_selection_box: connecting unselect_row" in - ignore(wlist#connect#unselect_row f_unselect); + ignore(wlist#connect#unselect_row ~callback:f_unselect); (* initialize the clist with the listref *) self#update !listref @@ -393,38 +399,50 @@ class string_param_box param (tt:GData.tooltips) = (** This class is used to build a box for a combo parameter.*) class combo_param_box param (tt:GData.tooltips) = - let _ = dbg "combo_param_box" in - let hbox = GPack.hbox () in - let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in - let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in - let wc = GEdit.combo - ~popdown_strings: param.combo_choices - ~value_in_list: (not param.combo_new_allowed) - (* ~allow_empty: param.combo_blank_allowed *) - ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) - () - in - let _ = - match param.combo_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in - let _ = wc#entry#set_editable param.combo_editable in - let _ = wc#entry#set_text param.combo_value in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce + let _ = dbg "combo_param_box" in + let hbox = GPack.hbox () in + let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in + let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in + let _ = + match param.combo_help with + None -> () + | Some help -> + tt#set_tip ~text: help ~privat: help wev#coerce + in + let get_value = if not param.combo_new_allowed then + let wc = GEdit.combo_box_text + ~strings: param.combo_choices + ?active:(let rec aux i = function + |[] -> None + |h::_ when h = param.combo_value -> Some i + |_::t -> aux (succ i) t + in aux 0 param.combo_choices) + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () + in + fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s + else + let (wc,_) = GEdit.combo_box_entry_text + ~strings: param.combo_choices + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () + in + let _ = wc#entry#set_editable param.combo_editable in + let _ = wc#entry#set_text param.combo_value in + fun () -> wc#entry#text + in +object (self) + (** This method returns the main box ready to be packed. *) + method box = hbox#coerce (** This method applies the new value of the parameter. *) - method apply = - let new_value = wc#entry#text in + method apply = + let new_value = get_value () in if new_value <> param.combo_value then let _ = param.combo_f_apply new_value in - param.combo_value <- new_value + param.combo_value <- new_value else () - end ;; +end ;; (** Class used to pack a custom box. *) class custom_param_box param (tt:GData.tooltips) = @@ -488,9 +506,9 @@ class color_param_box param (tt:GData.tooltips) = in let wb_ok = dialog#ok_button in let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy GMain.Main.quit in + let _ = dialog#connect#destroy ~callback:GMain.Main.quit in let _ = wb_ok#connect#clicked - (fun () -> + ~callback:(fun () -> (* let color = dialog#colorsel#color in let r = (Gdk.Color.red color) in let g = (Gdk.Color.green color)in @@ -505,11 +523,11 @@ class color_param_box param (tt:GData.tooltips) = dialog#destroy () ) in - let _ = wb_cancel#connect#clicked dialog#destroy in + let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in GMain.Main.main () in let _ = - if param.color_editable then ignore (wb#connect#clicked f_sel) + if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel) in object (self) @@ -525,7 +543,7 @@ class color_param_box param (tt:GData.tooltips) = () initializer - ignore (we#connect#changed (fun () -> set_color we#text)); + ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); end ;; @@ -573,19 +591,19 @@ class font_param_box param (tt:GData.tooltips) = dialog#selection#set_font_name !v; let wb_ok = dialog#ok_button in let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy GMain.Main.quit in + let _ = dialog#connect#destroy ~callback:GMain.Main.quit in let _ = wb_ok#connect#clicked - (fun () -> + ~callback:(fun () -> let font = dialog#selection#font_name in we#set_text font ; set_entry_font (Some font); dialog#destroy () ) in - let _ = wb_cancel#connect#clicked dialog#destroy in + let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in GMain.Main.main () in - let _ = if param.font_editable then ignore (wb#connect#clicked f_sel) in + let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) in object (self) (** This method returns the main box ready to be packed. *) @@ -730,7 +748,7 @@ class filename_param_box param (tt:GData.tooltips) = in let _ = if param.string_editable then - let _ = wb#connect#clicked f_click in + let _ = wb#connect#clicked ~callback:f_click in () else () @@ -782,7 +800,7 @@ class hotkey_param_box param (tt:GData.tooltips) = in let _ = if param.hk_editable then - ignore (we#event#connect#key_press capture) + ignore (we#event#connect#key_press ~callback:capture) else () in @@ -811,7 +829,7 @@ class modifiers_param_box param = ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled - (fun _ -> if but#active then value := modifier::!value + ~callback:(fun _ -> if but#active then value := modifier::!value else value := List.filter ((<>) modifier) !value))) param.md_allow in @@ -867,7 +885,7 @@ class date_param_box param (tt:GData.tooltips) = in let _ = if param.date_editable then - let _ = wb#connect#clicked f_click in + let _ = wb#connect#clicked ~callback:f_click in () else () @@ -910,106 +928,179 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = param.list_value <- !listref end ;; -(** This class is used to build a box from a configuration structure - and adds the page to the given notebook. *) -class configuration_box (tt:GData.tooltips) conf_struct (notebook : GPack.notebook) = - (* we build different widgets, according to the conf_struct parameter *) - let main_box = GPack.vbox () in - let (label, child_boxes) = +(** This class creates a configuration box from a configuration structure *) +class configuration_box (tt : GData.tooltips) conf_struct = + + let main_box = GPack.hbox () in + + let columns = new GTree.column_list in + let icon_col = columns#add GtkStock.conv in + let label_col = columns#add Gobject.Data.string in + let box_col = columns#add Gobject.Data.caml in + let () = columns#lock () in + + let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in + + (* Tree view part *) + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in + let tree = GTree.tree_store columns in + let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in + let selection = view#selection in + let _ = selection#set_mode `SINGLE in + + let menu_box = GPack.vbox ~packing:pane#pack2 () in + + let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in + let col = GTree.view_column ~renderer () in + let _ = view#append_column col in + + let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in + let col = GTree.view_column ~renderer () in + let _ = view#append_column col in + + let make_param (main_box : #GPack.box) = function + | String_param p -> + let box = new string_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Combo_param p -> + let box = new combo_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Text_param p -> + let box = new text_param_box p tt in + let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in + box + | Bool_param p -> + let box = new bool_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Filename_param p -> + let box = new filename_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | List_param f -> + let box = f tt in + let _ = main_box#pack ~expand: true ~padding: 2 box#box in + box + | Custom_param p -> + let box = new custom_param_box p tt in + let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in + box + | Color_param p -> + let box = new color_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Font_param p -> + let box = new font_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Date_param p -> + let box = new date_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Hotkey_param p -> + let box = new hotkey_param_box p tt in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Modifiers_param p -> + let box = new modifiers_param_box p in + let _ = main_box#pack ~expand: false ~padding: 2 box#box in + box + | Html_param p -> + let box = new html_param_box p tt in + let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in + box + in + + let set_icon iter = function + | None -> () + | Some icon -> tree#set iter icon_col icon + in + + (* Populate the tree *) + + let rec make_tree iter conf_struct = + (* box is not shown at first *) + let box = GPack.vbox ~packing:menu_box#add ~show:false () in + let new_iter = match iter with + | None -> tree#append () + | Some parent -> tree#append ~parent () + in match conf_struct with - Section (label, param_list) -> - let f parameter = - match parameter with - String_param p -> - let box = new string_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Combo_param p -> - let box = new combo_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Text_param p -> - let box = new text_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - | Bool_param p -> - let box = new bool_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | List_param f -> - let box = f tt in - let _ = main_box#pack ~expand: true ~padding: 2 box#box in - box - | Custom_param p -> - let box = new custom_param_box p tt in - let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in - box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Modifiers_param p -> - let box = new modifiers_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - in - let list_children_boxes = List.map f param_list in - - (label, list_children_boxes) - - | Section_list (label, struct_list) -> - let wnote = GPack.notebook - (*homogeneous_tabs: true*) - ~scrollable: true - ~show_tabs: true - ~tab_border: 3 - ~packing: (main_box#pack ~expand: true) - () - in - (* we create all the children boxes *) - let f structure = - let new_box = new configuration_box tt structure wnote in - new_box - in - let list_child_boxes = List.map f struct_list in - (label, list_child_boxes) + | Section (label, icon, param_list) -> + let params = List.map (make_param box) param_list in + let widget = + object + method box = box#coerce + method apply () = List.iter (fun param -> param#apply) params + end + in + let () = tree#set new_iter label_col label in + let () = set_icon new_iter icon in + let () = tree#set new_iter box_col widget in + () + | Section_list (label, icon, struct_list) -> + let widget = + object + (* Section_list does not contain any effect widget, so we do not have to + apply anything. *) + method apply () = () + method box = box#coerce + end + in + let () = tree#set new_iter label_col label in + let () = set_icon new_iter icon in + let () = tree#set new_iter box_col widget in + List.iter (make_tree (Some new_iter)) struct_list + in + + let () = List.iter (make_tree None) conf_struct in + + (* Dealing with signals *) + + let current_prop : widget option ref = ref None in + + let select_iter iter = + let () = match !current_prop with + | None -> () + | Some box -> box#box#misc#hide () + in + let box = tree#get ~row:iter ~column:box_col in + let () = box#box#misc#show () in + current_prop := Some box + in + let when_selected () = + let rows = selection#get_selected_rows in + match rows with + | [] -> () + | row :: _ -> + let iter = tree#get_iter row in + select_iter iter in - let page_label = GMisc.label ~text: label () in - let _ = notebook#append_page - ~tab_label: page_label#coerce - main_box#coerce + + (* Focus on a box when selected *) + + let _ = selection#connect#changed ~callback:when_selected in + + let _ = match tree#get_iter_first with + | None -> () + | Some iter -> select_iter iter in - object (self) - (** This method returns the main box ready to be packed. *) - method box = main_box#coerce - (** This method make the new values of the paramters applied, recursively in - all boxes.*) + object + + method box = main_box + method apply = - List.iter (fun box -> box#apply) child_boxes + let foreach _ iter = + let widget = tree#get ~row:iter ~column:box_col in + widget#apply(); false + in + tree#foreach foreach + end -;; (** Create a vbox with the list of given configuration structure list, and the given list of buttons (defined by their label and callback). @@ -1017,24 +1108,12 @@ class configuration_box (tt:GData.tooltips) conf_struct (notebook : GPack.notebo of each parameter is called. *) let tabbed_box conf_struct_list buttons tooltips = - let vbox = GPack.vbox () in - let wnote = GPack.notebook - (*homogeneous_tabs: true*) - ~scrollable: true - ~show_tabs: true - ~tab_border: 3 - ~packing: (vbox#pack ~expand: true) - () + let param_box = + new configuration_box tooltips conf_struct_list in - let list_param_box = - List.map - (fun conf_struct -> new configuration_box tooltips conf_struct wnote) - conf_struct_list + let f_apply () = param_box#apply in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box ; - in - let hbox_buttons = GPack.hbox ~packing: (vbox#pack ~expand: false ~padding: 4) () in + let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in let rec iter_buttons ?(grab=false) = function [] -> () @@ -1051,14 +1130,14 @@ let tabbed_box conf_struct_list buttons tooltips = in iter_buttons ~grab: true buttons; - vbox + param_box#box (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) ?(apply=(fun () -> ())) title ?(width=400) ?(height=400) - conf_struct_list = + conf_struct = let dialog = GWindow.dialog ~position:`CENTER ~modal: true ~title: title @@ -1066,47 +1145,34 @@ let edit ?(with_apply=true) () in let tooltips = GData.tooltips () in - let wnote = GPack.notebook - (*homogeneous_tabs: true*) - ~scrollable: true - ~show_tabs: true - ~tab_border: 3 - ~packing: (dialog#vbox#pack ~expand: true) - () - in - let list_param_box = - List.map - (fun conf_struct -> new configuration_box tooltips conf_struct wnote) - conf_struct_list - in - if with_apply then - dialog#add_button Configwin_messages.mApply `APPLY; + let config_box = new configuration_box tooltips conf_struct in - dialog#add_button Configwin_messages.mOk `OK; - dialog#add_button Configwin_messages.mCancel `CANCEL; + let _ = dialog#vbox#add config_box#box#coerce in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box ; - apply () - in - let destroy () = - tooltips#destroy () ; - dialog#destroy (); - in - let rec iter rep = - try - match dialog#run () with - | `APPLY -> f_apply (); iter Return_apply - | `OK -> f_apply (); destroy (); Return_ok - | _ -> destroy (); rep - with - Failure s -> - GToolbox.message_box "Error" s; iter rep - | e -> - GToolbox.message_box "Error" (Printexc.to_string e); iter rep - in - iter Return_cancel + if with_apply then + dialog#add_button Configwin_messages.mApply `APPLY; + + dialog#add_button Configwin_messages.mOk `OK; + dialog#add_button Configwin_messages.mCancel `CANCEL; + + let destroy () = + tooltips#destroy () ; + dialog#destroy (); + in + let rec iter rep = + try + match dialog#run () with + | `APPLY -> config_box#apply; iter Return_apply + | `OK -> config_box#apply; destroy (); Return_ok + | _ -> destroy (); rep + with + Failure s -> + GToolbox.message_box ~title:"Error" s; iter rep + | e -> + GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep + in + iter Return_cancel (** Create a vbox with the list of given parameters. *) let box param_list tt = @@ -1205,9 +1271,9 @@ let simple_edit ?(with_apply=true) | _ -> destroy (); rep with Failure s -> - GToolbox.message_box "Error" s; iter rep + GToolbox.message_box ~title:"Error" s; iter rep | e -> - GToolbox.message_box "Error" (Printexc.to_string e); iter rep + GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep in iter Return_cancel diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml index 26f5b61b..de292431 100644 --- a/ide/utils/configwin_messages.ml +++ b/ide/utils/configwin_messages.ml @@ -30,7 +30,7 @@ let version = "1.2";; let html_config = "Configwin bindings configurator for html parameters" -let home = System.home +let home = Minilib.home let mCapture = "Capture";; let mType_key = "Type key" ;; diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml index 90d5756b..5e2b1e7c 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.ml @@ -263,8 +263,8 @@ type parameter_kind = (** This type represents the structure of the configuration window. *) type configuration_structure = - | Section of string * parameter_kind list (** label of the section, parameters *) - | Section_list of string * configuration_structure list (** label of the section, list of the sub sections *) + | Section of string * GtkStock.id option * parameter_kind list (** label of the section, icon, parameters *) + | Section_list of string * GtkStock.id option * configuration_structure list (** label of the section, list of the sub sections *) ;; (** To indicate what button was pushed by the user when the window is closed. *) -- cgit v1.2.3