diff options
Diffstat (limited to 'ide/utils')
| -rw-r--r-- | ide/utils/config_file.ml | 642 | ||||
| -rw-r--r-- | ide/utils/config_file.mli | 352 | ||||
| -rw-r--r-- | ide/utils/configwin.ml | 67 | ||||
| -rw-r--r-- | ide/utils/configwin.mli | 148 | ||||
| -rw-r--r-- | ide/utils/configwin_html_config.ml | 65 | ||||
| -rw-r--r-- | ide/utils/configwin_ihm.ml | 846 | ||||
| -rw-r--r-- | ide/utils/configwin_keys.ml | 47 | ||||
| -rw-r--r-- | ide/utils/configwin_messages.ml | 49 | ||||
| -rw-r--r-- | ide/utils/configwin_types.ml | 309 | ||||
| -rw-r--r-- | ide/utils/okey.ml | 115 | ||||
| -rw-r--r-- | ide/utils/okey.mli | 47 |
11 files changed, 1881 insertions, 806 deletions
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml new file mode 100644 index 00000000..30eb0111 --- /dev/null +++ b/ide/utils/config_file.ml @@ -0,0 +1,642 @@ +(*********************************************************************************) +(* 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 *) +(* *) +(*********************************************************************************) + +(* $Id: config_file.ml 8618 2006-03-08 11:44:47Z notin $ *) + +(* TODO *) +(* section comments *) +(* better obsoletes: no "{}", line cuts *) + +(* possible improvements: *) +(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *) +(* description and help, level (beginner/advanced/...) for each cp *) +(* find an option from its name and group *) +(* class hooks *) +(* get the sections of a group / of a file *) +(* read file format from inifiles and ConfigParser *) + + +(* Read the mli before reading this file! *) + + +(* ******************************************************************************** *) +(* ******************************** misc utilities ******************************** *) +(* ******************************************************************************** *) +(* This code is intended to be usable without any dependencies. *) + +(* pipeline style, see for instance Raw.of_channel. *) +let (|>) x f = f x + +(* as List.assoc, but applies f to the element matching [key] and returns the list +where this element has been replaced by the result of f. *) +let rec list_assoc_remove key f = function + | [] -> raise Not_found + | (key',value) as elt :: tail -> + if key <> key' + then elt :: list_assoc_remove key f tail + else match f value with + | None -> tail + | Some a -> (key',a) :: tail + +(* reminiscent of String.concat. Same as [Queue.iter f1 queue] + but calls [f2 ()] between each calls to f1. + Does not call f2 before the first call nor after the last call to f2. + Could be more efficient with a richer module interface of Queue. +*) +let queue_iter_between f1 f2 queue = +(* let f flag elt = if flag then f2 (); (f1 elt:unit); true in *) + let f flag elt = if flag then f2 (); f1 elt; true in + ignore (Queue.fold f false queue) + +let list_iter_between f1 f2 = function + [] -> () + | a::[] -> f1 a + | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail +(* | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *) +(* !! types ??? *) + +(* to ensure that strings will be parsed correctly by Genlex. +It's more comfortable not to have quotes around the string, but sometimes it's necessary. *) +exception Unsafe_string +let safe_string s = + if s = "" + then "\"\"" + else if ( + try match s.[0] with + | 'a'..'z' | 'A'..'Z' -> + for i = 1 to String.length s - 1 do + match s.[i] with + 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> () + | _ -> raise Unsafe_string + done; + false + | _ -> + try + string_of_int (int_of_string s) <> s || + string_of_float (float_of_string s) <> s + with Failure "int_of_string" | Failure "float_of_string" -> true + with Unsafe_string -> true) + then Printf.sprintf "\"%s\"" (String.escaped s) + else s + + +(* ******************************************************************************** *) +(* ************************************* core ************************************* *) +(* ******************************************************************************** *) + +module Raw = struct + type cp = + | String of string + | Int of int + | Float of float + | List of cp list + | Tuple of cp list + | Section of (string * cp) list + +(* code generated by +camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4 +Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml. +Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*) + module Parse = struct + let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","] + let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l + and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure + and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure + and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure + end + + open Format + (* formating convention: the caller has to open the box, close it and flush the output *) + (* remarks on Format: + set_margin impose un appel à set_max_indent + sprintf et bprintf sont flushées à chaque appel*) + + (* pretty print a Raw.cp *) + let rec save formatter = function + | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *) + | Int i -> fprintf formatter "%d" i (* print backslashes just before the \n? *) + | Float f -> fprintf formatter "%g" f + | List l -> + fprintf formatter "[@[<b0>"; + list_iter_between + (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") + (fun () -> fprintf formatter ";@ ") + l; + fprintf formatter "@]]" + | Tuple l -> + fprintf formatter "(@[<b0>"; + list_iter_between + (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") + (fun () -> fprintf formatter ",@ ") + l; + fprintf formatter "@])" + | Section l -> + fprintf formatter "{@;<0 2>@[<hv0>"; + list_iter_between + (fun (name,value) -> + fprintf formatter "@[<hov2>%s =@ @[<b2>" name; + save formatter value; + fprintf formatter "@]@]";) + (fun () -> fprintf formatter "@;<2 0>") + l; + fprintf formatter "@]}" + +(* let to_string r = save str_formatter r; flush_str_formatter () *) + let to_channel out_channel r = + let f = formatter_of_out_channel out_channel in + fprintf f "@[<b2>"; save f r; fprintf f "@]@?" + + let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value + + let of_channel in_channel = + let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in + close_in in_channel; + result +end + +(* print the given string in a way compatible with Format. + Truncate the lines when needed, indent the newlines.*) +let print_help formatter = + String.iter (function + | ' ' -> Format.pp_print_space formatter () + | '\n' -> Format.pp_force_newline formatter () + | c -> Format.pp_print_char formatter c) + +type 'a wrappers = { + to_raw : 'a -> Raw.cp; + of_raw : Raw.cp -> 'a} + +class type ['a] cp = object +(* method private to_raw = wrappers.to_raw *) +(* method private of_raw = wrappers.of_raw *) +(* method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *) + method add_hook : ('a -> 'a -> unit) -> unit + method get : 'a + method get_default : 'a + method set : 'a -> unit + method reset : unit + + method get_formatted : Format.formatter -> unit + method get_default_formatted : Format.formatter -> unit + method get_help_formatted : Format.formatter -> unit + + method get_name : string list + method get_short_name : string option + method set_short_name : string -> unit + method get_help : string + method get_spec : Arg.spec + + method set_raw : Raw.cp -> unit +end + +type groupable_cp = < + get_name : string list; + get_short_name : string option; + get_help : string; + + get_formatted : Format.formatter -> unit; + get_default_formatted : Format.formatter -> unit; + get_help_formatted : Format.formatter -> unit; + get_spec : Arg.spec; + + reset : unit; + set_raw : Raw.cp -> unit; > + +exception Double_name +exception Missing_cp of groupable_cp +exception Wrong_type of (out_channel -> unit) + +(* Two exceptions to stop the iteration on queues. *) +exception Found +exception Found_cp of groupable_cp + +(* The data structure to store the cps. +It's a tree, each node is a section, and a queue of sons with their name. +Each leaf contains a cp. *) +type 'a nametree = + | Immediate of 'a + | Subsection of ((string * 'a nametree) Queue.t) + (* this Queue must be nonempty for group.read.choose *) + +class group = object (self) + val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *) + + method add : 'a. 'a cp -> unit = fun original_cp -> + let cp = (original_cp :> groupable_cp) in + (* function called when we reach the end of the list cp#get_name. *) + let add_immediate name cp queue = + Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue; + Queue.push (name, Immediate cp) queue in + (* adds the cp with name [first_name::last_name] in section [section]. *) + let rec add_in_section section first_name last_name cp queue = + let sub_add = match last_name with (* what to do once we have find the correct section *) + | [] -> add_immediate first_name + | middle_name :: last_name -> add_in_section first_name middle_name last_name in + try + Queue.iter + (function + | name, Subsection subsection when name = section -> + sub_add cp subsection; raise Found + | _ -> ()) + queue; + let sub_queue = Queue.create () in + sub_add cp sub_queue; + Queue.push (section, Subsection sub_queue) queue + with Found -> () in + (match cp#get_name with + | [] -> failwith "empty name" + | first_name :: [] -> add_immediate first_name cp cps + | first_name :: middle_name :: last_name -> + add_in_section first_name middle_name last_name cp cps) + + method write ?(with_help=true) filename = + let out_channel = open_out filename in + let formatter = Format.formatter_of_out_channel out_channel in + let print = Format.fprintf formatter in + print "@[<v>"; + let rec save_queue formatter = + queue_iter_between + (fun (name,nametree) -> save_nametree name nametree) + (Format.pp_print_cut formatter) + and save_nametree name = function + | Immediate cp -> + if with_help && cp#get_help <> "" then + (print "@[<hov3>(* "; cp#get_help_formatted formatter; + print "@ *)@]@,"); + Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name); + cp#get_formatted formatter; + print "@]@]" + | Subsection queue -> + Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name); + save_queue formatter queue; + print "@]@,}" in + save_queue formatter cps; + print "@]@."; close_out out_channel + + method read ?obsoletes ?(no_default=false) + ?(on_type_error = fun groupable_cp raw_cp output filename in_channel -> + close_in in_channel; + Printf.eprintf + "Type error while loading configuration parameter %s from file %s.\n%!" + (String.concat "." groupable_cp#get_name) filename; + output stderr; + exit 1) + filename = + (* [filename] is created if it doesn't exist. In this case there is no need to read it. *) + match Sys.file_exists filename with false -> self#write filename | true -> + let in_channel = open_in filename in + (* what to do when a cp is missing: *) + let missing cp default = if no_default then raise (Missing_cp cp) else default in + (* returns a cp contained in the nametree queue, which must be nonempty *) + let choose queue = + let rec iter q = Queue.iter (function + | _, Immediate cp -> raise (Found_cp cp) + | _, Subsection q -> iter q) q in + try iter queue; failwith "choose" with Found_cp cp -> cp in + (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value + defined in [raw_cps] and returns the remaining raw_cps. *) + let set_cp cp value = + try cp#set_raw value + with Wrong_type output -> on_type_error cp value output filename in_channel in + let rec set_and_remove raw_cps = function + | name, Immediate cp -> + (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps + with Not_found -> missing cp raw_cps) + | name, Subsection queue -> + (try list_assoc_remove name + (function + | Raw.Section l -> + (match remainings l queue with + | [] -> None + | l -> Some (Raw.Section l)) + | r -> missing (choose queue) (Some r)) + raw_cps + with Not_found -> missing (choose queue) raw_cps) + and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in + let remainings = remainings (Raw.of_channel in_channel) cps in + (* Handling of cps defined in filename but not belonging to self. *) + if remainings <> [] then match obsoletes with + | Some filename -> + let out_channel = + open_out filename in +(* open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *) + let formatter = Format.formatter_of_out_channel out_channel in + Format.fprintf formatter "@[<v>"; + Raw.save formatter (Raw.Section remainings); + Format.fprintf formatter "@]@."; + close_out out_channel + | None -> () + + method command_line_args ~section_separator = + let print = Format.fprintf Format.str_formatter in (* shortcut *) + let result = ref [] in let push x = result := x :: !result in + let rec iter = function + | _, Immediate cp -> + let key = "-" ^ String.concat section_separator cp#get_name in + let spec = cp#get_spec in + let doc = ( + print "@[<hv5>"; + Format.pp_print_as Format.str_formatter (String.length key +3) ""; + if cp#get_help <> "" + then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ") + else print "@,"; + print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter; + print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter; + print "@]@]@]@]"; + Format.flush_str_formatter ()) in + (match cp#get_short_name with + | None -> () + | Some short_name -> push ("-" ^ short_name,spec,"")); + push (key,spec,doc) + | _, Subsection queue -> Queue.iter iter queue in + Queue.iter iter cps; + List.rev !result +end + + +(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *) +class ['a] cp_custom_type wrappers + ?group:(group:group option) name ?short_name default help = +object (self) + method private to_raw = wrappers.to_raw + method private of_raw = wrappers.of_raw + + val mutable value = default + (* output *) + method get = value + method get_default = default + method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter + method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter + (* input *) + method set v = let v' = value in value <- v; self#exec_hooks v' v + method set_raw v = self#of_raw v |> self#set + method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set + method reset = self#set self#get_default + + (* name *) + val mutable shortname = short_name + method get_name = name + method get_short_name = shortname + method set_short_name s = shortname <- Some s + + (* help *) + method get_help = help + method get_help_formatted formatter = print_help formatter self#get_help + method get_spec = Arg.String self#set_string + + (* hooks *) + val mutable hooks = [] + method add_hook f = hooks <- (f:'a->'a->unit) :: hooks + method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks + + initializer match group with Some g -> g#add (self :> 'a cp) | None -> () +end + + +(* ******************************************************************************** *) +(* ****************************** predefined classes ****************************** *) +(* ******************************************************************************** *) + +let int_wrappers = { + to_raw = (fun v -> Raw.Int v); + of_raw = function + | Raw.Int v -> v + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Int expected, got %a\n%!" Raw.to_channel r))} +class int_cp ?group name ?short_name default help = object (self) + inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help + method get_spec = Arg.Int self#set +end + +let float_wrappers = { + to_raw = (fun v -> Raw.Float v); + of_raw = function + | Raw.Float v -> v + | Raw.Int v -> float v + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Float expected, got %a\n%!" Raw.to_channel r)) +} +class float_cp ?group name ?short_name default help = object (self) + inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help + method get_spec = Arg.Float self#set +end + +(* The Pervasives version is too restrictive *) +let bool_of_string s = + match String.lowercase s with + | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *) + | "true" | "yes" | "y" | "1" -> true + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Bool expected, got %s\n%!" r)) +let bool_wrappers = { + to_raw = (fun v -> Raw.String (string_of_bool v)); + of_raw = function + | Raw.String v -> bool_of_string v + | Raw.Int v -> v <> 0 + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Bool expected, got %a\n%!" Raw.to_channel r)) +} +class bool_cp ?group name ?short_name default help = object (self) + inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help + method get_spec = Arg.Bool self#set +end + +let string_wrappers = { + to_raw = (fun v -> Raw.String v); + of_raw = function + | Raw.String v -> v + | Raw.Int v -> string_of_int v + | Raw.Float v -> string_of_float v + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.String expected, got %a\n%!" Raw.to_channel r)) +} +class string_cp ?group name ?short_name default help = object (self) + inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help + method private of_string s = s + method get_spec = Arg.String self#set +end + +let list_wrappers wrappers = { + to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l)); + of_raw = function + | Raw.List l -> List.map wrappers.of_raw l + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.List expected, got %a\n%!" Raw.to_channel r)) +} +class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers) + +let option_wrappers wrappers = { + to_raw = (function + | Some v -> wrappers.to_raw v + | None -> Raw.String ""); + of_raw = function + | Raw.String s as v -> ( + if s = "" || s = "None" then None + else if String.length s >= 5 && String.sub s 0 5 = "Some " + then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5)))) + else Some (wrappers.of_raw v)) + | r -> Some (wrappers.of_raw r)} +class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers) + +let enumeration_wrappers enum = + let switched = List.map (fun (string,cons) -> cons,string) enum in + {to_raw = (fun v -> Raw.String (List.assq v switched)); + of_raw = function + | Raw.String s -> + (try List.assoc s enum + with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s)) + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw enumeration expected, got %a\n%!" Raw.to_channel r)) +} +class ['a] enumeration_cp enum ?group name ?short_name default help = object (self) + inherit ['a] cp_custom_type (enumeration_wrappers enum) + ?group name ?short_name default help + method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum))) +end + +let tuple2_wrappers wrapa wrapb = { + to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]); + of_raw = function + | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r)) +} +class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb) + +let tuple3_wrappers wrapa wrapb wrapc = { + to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]); + of_raw = function + | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r)) +} +class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc = + ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc) + +let tuple4_wrappers wrapa wrapb wrapc wrapd = { + to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]); + of_raw = function + | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d + | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan + "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r)) +} +class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd = + ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd) + +class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers +(* class color_cp = string_cp *) +class font_cp = string_cp +class filename_cp = string_cp + + +(* ******************************************************************************** *) +(******************** Backward compatibility with module Options ****************** *) +(* ******************************************************************************** *) + +type 'a option_class = 'a wrappers +type 'a option_record = 'a cp +type options_file = {mutable filename:string; group:group} + +let create_options_file filename = {filename = filename; group = new group} +let set_options_file options_file filename = options_file.filename <- filename +let load {filename=f; group = g} = g#read f +let append {group=g} filename = g#read filename +let save {filename=f; group = g} = g#write ~with_help:false f +let save_with_help {filename=f; group = g} = g#write ~with_help:true f +let define_option {group=group} name help option_class default = + (new cp_custom_type option_class ~group name default help) +let option_hook cp f = cp#add_hook (fun _ _ -> f ()) + +let string_option = string_wrappers +let color_option = string_wrappers +let font_option = string_wrappers +let int_option = int_wrappers +let bool_option = bool_wrappers +let float_option = float_wrappers +let string2_option = tuple2_wrappers string_wrappers string_wrappers + +let option_option = option_wrappers +let list_option = list_wrappers +let sum_option = enumeration_wrappers +let tuple2_option (a,b) = tuple2_wrappers a b +let tuple3_option (a,b,c) = tuple3_wrappers a b c +let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d + +let ( !! ) cp = cp#get +let ( =:= ) cp value = cp#set value + +let shortname cp = String.concat ":" cp#get_name +let get_help cp = cp#get_help + +type option_value = + Module of option_module +| StringValue of string +| IntValue of int +| FloatValue of float +| List of option_value list +| SmallList of option_value list +and option_module = (string * option_value) list + +let rec value_to_raw = function + | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a) + | StringValue a -> Raw.String a + | IntValue a -> Raw.Int a + | FloatValue a -> Raw.Float a + | List a -> Raw.List (List.map value_to_raw a) + | SmallList a -> Raw.Tuple (List.map value_to_raw a) +let rec raw_to_value = function + | Raw.String a -> StringValue a + | Raw.Int a -> IntValue a + | Raw.Float a -> FloatValue a + | Raw.List a -> List (List.map raw_to_value a) + | Raw.Tuple a -> SmallList (List.map raw_to_value a) + | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a) + +let define_option_class _ of_option_value to_option_value = + {to_raw = (fun a -> a |> to_option_value |> value_to_raw); + of_raw = (fun a -> a |> raw_to_value |> of_option_value)} + +let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value +let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw + +let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw +let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value +(* fancy indentation when finishing this stub code, not good style :-) *) +let value_to_string : option_value -> string = of_value_w string_option +let string_to_value = to_value_w string_option +let value_to_int = of_value_w int_option +let int_to_value = to_value_w int_option +let value_to_bool = of_value_w bool_option +let bool_to_value = to_value_w bool_option +let value_to_float = of_value_w float_option +let float_to_value = to_value_w float_option +let value_to_string2 = of_value_w string2_option +let string2_to_value = to_value_w string2_option +let value_to_list of_value = + let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in + of_value_w (list_option wrapper) +let list_to_value to_value = + let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in + to_value_w (list_option wrapper) diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli new file mode 100644 index 00000000..b9c77682 --- /dev/null +++ b/ide/utils/config_file.mli @@ -0,0 +1,352 @@ +(*********************************************************************************) +(* 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 implements a mechanism to handle configuration files. + A configuration file is defined as a set of [variable = value] lines, + where value can be + a simple string (types int, string, bool...), + a list of values between brackets (lists) or parentheses (tuples), + or a set of [variable = value] lines between braces. + The configuration file is automatically loaded and saved, + and configuration parameters are manipulated inside the program as easily as references. + + Object implementation by Jean-Baptiste Rouquier. +*) + +(** {1:lowlevelinterface Low level interface} *) +(** Skip this section on a first reading... *) + +(** The type of cp freshly parsed from configuration file, +not yet wrapped in their proper type. *) +module Raw : sig + type cp = + | String of string (** base types, reproducing the tokens of Genlex *) + | Int of int + | Float of float + | List of cp list (** compound types *) + | Tuple of cp list + | Section of (string * cp) list + + (** A parser. *) + val of_string : string -> cp + + (** Used to print the values into a log file for instance. *) + val to_channel : out_channel -> cp -> unit +end + +(** A type used to specialize polymorphics classes and define new classes. + {!Config_file.predefinedwrappers} are provided. + *) +type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; } + +(** An exception raised by {!Config_file.cp.set_raw} + when the argument doesn't have a suitable {!Config_file.Raw.cp} type. + The function explains the problem and flush the output.*) +exception Wrong_type of (out_channel -> unit) + +(* (\** {2 Miscellaneous functions} *\) *) + +(* val bool_of_string : string -> bool *) + +(** {1 High level interface} *) +(** {2 The two main classes} *) + +(** A Configuration Parameter, in short cp, ie + a value we can store in and read from a configuration file. *) +class type ['a] cp = object + (** {1 Accessing methods} *) + + method get : 'a + method set : 'a -> unit + method get_default : 'a + method get_help : string + method get_name : string list + + (** Resets to the default value. *) + method reset : unit + + (** {1 Miscellaneous} *) + + (** All the hooks are executed each time the method set is called, + just after setting the new value.*) + method add_hook : ('a -> 'a -> unit) -> unit + + (** Used to generate command line arguments in {!Config_file.group.command_line_args} *) + method set_short_name : string -> unit + + (** [None] if no optional short_name was provided during object creation + and [set_short_name] was never called.*) + method get_short_name : string option + + (** {1 Methods for internal use} *) + + method get_formatted : Format.formatter -> unit + method get_default_formatted : Format.formatter -> unit + method get_help_formatted : Format.formatter -> unit + + method get_spec : Arg.spec + method set_raw : Raw.cp -> unit +end + +(** Unification over all possible ['a cp]: + contains the main methods of ['a cp] except the methods using the type ['a]. + A [group] manipulates only [groupable_cp] for homogeneity. *) +type groupable_cp = < + get_name : string list; + get_short_name : string option; + get_help : string; + + get_formatted : Format.formatter -> unit; + get_default_formatted : Format.formatter -> unit; + get_help_formatted : Format.formatter -> unit; + get_spec : Arg.spec; + + reset : unit; + set_raw : Raw.cp -> unit; > + +(** Raised in case a name is already used. + See {!Config_file.group.add} *) +exception Double_name + +(** An exception possibly raised if we want to check that + every cp is defined in a configuration file. + See {!Config_file.group.read}. +*) +exception Missing_cp of groupable_cp + +(** A group of cps, that can be loaded and saved, +or used to generate command line arguments. + +The basic usage is to have only one group and one configuration file, +but this mechanism allows to have more, +for instance to have another smaller group for the options to pass on the command line. +*) +class group : object + (** Adds a cp to the group. + Note that the type ['a] must be lost + to allow cps of different types to belong to the same group. + @raise Double_name if [cp#get_name] is already used. *) +(* method add : 'a cp -> 'a cp *) + method add : 'a cp -> unit + + (**[write filename] saves all the cps into the configuration file [filename].*) + method write : ?with_help:bool -> string -> unit + + (** [read filename] reads [filename] + and stores the values it specifies into the cps belonging to this group. + The file is created (and not read) if it doesn't exists. + In the default behaviour, no warning is issued + if not all cps are updated or if some values of [filename] aren't used. + + If [obsoletes] is specified, + then prints in this file all the values that are + in [filename] but not in this group. + Those cps are likely to be erroneous or obsolete. + Opens this file only if there is something to write in it. + + If [no_default] is [true], then raises [Missing_cp foo] if + the cp [foo] isn't defined in [filename] but belongs to this group. + + [on_type_error groupable_cp value output filename in_channel] + is called if the file doesn't give suitable value + (string instead of int for instance, or a string not belonging to the expected enumeration) + for the cp [groupable_cp]. + [value] is the value read from the file, + [output] is the argument of {!Config_file.Wrong_type}, + [filename] is the same argument as the one given to read, + and [in_channel] refers to [filename] to allow a function to close it if needed. + Default behaviour is to print an error message and call [exit 1]. +*) + method read : ?obsoletes:string -> ?no_default:bool -> + ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) -> + string -> in_channel -> unit) -> + string -> unit + + (** Interface with module Arg. + @param section_separator the string used to concatenate the name of a cp, + to get the command line option name. + ["-"] is a good default. + @return a list that can be used with [Arg.parse] and [Arg.usage].*) + method command_line_args : section_separator:string -> (string * Arg.spec * string) list + end + +(** {2 Predefined cp classes} *) + +(** The last three non-optional arguments are always + [name] (of type string list), [default_value] and [help] (of type string). + + [name] is the path to the cp: [["section";"subsection"; ...; "foo"]]. + It can consists of a single element but must not be empty. + + [short_name] will be added a "-" and used in + {!Config_file.group.command_line_args}. + + [group], if provided, adds the freshly defined option to it + (something like [initializer group#add self]). + + [help] needs not contain newlines, it will be automatically truncated where needed. + It is mandatory but can be [""]. +*) + +class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp +class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp +class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp +class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp +class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp +class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp +class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp +class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp +class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp +class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp +class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp +(* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *) +class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp +class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp + +(** {2:predefinedwrappers Predefined wrappers} *) + +val int_wrappers : int wrappers +val float_wrappers : float wrappers +val bool_wrappers : bool wrappers +val string_wrappers : string wrappers +val list_wrappers : 'a wrappers -> 'a list wrappers +val option_wrappers : 'a wrappers -> 'a option wrappers + +(** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then +{[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]} +will allow you to use cp of this type. +For sum types with not only constant constructors, +you will need to define your own cp class. *) +val enumeration_wrappers : (string * 'a) list -> 'a wrappers +val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers +val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers +val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers + +(** {2 Defining new cp classes} *) + +(** To define a new cp class, you just have to provide an implementation for the wrappers +between your type [foo] and the type [Raw.cp]. +Once you have your wrappers [w], write +{[class foo_cp = [foo] cp_custom_type w]} + +For further details, have a look at the commented .ml file, +section "predefined cp classes". +*) +class ['a] cp_custom_type : 'a wrappers -> + ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp + + +(** {1 Backward compatibility} + +Deprecated. + +All the functions from the module Options are available, except: + +- [prune_file]: use [group#write ?obsoletes:"foo.ml"]. +- [smalllist_to_value], [smalllist_option]: use lists or tuples. +- [get_class]. +- [class_hook]: hooks are local to a cp. + If you want hooks global to a class, + define a new class that inherit from {!Config_file.cp_custom_type}. +- [set_simple_option], [get_simple_option], [simple_options], [simple_args]: + use {!Config_file.group.write}. +- [set_option_hook]: use {!Config_file.cp.add_hook}. +- [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}. + +The old configurations files are readable by this module. +*) + + + + + +(**/**) +type 'a option_class +type 'a option_record +type options_file + +val create_options_file : string -> options_file +val set_options_file : options_file -> string -> unit +val load : options_file -> unit +val append : options_file -> string -> unit +val save : options_file -> unit +val save_with_help : options_file -> unit +(* val define_option : options_file -> *) +(* string list -> string -> 'a option_class -> 'a -> 'a option_record *) +val option_hook : 'a option_record -> (unit -> unit) -> unit + +val string_option : string option_class +val color_option : string option_class +val font_option : string option_class +val int_option : int option_class +val bool_option : bool option_class +val float_option : float option_class +val string2_option : (string * string) option_class + +val option_option : 'a option_class -> 'a option option_class +val list_option : 'a option_class -> 'a list option_class +val sum_option : (string * 'a) list -> 'a option_class +val tuple2_option : + 'a option_class * 'b option_class -> ('a * 'b) option_class +val tuple3_option : 'a option_class * 'b option_class * 'c option_class -> + ('a * 'b * 'c) option_class +val tuple4_option : + 'a option_class * 'b option_class * 'c option_class * 'd option_class -> + ('a * 'b * 'c * 'd) option_class + +val ( !! ) : 'a option_record -> 'a +val ( =:= ) : 'a option_record -> 'a -> unit +val shortname : 'a option_record -> string +val get_help : 'a option_record -> string + +type option_value = + Module of option_module +| StringValue of string +| IntValue of int +| FloatValue of float +| List of option_value list +| SmallList of option_value list +and option_module = (string * option_value) list + +val define_option_class : + string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class + +val to_value : 'a option_class -> 'a -> option_value +val from_value : 'a option_class -> option_value -> 'a + +val value_to_string : option_value -> string +val string_to_value : string -> option_value +val value_to_int : option_value -> int +val int_to_value : int -> option_value +val bool_of_string : string -> bool +val value_to_bool : option_value -> bool +val bool_to_value : bool -> option_value +val value_to_float : option_value -> float +val float_to_value : float -> option_value +val value_to_string2 : option_value -> string * string +val string2_to_value : string * string -> option_value +val value_to_list : (option_value -> 'a) -> option_value -> 'a list +val list_to_value : ('a -> option_value) -> 'a list -> option_value diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index de6a7c57..275d8616 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -1,26 +1,27 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) type parameter_kind = Configwin_types.parameter_kind @@ -35,10 +36,16 @@ type return_button = | Return_ok | Return_cancel -module KeyOption = Configwin_types.KeyOption +let string_to_key = Configwin_types.string_to_key +let key_to_string = Configwin_types.key_to_string +let key_cp_wrapper = Configwin_types.key_cp_wrapper +class key_cp = Configwin_types.key_cp + let string = Configwin_ihm.string +let custom_string = Configwin_ihm.custom_string let text = Configwin_ihm.text +let custom_text = Configwin_ihm.custom_text let strings = Configwin_ihm.strings let list = Configwin_ihm.list let bool = Configwin_ihm.bool @@ -53,20 +60,20 @@ let hotkey = Configwin_ihm.hotkey let modifiers = Configwin_ihm.modifiers let html = Configwin_ihm.html -let edit +let edit ?(apply=(fun () -> ())) - title ?(width=400) ?(height=400) - conf_struct_list = + title ?(width=400) ?(height=400) + conf_struct_list = Configwin_ihm.edit ~with_apply: true ~apply title ~width ~height conf_struct_list let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) -let simple_edit +let simple_edit ?(apply=(fun () -> ())) - title ?width ?height + title ?width ?height param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list -let simple_get = Configwin_ihm.simple_edit +let simple_get = Configwin_ihm.simple_edit ~with_apply: false ~apply: (fun () -> ()) let box = Configwin_ihm.box diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index 078befc6..2d4dd4a7 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -1,26 +1,27 @@ -(**************************************************************************) -(* 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 is the interface of the Configwin library. *) @@ -30,8 +31,8 @@ type parameter_kind;; (** This type represents the structure of the configuration window. *) -type configuration_structure = - | Section of string * parameter_kind list +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 *) @@ -50,13 +51,20 @@ type return_button = on the apply button.*) -(** {2 The key option class (to use with the {!Uoptions} library)} *) +(** {2 The key option class (to use with the {!Config_file} library)} *) -module KeyOption : sig - val string_to_key : string -> (Gdk.Tags.modifier list * int) - val key_to_string : (Gdk.Tags.modifier list * int) -> string - val t : (Gdk.Tags.modifier list * int) Uoptions.option_class -end +val string_to_key : string -> Gdk.Tags.modifier list * int + +val key_to_string : Gdk.Tags.modifier list * int -> string + +val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers + +class key_cp : + ?group:Config_file.group -> + string list -> + ?short_name:string -> + Gdk.Tags.modifier list * int -> + string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type (** {2 Functions to create parameters} *) @@ -69,6 +77,13 @@ end val string : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind +(** Same as {!Configwin.string} but for values which are not strings. *) +val custom_string : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: ('a -> unit) -> + to_string: ('a -> string) -> + of_string: (string -> 'a) -> + string -> 'a -> parameter_kind + (** [bool label value] creates a boolean parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @@ -88,12 +103,12 @@ val bool : ?editable: bool -> ?help: string -> always returning false. *) val strings : ?editable: bool -> ?help: string -> - ?f: (string list -> unit) -> + ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> - ?add: (unit -> string list) -> + ?add: (unit -> string list) -> string -> string list -> parameter_kind - -(** [list label f_strings value] creates a list parameter. + +(** [list label f_strings value] creates a list parameter. [f_strings] is a function taking a value and returning a list of strings to display it. The list length should be the same for any value, and the same as the titles list length. The [value] @@ -117,15 +132,15 @@ val strings : ?editable: bool -> ?help: string -> no color for any element. *) val list : ?editable: bool -> ?help: string -> - ?f: ('a list -> unit) -> + ?f: ('a list -> unit) -> ?eq: ('a -> 'a -> bool) -> ?edit: ('a -> 'a) -> - ?add: (unit -> 'a list) -> + ?add: (unit -> 'a list) -> ?titles: string list -> ?color: ('a -> string option) -> - string -> + string -> ('a -> string list) -> - 'a list -> + 'a list -> parameter_kind (** [color label value] creates a color parameter. @@ -134,7 +149,7 @@ val list : ?editable: bool -> ?help: string -> @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) -val color : ?editable: bool -> ?expand: bool -> ?help: string -> +val color : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [font label value] creates a font parameter. @@ -143,7 +158,7 @@ val color : ?editable: bool -> ?expand: bool -> ?help: string -> @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) -val font : ?editable: bool -> ?expand: bool -> ?help: string -> +val font : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [combo label choices value] creates a combo parameter. @@ -156,8 +171,8 @@ val font : ?editable: bool -> ?expand: bool -> ?help: string -> @param blank_allowed indicate if the empty selection [""] is accepted (default is [false]). *) -val combo : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> +val combo : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> ?new_allowed: bool -> ?blank_allowed: bool -> string -> string list -> string -> parameter_kind @@ -167,14 +182,21 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string -> @param help an optional help message. @param f the function called to apply the value (default function does nothing). *) -val text : ?editable: bool -> ?expand: bool -> ?help: string -> +val text : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind -(** Same as {!Configwin.text} but html bindings are available - in the text widget. Use the [configwin_html_config] utility +(** Same as {!Configwin.text} but for values which are not strings. *) +val custom_text : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: ('a -> unit) -> + to_string: ('a -> string) -> + of_string: (string -> 'a) -> + string -> 'a -> parameter_kind + +(** Same as {!Configwin.text} but html bindings are available + in the text widget. Use the [configwin_html_config] utility to edit your bindings. *) -val html : ?editable: bool -> ?expand: bool -> ?help: string -> +val html : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind (** [filename label value] creates a filename parameter. @@ -194,8 +216,8 @@ val filename : ?editable: bool -> ?expand: bool -> ?help: string -> is [Pervasives.(=)]. If you want to allow doubles in the list, give a function always returning false. *) -val filenames : ?editable: bool -> ?help: string -> - ?f: (string list -> unit) -> +val filenames : ?editable: bool -> ?help: string -> + ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> string -> string list -> parameter_kind @@ -208,8 +230,8 @@ val filenames : ?editable: bool -> ?help: string -> is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default function creates the string [year/month/day]. *) -val date : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((int * int * int) -> unit) -> +val date : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: ((int * int * int) -> unit) -> ?f_string: ((int * int * int -> string)) -> string -> (int * int * int) -> parameter_kind @@ -221,7 +243,7 @@ val date : ?editable: bool -> ?expand: bool -> ?help: string -> @param f the function called to apply the value (default function does nothing). *) val hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((Gdk.Tags.modifier list * int) -> unit) -> + ?f: ((Gdk.Tags.modifier list * int) -> unit) -> string -> (Gdk.Tags.modifier list * int) -> parameter_kind val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> @@ -229,7 +251,6 @@ val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (Gdk.Tags.modifier list -> unit) -> string -> Gdk.Tags.modifier list -> parameter_kind - (** [custom box f expand] creates a custom parameter, with the given [box], the [f] function is called when the user wants to apply his changes, and [expand] indicates if the box @@ -241,8 +262,8 @@ val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_ (** {2 Functions creating configuration windows and boxes} *) (** This function takes a configuration structure and creates a window - to configure the various parameters. - @param apply this function is called when the apply button is clicked, after + to configure the various parameters. + @param apply this function is called when the apply button is clicked, after giving new values to parameters. *) val edit : @@ -263,9 +284,9 @@ val get : configuration_structure list -> return_button -(** This function takes a list of parameter specifications and +(** This function takes a list of parameter specifications and creates a window to configure the various parameters. - @param apply this function is called when the apply button is clicked, after + @param apply this function is called when the apply button is clicked, after giving new values to parameters.*) val simple_edit : ?apply: (unit -> unit) -> @@ -274,7 +295,7 @@ val simple_edit : ?height:int -> parameter_kind list -> return_button -(** This function takes a list of parameter specifications and +(** This function takes a list of parameter specifications and creates a window to configure the various parameters, without Apply button.*) val simple_get : @@ -284,17 +305,14 @@ val simple_get : parameter_kind list -> return_button (** Create a [GPack.box] 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. + Return the box and the function to call to apply new values to parameters. *) -val box : parameter_kind list -> - (string * (unit -> unit)) list -> GPack.box +val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit) (** Create a [GPack.box] 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. *) -val tabbed_box : configuration_structure list -> - (string * (unit -> unit)) list -> GPack.box +val tabbed_box : configuration_structure list -> + (string * (unit -> unit)) list -> GData.tooltips -> GPack.box diff --git a/ide/utils/configwin_html_config.ml b/ide/utils/configwin_html_config.ml index fc2913d1..fe39de0a 100644 --- a/ide/utils/configwin_html_config.ml +++ b/ide/utils/configwin_html_config.ml @@ -1,38 +1,39 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) (** The HTML editor bindings configurator. *) module C = Configwin_ihm open Configwin_types -open Uoptions +open Config_file -let simple_get = C.simple_edit +let simple_get = C.simple_edit ~with_apply: false ~apply: (fun () -> ()) let params_hb hb = - let p_key = C.hotkey + let p_key = C.hotkey ~f: (fun k -> hb.html_key <- k) Configwin_messages.mKey hb.html_key in @@ -53,10 +54,10 @@ let edit_hb hb = hb let add () = - let hb = { html_key = KeyOption.string_to_key "C-a" ; + let hb = { html_key = Configwin_types.string_to_key "C-a" ; html_begin = "" ; html_end = "" ; - } + } in match simple_get Configwin_messages.mAdd (params_hb hb) with Return_ok -> [hb] @@ -66,18 +67,18 @@ let main () = ignore (GMain.Main.init ()); let (ini, bindings) = C.html_config_file_and_option () in let param = C.list - ~f: (fun l -> bindings =:= l ; Uoptions.save_with_help ini) + ~f: (fun l -> bindings#set l ; ini#write Configwin_ihm.file_html_config ) ~eq: (fun hb1 hb2 -> hb1.html_key = hb2.html_key) ~edit: edit_hb ~add: add ~titles: [ Configwin_messages.mKey ; Configwin_messages.html_begin ; Configwin_messages.html_end ] Configwin_messages.shortcuts - (fun hb -> [ KeyOption.key_to_string hb.html_key ; + (fun hb -> [ Configwin_types.key_to_string hb.html_key ; hb.html_begin ; hb.html_end ]) - !!bindings + bindings#get in - ignore (simple_get ~width: 300 ~height: 400 + ignore (simple_get ~width: 300 ~height: 400 Configwin_messages.html_config [param]) let _ = main () 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 ; - } + } diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml index 9c867845..e1d7f33b 100644 --- a/ide/utils/configwin_keys.ml +++ b/ide/utils/configwin_keys.ml @@ -1,26 +1,27 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) (** Key codes diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml index a6085138..f8984462 100644 --- a/ide/utils/configwin_messages.ml +++ b/ide/utils/configwin_messages.ml @@ -1,31 +1,32 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) (** Module containing the messages of Configwin.*) let software = "Configwin";; -let version = "1.3";; +let version = "1.2";; let html_config = "Configwin bindings configurator for html parameters" 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 diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml index 17e371f5..57939266 100644 --- a/ide/utils/okey.ml +++ b/ide/utils/okey.ml @@ -1,33 +1,34 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) type modifier = Gdk.Tags.modifier type handler = { cond : (unit -> bool) ; cback : (unit -> unit) ; - } + } type handler_spec = int * int * Gdk.keysym (** mods * mask * key *) @@ -49,9 +50,9 @@ let int_of_modifier = function let print_modifier l = List.iter - (fun m -> + (fun m -> print_string - (((function + (((function `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL" @@ -69,11 +70,11 @@ let print_modifier l = ) l; print_newline () - + let int_of_modifiers l = List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l -module H = +module H = struct type t = handler_spec * handler let equal (m,k) (mods, mask, key) = @@ -85,7 +86,7 @@ module H = let find_handlers mods key l = List.map snd (List.filter - (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) + (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) l ) @@ -97,23 +98,25 @@ let key_press w ev = let key = GdkEvent.Key.keyval ev in let modifiers = GdkEvent.Key.state ev in try - let (r : H.t list ref) = Hashtbl.find table w#get_oid in + let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in let l = H.find_handlers (int_of_modifiers modifiers) key !r in - let b = ref true in - List.iter - (fun h -> - if h.cond () then - (h.cback () ; b := false) - else - () - ) - l; - !b + match l with + [] -> false + | _ -> + List.iter + (fun h -> + if h.cond () then + try h.cback () + with e -> prerr_endline (Printexc.to_string e) + else () + ) + l; + true with Not_found -> - true + false -let associate_key_press w = +let associate_key_press w = ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id) let default_modifiers = ref ([] : modifier list) @@ -122,24 +125,25 @@ let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list) let set_default_modifiers l = default_modifiers := l let set_default_mask l = default_mask := l -let remove_widget (w : < event : GObj.event_ops ; get_oid : int ; ..>) () = - try - let r = Hashtbl.find table w#get_oid in +let remove_widget (w : < event : GObj.event_ops ; ..>) () = + try + let r = Hashtbl.find table (Oo.id w) in r := [] - with + with Not_found -> () let add1 ?(remove=false) w - ?(cond=(fun () -> true)) + ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = + let r = - try Hashtbl.find table w#get_oid - with Not_found -> + try Hashtbl.find table (Oo.id w) + with Not_found -> let r = ref [] in - Hashtbl.add table w#get_oid r; + Hashtbl.add table (Oo.id w) r; ignore (w#connect#destroy ~callback: (remove_widget w)); associate_key_press w; r @@ -147,7 +151,7 @@ let add1 ?(remove=false) w let n_mods = int_of_modifiers mods in let n_mask = lnot (int_of_modifiers mask) in let new_h = { cond = cond ; cback = callback } in - if remove then + if remove then ( let l = H.filter_with_mask n_mods n_mask k !r in r := ((n_mods, n_mask, k), new_h) :: l @@ -156,30 +160,29 @@ let add1 ?(remove=false) w r := ((n_mods, n_mask, k), new_h) :: !r let add w - ?(cond=(fun () -> true)) + ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = add1 w ~cond ~mods ~mask k callback let add_list w - ?(cond=(fun () -> true)) + ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k_list callback = List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list let set w - ?(cond=(fun () -> true)) + ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k callback = add1 ~remove: true w ~cond ~mods ~mask k callback let set_list w - ?(cond=(fun () -> true)) + ?(cond=(fun () -> true)) ?(mods= !default_modifiers) ?(mask= !default_mask) k_list callback = List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list - diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli index a0effe72..c8d48389 100644 --- a/ide/utils/okey.mli +++ b/ide/utils/okey.mli @@ -1,26 +1,27 @@ -(**************************************************************************) -(* 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 *) +(* *) +(*********************************************************************************) (** Okey interface. |