summaryrefslogtreecommitdiff
path: root/ide/utils/uoptions.ml
diff options
context:
space:
mode:
Diffstat (limited to 'ide/utils/uoptions.ml')
-rw-r--r--ide/utils/uoptions.ml772
1 files changed, 772 insertions, 0 deletions
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 "<string> : \t%s (current: %s)"
+ (get_option opfile name).option_help
+ v)
+ ) (simple_options opfile)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-26 15:37:52 +0000