From 6b649aba925b6f7462da07599fe67ebb12a3460e Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Wed, 28 Jul 2004 21:54:47 +0000 Subject: Imported Upstream version 8.0pl1 --- ide/utils/uoptions.ml | 772 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 772 insertions(+) create mode 100644 ide/utils/uoptions.ml (limited to 'ide/utils/uoptions.ml') diff --git a/ide/utils/uoptions.ml b/ide/utils/uoptions.ml new file mode 100644 index 00000000..416f5769 --- /dev/null +++ b/ide/utils/uoptions.ml @@ -0,0 +1,772 @@ +(**************************************************************************) +(* 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 *) +(**************************************************************************) + +(** Simple options: + This will enable very simple configuration, by a mouse-based configurator. + Options will be defined by a special function, which will also check + if a value has been provided by the user in its .gwmlrc file. + The .gwmlrc will be created by a dedicated tool, which could be used + to generate both .gwmlrc and .efunsrc files. + +Note: this is redundant, since such options could also be better set +in the .Xdefaults file (using Xrm to load them). Maybe we should merge +both approaches in a latter release. + + Code from Fabrice Le Fessant. + + *) + +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 +;; + + + +type 'a option_class = + { class_name : string; + from_value : option_value -> 'a; + to_value : 'a -> option_value; + mutable class_hooks : ('a option_record -> unit) list } + +and 'a option_record = + { option_name : string list; + option_class : 'a option_class; + mutable option_value : 'a; + option_help : string; + mutable option_hooks : (unit -> unit) list; + mutable string_wrappers : (('a -> string) * (string -> 'a)) option; + option_file : options_file; + } + +and options_file = { + mutable file_name : string; + mutable file_options : Obj.t option_record list; + mutable file_rc : option_module; + mutable file_pruned : bool; + } +;; + +let create_options_file name = + ignore + ( + if not (Sys.file_exists name) then + let oc = open_out name in + close_out oc + ); + { + file_name = name; + file_options =[]; + file_rc = []; + file_pruned = false; + } + +let set_options_file opfile name = opfile.file_name <- name + +let + define_option_class + (class_name : string) + (from_value : option_value -> 'a) + (to_value : 'a -> option_value) = + let c = + {class_name = class_name; + from_value = from_value; + to_value = to_value; + class_hooks = []} + in + c +;; + +(* +let filename = + ref + (Filename.concat Sysenv.home + ("." ^ Filename.basename Sys.argv.(0) ^ "rc")) +;; +let gwmlrc = ref [];; + +let options = ref [];; +*) + +let rec find_value list m = + match list with + [] -> raise Not_found + | name :: tail -> + let m = List.assoc name m in + match m, tail with + _, [] -> m + | Module m, _ :: _ -> find_value tail m + | _ -> raise Not_found +;; + +let prune_file file = + file.file_pruned <- true + +let + define_option + (opfile : options_file) + (option_name : string list) + (option_help : string) + (option_class : 'a option_class) + (default_value : 'a) = + let o = + {option_name = option_name; + option_help = option_help; + option_class = option_class; + option_value = default_value; + string_wrappers = None; + option_hooks = []; + option_file = opfile; } + in + opfile.file_options <- (Obj.magic o : Obj.t option_record) :: + opfile.file_options; + o.option_value <- + begin try o.option_class.from_value (find_value option_name + opfile.file_rc) with + Not_found -> default_value + | e -> + Printf.printf "Options.define_option, for option %s: " + (match option_name with + [] -> "???" + | name :: _ -> name); + Printf.printf "%s" (Printexc.to_string e); + print_newline (); + default_value + end; + o +;; + + +open Genlex;; + +let lexer = make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","; "."];; + +let rec parse_gwmlrc (strm__ : _ Stream.t) = + match + try Some (parse_id strm__) with + Stream.Failure -> None + with + Some id -> + begin match Stream.peek strm__ with + Some (Kwd "=") -> + Stream.junk strm__; + let v = + try parse_option strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let eof = + try parse_gwmlrc strm__ with + Stream.Failure -> raise (Stream.Error "") + in + (id, v) :: eof + | _ -> raise (Stream.Error "") + end + | _ -> [] +and parse_option (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some (Kwd "{") -> + Stream.junk strm__; + let v = + try parse_gwmlrc strm__ with + Stream.Failure -> raise (Stream.Error "") + in + begin match Stream.peek strm__ with + Some (Kwd "}") -> Stream.junk strm__; Module v + | _ -> raise (Stream.Error "") + end + | Some (Ident s) -> Stream.junk strm__; StringValue s + | Some (String s) -> Stream.junk strm__; StringValue s + | Some (Int i) -> Stream.junk strm__; IntValue i + | Some (Float f) -> Stream.junk strm__; FloatValue f + | Some (Char c) -> + Stream.junk strm__; + StringValue (let s = String.create 1 in s.[0] <- c; s) + | Some (Kwd "[") -> + Stream.junk strm__; + let v = + try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + in + List v + | Some (Kwd "(") -> + Stream.junk strm__; + let v = + try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + in + List v + | _ -> raise Stream.Failure +and parse_id (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some (Ident s) -> Stream.junk strm__; s + | Some (String s) -> Stream.junk strm__; s + | _ -> raise Stream.Failure +and parse_list (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some (Kwd ";") -> + Stream.junk strm__; + begin try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + end + | Some (Kwd ",") -> + Stream.junk strm__; + begin try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + end + | Some (Kwd ".") -> + Stream.junk strm__; + begin try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + end + | _ -> + match + try Some (parse_option strm__) with + Stream.Failure -> None + with + Some v -> + let t = + try parse_list strm__ with + Stream.Failure -> raise (Stream.Error "") + in + v :: t + | _ -> + match Stream.peek strm__ with + Some (Kwd "]") -> Stream.junk strm__; [] + | Some (Kwd ")") -> Stream.junk strm__; [] + | _ -> raise Stream.Failure +;; + +let exec_hooks o = + List.iter + (fun f -> + try f () with + _ -> ()) + o.option_hooks +;; + +let exec_chooks o = + List.iter + (fun f -> + try f o with + _ -> ()) + o.option_class.class_hooks +;; + +let really_load filename options = + let temp_file = filename ^ ".tmp" in + if Sys.file_exists temp_file then begin + Printf.printf + "File %s exists\n" temp_file; + Printf.printf + "An error may have occurred during previous configuration save.\n"; + Printf.printf + "Please, check your configurations files, and rename/remove this file\n"; + Printf.printf "before restarting"; + print_newline (); + exit 1 + end + else + let ic = open_in filename in + let s = Stream.of_channel ic in + try + let stream = lexer s in + let list = + try parse_gwmlrc stream with + e -> + Printf.printf "At pos %d/%d" (Stream.count s) (Stream.count stream); + print_newline (); + raise e + in + List.iter + (fun o -> + try + o.option_value <- + o.option_class.from_value (find_value o.option_name list); + exec_chooks o; + exec_hooks o + with + e -> + () + ) + options; + list + with + e -> + Printf.printf "Error %s in %s" (Printexc.to_string e) filename; + print_newline (); + [] +;; + +let load opfile = + try opfile.file_rc <- really_load opfile.file_name opfile.file_options with + Not_found -> + Printf.printf "No %s found" opfile.file_name; print_newline () +;; + +let append opfile filename = + try opfile.file_rc <- + really_load filename opfile.file_options @ opfile.file_rc with + Not_found -> + Printf.printf "No %s found" filename; print_newline () +;; + +let ( !! ) o = o.option_value;; +let ( =:= ) o v = o.option_value <- v; exec_chooks o; exec_hooks o;; + +let value_to_string v = + match v with + StringValue s -> s + | IntValue i -> string_of_int i + | FloatValue f -> string_of_float f + | _ -> failwith "Options: not a string option" +;; + +let string_to_value s = StringValue s;; + +let value_to_int v = + match v with + StringValue s -> int_of_string s + | IntValue i -> i + | _ -> failwith "Options: not an int option" +;; + +let int_to_value i = IntValue i;; + +(* The Pervasives version is too restrictive *) +let bool_of_string s = + match String.lowercase s with + "true" -> true + | "false" -> false + | "yes" -> true + | "no" -> false + | "y" -> true + | "n" -> false + | _ -> invalid_arg "bool_of_string" +;; + +let value_to_bool v = + match v with + StringValue s -> bool_of_string s + | IntValue v when v = 0 -> false + | IntValue v when v = 1 -> true + | _ -> failwith "Options: not a bool option" +;; +let bool_to_value i = StringValue (string_of_bool i);; + +let value_to_float v = + match v with + StringValue s -> float_of_string s + | FloatValue f -> f + | _ -> failwith "Options: not a float option" +;; + +let float_to_value i = FloatValue i;; + +let value_to_string2 v = + match v with + List [s1; s2] | SmallList [s1;s2] -> + value_to_string s1, value_to_string s2 + | _ -> failwith "Options: not a string2 option" +;; + +let string2_to_value (s1, s2) = SmallList [StringValue s1; StringValue s2];; + +let value_to_list v2c v = + match v with + List l | SmallList l -> List.rev (List.rev_map v2c l) + | StringValue s -> failwith (Printf.sprintf + "Options: not a list option (StringValue [%s])" s) + | FloatValue _ -> failwith "Options: not a list option (FloatValue)" + | IntValue _ -> failwith "Options: not a list option (IntValue)" + | Module _ -> failwith "Options: not a list option (Module)" +;; + +let list_to_value c2v l = + List + (List.fold_right + (fun v list -> + try c2v v :: list with + _ -> list) + l []) +;; + +let smalllist_to_value c2v l = + SmallList + (List.fold_right + (fun v list -> + try c2v v :: list with + _ -> list) + l []) +;; + +let string_option = + define_option_class "String" value_to_string string_to_value +;; +let color_option = + define_option_class "Color" value_to_string string_to_value +;; +let font_option = define_option_class "Font" value_to_string string_to_value;; + +let int_option = define_option_class "Int" value_to_int int_to_value;; + +let bool_option = define_option_class "Bool" value_to_bool bool_to_value;; +let float_option = define_option_class "Float" value_to_float float_to_value;; + +let string2_option = + define_option_class "String2" value_to_string2 string2_to_value +;; + +let list_option cl = + define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value) + (list_to_value cl.to_value) +;; + +let smalllist_option cl = + define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value) + (smalllist_to_value cl.to_value) +;; + +let to_value cl = cl.to_value;; +let from_value cl = cl.from_value;; + +let value_to_sum l v = + match v with + StringValue s -> List.assoc s l + | _ -> failwith "Options: not a sum option" +;; + +let sum_to_value l v = StringValue (List.assq v l);; + +let sum_option l = + let ll = List.map (fun (a1, a2) -> a2, a1) l in + define_option_class "Sum" (value_to_sum l) (sum_to_value ll) +;; + +let exit_exn = Exit;; +let safe_string s = + if s = "" then "\"\"" + else + 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 exit_exn + done; + s + | _ -> + if string_of_int (int_of_string s) = s || + string_of_float (float_of_string s) = s then + s + else raise exit_exn + with + _ -> Printf.sprintf "\"%s\"" (String.escaped s) +;; + +let with_help = ref false;; + +let rec save_module indent oc list = + let subm = ref [] in + List.iter + (fun (name, help, value) -> + match name with + [] -> assert false + | [name] -> + if !with_help && help <> "" then + Printf.fprintf oc "(* %s *)\n" help; + Printf.fprintf oc "%s %s = " indent (safe_string name); + save_value indent oc value; + Printf.fprintf oc "\n" + | m :: tail -> + let p = + try List.assoc m !subm with + _ -> let p = ref [] in subm := (m, p) :: !subm; p + in + p := (tail, help, value) :: !p) + list; + List.iter + (fun (m, p) -> + Printf.fprintf oc "%s %s = {\n" indent (safe_string m); + save_module (indent ^ " ") oc !p; + Printf.fprintf oc "%s}\n" indent) + !subm +and save_list indent oc list = + match list with + [] -> () + | [v] -> save_value indent oc v + | v :: tail -> + save_value indent oc v; Printf.fprintf oc ", "; save_list indent oc tail +and save_list_nl indent oc list = + match list with + [] -> () + | [v] -> Printf.fprintf oc "\n%s" indent; save_value indent oc v + | v :: tail -> + Printf.fprintf oc "\n%s" indent; + save_value indent oc v; + Printf.fprintf oc ";"; + save_list_nl indent oc tail +and save_value indent oc v = + match v with + StringValue s -> Printf.fprintf oc "%s" (safe_string s) + | IntValue i -> Printf.fprintf oc "%d" i + | FloatValue f -> Printf.fprintf oc "%f" f + | List l -> + Printf.fprintf oc "["; + save_list_nl (indent ^ " ") oc l; + Printf.fprintf oc "]" + | SmallList l -> + Printf.fprintf oc "("; + save_list (indent ^ " ") oc l; + Printf.fprintf oc ")" + | Module m -> + Printf.fprintf oc "{"; + save_module_fields (indent ^ " ") oc m; + Printf.fprintf oc "}" + +and save_module_fields indent oc m = + match m with + [] -> () + | (name, v) :: tail -> + Printf.fprintf oc "%s %s = " indent (safe_string name); + save_value indent oc v; + Printf.fprintf oc "\n"; + save_module_fields indent oc tail +;; + +let save opfile = + let filename = opfile.file_name in + let temp_file = filename ^ ".tmp" in + let old_file = filename ^ ".old" in + let oc = open_out temp_file in + save_module "" oc + (List.map + (fun o -> + o.option_name, o.option_help, + (try + o.option_class.to_value o.option_value + with + e -> + Printf.printf "Error while saving option \"%s\": %s" + (try List.hd o.option_name with + _ -> "???") + (Printexc.to_string e); + print_newline (); + StringValue "")) + (List.rev opfile.file_options)); + if not opfile.file_pruned then begin + Printf.fprintf oc + "\n(*\n The following options are not used (errors, obsolete, ...) \n*)\n"; + List.iter + (fun (name, value) -> + try + List.iter + (fun o -> + match o.option_name with + n :: _ -> if n = name then raise Exit + | _ -> ()) + opfile.file_options; + Printf.fprintf oc "%s = " (safe_string name); + save_value " " oc value; + Printf.fprintf oc "\n" + with + _ -> ()) + opfile.file_rc; + end; + close_out oc; + (try Sys.rename filename old_file with _ -> ()); + (try Sys.rename temp_file filename with _ -> ()) +;; + +let save_with_help opfile = + with_help := true; + begin try save opfile with + _ -> () + end; + with_help := false +;; + +let option_hook option f = option.option_hooks <- f :: option.option_hooks;; + +let class_hook option_class f = + option_class.class_hooks <- f :: option_class.class_hooks +;; + +let rec iter_order f list = + match list with + [] -> () + | v :: tail -> f v; iter_order f tail +;; + +let help oc opfile = + List.iter + (fun o -> + Printf.fprintf oc "OPTION \""; + begin match o.option_name with + [] -> Printf.fprintf oc "???" + | [name] -> Printf.fprintf oc "%s" name + | name :: tail -> + Printf.fprintf oc "%s" name; + iter_order (fun name -> Printf.fprintf oc ":%s" name) o.option_name + end; + Printf.fprintf oc "\" (TYPE \"%s\"): %s\n CURRENT: \n" + o.option_class.class_name o.option_help; + begin try + save_value "" oc (o.option_class.to_value o.option_value) + with + _ -> () + end; + Printf.fprintf oc "\n") + opfile.file_options; + flush oc +;; + + +let tuple2_to_value (c1, c2) (a1, a2) = + SmallList [to_value c1 a1; to_value c2 a2] +;; + +let value_to_tuple2 (c1, c2) v = + match v with + List [v1; v2] -> from_value c1 v1, from_value c2 v2 + | SmallList [v1; v2] -> from_value c1 v1, from_value c2 v2 + | List l | SmallList l -> + Printf.printf "list of %d" (List.length l); + print_newline (); + failwith "Options: not a tuple2 list option" + | _ -> failwith "Options: not a tuple2 option" +;; + +let tuple2_option p = + define_option_class "tuple2_option" (value_to_tuple2 p) (tuple2_to_value p) +;; + +let tuple3_to_value (c1, c2, c3) (a1, a2, a3) = + SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3] +;; +let value_to_tuple3 (c1, c2, c3) v = + match v with + List [v1; v2; v3] -> from_value c1 v1, from_value c2 v2, from_value c3 v3 + | SmallList [v1; v2; v3] -> + from_value c1 v1, from_value c2 v2, from_value c3 v3 + | _ -> failwith "Options: not a tuple3 option" +;; + +let tuple3_option p = + define_option_class "tuple3_option" (value_to_tuple3 p) (tuple3_to_value p) +;; + +let tuple4_to_value (c1, c2, c3, c4) (a1, a2, a3, a4) = + SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3; to_value c4 a4] +;; +let value_to_tuple4 (c1, c2, c3, c4) v = + match v with + List [v1; v2; v3; v4] -> + (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4) + | SmallList [v1; v2; v3; v4] -> + (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4) + | _ -> failwith "Options: not a tuple4 option" +;; + +let tuple4_option p = + define_option_class "tuple4_option" (value_to_tuple4 p) (tuple4_to_value p) +;; + + +let shortname o = String.concat ":" o.option_name;; +let get_class o = o.option_class;; +let get_help o = + let help = o.option_help in if help = "" then "No Help Available" else help +;; + + +let simple_options opfile = + let list = ref [] in + List.iter (fun o -> + match o.option_name with + [] | _ :: _ :: _ -> () + | [name] -> + match o.option_class.to_value o.option_value with + Module _ | SmallList _ | List _ -> + begin + match o.string_wrappers with + None -> () + | Some (to_string, from_string) -> + list := (name, to_string o.option_value) :: !list + end + | v -> + list := (name, value_to_string v) :: !list + ) opfile.file_options; + !list + +let get_option opfile name = + let rec iter name list = + match list with + [] -> raise Not_found + | o :: list -> + if o.option_name = name then o + else iter name list + in + iter [name] opfile.file_options + + +let set_simple_option opfile name v = + let o = get_option opfile name in + begin + match o.string_wrappers with + None -> + o.option_value <- o.option_class.from_value (string_to_value v); + | Some (_, from_string) -> + o.option_value <- from_string v + end; + exec_chooks o; exec_hooks o;; + +let get_simple_option opfile name = + let o = get_option opfile name in + match o.string_wrappers with + None -> + value_to_string (o.option_class.to_value o.option_value) + | Some (to_string, _) -> + to_string o.option_value + +let set_option_hook opfile name hook = + let o = get_option opfile name in + o.option_hooks <- hook :: o.option_hooks + +let set_string_wrappers o to_string from_string = + o.string_wrappers <- Some (to_string, from_string) + +let simple_args opfile = + List.map (fun (name, v) -> + ("-" ^ name), + Arg.String (set_simple_option opfile name), + (Printf.sprintf " : \t%s (current: %s)" + (get_option opfile name).option_help + v) + ) (simple_options opfile) -- cgit v1.2.3