(* Copyright (C) 2000, HELM Team.
 * 
 * This file is part of HELM, an Hypertextual, Electronic
 * Library of Mathematics, developed at the Computer Science
 * Department, University of Bologna, Italy.
 * 
 * HELM is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 * 
 * HELM is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with HELM; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 * MA  02111-1307, USA.
 * 
 * For details, see the HELM World-Wide-Web page,
 * http://cs.unibo.it/helm/.
 *)

(******************************************************************************)
(*                                                                            *)
(*                               PROJECT HELM                                 *)
(*                                                                            *)
(*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
(*                                 24/01/2000                                 *)
(*                                                                            *)
(* This module implements a trival cache system (an hash-table) for cic       *)
(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml)         *)
(*                                                                            *)
(******************************************************************************)

type type_checked_obj =
   CheckedObj of Cic.obj     (* cooked obj *)
 | UncheckedObj of Cic.obj   (* uncooked obj to proof-check *)
;;

exception NoFunctionProvided;;

let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);;

let set_cooking_function foo =
 cook_obj := foo
;;

exception AlreadyCooked of string;;
exception CircularDependency of string;;
exception CouldNotFreeze of string;;
exception CouldNotUnfreeze of string;;

(* Cache that uses == instead of = for testing equality *)
(* Invariant: an object is always in at most one of the *)
(* following states: unchecked, frozen and cooked.      *)
module Cache :
  sig
   val find_or_add_unchecked :
    UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
   val unchecked_to_frozen : UriManager.uri -> unit
   val frozen_to_cooked :
    uri:UriManager.uri ->
    cooking_procedure:
     (object_to_cook:Cic.obj ->
      add_cooked:(UriManager.uri * int-> Cic.obj -> unit)
      -> unit
     )
    -> unit
   val find_cooked : key:(UriManager.uri * int) -> Cic.obj
  end 
=
  struct
   module CacheOfCookedObjects :
    sig
     val mem  : UriManager.uri -> int -> bool
     val find : UriManager.uri -> int -> Cic.obj
     val add  : UriManager.uri -> int -> Cic.obj -> unit
    end
   =
    struct
     module HashedType =
      struct
       type t = UriManager.uri
       let equal = UriManager.eq
       let hash = Hashtbl.hash
      end
     ;;
     module HT = Hashtbl.Make(HashedType);;
     let hashtable = HT.create 1009;;
     let mem uri cookingsno =
      try
       let cooked_list =
        HT.find hashtable uri
       in
        List.mem_assq cookingsno !cooked_list
      with
       Not_found -> false
     ;;
     let find uri cookingsno =
      List.assq cookingsno !(HT.find hashtable uri)
     ;;
     let add uri cookingsno obj =
      let cooked_list =
       try
        HT.find hashtable uri
       with
        Not_found ->
         let newl = ref [] in
          HT.add hashtable uri newl ;
          newl
      in
       cooked_list := (cookingsno,obj)::!cooked_list
     ;;
    end
   ;;
   let frozen_list = ref [];;
   let unchecked_list = ref [];;

   let find_or_add_unchecked uri ~get_object_to_add =
    try
     List.assq uri !unchecked_list
    with
     Not_found ->
      if List.mem_assq uri !frozen_list then
       raise (CircularDependency (UriManager.string_of_uri uri))
      else
       if CacheOfCookedObjects.mem uri 0 then
        raise (AlreadyCooked (UriManager.string_of_uri uri))
       else
        (* OK, it is not already frozen nor cooked *)
        let obj = get_object_to_add () in
         unchecked_list := (uri,obj)::!unchecked_list ;
         obj
   ;;
   let unchecked_to_frozen uri =
    try
     let obj = List.assq uri !unchecked_list in
      unchecked_list := List.remove_assq uri !unchecked_list ;
      frozen_list := (uri,obj)::!frozen_list
    with
     Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
   ;;
   let frozen_to_cooked ~uri ~cooking_procedure =
    try
     let obj = List.assq uri !frozen_list in
      frozen_list := List.remove_assq uri !frozen_list ;
      cooking_procedure
       ~object_to_cook:obj
       ~add_cooked:(fun (uri,cookno) -> CacheOfCookedObjects.add uri cookno)
    with
     Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
   ;;
   let find_cooked ~key:(uri,cookingsno)= CacheOfCookedObjects.find uri cookingsno;;
  end
;;

(* get_cooked_obj uri                                                               *)
(* returns the cooked cic object whose uri is uri. The term must be present  *)
(* and cooked in cache                                                       *)
let get_cooked_obj uri cookingsno =
 Cache.find_cooked (uri,cookingsno)
;;

let find_or_add_unchecked_to_cache uri =
 Cache.find_or_add_unchecked uri
  ~get_object_to_add:
   (function () ->
     let filename = Getter.getxml uri in
      let obj = CicParser.obj_of_xml filename uri in
       obj
   )
;;

(* get_obj uri                                                                *)
(* returns the cic object whose uri is uri. If the term is not just in cache, *)
(* then it is parsed via CicParser.term_of_xml from the file whose name is    *)
(* the result of Getter.getxml uri                                            *)
let get_obj uri =
 try
  get_cooked_obj uri 0
 with
  Not_found ->
   find_or_add_unchecked_to_cache uri
;; 

(* is_type_checked uri                                                *)
(* CSC: commento falso ed obsoleto *)
(* returns a CheckedObj if the term has been type-checked             *)
(* otherwise it freezes the term for type-checking and returns
 it *)
(* set_type_checking_info must be called to unfreeze the term         *)
let is_type_checked uri cookingsno =
 try
  CheckedObj (Cache.find_cooked (uri,cookingsno))
 with
  Not_found ->
   let obj = find_or_add_unchecked_to_cache uri in
    Cache.unchecked_to_frozen uri ;
    UncheckedObj obj
;;

(* set_type_checking_info uri                               *)
(* must be called once the type-checking of uri is finished *)
(* The object whose uri is uri is unfreezed                 *)
let set_type_checking_info uri =
 Cache.frozen_to_cooked uri
  (fun ~object_to_cook:obj ~add_cooked ->
    (* let's cook the object at every level *)
    let obj' = CicSubstitution.undebrujin_inductive_def uri obj in
     add_cooked (uri,0) obj' ;
     let cooked_objs = !cook_obj obj' uri in
      let last_cooked_level = ref 0 in
      let last_cooked_obj = ref obj' in
       List.iter
        (fun (n,cobj) ->
          for i = !last_cooked_level + 1 to n do
           add_cooked (uri,i) !last_cooked_obj
          done ;
          add_cooked (uri,n + 1) cobj ;
          last_cooked_level := n + 1 ;
          last_cooked_obj := cobj
        ) cooked_objs ;
       for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do
        add_cooked (uri,i) !last_cooked_obj
       done
  )
;;