X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=35726d4c966868d20465c9374fb21bac1d1c8d29;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=b0fcdab857f417474e1e3f8d3476e47a9c2b6862;hpb=cfda0acfce3f5e0b843bfe2b7ba7c371e5690db0;p=helm.git

diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml
index b0fcdab85..35726d4c9 100644
--- a/helm/ocaml/registry/helm_registry.ml
+++ b/helm/ocaml/registry/helm_registry.ml
@@ -117,10 +117,11 @@ let key_is_valid key =
   if not (Str.string_match valid_key_rex key 0) then
     raise (Malformed_key key)
 
-let set' registry ~key ~value =
-  debug_print (lazy (sprintf "Setting %s = %s" key value));
+let set' ?(replace=false) registry ~key ~value =
+  debug_print (lazy(sprintf "Setting (replace: %b) %s = %s" replace key value));
   key_is_valid key;
-  Hashtbl.add registry key value
+  let add_fun = if replace then Hashtbl.replace else Hashtbl.add in
+  add_fun registry key value
 
 let unset registry = Hashtbl.remove registry
 
@@ -163,8 +164,6 @@ let get registry key =
   in
   List.map strip_blanks (aux [] key)
 
-let set registry = set' registry
-
 let has registry key = Hashtbl.mem registry key
 
 let get_typed registry unmarshaller key =
@@ -172,7 +171,7 @@ let get_typed registry unmarshaller key =
   unmarshaller value
 
 let set_typed registry marshaller ~key ~value =
-  set registry ~key ~value:(marshaller value)
+  set' ~replace:true registry ~key ~value:(marshaller value)
 
 let get_opt registry unmarshaller key =
   try
@@ -187,7 +186,7 @@ let get_opt_default registry unmarshaller ~default key =
 let set_opt registry marshaller ~key ~value =
   match value with
   | None -> unset registry key
-  | Some value -> set registry ~key ~value:(marshaller value)
+  | Some value -> set' ~replace:true registry ~key ~value:(marshaller value)
 
 let get_list registry unmarshaller key =
   try
@@ -201,7 +200,10 @@ let get_pair registry fst_unmarshaller snd_unmarshaller key =
   | _ -> raise (Type_error "not a pair")
 
 let set_list registry marshaller ~key ~value =
-  List.iter (fun v -> set registry ~key ~value:(marshaller v)) value
+  Hashtbl.remove registry key;
+  List.iter
+    (fun v -> set' ~replace:false registry ~key ~value:(marshaller v))
+    value
 
 type xml_tree =
   | Cdata of string
@@ -286,7 +288,7 @@ let rec load_from_absolute ?path registry fname =
     | "section" -> pop_path ()
     | "key" ->
         let key = String.concat "." (List.rev !_path) in
-        set registry ~key ~value:!cdata;
+        set' registry ~key ~value:!cdata;
         cdata := "";
         in_key := false;
         pop_path ()
@@ -304,7 +306,7 @@ let rec load_from_absolute ?path registry fname =
   } in
   let xml_parser = XmlPushParser.create_parser callbacks in
   let backup = backup_registry registry in
-  if path = None then Hashtbl.clear registry;
+(*   if path = None then Hashtbl.clear registry; *)
   try
     XmlPushParser.parse xml_parser (`File fname)
   with exn ->
@@ -387,7 +389,7 @@ let ls registry prefix =
 let default_registry = Hashtbl.create magic_size
 
 let get key = singleton (get default_registry key)
-let set = set default_registry
+let set = set' ~replace:true default_registry
 let has = has default_registry
 let fold ?prefix ?interpolate f init =
   fold default_registry ?prefix ?interpolate f init
@@ -405,6 +407,7 @@ let set_list marshaller = set_list default_registry marshaller
 let unset = unset default_registry
 let save_to = save_to default_registry
 let load_from = load_from default_registry
+let clear () = Hashtbl.clear default_registry
 
 let get_string = get_typed string
 let get_int = get_typed int