1) unification hint now takes NG terms (as it should have been from the very

[helm.git] / helm / software / components / ng_kernel / nCicLibrary.ml

diff --git a/helm/software/components/ng_kernel/nCicLibrary.ml b/helm/software/components/ng_kernel/nCicLibrary.ml
index 414e5c5de1fad5296fefc5f9fdd8549fbb87ffe6..cc13dde6e306959c18ba48d0a64f4a992c1e7012 100644 (file)
--- a/helm/software/components/ng_kernel/nCicLibrary.ml
+++ b/helm/software/components/ng_kernel/nCicLibrary.ml
@@ -11,7 +11,6 @@
 
 (* $Id$ *)
 
-exception ObjectNotFound of string Lazy.t
 exception LibraryOutOfSync of string Lazy.t
 
 type timestamp =
@@ -60,11 +59,30 @@ let serialize ~baseuri dump =
  time_travel time0
 ;;
 
+let refresh_uri uri = NUri.uri_of_string (NUri.string_of_uri uri);;
+
+let rec refresh_uri_in_term =
+ function
+    NCic.Const (NReference.Ref (u,spec)) ->
+     NCic.Const (NReference.reference_of_spec (refresh_uri u) spec)
+  | t -> NCicUtils.map (fun _ _ -> ()) () (fun _ -> refresh_uri_in_term) t
+;;
+
+let refresh_uri_in_obj (uri,height,metasenv,subst,obj_kind) =
+ assert (metasenv = []);
+ assert (subst = []);
+ uri,height,metasenv,subst,
+  NCicUntrusted.map_obj_kind refresh_uri_in_term obj_kind
+;;
+
 module type Serializer =
  sig
   type status
   type obj
-  val register: string -> ('a -> status -> status) -> ('a -> obj)
+  val register:
+   string ->
+    ('a -> refresh_uri_in_term:(NCic.term -> NCic.term) -> status -> status) ->
+    ('a -> obj)
   val serialize: baseuri:NUri.uri -> obj list -> unit
   val require: baseuri:NUri.uri -> status -> status
  end
@@ -72,7 +90,7 @@ module type Serializer =
 module Serializer(S: sig type status end) =
  struct
   type status = S.status
-  type obj = Obj.t
+  type obj = string * Obj.t
 
   let require1 = ref (fun _ -> assert false (* unknown data*))
   let already_registered = ref []
@@ -82,14 +100,17 @@ module Serializer(S: sig type status end) =
    already_registered := tag :: !already_registered;
    require1 :=
     (fun (tag',data) as x ->
-     if tag=tag' then Obj.magic require data else Obj.magic !require1 x);
-   Obj.magic (fun x -> tag,x)
+     if tag=tag' then
+      require (Obj.magic data) ~refresh_uri_in_term
+     else
+      !require1 x);
+   (fun x -> tag,Obj.repr x)
 
   let serialize = serialize
 
   let require ~baseuri status =
    let dump = require0 ~baseuri in
-    List.fold_right (Obj.magic !require1) dump status
+    List.fold_right !require1 dump status
 end
 
 let decompile ~baseuri =
@@ -97,11 +118,9 @@ let decompile ~baseuri =
  (* WE ARE NOT REMOVING ALL THE OBJECTS YET! *)
 ;;
 
-(* the miracles of Marshal... *)
 let fetch_obj uri =
  let obj = require0 ~baseuri:uri in
-  (* here we need to refresh the URIs! *)
-  obj
+  refresh_uri_in_obj obj
 ;;
 
 let resolve name =
@@ -109,7 +128,7 @@ let resolve name =
   HExtlib.filter_map
    (fun (_,name',nref) -> if name'=name then Some nref else None) !aliases
  with
-  Not_found -> raise (ObjectNotFound (lazy name))
+  Not_found -> raise (NCicEnvironment.ObjectNotFound (lazy name))
 ;;
 
 let aliases_of uri =
@@ -117,7 +136,7 @@ let aliases_of uri =
   HExtlib.filter_map
    (fun (uri',_,nref) -> if NUri.eq uri' uri then Some nref else None) !aliases
  with
-  Not_found -> raise (ObjectNotFound (lazy (NUri.string_of_uri uri)))
+  Not_found -> raise (NCicEnvironment.ObjectNotFound (lazy (NUri.string_of_uri uri)))
 ;;
 
 let add_obj u obj =
@@ -168,8 +187,11 @@ let get_obj u =
       List.iter (fun (u,_,_,_,_ as o) -> cache:= NUri.UriMap.add u o !cache) l;
       HExtlib.list_last l
     with CicEnvironment.Object_not_found u -> 
-      raise (ObjectNotFound 
+      raise (NCicEnvironment.ObjectNotFound 
                (lazy (NUri.string_of_uri (OCic2NCic.nuri_of_ouri u))))
 ;;
 
 let clear_cache () = cache := NUri.UriMap.empty;;
+
+NCicEnvironment.set_get_obj get_obj;;
+NCicPp.set_get_obj get_obj;;