diff options
Diffstat (limited to 'ide/utils/uoptions.ml')
| -rw-r--r-- | ide/utils/uoptions.ml | 772 |
1 files changed, 0 insertions, 772 deletions
diff --git a/ide/utils/uoptions.ml b/ide/utils/uoptions.ml deleted file mode 100644 index aa3b42cd..00000000 --- a/ide/utils/uoptions.ml +++ /dev/null @@ -1,772 +0,0 @@ -(**************************************************************************) -(* 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. - Flags.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 "Flags.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 "Flags. 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 "Flags. 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 "Flags. 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 "Flags. 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 "Flags. 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 - "Flags. not a list option (StringValue [%s])" s) - | FloatValue _ -> failwith "Flags. not a list option (FloatValue)" - | IntValue _ -> failwith "Flags. not a list option (IntValue)" - | Module _ -> failwith "Flags. 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 "Flags. 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 "Flags. not a tuple2 list option" - | _ -> failwith "Flags. 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 "Flags. 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 "Flags. 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 "<string> : \t%s (current: %s)" - (get_option opfile name).option_help - v) - ) (simple_options opfile) |