From: Stefano Zacchiroli Date: Mon, 24 May 2004 12:15:09 +0000 (+0000) Subject: added OO interface X-Git-Tag: V_0_0_9~11 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=f277b17863953c96c944ca5101394b6a726abc8c;p=helm.git added OO interface --- diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index ffe3b3a20..8e300797a 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -64,23 +64,25 @@ exception Type_error of string * string * string (* expected type, value, msg *) exception Parse_error of string * int * int * string (* file, line, col, msg *) exception Invalid_value of (string * string) * string (* key, value, descr *) +(* type validator_id = int - (* root XML tag: used by save_to, ignored by load_from *) -let root_tag = "helm_registry" - let get_next_validator_id = let next_id = ref 0 in fun () -> incr next_id; !next_id -let magic_size = 127 let validators = Hashtbl.create magic_size -let registry = Hashtbl.create magic_size +*) + + (* root XML tag: used by save_to, ignored by load_from *) +let root_tag = "helm_registry" + +let magic_size = 127 -let backup_registry () = Hashtbl.copy registry -let restore_registry backup = +let backup_registry registry = Hashtbl.copy registry +let restore_registry backup registry = Hashtbl.clear registry; Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup @@ -111,24 +113,26 @@ let key_is_valid key = if not (Str.string_match valid_key_rex key 0) then raise (Malformed_key key) +(* let value_is_valid ~key ~value = List.iter (fun (validator, descr) -> if not (validator value) then raise (Invalid_value ((key, value), descr))) (Hashtbl.find_all validators key) +*) let set' registry ~key ~value = debug_print (sprintf "Setting %s = %s" key value); key_is_valid key; - value_is_valid ~key ~value; +(* value_is_valid ~key ~value; *) Hashtbl.replace registry key value -let unset = Hashtbl.remove registry +let unset registry = Hashtbl.remove registry let env_var_of_key = Str.global_replace dot_rex "__" -let get key = +let get registry key = let rec aux stack key = key_is_valid key; if List.mem key stack then begin @@ -164,19 +168,23 @@ let get key = in aux [] key -let set = set' registry +let set registry = set' registry -let has key = Hashtbl.mem registry key +let has registry key = Hashtbl.mem registry key -let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) = - let getter key = - let value = get key in +let mk_get_set type_name + (from_string: string -> 'a) (to_string: 'a -> string) + = + let getter registry key = + let value = get registry key in try from_string value with exn -> raise (Type_error (type_name, value, Printexc.to_string exn)) in - let setter ~key ~value = set ~key ~value:(to_string value) in + let setter registry ~key ~value = + set registry ~key ~value:(to_string value) + in (getter, setter) let (get_string, set_string) = (get, set) @@ -185,23 +193,25 @@ let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float let (get_bool, set_bool) = mk_get_set "bool" bool_of_string string_of_bool let (get_string_list, set_string_list) = mk_get_set "string list" split merge -let get_opt getter key = +let get_opt registry getter key = try - Some (getter key) + Some (getter registry key) with Key_not_found _ -> None -let set_opt setter ~key ~value = +let set_opt registry setter ~key ~value = match value with - | None -> unset key - | Some value -> setter ~key ~value -let get_opt_default getter default key = - match get_opt getter key with + | None -> unset registry key + | Some value -> setter registry ~key ~value +let get_opt_default registry getter default key = + match get_opt registry getter key with | None -> default | Some v -> v +(* let add_validator ~key ~validator ~descr = let id = get_next_validator_id () in Hashtbl.add validators key (validator, descr); id +*) open Pxp_dtd open Pxp_document @@ -248,7 +258,7 @@ let save_to = in aux root sections in - fun fname -> + fun registry fname -> let xml_root = create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd "helm_registry" [] @@ -295,7 +305,7 @@ let load_from_absolute = | [] -> key | _ -> String.concat "." key_stack ^ "." ^ key in - fun fname -> + fun registry fname -> debug_print ("Loading configuration from " ^ fname); let document = parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec @@ -310,22 +320,22 @@ let load_from_absolute = | T_element "key" -> let key = n#required_string_attribute "name" in let value = n#data in - set ~key:(fold_key key_stack key) ~value + set registry ~key:(fold_key key_stack key) ~value | _ -> ()) with exn -> let (fname, line, pos) = n#position in raise (Parse_error (fname, line, pos, "Uncaught exception: " ^ Printexc.to_string exn))) in - let backup = backup_registry () in + let backup = backup_registry registry in Hashtbl.clear registry; try aux [] document#root with exn -> - restore_registry backup; + restore_registry backup registry; raise exn -let load_from ?path fname = +let load_from registry ?path fname = if Filename.is_relative fname then begin let no_file_found = ref true in let path = @@ -338,7 +348,7 @@ let load_from ?path fname = let conffile = dir ^ "/" ^ fname in if Sys.file_exists conffile then begin no_file_found := false; - load_from_absolute conffile + load_from_absolute registry conffile end) path; if !no_file_found then @@ -346,9 +356,9 @@ let load_from ?path fname = "Helm_registry.init: no configuration file named %s in [ %s ]" fname (String.concat "; " path)) end else - load_from_absolute fname + load_from_absolute registry fname -let fold ?prefix f init = +let fold registry ?prefix f init = match prefix with | None -> Hashtbl.fold (fun k v acc -> f acc k v) registry init | Some s -> @@ -360,15 +370,16 @@ let fold ?prefix f init = in fold_filter init (hashtbl_pairs registry) -let iter ?prefix f = fold ?prefix (fun _ k v -> f k v) () -let to_list ?prefix () = fold ?prefix (fun acc k v -> (k, v) :: acc) [] +let iter registry ?prefix f = fold registry ?prefix (fun _ k v -> f k v) () +let to_list registry ?prefix () = + fold registry ?prefix (fun acc k v -> (k, v) :: acc) [] -let ls prefix = +let ls registry prefix = let prefix = prefix ^ "." in let prefix_len = String.length prefix in let key_matches = starts_with prefix in let matching_keys = (* collect matching keys' _postfixes_ *) - fold + fold registry (fun acc key _ -> if key_matches key then String.sub key prefix_len (String.length key - prefix_len) :: acc @@ -388,7 +399,86 @@ let ls prefix = in (list_uniq (List.sort Pervasives.compare sections), keys) - (* DEBUGGING ONLY *) - -let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry +(** {2 OO interface} *) + +class registry ?path fname = + object (self) + val _registry = Hashtbl.create magic_size + initializer load_from _registry ?path fname + method get = get _registry + method set = set _registry + method has = has _registry + method unset = unset _registry + method fold: + 'a. ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a + = + fold _registry + method iter = iter _registry + method to_list = to_list _registry + method ls = ls _registry + method get_string = get_string _registry + method get_int = get_int _registry + method get_float = get_float _registry + method get_bool = get_bool _registry + method get_string_list = get_string_list _registry + method set_string = set_string _registry + method set_int = set_int _registry + method set_float = set_float _registry + method set_bool = set_bool _registry + method set_string_list = set_string_list _registry + method get_opt: 'a. (string -> 'a) -> string -> 'a option = + fun getter key -> + try Some (getter key) with Key_not_found _ -> None + method set_opt: + 'a. (key:string -> value:'a -> unit) -> key:string -> value:'a option -> + unit + = + fun setter ~key ~value -> + match value with + | None -> self#unset key + | Some value -> setter ~key ~value + method get_opt_default: 'a. (string -> 'a) -> 'a -> string -> 'a = + fun getter default key -> + match self#get_opt getter key with + | None -> default + | Some v -> v + method save_to = save_to _registry +(* method load_from = load_from _registry *) + end + +(** {2 API implementation} + * functional methods above are wrapped so that they work on a default + * (imperative) registry*) + +let default_registry = Hashtbl.create magic_size + +let get = get default_registry +let set = set default_registry +let has = has default_registry +let fold ?prefix f init = fold default_registry ?prefix f init +let iter = iter default_registry +let to_list = to_list default_registry +let ls = ls default_registry +let get_string = get_string default_registry +let get_int = get_int default_registry +let get_float = get_float default_registry +let get_bool = get_bool default_registry +let get_string_list = get_string_list default_registry +let set_string = set_string default_registry +let set_int = set_int default_registry +let set_float = set_float default_registry +let set_bool = set_bool default_registry +let set_string_list = set_string_list default_registry +let get_opt getter key = try Some (getter key) with Key_not_found _ -> None +let set_opt setter ~key ~value = + match value with + | None -> unset default_registry key + | Some value -> setter ~key ~value +let unset = unset default_registry +let get_opt_default getter default key = + match get_opt getter key with + | None -> default + | Some v -> v +let save_to = save_to default_registry +let load_from = load_from default_registry diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli index 0f13a6162..a6b51271b 100644 --- a/helm/ocaml/registry/helm_registry.mli +++ b/helm/ocaml/registry/helm_registry.mli @@ -164,8 +164,9 @@ val get_opt_default: (* as get_opt with an additional default value *) * associated to the corresponding key are executed, if at least one of them * fails, Invalid_value exception will be raised *) -type validator_id +(* +type validator_id (** register a new validator for a given key * @param key key to which validator applies * @param validator a function applying to a value returning true if that @@ -176,7 +177,8 @@ type validator_id val add_validator: key:string -> validator:(string -> bool) -> descr:string -> validator_id -(* val remove_validator: validator_id -> unit *) +val remove_validator: validator_id -> unit +*) (** {2 Persistent configuration} * Validators aren't saved. load_from/save_to sequences don't preserve comments @@ -196,6 +198,38 @@ val save_to: string -> unit *) val load_from: ?path:string list -> string -> unit -(* DEBUGGING *) -(* val dump: unit -> unit *) +(** {2 OO interface} *) + + (** @see load_from *) +class registry: ?path: string list -> string -> + object + method get: string -> string + method set: key:string -> value:string -> unit + method has: string -> bool + method unset: string -> unit + method fold: ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a + method iter: ?prefix:string -> (string -> string -> unit) -> unit + method to_list: ?prefix:string -> unit -> (string * string) list + method ls: string -> string list * string list + method get_string: string -> string + method get_int: string -> int + method get_float: string -> float + method get_bool: string -> bool + method get_string_list: string -> string list + method set_string: key:string -> value:string -> unit + method set_int: key:string -> value:int -> unit + method set_float: key:string -> value:float -> unit + method set_bool: key:string -> value:bool -> unit + method set_string_list: key:string -> value:string list -> unit + method get_opt: + (string -> 'a) (* getter *) -> + string -> 'a option + method set_opt: + (key:string -> value:'a -> unit) (* setter *) -> + key:string -> value:'a option -> unit + method get_opt_default: + (string -> 'a) (* getter *) -> + 'a -> string -> 'a + method save_to: string -> unit + end