diff options
Diffstat (limited to 'ide/utils/configwin_types.ml')
-rw-r--r-- | ide/utils/configwin_types.ml | 309 |
1 files changed, 158 insertions, 151 deletions
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml index ee8ec70c..0def0b25 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.ml @@ -1,140 +1,148 @@ -(**************************************************************************) -(* 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 *) -(**************************************************************************) +(*********************************************************************************) +(* 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 types used in Configwin. *) -open Uoptions +open Config_file -(** A module to define key options, with the {!Uoptions} module. *) -module KeyOption = struct - let name_to_keysym = - ("Button1", Configwin_keys.xk_Pointer_Button1) :: - ("Button2", Configwin_keys.xk_Pointer_Button2) :: - ("Button3", Configwin_keys.xk_Pointer_Button3) :: - ("Button4", Configwin_keys.xk_Pointer_Button4) :: - ("Button5", Configwin_keys.xk_Pointer_Button5) :: - Configwin_keys.name_to_keysym - - let string_to_key s = - let mask = ref [] in - let key = try - let pos = String.rindex s '-' in - for i = 0 to pos - 1 do - let m = match s.[i] with - 'C' -> `CONTROL - | 'S' -> `SHIFT - | 'L' -> `LOCK - | 'M' -> `MOD1 - | 'A' -> `MOD1 - | '1' -> `MOD1 - | '2' -> `MOD2 - | '3' -> `MOD3 - | '4' -> `MOD4 - | '5' -> `MOD5 - | _ -> - prerr_endline s; - raise Not_found - in - mask := m :: !mask - done; - String.sub s (pos+1) (String.length s - pos - 1) - with _ -> - s - in - try - !mask, List.assoc key name_to_keysym - with - e -> - prerr_endline s; - raise e - - let key_to_string (m, k) = - let s = List.assoc k Configwin_keys.keysym_to_name in - match m with - [] -> s - | _ -> - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "C" - | `SHIFT -> "S" - | `LOCK -> "L" - | `MOD1 -> "A" - | `MOD2 -> "2" - | `MOD3 -> "3" - | `MOD4 -> "4" - | `MOD5 -> "5" - | _ -> raise Not_found - ) ^ s) - in - iter m ("-" ^ s) +let name_to_keysym = + ("Button1", Configwin_keys.xk_Pointer_Button1) :: + ("Button2", Configwin_keys.xk_Pointer_Button2) :: + ("Button3", Configwin_keys.xk_Pointer_Button3) :: + ("Button4", Configwin_keys.xk_Pointer_Button4) :: + ("Button5", Configwin_keys.xk_Pointer_Button5) :: + Configwin_keys.name_to_keysym + +let string_to_key s = + let mask = ref [] in + let key = try + let pos = String.rindex s '-' in + for i = 0 to pos - 1 do + let m = match s.[i] with + 'C' -> `CONTROL + | 'S' -> `SHIFT + | 'L' -> `LOCK + | 'M' -> `MOD1 + | 'A' -> `MOD1 + | '1' -> `MOD1 + | '2' -> `MOD2 + | '3' -> `MOD3 + | '4' -> `MOD4 + | '5' -> `MOD5 + | _ -> + prerr_endline s; + raise Not_found + in + mask := m :: !mask + done; + String.sub s (pos+1) (String.length s - pos - 1) + with _ -> + s + in + try + !mask, List.assoc key name_to_keysym + with + e -> + prerr_endline s; + raise e - let modifiers_to_string m = - let rec iter m s = - match m with +let key_to_string (m, k) = + let s = List.assoc k Configwin_keys.keysym_to_name in + match m with + [] -> s + | _ -> + 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 + match c with + `CONTROL -> "C" + | `SHIFT -> "S" + | `LOCK -> "L" + | `MOD1 -> "A" + | `MOD2 -> "2" + | `MOD3 -> "3" + | `MOD4 -> "4" + | `MOD5 -> "5" + | _ -> raise Not_found + ) ^ s) + in + iter m ("-" ^ s) + +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 "" - - let value_to_key v = - match v with - StringValue s -> string_to_key s - | _ -> - prerr_endline "value_to_key"; - raise Not_found - - let key_to_value k = - StringValue (key_to_string k) - let (t : (Gdk.Tags.modifier list * int) option_class) = - define_option_class "Key" value_to_key key_to_value -end +let value_to_key v = + match v with + Raw.String s -> string_to_key s + | _ -> + prerr_endline "value_to_key"; + raise Not_found + +let key_to_value k = + Raw.String (key_to_string k) + +let key_cp_wrapper = + { + to_raw = key_to_value ; + of_raw = value_to_key ; + } -(** This type represents a string or filename parameter. *) -type string_param = { +(** A class to define key options, with the {!Config_file} module. *) +class key_cp = + [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper + +(** This type represents a string or filename parameter, or + any other type, depending on the given conversion functions. *) +type 'a string_param = { string_label : string; (** the label of the parameter *) - mutable string_value : string; (** the current value of the parameter *) + mutable string_value : 'a; (** the current value of the parameter *) string_editable : bool ; (** indicates if the value can be changed *) - string_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) + string_f_apply : ('a -> unit) ; (** the function to call to apply the new value of the parameter *) string_help : string option ; (** optional help string *) string_expand : bool ; (** expand or not *) + string_to_string : 'a -> string ; + string_of_string : string -> 'a ; } ;; (** This type represents a boolean parameter. *) @@ -214,14 +222,14 @@ type font_param = { type hotkey_param = { hk_label : string ; (** the label of the parameter *) - mutable hk_value : (Gdk.Tags.modifier list * int) ; + mutable hk_value : (Gdk.Tags.modifier list * int) ; (** The value, as a list of modifiers and a key code *) hk_editable : bool ; (** indicates if the value can be changed *) hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ; (** the function to call to apply the new value of the paramter *) hk_help : string option ; (** optional help string *) hk_expand : bool ; (** expand or not *) - } + } type modifiers_param = { md_label : string ; (** the label of the parameter *) @@ -235,13 +243,18 @@ type modifiers_param = { md_allow : Gdk.Tags.modifier list } + +let mk_custom_text_string_param (a : 'a string_param) : string string_param = + Obj.magic a + + (** This type represents the different kinds of parameters. *) type parameter_kind = - String_param of string_param - | List_param of (unit -> <box: GObj.widget ; apply : unit>) - | Filename_param of string_param + String_param of string string_param + | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) + | Filename_param of string string_param | Bool_param of bool_param - | Text_param of string_param + | Text_param of string string_param | Combo_param of combo_param | Custom_param of custom_param | Color_param of color_param @@ -249,7 +262,7 @@ type parameter_kind = | Font_param of font_param | Hotkey_param of hotkey_param | Modifiers_param of modifiers_param - | Html_param of string_param + | Html_param of string string_param ;; (** This type represents the structure of the configuration window. *) @@ -273,27 +286,21 @@ type html_binding = { mutable html_key : (Gdk.Tags.modifier list * int) ; mutable html_begin : string ; mutable html_end : string ; - } - -module Html_binding = struct - let value_to_hb v = - match v with - List [StringValue hk ; StringValue debut; StringValue fin ] - | SmallList [StringValue hk ; StringValue debut; StringValue fin ] -> - { html_key = KeyOption.string_to_key hk ; - html_begin = debut ; - html_end = fin ; - } - | _ -> - prerr_endline "Html_binding.value_to_hb"; - raise Not_found + } - let hb_to_value hb = - SmallList [ StringValue (KeyOption.key_to_string hb.html_key) ; - StringValue hb.html_begin ; - StringValue hb.html_end ; - ] +let htmlbinding_cp_wrapper = + let w = Config_file.tuple3_wrappers + key_cp_wrapper + Config_file.string_wrappers + Config_file.string_wrappers + in + { + to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ; + of_raw = + (fun r -> let (k,b,e) = w.of_raw r in + { html_key = k ; html_begin = b ; html_end = e } + ) ; + } - let (t : html_binding option_class) = - define_option_class "html_binding" value_to_hb hb_to_value -end +class htmlbinding_cp = + [html_binding] Config_file.option_cp htmlbinding_cp_wrapper |