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