]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/cic_proof_checking/cicEnvironment.ml
use a dummy location when no location is provided
[helm.git] / helm / ocaml / cic_proof_checking / cicEnvironment.ml
1 (* Copyright (C) 2000, HELM Team.
2  * 
3  * This file is part of HELM, an Hypertextual, Electronic
4  * Library of Mathematics, developed at the Computer Science
5  * Department, University of Bologna, Italy.
6  * 
7  * HELM is free software; you can redistribute it and/or
8  * modify it under the terms of the GNU General Public License
9  * as published by the Free Software Foundation; either version 2
10  * of the License, or (at your option) any later version.
11  * 
12  * HELM is distributed in the hope that it will be useful,
13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with HELM; if not, write to the Free Software
19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 (******************************************************************************)
27 (*                                                                            *)
28 (*                               PROJECT HELM                                 *)
29 (*                                                                            *)
30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
31 (*                                 24/01/2000                                 *)
32 (*                                                                            *)
33 (* This module implements a trival cache system (an hash-table) for cic       *)
34 (* objects. Uses the getter (getter.ml) and the parser (cicParser.ml)         *)
35 (*                                                                            *)
36 (******************************************************************************)
37
38 let cleanup_tmp = true;;
39
40 let trust_obj = function uri -> true;;
41
42 type type_checked_obj =
43    CheckedObj of Cic.obj     (* cooked obj *)
44  | UncheckedObj of Cic.obj   (* uncooked obj to proof-check *)
45 ;;
46
47
48 exception AlreadyCooked of string;;
49 exception CircularDependency of string;;
50 exception CouldNotFreeze of string;;
51 exception CouldNotUnfreeze of string;;
52
53 (* Cache that uses == instead of = for testing equality *)
54 (* Invariant: an object is always in at most one of the *)
55 (* following states: unchecked, frozen and cooked.      *)
56 module Cache :
57   sig
58    val find_or_add_unchecked :
59     UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
60    val unchecked_to_frozen : UriManager.uri -> unit
61    val frozen_to_cooked :
62     uri:UriManager.uri -> unit
63    val find_cooked : key:UriManager.uri -> Cic.obj
64    val add_cooked : key:UriManager.uri -> Cic.obj -> unit
65
66    val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
67    val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
68    val empty : unit -> unit
69   end 
70 =
71   struct
72    module CacheOfCookedObjects :
73     sig
74      val mem  : UriManager.uri -> bool
75      val find : UriManager.uri -> Cic.obj
76      val add  : UriManager.uri -> Cic.obj -> unit
77
78       (** (de)serialization of type checker cache *)
79      val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
80      val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
81      val empty : unit -> unit
82     end
83    =
84     struct
85      module HashedType =
86       struct
87        type t = UriManager.uri
88        let equal = UriManager.eq
89        let hash = Hashtbl.hash
90       end
91      ;;
92      module HT = Hashtbl.Make(HashedType);;
93      let hashtable = HT.create 1009;;
94      let mem uri =
95       try
96        HT.mem hashtable uri
97       with
98        Not_found -> false
99      ;;
100      let find uri = HT.find hashtable uri
101      ;;
102      let add uri obj =
103       HT.add hashtable uri obj
104      ;;
105
106       (* used to hash cons uris on restore to grant URI structure unicity *)
107      let restore_uris =
108        let module C = Cic in
109        let recons uri =
110          UriManager.uri_of_string (UriManager.string_of_uri uri)
111        in
112        let rec restore_in_term =
113          function
114             (C.Rel _) as t -> t
115           | C.Var (uri,exp_named_subst) ->
116              let uri' = recons uri in
117              let exp_named_subst' =
118               List.map
119                (function (uri,t) ->(recons uri,restore_in_term t)) exp_named_subst
120              in
121               C.Var (uri',exp_named_subst')
122           | C.Meta (i,l) ->
123              let l' =
124               List.map
125                (function
126                    None -> None
127                  | Some t -> Some (restore_in_term t)
128                ) l
129              in
130               C.Meta(i,l')
131           | C.Sort _ as t -> t
132           | C.Implicit as t -> t
133           | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
134           | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
135           | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
136           | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
137           | C.Appl l -> C.Appl (List.map restore_in_term l)
138           | C.Const (uri,exp_named_subst) ->
139              let uri' = recons uri in
140              let exp_named_subst' = 
141               List.map
142                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
143              in
144               C.Const (uri',exp_named_subst')
145           | C.MutInd (uri,tyno,exp_named_subst) ->
146              let uri' = recons uri in
147              let exp_named_subst' = 
148               List.map
149                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
150              in
151               C.MutInd (uri',tyno,exp_named_subst')
152           | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
153              let uri' = recons uri in
154              let exp_named_subst' = 
155               List.map
156                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
157              in
158               C.MutConstruct (uri',tyno,consno,exp_named_subst')
159           | C.MutCase (uri,i,outty,t,pl) ->
160              C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
161               List.map restore_in_term pl)
162           | C.Fix (i, fl) ->
163              let len = List.length fl in
164              let liftedfl =
165               List.map
166                (fun (name, i, ty, bo) ->
167                  (name, i, restore_in_term ty, restore_in_term bo))
168                 fl
169              in
170               C.Fix (i, liftedfl)
171           | C.CoFix (i, fl) ->
172              let len = List.length fl in
173              let liftedfl =
174               List.map
175                (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
176                 fl
177              in
178               C.CoFix (i, liftedfl)
179        in
180        function
181           C.Constant (name,bo,ty,params) ->
182             let bo' =
183               match bo with
184                 None -> None
185               | Some bo -> Some (restore_in_term bo)
186             in
187             let ty' = restore_in_term ty in
188             let params' = List.map recons params in
189             C.Constant (name, bo', ty', params')
190         | C.CurrentProof (name,conjs,bo,ty,params) ->
191             let conjs' =
192               List.map
193                 (function (i,hyps,ty) ->
194                   (i,
195                   List.map (function
196                       None -> None
197                     | Some (name,C.Decl t) ->
198                         Some (name,C.Decl (restore_in_term t))
199                     | Some (name,C.Def (bo,ty)) ->
200                         let ty' =
201                           match ty with
202                             None -> None
203                           | Some ty'' -> Some (restore_in_term ty'')
204                         in
205                         Some (name,C.Def (restore_in_term bo, ty'))) hyps,
206                   restore_in_term ty))
207                 conjs
208             in
209             let bo' = restore_in_term bo in
210             let ty' = restore_in_term ty in
211             let params' = List.map recons params in
212             C.CurrentProof (name, conjs', bo', ty', params')
213         | C.Variable (name,bo,ty,params) ->
214             let bo' =
215               match bo with
216                 None -> None
217               | Some bo -> Some (restore_in_term bo)
218             in
219             let ty' = restore_in_term ty in
220             let params' = List.map recons params in
221             C.Variable (name, bo', ty', params')
222         | C.InductiveDefinition (tl,params,paramsno) ->
223             let params' = List.map recons params in
224             let tl' =
225               List.map (function (name, inductive, ty, constructors) ->
226                 name,
227                 inductive,
228                 restore_in_term ty,
229                 (List.map
230                   (function (name, ty) -> name, restore_in_term ty)
231                   constructors))
232                 tl
233             in
234             C.InductiveDefinition (tl', params', paramsno)
235
236      let dump_to_channel ?(callback = ignore) oc =
237        HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable;
238        Marshal.to_channel oc hashtable [] ;;
239      let empty () = HT.clear hashtable ;;
240      let restore_from_channel ?(callback = ignore) ic =
241        let restored = Marshal.from_channel ic in
242        empty ();
243        HT.iter
244         (fun k v ->
245           callback (UriManager.string_of_uri k);
246           HT.add hashtable
247             (UriManager.uri_of_string (UriManager.string_of_uri k))
248             (restore_uris v))
249         restored
250      ;;
251
252     end
253    ;;
254    let frozen_list = ref [];;
255    let unchecked_list = ref [];;
256
257    let find_or_add_unchecked uri ~get_object_to_add =
258     try
259      List.assq uri !unchecked_list
260     with
261      Not_found ->
262       if List.mem_assq uri !frozen_list then
263        raise (CircularDependency (UriManager.string_of_uri uri))
264       else
265        if CacheOfCookedObjects.mem uri then
266         raise (AlreadyCooked (UriManager.string_of_uri uri))
267        else
268         (* OK, it is not already frozen nor cooked *)
269         let obj = get_object_to_add () in
270          unchecked_list := (uri,obj)::!unchecked_list ;
271          obj
272    ;;
273    let unchecked_to_frozen uri =
274     try
275      let obj = List.assq uri !unchecked_list in
276       unchecked_list := List.remove_assq uri !unchecked_list ;
277       frozen_list := (uri,obj)::!frozen_list
278     with
279      Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
280    ;;
281    let frozen_to_cooked ~uri =
282     try
283      let obj = List.assq uri !frozen_list in
284       frozen_list := List.remove_assq uri !frozen_list ;
285        CacheOfCookedObjects.add uri obj
286     with
287      Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
288    ;;
289    let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
290    let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;;
291
292    let dump_to_channel = CacheOfCookedObjects.dump_to_channel;;
293    let restore_from_channel = CacheOfCookedObjects.restore_from_channel;;
294    let empty = CacheOfCookedObjects.empty;;
295   end
296 ;;
297
298 let dump_to_channel = Cache.dump_to_channel;;
299 let restore_from_channel = Cache.restore_from_channel;;
300 let empty = Cache.empty;;
301
302 let find_or_add_unchecked_to_cache uri =
303  Cache.find_or_add_unchecked uri
304   ~get_object_to_add:
305    (function () ->
306      let filename = Getter.getxml uri in
307      let bodyfilename =
308       match UriManager.bodyuri_of_uri uri with
309          None -> None
310        | Some bodyuri ->
311           try
312            ignore (Getter.resolve bodyuri) ;
313            (* The body exists ==> it is not an axiom *)
314            Some (Getter.getxml bodyuri)
315           with
316            Getter.Unresolved ->
317             (* The body does not exist ==> we consider it an axiom *)
318             None
319      in
320       let obj = CicParser.obj_of_xml filename bodyfilename in
321        if cleanup_tmp then
322         begin
323          Unix.unlink filename ;
324          match bodyfilename with
325             Some f -> Unix.unlink f
326           | None -> ()
327         end ;
328        obj
329    )
330 ;;
331
332 (* set_type_checking_info uri                               *)
333 (* must be called once the type-checking of uri is finished *)
334 (* The object whose uri is uri is unfreezed                 *)
335 let set_type_checking_info uri =
336  Cache.frozen_to_cooked uri
337 ;;
338
339 (* is_type_checked uri                                                *)
340 (* CSC: commento falso ed obsoleto *)
341 (* returns a CheckedObj if the term has been type-checked             *)
342 (* otherwise it freezes the term for type-checking and returns
343  it *)
344 (* set_type_checking_info must be called to unfreeze the term         *)
345 let is_type_checked ?(trust=true) uri =
346  try
347   CheckedObj (Cache.find_cooked uri)
348  with
349   Not_found ->
350    let obj = find_or_add_unchecked_to_cache uri in
351     Cache.unchecked_to_frozen uri ;
352     if trust && trust_obj uri then
353      begin
354       CicLogger.log (`Trusting uri) ;
355       set_type_checking_info uri ;
356       CheckedObj (Cache.find_cooked uri)
357      end
358     else
359      UncheckedObj obj
360 ;;
361
362 (* get_cooked_obj ~trust uri *)
363 (* returns the object if it is already type-checked or if it can be *)
364 (* trusted (if [trust] = true and the trusting function accepts it) *)
365 (* Otherwise it raises Not_found                                    *)
366 let get_cooked_obj ?(trust=true) uri =
367  try
368   Cache.find_cooked uri
369  with Not_found ->
370   if trust && trust_obj uri then
371    begin
372     match is_type_checked uri with
373        CheckedObj obj -> obj
374      | _ -> assert false
375    end
376   else
377    begin
378     prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ;
379     raise Not_found
380    end
381 ;;
382
383 (* get_obj uri                                                                *)
384 (* returns the cic object whose uri is uri. If the term is not just in cache, *)
385 (* then it is parsed via CicParser.term_of_xml from the file whose name is    *)
386 (* the result of Getter.getxml uri                                            *)
387 let get_obj uri =
388  try
389   get_cooked_obj uri
390  with
391   Not_found ->
392    find_or_add_unchecked_to_cache uri
393 ;; 
394
395 exception OnlyPutOfInductiveDefinitionsIsAllowed
396
397 let put_inductive_definition uri obj =
398  match obj with
399     Cic.InductiveDefinition _ -> Cache.add_cooked uri obj
400   | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
401 ;;