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 cff822316e45c311e4fdbd05e8430f84e3d62128..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 =
@@ -26,8 +25,6 @@ let cache = ref NUri.UriMap.empty;;
 
 let time_travel (sto,ali,cac) = storage := sto; aliases := ali; cache := cac;;
 
-let magic = 0;;
-
 let path_of_baseuri baseuri =
  let uri = NUri.string_of_uri baseuri in
  let path = String.sub uri 4 (String.length uri - 4) in
@@ -37,6 +34,18 @@ let path_of_baseuri baseuri =
   path ^ ".ng"
 ;;
 
+let magic = 0;;
+
+let require0 ~baseuri =
+ let ch = open_in (path_of_baseuri baseuri) in
+ let mmagic,dump = Marshal.from_channel ch in
+  close_in ch;
+  if mmagic <> magic then
+   raise (LibraryOutOfSync (lazy "The library is out of sync with the implementation. Please recompile the library."))
+  else
+   dump
+;;
+
 let serialize ~baseuri dump =
  let ch = open_out (path_of_baseuri baseuri) in
  Marshal.to_channel ch (magic,dump) [Marshal.Closures];
@@ -47,29 +56,71 @@ let serialize ~baseuri dump =
     Marshal.to_channel ch (magic,obj) [];
     close_out ch
   ) !storage;
- time_travel time0;
+ time_travel time0
 ;;
 
-let require ~baseuri =
- let ch = open_in (path_of_baseuri baseuri) in
- let mmagic,dump = Marshal.from_channel ch in
-  close_in ch;
-  if mmagic <> magic then
-   raise (LibraryOutOfSync (lazy "The library is out of sync with the implementation. Please recompile the library."))
-  else
-   dump
+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 -> 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
+
+module Serializer(S: sig type status end) =
+ struct
+  type status = S.status
+  type obj = string * Obj.t
+
+  let require1 = ref (fun _ -> assert false (* unknown data*))
+  let already_registered = ref []
+
+  let register tag require =
+   assert (not (List.mem tag !already_registered));
+   already_registered := tag :: !already_registered;
+   require1 :=
+    (fun (tag',data) as 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 !require1 dump status
+end
+
 let decompile ~baseuri =
  Unix.unlink (path_of_baseuri baseuri)
  (* WE ARE NOT REMOVING ALL THE OBJECTS YET! *)
 ;;
 
-(* the miracles of Marshal... *)
 let fetch_obj uri =
- let obj = require ~baseuri:uri in
-  (* here we need to refresh the URIs! *)
-  obj
+ let obj = require0 ~baseuri:uri in
+  refresh_uri_in_obj obj
 ;;
 
 let resolve name =
@@ -77,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 =
@@ -85,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 =
@@ -136,9 +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;;