diff options
author | Samuel Mimram <smimram@debian.org> | 2006-04-28 14:59:16 +0000 |
---|---|---|
committer | Samuel Mimram <smimram@debian.org> | 2006-04-28 14:59:16 +0000 |
commit | 3ef7797ef6fc605dfafb32523261fe1b023aeecb (patch) | |
tree | ad89c6bb57ceee608fcba2bb3435b74e0f57919e /ide/utils/configwin_ihm.ml | |
parent | 018ee3b0c2be79eb81b1f65c3f3fa142d24129c8 (diff) |
Imported Upstream version 8.0pl3+8.1alphaupstream/8.0pl3+8.1alpha
Diffstat (limited to 'ide/utils/configwin_ihm.ml')
-rw-r--r-- | ide/utils/configwin_ihm.ml | 846 |
1 files changed, 444 insertions, 402 deletions
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index 03ca706c..e9ba9789 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -1,68 +1,73 @@ -(**************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation; either version 2 of the License, or *) -(* any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(**************************************************************************) - -(** This module contains the gui functions of Confgiwin.*) +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +(** This module contains the gui functions of Configwin.*) open Configwin_types -module O = Uoptions +module O = Config_file - -(** The file where the html config is. *) let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" - -(** Return the ini file for the html config, and the option for bindings. *) + +let debug = false +let dbg = if debug then prerr_endline else (fun _ -> ()) + +(** Return the config group for the html config file, + and the option for bindings. *) let html_config_file_and_option () = - let ini = O.create_options_file file_html_config in - let bindings = O.define_option ini ["bindings"] - "" - (O.list_option Configwin_types.Html_binding.t) - [ { html_key = KeyOption.string_to_key "A-b" ; + let ini = new O.group in + let bindings = new O.list_cp + Configwin_types.htmlbinding_cp_wrapper + ~group: ini + ["bindings"] + ~short_name: "bd" + [ { html_key = Configwin_types.string_to_key "A-b" ; html_begin = "<b>"; html_end = "</b>" ; } ; - { html_key = KeyOption.string_to_key "A-i" ; + { html_key = Configwin_types.string_to_key "A-i" ; html_begin = "<i>"; html_end = "</i>" ; - } - ] + } + ] + "" in - O.load ini ; + ini#read file_html_config ; (ini, bindings) - (** This variable contains the last directory where the user selected a file.*) let last_dir = ref "";; (** This function allows the user to select a file and returns the - selected file name. An optional function allows to change the + selected file name. An optional function allows to change the behaviour of the ok button. A VOIR : mutli-selection ? *) let select_files ?dir ?(fok : (string -> unit) option) the_title = - let files = ref ([] : string list) in + let files = ref ([] : string list) in let fs = GWindow.file_selection ~modal:true ~title: the_title () in (* we set the previous directory, if no directory is given *) @@ -78,7 +83,7 @@ let select_files ?dir let _ = fs#set_filename !last_dir in () ); - + let _ = fs # connect#destroy ~callback: GMain.Main.quit in let _ = fs # ok_button # connect#clicked ~callback: (match fok with @@ -134,52 +139,55 @@ let select_date title (day,mon,year) = one to add items and one to remove the selected items. The class takes in parameter a function used to add items and a string list ref which is used to store the content of the clist. - At last, a title for the frame is also in parameter, so that + At last, a title for the frame is also in parameter, so that each instance of the class creates a frame. *) -class ['a] list_selection_box (listref : 'a list ref) +class ['a] list_selection_box + (listref : 'a list ref) titles_opt help_opt f_edit_opt f_strings f_color (eq : 'a -> 'a -> bool) - add_function title editable = + add_function title editable + (tt:GData.tooltips) + = + let _ = dbg "list_selection_box" in let wev = GBin.event_box () in let wf = GBin.frame ~label: title ~packing: wev#add () in let hbox = GPack.hbox ~packing: wf#add () in (* the scroll window and the clist *) let wscroll = GBin.scrolled_window - ~vpolicy: `AUTOMATIC - ~hpolicy: `AUTOMATIC - ~packing: (hbox#pack ~expand: true) () + ~vpolicy: `AUTOMATIC + ~hpolicy: `AUTOMATIC + ~packing: (hbox#pack ~expand: true) () in let wlist = match titles_opt with - None -> + None -> GList.clist ~selection_mode: `MULTIPLE ~titles_show: false ~packing: wscroll#add () - | Some l -> - GList.clist ~selection_mode: `MULTIPLE + | Some l -> + GList.clist ~selection_mode: `MULTIPLE ~titles: l ~titles_show: true ~packing: wscroll#add () in - let _ = + let _ = match help_opt with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (wf#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wev#coerce in (* the vbox for the buttons *) let vbox_buttons = GPack.vbox () in - let _ = + let _ = if editable then let _ = hbox#pack ~expand: false vbox_buttons#coerce in () else - () + () in + let _ = dbg "list_selection_box: wb_add" in let wb_add = GButton.button ~label: Configwin_messages.mAdd ~packing: (vbox_buttons#pack ~expand:false ~padding:2) @@ -203,6 +211,7 @@ class ['a] list_selection_box (listref : 'a list ref) ~packing: (vbox_buttons#pack ~expand:false ~padding:2) () in + let _ = dbg "list_selection_box: object(self)" in object (self) (** the list of selected rows *) val mutable list_select = [] @@ -216,17 +225,17 @@ class ['a] list_selection_box (listref : 'a list ref) (* insert the elements in the clist *) wlist#freeze (); wlist#clear (); - List.iter - (fun ele -> + List.iter + (fun ele -> ignore (wlist#append (f_strings ele)); match f_color ele with None -> () | Some c -> try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1) with _ -> () - ) + ) !listref; - + (match titles_opt with None -> wlist#columns_autosize () | Some _ -> GToolbox.autosize_clist wlist); @@ -280,10 +289,10 @@ class ['a] list_selection_box (listref : 'a list ref) initializer (** create the functions called when the buttons are clicked *) - let f_add () = + let f_add () = (* get the files to add with the function provided *) let l = add_function () in - (* remove from the list the ones which are already in + (* remove from the list the ones which are already in the listref, using the eq predicate *) let l2 = List.fold_left (fun acc -> fun ele -> @@ -293,7 +302,7 @@ class ['a] list_selection_box (listref : 'a list ref) acc @ [ele]) !listref l - in + in self#update l2 in let f_remove () = @@ -309,14 +318,19 @@ class ['a] list_selection_box (listref : 'a list ref) let new_list = iter 0 !listref in self#update new_list in + let _ = dbg "list_selection_box: connecting wb_add" in (* connect the functions to the buttons *) ignore (wb_add#connect#clicked f_add); + let _ = dbg "list_selection_box: connecting wb_remove" in ignore (wb_remove#connect#clicked f_remove); + let _ = dbg "list_selection_box: connecting wb_up" in ignore (wb_up#connect#clicked (fun () -> self#up_selected)); ( match f_edit_opt with None -> () - | Some f -> ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f)) + | Some f -> + let _ = dbg "list_selection_box: connecting wb_edit" in + ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f)) ); (* connect the selection and deselection of items in the clist *) let f_select ~row ~column ~event = @@ -335,7 +349,9 @@ class ['a] list_selection_box (listref : 'a list ref) () in (* connect the select and deselect events *) + let _ = dbg "list_selection_box: connecting select_row" in ignore(wlist#connect#select_row f_select); + let _ = dbg "list_selection_box: connecting unselect_row" in ignore(wlist#connect#unselect_row f_unselect); (* initialize the clist with the listref *) @@ -344,7 +360,8 @@ class ['a] list_selection_box (listref : 'a list ref) (** This class is used to build a box for a string parameter.*) -class string_param_box param = +class string_param_box param (tt:GData.tooltips) = + let _ = dbg "string_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.string_label ~packing: wev#add () in @@ -353,22 +370,20 @@ class string_param_box param = ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in - let _ = + let _ = match param.string_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wev#coerce in - let _ = we#set_text param.string_value in + let _ = we#set_text (param.string_to_string param.string_value) 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 = we#text in + let new_value = param.string_of_string we#text in if new_value <> param.string_value then let _ = param.string_f_apply new_value in param.string_value <- new_value @@ -377,24 +392,23 @@ class string_param_box param = end ;; (** This class is used to build a box for a combo parameter.*) -class combo_param_box param = +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) -(* ~ok_if_empty: param.combo_blank_allowed*) + (* ~allow_empty: param.combo_blank_allowed *) ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) () in - let _ = + let _ = match param.combo_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback:tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: 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 @@ -413,8 +427,9 @@ class combo_param_box param = end ;; (** Class used to pack a custom box. *) -class custom_param_box param = - let top = +class custom_param_box param (tt:GData.tooltips) = + let _ = dbg "custom_param_box" in + let top = match param.custom_framed with None -> param.custom_box#coerce | Some l -> @@ -428,40 +443,39 @@ class custom_param_box param = end (** This class is used to build a box for a color parameter.*) -class color_param_box param = +class color_param_box param (tt:GData.tooltips) = + let _ = dbg "color_param_box" in let v = ref param.color_value in let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.color_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () + let wb = GButton.button ~label: param.color_label + ~packing: (hbox#pack ~expand: false ~padding: 2) () in - let w_test = GMisc.arrow + let w_test = GMisc.arrow ~kind: `RIGHT ~shadow: `OUT ~width: 20 ~height: 20 ~packing: (hbox#pack ~expand: false ~padding: 2 ) - () + () in let we = GEdit.entry ~editable: param.color_editable ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2) () in - let _ = + let _ = match param.color_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wb#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wb#coerce in let set_color s = let style = w_test#misc#style#copy in ( - try style#set_bg [ (`NORMAL, `NAME s) ; ] + try style#set_fg [ (`NORMAL, `NAME s) ; ] with _ -> () ); - w_test#misc#set_style style + w_test#misc#set_style style; in let _ = set_color !v in let _ = we#set_text !v in @@ -476,26 +490,25 @@ class color_param_box param = let wb_cancel = dialog#cancel_button in let _ = dialog#connect#destroy GMain.Main.quit in let _ = wb_ok#connect#clicked - (fun () -> - (* let color = dialog#colorsel#get_color in - let r = int_of_float (ceil (color.Gtk.red *. 255.)) in - let g = int_of_float (ceil (color.Gtk.green *. 255.)) in - let b = int_of_float (ceil (color.Gtk.blue *. 255.)) in - let s = Printf.sprintf "#%2X%2X%2X" r g b in - let _ = + (fun () -> +(* let color = dialog#colorsel#color in + let r = (Gdk.Color.red color) in + let g = (Gdk.Color.green color)in + let b = (Gdk.Color.blue color) in + let s = Printf.sprintf "#%4X%4X%4X" r g b in + let _ = for i = 1 to (String.length s) - 1 do if s.[i] = ' ' then s.[i] <- '0' done in - we#set_text s ; - set_color s;*) + we#set_text s ; *) dialog#destroy () ) in let _ = wb_cancel#connect#clicked dialog#destroy in GMain.Main.main () in - let _ = + let _ = if param.color_editable then ignore (wb#connect#clicked f_sel) in @@ -510,27 +523,30 @@ class color_param_box param = param.color_value <- new_value else () + + initializer + ignore (we#connect#changed (fun () -> set_color we#text)); + end ;; (** This class is used to build a box for a font parameter.*) -class font_param_box param = +class font_param_box param (tt:GData.tooltips) = + let _ = dbg "font_param_box" in let v = ref param.font_value in let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.font_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () + let wb = GButton.button ~label: param.font_label + ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: false ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) () in - let _ = + let _ = match param.font_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wb#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wb#coerce in let set_entry_font font_opt = match font_opt with @@ -538,7 +554,7 @@ class font_param_box param = | Some s -> let style = we#misc#style#copy in ( - try + try let font = Gdk.Font.load_fontset s in style#set_font font with _ -> () @@ -559,10 +575,10 @@ class font_param_box param = let wb_cancel = dialog#cancel_button in let _ = dialog#connect#destroy GMain.Main.quit in let _ = wb_ok#connect#clicked - (fun () -> - let font_opt = dialog#selection#font_name in -(* we#set_text (match font_opt with None -> "" | Some s -> s) ; - set_entry_font font_opt;*) + (fun () -> + let font = dialog#selection#font_name in + we#set_text font ; + set_entry_font (Some font); dialog#destroy () ) in @@ -585,79 +601,89 @@ class font_param_box param = end ;; (** This class is used to build a box for a text parameter.*) -class text_param_box param = - let hbox = GPack.hbox ~height: 100 () in - let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in - let wl = GMisc.label ~text: param.string_label ~packing: wev#add () in +class text_param_box param (tt:GData.tooltips) = + let _ = dbg "text_param_box" in + let wf = GBin.frame ~label: param.string_label ~height: 100 () in + let wev = GBin.event_box ~packing: wf#add () in let wscroll = GBin.scrolled_window ~vpolicy: `AUTOMATIC ~hpolicy: `AUTOMATIC - ~packing: (hbox#pack ~expand: true ~padding: 2) () + ~packing: wev#add () in - let wt = GText.view ~packing:wscroll#add () in -(* let _ = wt#coerce#misc#set_size_request ~height:100 in *) - let _ = wt#set_editable param.string_editable in - let _ = + let wview = GText.view + ~editable: param.string_editable + ~packing: wscroll#add + () + in + let _ = match param.string_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wev#coerce in - let _ = wt#buffer#insert param.string_value in + let _ = dbg "text_param_box: buffer creation" in + let buffer = GText.buffer () in + let _ = wview#set_buffer buffer in + let _ = buffer#insert (param.string_to_string param.string_value) in + let _ = dbg "text_param_box: object(self)" in object (self) - val wt = wt + val wview = wview (** This method returns the main box ready to be packed. *) - method box = hbox#coerce + method box = wf#coerce (** This method applies the new value of the parameter. *) method apply = - let new_value = wt#buffer#get_text () in - if new_value <> param.string_value then - let _ = param.string_f_apply new_value in - param.string_value <- new_value + let v = param.string_of_string (buffer#get_text ()) in + if v <> param.string_value then + ( + dbg "apply new value !"; + let _ = param.string_f_apply v in + param.string_value <- v + ) else () end ;; (** This class is used to build a box a html parameter. *) -class html_param_box param = +class html_param_box param (tt:GData.tooltips) = + let _ = dbg "html_param_box" in object (self) - inherit text_param_box param + inherit text_param_box param tt method private exec html_start html_end () = - let s,e = wt#buffer#selection_bounds in - if s#compare e = 0 then - wt#buffer#insert (html_start^html_end) - else begin - ignore (wt#buffer#insert ~iter:e html_end); - ignore (wt#buffer#insert ~iter:s html_start); - wt#buffer#place_cursor - (e#forward_chars (String.length (html_start^html_end))) - end + let (i1,i2) = wview#buffer#selection_bounds in + let s = i1#get_text ~stop: i2 in + match s with + "" -> + wview#buffer#insert (html_start^html_end) + | _ -> + ignore (wview#buffer#insert ~iter: i2 html_end); + ignore (wview#buffer#insert ~iter: i1 html_start); + wview#buffer#place_cursor ~where: i2 + initializer + dbg "html_param_box:initializer"; let (_,html_bindings) = html_config_file_and_option () in + dbg "html_param_box:connecting key press events"; let add_shortcut hb = let (mods, k) = hb.html_key in - Okey.add wt ~mods k (self#exec hb.html_begin hb.html_end) + Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end) in - List.iter add_shortcut (O.(!!) html_bindings) + List.iter add_shortcut html_bindings#get; + dbg "html_param_box:end" end (** This class is used to build a box for a boolean parameter.*) -class bool_param_box param = +class bool_param_box param (tt:GData.tooltips) = + let _ = dbg "bool_param_box" in let wchk = GButton.check_button ~label: param.bool_label () in - let _ = + let _ = match param.bool_help with None -> () - | Some help -> - let tooltips = GData.tooltips () in - ignore (wchk#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wchk#coerce ~text: help ~privat: help + | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce in let _ = wchk#set_active param.bool_value in let _ = wchk#misc#set_sensitive param.bool_editable in @@ -676,25 +702,24 @@ class bool_param_box param = end ;; (** This class is used to build a box for a file name parameter.*) -class filename_param_box param = +class filename_param_box param (tt:GData.tooltips) = + let _ = dbg "filename_param_box" in let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.string_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () + let wb = GButton.button ~label: param.string_label + ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: param.string_editable ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in - let _ = + let _ = match param.string_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wb#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wb#coerce in - let _ = we#set_text param.string_value in + let _ = we#set_text (param.string_to_string param.string_value) in let f_click () = match select_files param.string_label with @@ -703,7 +728,7 @@ class filename_param_box param = | f :: _ -> we#set_text f in - let _ = + let _ = if param.string_editable then let _ = wb#connect#clicked f_click in () @@ -716,7 +741,7 @@ class filename_param_box param = method box = hbox#coerce (** This method applies the new value of the parameter. *) method apply = - let new_value = we#text in + let new_value = param.string_of_string we#text in if new_value <> param.string_value then let _ = param.string_f_apply new_value in param.string_value <- new_value @@ -725,11 +750,12 @@ class filename_param_box param = end ;; (** This class is used to build a box for a hot key parameter.*) -class hotkey_param_box param = +class hotkey_param_box param (tt:GData.tooltips) = + let _ = dbg "hotkey_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.hk_label - ~packing: wev#add () + let wl = GMisc.label ~text: param.hk_label + ~packing: wev#add () in let we = GEdit.entry ~editable: false @@ -737,15 +763,13 @@ class hotkey_param_box param = () in let value = ref param.hk_value in - let _ = + let _ = match param.hk_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wev#coerce in - let _ = we#set_text (KeyOption.key_to_string param.hk_value) in + let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in let capture ev = let key = GdkEvent.Key.keyval ev in @@ -755,10 +779,10 @@ class hotkey_param_box param = modifiers in value := (mods, key); - we#set_text (KeyOption.key_to_string !value); + we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); false in - let _ = + let _ = if param.hk_editable then ignore (we#event#connect#key_press capture) else @@ -798,7 +822,7 @@ class modifiers_param_box param = ignore (hbox#connect#destroy ~callback: tooltips#destroy); tooltips#set_tip wev#coerce ~text: help ~privat: help in - let _ = we#set_text (KeyOption.modifiers_to_string param.md_value) in + let _ = we#set_text (Configwin_types.modifiers_to_string param.md_value) in let mods_we_care = param.md_allow in let capture ev = let modifiers = GdkEvent.Key.state ev in @@ -807,7 +831,7 @@ class modifiers_param_box param = modifiers in value := mods; - we#set_text (KeyOption.modifiers_to_string !value); + we#set_text (Configwin_types.modifiers_to_string !value); false in let _ = @@ -831,35 +855,35 @@ class modifiers_param_box param = end ;; (** This class is used to build a box for a date parameter.*) -class date_param_box param = +class date_param_box param (tt:GData.tooltips) = + let _ = dbg "date_param_box" in let v = ref param.date_value in let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.date_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () + let wb = GButton.button ~label: param.date_label + ~packing: (hbox#pack ~expand: false ~padding: 2) () in let we = GEdit.entry ~editable: false ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) () in - let _ = + + let _ = match param.date_help with None -> () | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wb#coerce ~text: help ~privat: help + tt#set_tip ~text: help ~privat: help wb#coerce in - let _ = we#set_text (param.date_f_string param.date_value) in + let _ = we#set_text (param.date_f_string param.date_value) in let f_click () = match select_date param.date_label !v with None -> () - | Some (y,m,d) -> + | Some (y,m,d) -> v := (d,m,y) ; we#set_text (param.date_f_string (d,m,y)) in - let _ = + let _ = if param.date_editable then let _ = wb#connect#clicked f_click in () @@ -880,7 +904,8 @@ class date_param_box param = end ;; (** This class is used to build a box for a parameter whose values are a list.*) -class ['a] list_param_box (param : 'a list_param) = +class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = + let _ = dbg "list_param_box" in let listref = ref param.list_value in let frame_selection = new list_selection_box listref @@ -891,8 +916,9 @@ class ['a] list_param_box (param : 'a list_param) = param.list_color param.list_eq param.list_f_add param.list_label param.list_editable + tt in - + object (self) (** This method returns the main box ready to be packed. *) method box = frame_selection#box#coerce @@ -902,75 +928,75 @@ class ['a] list_param_box (param : 'a list_param) = param.list_value <- !listref end ;; -(** This class is used to build a box from a configuration structure +(** This class is used to build a box from a configuration structure and adds the page to the given notebook. *) -class configuration_box conf_struct (notebook : GPack.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) = + let (label, child_boxes) = match conf_struct with Section (label, param_list) -> let f parameter = - match parameter with - String_param p -> - let box = new string_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Combo_param p -> - let box = new combo_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Text_param p -> - let box = new text_param_box p 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 in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Filename_param p -> - let box = new filename_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | List_param f -> - let box = f () in - let _ = main_box#pack ~expand: true ~padding: 2 box#box in - box - | Custom_param p -> - let box = new custom_param_box p 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 in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p 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 in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box + 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 + let wnote = GPack.notebook (*homogeneous_tabs: true*) ~scrollable: true ~show_tabs: true @@ -980,15 +1006,15 @@ class configuration_box conf_struct (notebook : GPack.notebook) = in (* we create all the children boxes *) let f structure = - let new_box = new configuration_box structure wnote in + 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) - + in let page_label = GMisc.label ~text: label () in - let _ = notebook#append_page + let _ = notebook#append_page ~tab_label: page_label#coerce main_box#coerce in @@ -1008,9 +1034,9 @@ class configuration_box conf_struct (notebook : GPack.notebook) = Before calling the callback of a button, the [apply] function of each parameter is called. *) -let tabbed_box conf_struct_list buttons = +let tabbed_box conf_struct_list buttons tooltips = let vbox = GPack.vbox () in - let wnote = GPack.notebook + let wnote = GPack.notebook (*homogeneous_tabs: true*) ~scrollable: true ~show_tabs: true @@ -1018,18 +1044,19 @@ let tabbed_box conf_struct_list buttons = ~packing: (vbox#pack ~expand: true) () in - let list_param_box = - List.map (fun conf_struct -> new configuration_box conf_struct wnote) + let list_param_box = + List.map + (fun conf_struct -> new configuration_box tooltips conf_struct wnote) conf_struct_list in - let f_apply () = + 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 rec iter_buttons ?(grab=false) = function [] -> () - | (label, callb) :: q -> + | (label, callb) :: q -> let b = GButton.button ~label: label ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () in @@ -1046,127 +1073,110 @@ let tabbed_box conf_struct_list buttons = (** This function takes a configuration structure list and creates a window to configure the various parameters. *) -let edit ?(with_apply=true) +let edit ?(with_apply=true) ?(apply=(fun () -> ())) - title ?(width=400) ?(height=400) + title ?(width=400) ?(height=400) conf_struct_list = - let return = ref Return_cancel in - let window = GWindow.window - ~position:`CENTER - ~modal: true ~title: title - ~width: width ~height: height () - in - let _ = window#connect#destroy ~callback: GMain.Main.quit in - let vbox = GPack.vbox ~packing: window#add () in - let wnote = GPack.notebook - (*homogeneous_tabs: true*) - ~scrollable: true - ~show_tabs: true - ~tab_border: 3 - ~packing: (vbox#pack ~expand: true) - () - in - let list_param_box = - List.map (fun conf_struct -> new configuration_box conf_struct wnote) + let dialog = GWindow.dialog + ~position:`CENTER + ~modal: true ~title: title + ~height ~width + () + 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; + + dialog#add_button Configwin_messages.mOk `OK; + dialog#add_button Configwin_messages.mCancel `CANCEL; + + let f_apply () = + List.iter (fun param_box -> param_box#apply) list_param_box ; + apply () + in + let f_ok () = + List.iter (fun param_box -> param_box#apply) list_param_box ; + Return_ok + in + let destroy () = + tooltips#destroy () ; + dialog#destroy (); + in + let rec iter rep = + try + match dialog#run () with + | `APPLY -> f_apply (); iter Return_apply + | `OK -> destroy (); f_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 - let hbox_buttons = GPack.hbox ~packing: (vbox#pack ~expand: false ~padding: 4) () in - let bApply = GButton.button - ~stock:`APPLY - ~label: Configwin_messages.mApply - () - in - if with_apply then hbox_buttons#pack ~expand: true ~padding: 3 bApply#coerce; - let bOk = GButton.button - ~stock:`OK - ~label: Configwin_messages.mOk - ~packing: (hbox_buttons#pack ~expand: true ~padding: 3) - () - in - let bCancel = GButton.button - ~stock:`CANCEL - ~label: Configwin_messages.mCancel - ~packing: (hbox_buttons#pack ~expand: true ~padding: 3) - () - in - (* we connect the click on the apply button *) - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box ; - apply (); - return := Return_apply - in - let _ = bApply#connect#clicked f_apply in - (* we connect the click on the ok button : the same than apply but we then close the window *) - let f_ok () = - List.iter (fun param_box -> param_box#apply) list_param_box ; - return := Return_ok ; - window#destroy () - in - let _ = bOk#connect#clicked f_ok in - (* we connect the click on the cancel button : close the window *) - let f_cancel () = window#destroy () in - let _ = bCancel#connect#clicked f_cancel in - - let _ = window#event#connect#key_press ~callback: - (fun k -> if GdkEvent.Key.keyval k = GdkKeysyms._Escape then f_cancel ();false) - in - let _ = window#show () in - GMain.Main.main () ; - !return - - -(** Create a vbox with the list of given parameters, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -let box param_list buttons = +(** Create a vbox with the list of given parameters. *) +let box param_list tt = let main_box = GPack.vbox () in let f parameter = match parameter with String_param p -> - let box = new string_param_box p in + 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 in + 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 in + 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 in + 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 in + 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 () in + 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 in + 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 in + 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 in + 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 in + 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 in + let box = new hotkey_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Modifiers_param p -> @@ -1174,70 +1184,61 @@ let box param_list buttons = let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Html_param p -> - let box = new html_param_box p in + 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_param_box = List.map f param_list in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box + let f_apply () = + List.iter (fun param_box -> param_box#apply) list_param_box in - let hbox_buttons = GPack.hbox ~packing: (main_box#pack ~expand: false ~padding: 4) () in - let rec iter_buttons ?(grab=false) = function - [] -> - () - | (label, callb) :: q -> - let b = GButton.button ~label: label - ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () - in - ignore (b#connect#clicked ~callback: - (fun () -> f_apply (); callb ())); - (* If it's the first button then give it the focus *) - if grab then b#grab_default (); + (main_box, f_apply) - iter_buttons q +(** This function takes a list of parameter specifications and + creates a window to configure the various parameters.*) +let simple_edit ?(with_apply=true) + ?(apply=(fun () -> ())) + title ?width ?height + param_list = + let dialog = GWindow.dialog + ~modal: true ~title: title + ?height ?width + () in - iter_buttons ~grab: true buttons; + let tooltips = GData.tooltips () in + if with_apply then + dialog#add_button Configwin_messages.mApply `APPLY; - main_box + dialog#add_button Configwin_messages.mOk `OK; + dialog#add_button Configwin_messages.mCancel `CANCEL; + let (box, f_apply) = box param_list tooltips in + dialog#vbox#pack ~expand: true ~fill: true box#coerce; -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters.*) -let simple_edit ?(with_apply=true) - ?(apply=(fun () -> ())) - title ?width ?height - param_list = - let return = ref Return_cancel in - let window = GWindow.window ~modal: true ~title: title () in - let _ = match width, height with - None, None -> () - | Some w, None -> window#misc#set_size_request ~width: w () - | None, Some h -> window#misc#set_size_request ~height: h () - | Some w, Some h -> window#misc#set_size_request ~width: w ~height: h () - in - let _ = window#connect#destroy ~callback: GMain.Main.quit in - let buttons = - (if with_apply then - [Configwin_messages.mApply, fun () -> apply (); return := Return_apply] - else - [] - ) @ [ - (Configwin_messages.mOk, fun () -> return := Return_ok ; window#destroy ()) ; - (Configwin_messages.mCancel, window#destroy) ; - ] + let destroy () = + tooltips#destroy () ; + dialog#destroy (); in - let box = box param_list buttons in - window#add box#coerce; - let _ = window#show () in - GMain.Main.main () ; - !return + let rec iter rep = + try + match dialog#run () with + | `APPLY -> f_apply (); 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 + let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s | Some s2 -> s2 - + (** Create a string param. *) let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = String_param @@ -1248,7 +1249,25 @@ let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = string_editable = editable ; string_f_apply = f ; string_expand = expand ; - } + string_to_string = (fun x -> x) ; + string_of_string = (fun x -> x) ; + } + +(** Create a custom string param. *) +let custom_string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v = + String_param + (Configwin_types.mk_custom_text_string_param + { + string_label = label ; + string_help = help ; + string_value = v ; + string_editable = editable ; + string_f_apply = f ; + string_expand = expand ; + string_to_string = to_string; + string_of_string = of_string ; + } + ) (** Create a bool param. *) let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = @@ -1263,14 +1282,14 @@ let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = (** Create a list param. *) let list ?(editable=true) ?help - ?(f=(fun (_:'a list) -> ())) + ?(f=(fun (_:'a list) -> ())) ?(eq=Pervasives.(=)) ?(edit:('a -> 'a) option) ?(add=(fun () -> ([] : 'a list))) ?titles ?(color=(fun (_:'a) -> (None : string option))) label (f_strings : 'a -> string list) v = List_param - (fun () -> + (fun tt -> Obj.magic (new list_param_box { @@ -1285,13 +1304,14 @@ let list ?(editable=true) ?help list_f_edit = edit ; list_f_add = add ; list_f_apply = f ; - } + } + tt ) ) (** Create a strings param. *) let strings ?(editable=true) ?help - ?(f=(fun _ -> ())) + ?(f=(fun _ -> ())) ?(eq=Pervasives.(=)) ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v @@ -1321,8 +1341,8 @@ let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = } (** Create a combo param. *) -let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) - ?(new_allowed=false) +let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) + ?(new_allowed=false) ?(blank_allowed=false) label choices v = Combo_param { @@ -1338,7 +1358,7 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) } (** Create a text param. *) -let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = +let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Text_param { string_label = label ; @@ -1347,10 +1367,28 @@ let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = string_editable = editable ; string_f_apply = f ; string_expand = expand ; - } + string_to_string = (fun x -> x) ; + string_of_string = (fun x -> x) ; + } + +(** Create a custom text param. *) +let custom_text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v = + Text_param + (Configwin_types.mk_custom_text_string_param + { + string_label = label ; + string_help = help ; + string_value = v ; + string_editable = editable ; + string_f_apply = f ; + string_expand = expand ; + string_to_string = to_string; + string_of_string = of_string ; + } + ) (** Create a html param. *) -let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = +let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = Html_param { string_label = label ; @@ -1359,10 +1397,12 @@ let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = string_editable = editable ; string_f_apply = f ; string_expand = expand ; - } + string_to_string = (fun x -> x) ; + string_of_string = (fun x -> x) ; + } (** Create a filename param. *) -let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = +let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = Filename_param { string_label = label ; @@ -1371,17 +1411,19 @@ let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = string_editable = editable ; string_f_apply = f ; string_expand = expand ; - } + string_to_string = (fun x -> x) ; + string_of_string = (fun x -> x) ; + } (** Create a filenames param.*) -let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) +let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) ?(eq=Pervasives.(=)) label v = let add () = select_files label in - list ~editable ?help ~f ~eq ~add label (fun s -> [s]) v + list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v (** Create a date param. *) -let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) +let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) label v = Date_param @@ -1393,7 +1435,7 @@ let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) date_f_string = f_string ; date_f_apply = f ; date_expand = expand ; - } + } (** Create a hot key param. *) let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = @@ -1405,7 +1447,7 @@ let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = hk_editable = editable ; hk_f_apply = f ; hk_expand = expand ; - } + } let modifiers ?(editable=true) @@ -1432,4 +1474,4 @@ let custom ?label box f expand = custom_f_apply = f ; custom_expand = expand ; custom_framed = label ; - } + } |