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 (*let trust_obj = function uri -> false;;*)
  42
  43 type type_checked_obj =
  44    CheckedObj of Cic.obj     (* cooked obj *)
  45  | UncheckedObj of Cic.obj   (* uncooked obj to proof-check *)
  46 ;;
  47
  48
  49 exception AlreadyCooked of string;;
  50 exception CircularDependency of string;;
  51 exception CouldNotFreeze of string;;
  52 exception CouldNotUnfreeze of string;;
  53 exception Term_not_found of UriManager.uri;;
  54
  55 (* Cache that uses == instead of = for testing equality *)
  56 (* Invariant: an object is always in at most one of the *)
  57 (* following states: unchecked, frozen and cooked.      *)
  58 module Cache :
  59   sig
  60    val find_or_add_unchecked :
  61     UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
  62    val unchecked_to_frozen : UriManager.uri -> unit
  63    val frozen_to_cooked :
  64     uri:UriManager.uri -> unit
  65    val find_cooked : key:UriManager.uri -> Cic.obj
  66    val add_cooked : key:UriManager.uri -> Cic.obj -> unit
  67    val remove: UriManager.uri -> unit
  68
  69    val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
  70    val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
  71    val empty : unit -> unit
  72   end
  73 =
  74   struct
  75    module CacheOfCookedObjects :
  76     sig
  77      val mem  : UriManager.uri -> bool
  78      val find : UriManager.uri -> Cic.obj
  79      val add  : UriManager.uri -> Cic.obj -> unit
  80      val remove : UriManager.uri -> unit
  81
  82       (** (de)serialization of type checker cache *)
  83      val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
  84      val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
  85      val empty : unit -> unit
  86     end
  87    =
  88     struct
  89      module HashedType =
  90       struct
  91        type t = UriManager.uri
  92        let equal = UriManager.eq
  93        let hash = Hashtbl.hash
  94       end
  95      ;;
  96      module HT = Hashtbl.Make(HashedType);;
  97      let hashtable = HT.create 1009;;
  98      let mem uri =
  99       try
 100        HT.mem hashtable uri
 101       with
 102        Not_found -> false
 103      ;;
 104      let find uri = HT.find hashtable uri
 105      ;;
 106      let add uri obj =
 107       HT.add hashtable uri obj
 108      ;;
 109      let remove uri =
 110        if mem uri then
 111          HT.remove hashtable uri
 112        else
 113          raise (Term_not_found uri);
 114      ;;
 115
 116       (* used to hash cons uris on restore to grant URI structure unicity *)
 117      let restore_uris =
 118        let module C = Cic in
 119        let recons uri =
 120          UriManager.uri_of_string (UriManager.string_of_uri uri)
 121        in
 122        let rec restore_in_term =
 123          function
 124             (C.Rel _) as t -> t
 125           | C.Var (uri,exp_named_subst) ->
 126              let uri' = recons uri in
 127              let exp_named_subst' =
 128               List.map
 129                (function (uri,t) ->(recons uri,restore_in_term t)) exp_named_subst
 130              in
 131               C.Var (uri',exp_named_subst')
 132           | C.Meta (i,l) ->
 133              let l' =
 134               List.map
 135                (function
 136                    None -> None
 137                  | Some t -> Some (restore_in_term t)
 138                ) l
 139              in
 140               C.Meta(i,l')
 141           | C.Sort _ as t -> t
 142           | C.Implicit _ as t -> t
 143           | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
 144           | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
 145           | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
 146           | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
 147           | C.Appl l -> C.Appl (List.map restore_in_term l)
 148           | C.Const (uri,exp_named_subst) ->
 149              let uri' = recons uri in
 150              let exp_named_subst' =
 151               List.map
 152                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
 153              in
 154               C.Const (uri',exp_named_subst')
 155           | C.MutInd (uri,tyno,exp_named_subst) ->
 156              let uri' = recons uri in
 157              let exp_named_subst' =
 158               List.map
 159                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
 160              in
 161               C.MutInd (uri',tyno,exp_named_subst')
 162           | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
 163              let uri' = recons uri in
 164              let exp_named_subst' =
 165               List.map
 166                (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
 167              in
 168               C.MutConstruct (uri',tyno,consno,exp_named_subst')
 169           | C.MutCase (uri,i,outty,t,pl) ->
 170              C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
 171               List.map restore_in_term pl)
 172           | C.Fix (i, fl) ->
 173              let len = List.length fl in
 174              let liftedfl =
 175               List.map
 176                (fun (name, i, ty, bo) ->
 177                  (name, i, restore_in_term ty, restore_in_term bo))
 178                 fl
 179              in
 180               C.Fix (i, liftedfl)
 181           | C.CoFix (i, fl) ->
 182              let len = List.length fl in
 183              let liftedfl =
 184               List.map
 185                (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
 186                 fl
 187              in
 188               C.CoFix (i, liftedfl)
 189        in
 190        function
 191           C.Constant (name,bo,ty,params) ->
 192             let bo' =
 193               match bo with
 194                 None -> None
 195               | Some bo -> Some (restore_in_term bo)
 196             in
 197             let ty' = restore_in_term ty in
 198             let params' = List.map recons params in
 199             C.Constant (name, bo', ty', params')
 200         | C.CurrentProof (name,conjs,bo,ty,params) ->
 201             let conjs' =
 202               List.map
 203                 (function (i,hyps,ty) ->
 204                   (i,
 205                   List.map (function
 206                       None -> None
 207                     | Some (name,C.Decl t) ->
 208                         Some (name,C.Decl (restore_in_term t))
 209                     | Some (name,C.Def (bo,ty)) ->
 210                         let ty' =
 211                           match ty with
 212                             None -> None
 213                           | Some ty'' -> Some (restore_in_term ty'')
 214                         in
 215                         Some (name,C.Def (restore_in_term bo, ty'))) hyps,
 216                   restore_in_term ty))
 217                 conjs
 218             in
 219             let bo' = restore_in_term bo in
 220             let ty' = restore_in_term ty in
 221             let params' = List.map recons params in
 222             C.CurrentProof (name, conjs', bo', ty', params')
 223         | C.Variable (name,bo,ty,params) ->
 224             let bo' =
 225               match bo with
 226                 None -> None
 227               | Some bo -> Some (restore_in_term bo)
 228             in
 229             let ty' = restore_in_term ty in
 230             let params' = List.map recons params in
 231             C.Variable (name, bo', ty', params')
 232         | C.InductiveDefinition (tl,params,paramsno) ->
 233             let params' = List.map recons params in
 234             let tl' =
 235               List.map (function (name, inductive, ty, constructors) ->
 236                 name,
 237                 inductive,
 238                 restore_in_term ty,
 239                 (List.map
 240                   (function (name, ty) -> name, restore_in_term ty)
 241                   constructors))
 242                 tl
 243             in
 244             C.InductiveDefinition (tl', params', paramsno)
 245
 246      let dump_to_channel ?(callback = ignore) oc =
 247        HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable;
 248        Marshal.to_channel oc hashtable [] ;;
 249      let empty () = HT.clear hashtable ;;
 250      let restore_from_channel ?(callback = ignore) ic =
 251        let restored = Marshal.from_channel ic in
 252        empty ();
 253        HT.iter
 254         (fun k v ->
 255           callback (UriManager.string_of_uri k);
 256           HT.add hashtable
 257             (UriManager.uri_of_string (UriManager.string_of_uri k))
 258             (restore_uris v))
 259         restored
 260      ;;
 261
 262     end
 263    ;;
 264    let frozen_list = ref [];;
 265    let unchecked_list = ref [];;
 266
 267    let find_or_add_unchecked uri ~get_object_to_add =
 268     try
 269      List.assq uri !unchecked_list
 270     with
 271      Not_found ->
 272       if List.mem_assq uri !frozen_list then
 273        raise (CircularDependency (UriManager.string_of_uri uri))
 274       else
 275        if CacheOfCookedObjects.mem uri then
 276         raise (AlreadyCooked (UriManager.string_of_uri uri))
 277        else
 278         (* OK, it is not already frozen nor cooked *)
 279         let obj = get_object_to_add () in
 280          unchecked_list := (uri,obj)::!unchecked_list ;
 281          obj
 282    ;;
 283    let unchecked_to_frozen uri =
 284     try
 285      let obj = List.assq uri !unchecked_list in
 286       unchecked_list := List.remove_assq uri !unchecked_list ;
 287       frozen_list := (uri,obj)::!frozen_list
 288     with
 289      Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
 290    ;;
 291    let frozen_to_cooked ~uri =
 292     try
 293      let obj = List.assq uri !frozen_list in
 294       frozen_list := List.remove_assq uri !frozen_list ;
 295        CacheOfCookedObjects.add uri obj
 296     with
 297      Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
 298    ;;
 299    let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
 300    let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;;
 301    let remove uri =
 302      if (!unchecked_list <> []) || (!frozen_list <> []) then
 303        failwith "CicEnvironment.remove while type checking"
 304      else
 305        CacheOfCookedObjects.remove uri
 306    ;;
 307    let dump_to_channel = CacheOfCookedObjects.dump_to_channel;;
 308    let restore_from_channel = CacheOfCookedObjects.restore_from_channel;;
 309    let empty = CacheOfCookedObjects.empty;;
 310   end
 311 ;;
 312
 313 let dump_to_channel = Cache.dump_to_channel;;
 314 let restore_from_channel = Cache.restore_from_channel;;
 315 let empty = Cache.empty;;
 316
 317 let find_or_add_unchecked_to_cache uri =
 318  Cache.find_or_add_unchecked uri
 319   ~get_object_to_add:
 320    (function () ->
 321      let filename = Http_getter.getxml' uri in
 322      let bodyfilename =
 323       match UriManager.bodyuri_of_uri uri with
 324          None -> None
 325        | Some bodyuri ->
 326           try
 327            ignore (Http_getter.resolve' bodyuri) ;
 328            (* The body exists ==> it is not an axiom *)
 329            Some (Http_getter.getxml' bodyuri)
 330           with
 331            Http_getter_types.Key_not_found _ ->
 332             (* The body does not exist ==> we consider it an axiom *)
 333             None
 334      in
 335      let cleanup () =
 336        if cleanup_tmp then
 337         begin
 338          if Sys.file_exists filename then Unix.unlink filename ;
 339          match bodyfilename with
 340             Some f -> if Sys.file_exists f then Unix.unlink f
 341           | None -> ()
 342         end ;
 343       in
 344       CicUniv.directly_to_env_begin ();
 345       let obj =
 346         try
 347           CicParser.obj_of_xml filename bodyfilename
 348         with exn ->
 349           cleanup ();
 350           raise exn
 351       in
 352       CicUniv.directly_to_env_end ();
 353       cleanup ();
 354        obj
 355    )
 356 ;;
 357
 358 (* set_type_checking_info uri                               *)
 359 (* must be called once the type-checking of uri is finished *)
 360 (* The object whose uri is uri is unfreezed                 *)
 361 let set_type_checking_info uri =
 362  Cache.frozen_to_cooked uri
 363 ;;
 364
 365 (* is_type_checked uri                                                *)
 366 (* CSC: commento falso ed obsoleto *)
 367 (* returns a CheckedObj if the term has been type-checked             *)
 368 (* otherwise it freezes the term for type-checking and returns
 369  it *)
 370 (* set_type_checking_info must be called to unfreeze the term         *)
 371 let is_type_checked ?(trust=true) uri =
 372  try
 373   CheckedObj (Cache.find_cooked uri)
 374  with
 375   Not_found ->
 376    let obj = find_or_add_unchecked_to_cache uri in
 377     Cache.unchecked_to_frozen uri ;
 378     if trust && trust_obj uri then
 379      begin
 380       CicLogger.log (`Trusting uri) ;
 381       set_type_checking_info uri ;
 382       CheckedObj (Cache.find_cooked uri)
 383      end
 384     else
 385      UncheckedObj obj
 386 ;;
 387
 388 (* get_cooked_obj ~trust uri *)
 389 (* returns the object if it is already type-checked or if it can be *)
 390 (* trusted (if [trust] = true and the trusting function accepts it) *)
 391 (* Otherwise it raises Not_found                                    *)
 392 let get_cooked_obj ?(trust=true) uri =
 393  try
 394   Cache.find_cooked uri
 395  with Not_found ->
 396   if trust && trust_obj uri then
 397    begin
 398     match is_type_checked uri with
 399        CheckedObj obj -> obj
 400      | _ -> assert false
 401    end
 402   else
 403    begin
 404     prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ;
 405     raise Not_found
 406    end
 407 ;;
 408
 409 (* get_obj uri                                                                *)
 410 (* returns the cic object whose uri is uri. If the term is not just in cache, *)
 411 (* then it is parsed via CicParser.term_of_xml from the file whose name is    *)
 412 (* the result of Getter.getxml uri                                            *)
 413 let get_obj uri =
 414  try
 415   get_cooked_obj uri
 416  with
 417   Not_found ->
 418    find_or_add_unchecked_to_cache uri
 419 ;;
 420
 421 exception OnlyPutOfInductiveDefinitionsIsAllowed
 422
 423 let put_inductive_definition uri obj =
 424  match obj with
 425     Cic.InductiveDefinition _ -> Cache.add_cooked uri obj
 426   | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
 427 ;;
 428
 429 let in_cache uri =
 430  try
 431   ignore (Cache.find_cooked uri);true
 432  with Not_found -> false
 433 ;;
 434
 435 let add_type_checked_term uri obj =
 436   match obj with
 437   Cic.Constant (s,(Some bo),ty,ul) ->
 438     Cache.add_cooked ~key:uri obj
 439   | _ -> assert false
 440   Cache.add_cooked
 441 ;;
 442
 443 let remove_term = Cache.remove
 444