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 ;;