diff options
Diffstat (limited to 'ide/utils/configwin_ihm.ml')
| -rw-r--r-- | ide/utils/configwin_ihm.ml | 720 |
1 files changed, 21 insertions, 699 deletions
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index c1062a9d..d16efa60 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -27,7 +27,25 @@ open Configwin_types -module O = Config_file +let modifiers_to_string m = + let rec iter m s = + match m with + [] -> s + | c :: m -> + iter m (( + match c with + `CONTROL -> "<ctrl>" + | `SHIFT -> "<shft>" + | `LOCK -> "<lock>" + | `MOD1 -> "<alt>" + | `MOD2 -> "<mod2>" + | `MOD3 -> "<mod3>" + | `MOD4 -> "<mod4>" + | `MOD5 -> "<mod5>" + | _ -> raise Not_found + ) ^ s) + in + iter m "" class type widget = object @@ -35,112 +53,9 @@ class type widget = method apply : unit -> unit end -let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" - let debug = false let dbg s = if debug then Minilib.log s else () -(** Return the config group for the html config file, - and the option for bindings. *) -let html_config_file_and_option () = - 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 = Configwin_types.string_to_key "A-i" ; - html_begin = "<i>"; - html_end = "</i>" ; - } - ] - "" - in - 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 changing 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 fs = GWindow.file_selection ~modal:true - ~title: the_title () in - (* we set the previous directory, if no directory is given *) - ( - match dir with - None -> - if !last_dir <> "" then - let _ = fs#set_filename !last_dir in - () - else - () - | Some 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 - None -> - (fun () -> files := [fs#filename] ; fs#destroy ()) - | Some f -> - (fun () -> f fs#filename) - ) - in - let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in - fs # show (); - GMain.Main.main (); - match !files with - | [] -> - [] - | [""] -> - [] - | l -> - (* we keep the directory in last_dir *) - last_dir := Filename.dirname (List.hd l); - l -;; - -(** Make the user select a date. *) -let select_date title (day,mon,year) = - let v_opt = ref None in - let window = GWindow.dialog ~modal:true ~title () in - let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in - let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in - cal#select_month ~month: mon ~year: year ; - cal#select_day day; - let bbox = window#action_area in - - let bok = GButton.button ~label: Configwin_messages.mOk - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - let bcancel = GButton.button ~label: Configwin_messages.mCancel - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - ignore (bok#connect#clicked ~callback: - (fun () -> v_opt := Some (cal#date); window#destroy ())); - ignore(bcancel#connect#clicked ~callback: window#destroy); - - bok#grab_default (); - ignore(window#connect#destroy ~callback: GMain.Main.quit); - window#set_position `CENTER; - window#show (); - GMain.Main.main (); - !v_opt - - (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and @@ -460,164 +375,6 @@ class custom_param_box param (tt:GData.tooltips) = method apply = param.custom_f_apply () end -(** This class is used to build a box for a color parameter.*) -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) () - in - 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 _ = - match param.color_help with - None -> () - | Some 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_fg [ (`NORMAL, `NAME s) ; ] - with _ -> () - ); - w_test#misc#set_style style; - in - let _ = set_color !v in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.color_selection_dialog - ~title: param.color_label - ~modal: true - ~show: true - () - in - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(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 ; *) - 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 ~callback:f_sel) - 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 - if new_value <> param.color_value then - let _ = param.color_f_apply new_value in - param.color_value <- new_value - else - () - - initializer - ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); - - end ;; - -(** This class is used to build a box for a font parameter.*) -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) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) - () - in - let _ = - match param.font_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_entry_font font_opt = - match font_opt with - None -> () - | Some s -> - let style = we#misc#style#copy in - ( - try - let font = Gdk.Font.load_fontset s in - style#set_font font - with _ -> () - ); - we#misc#set_style style - in - let _ = set_entry_font (Some !v) in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.font_selection_dialog - ~title: param.font_label - ~modal: true - ~show: true - () - in - dialog#selection#set_font_name !v; - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~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 ~callback:dialog#destroy in - GMain.Main.main () - 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. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = we#text in - if new_value <> param.font_value then - let _ = param.font_f_apply new_value in - param.font_value <- new_value - else - () - end ;; - (** This class is used to build a box for a text parameter.*) class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box" in @@ -654,7 +411,7 @@ class text_param_box param (tt:GData.tooltips) = let v = param.string_of_string (buffer#get_text ()) in if v <> param.string_value then ( - dbg "apply new value !"; + dbg "apply new value!"; let _ = param.string_f_apply v in param.string_value <- v ) @@ -662,35 +419,6 @@ class text_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box a html parameter. *) -class html_param_box param (tt:GData.tooltips) = - let _ = dbg "html_param_box" in - object (self) - inherit text_param_box param tt - - method private exec html_start html_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 wview ~mods k (self#exec hb.html_begin hb.html_end) - in - 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 (tt:GData.tooltips) = let _ = dbg "bool_param_box" in @@ -719,105 +447,6 @@ class bool_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box for a file name parameter.*) -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) () - in - let we = GEdit.entry - ~editable: param.string_editable - ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) - () - in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let _ = we#set_text (param.string_to_string param.string_value) in - - let f_click () = - match select_files param.string_label with - [] -> - () - | f :: _ -> - we#set_text f - in - let _ = - if param.string_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - 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 = 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 - else - () - end ;; - -(** This class is used to build a box for a hot key parameter.*) -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 () in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2) - () - in - let value = ref param.hk_value in - let _ = - match param.hk_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - 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 - let modifiers = GdkEvent.Key.state ev in - let mods = List.filter - (fun m -> not (List.mem m mods_we_dont_care)) - modifiers - in - value := (mods, key); - we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); - false - in - let _ = - if param.hk_editable then - ignore (we#event#connect#key_press ~callback:capture) - else - () - 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 = !value in - if new_value <> param.hk_value then - let _ = param.hk_f_apply new_value in - param.hk_value <- new_value - else - () - end ;; - class modifiers_param_box param = let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in @@ -825,7 +454,7 @@ class modifiers_param_box param = let value = ref param.md_value in let _ = List.map (fun modifier -> let but = GButton.toggle_button - ~label:(Configwin_types.modifiers_to_string [modifier]) + ~label:(modifiers_to_string [modifier]) ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled @@ -854,55 +483,6 @@ class modifiers_param_box param = () end ;; -(** This class is used to build a box for a date parameter.*) -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) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) - () - in - - let _ = - match param.date_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - 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) -> - v := (d,m,y) ; - we#set_text (param.date_f_string (d,m,y)) - in - let _ = - if param.date_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - 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 = - if !v <> param.date_value then - let _ = param.date_f_apply !v in - param.date_value <- !v - else - () - 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) (tt:GData.tooltips) = let _ = dbg "list_param_box" in @@ -975,10 +555,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = 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 @@ -987,30 +563,10 @@ class configuration_box (tt : GData.tooltips) conf_struct = 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 @@ -1102,36 +658,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = end -(** Create a vbox with the list of given configuration structure list, - 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 tabbed_box conf_struct_list buttons tooltips = - let param_box = - new configuration_box tooltips conf_struct_list - in - let f_apply () = param_box#apply - in - let hbox_buttons = GPack.hbox ~packing: (param_box#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 (); - - iter_buttons q - in - iter_buttons ~grab: true buttons; - - param_box#box - (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) @@ -1174,110 +700,6 @@ let edit ?(with_apply=true) in iter Return_cancel -(** 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 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_param_box = List.map f param_list in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box - in - (main_box, f_apply) - -(** 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 - let tooltips = GData.tooltips () 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 (box, f_apply) = box param_list tooltips in - dialog#vbox#pack ~expand: true ~fill: true box#coerce; - - let destroy () = - tooltips#destroy () ; - dialog#destroy (); - in - 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 ~title:"Error" s; iter rep - | e -> - GToolbox.message_box ~title:"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 @@ -1342,30 +764,6 @@ let strings ?(editable=true) ?help ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v -(** Create a color param. *) -let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Color_param - { - color_label = label ; - color_help = help ; - color_value = v ; - color_editable = editable ; - color_f_apply = f ; - color_expand = expand ; - } - -(** Create a font param. *) -let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Font_param - { - font_label = label ; - font_help = help ; - font_value = v ; - font_editable = editable ; - font_f_apply = f ; - font_expand = expand ; - } - (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(new_allowed=false) @@ -1383,82 +781,6 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) combo_expand = expand ; } -(** Create a text param. *) -let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Text_param - { - string_label = label ; - string_help = help ; - string_value = 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 html param. *) -let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Html_param - { - string_label = label ; - string_help = help ; - string_value = 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 = - Filename_param - { - string_label = label ; - string_help = help ; - string_value = 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 _ -> ())) - ?(eq=Pervasives.(=)) - label v = - let add () = select_files label in - 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 _ -> ())) - ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) - label v = - Date_param - { - date_label = label ; - date_help = help ; - date_value = v ; - date_editable = editable ; - 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 = - Hotkey_param - { - hk_label = label ; - hk_help = help ; - hk_value = v ; - hk_editable = editable ; - hk_f_apply = f ; - hk_expand = expand ; - } - let modifiers ?(editable=true) ?(expand=true) |