(* 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)         *)
(*                                                                            *)
(******************************************************************************)

let cleanup_tmp = true;;

let trust_obj = function uri -> true;;
(*let trust_obj = function uri -> false;;*)

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


exception AlreadyCooked of string;;
exception CircularDependency of string;;
exception CouldNotFreeze of string;;
exception CouldNotUnfreeze of string;;
exception Term_not_found of UriManager.uri;;

(* 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 -> unit
   val find_cooked : key:UriManager.uri -> Cic.obj
   val add_cooked : key:UriManager.uri -> Cic.obj -> unit
   val remove: UriManager.uri -> unit

   val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
   val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
   val empty : unit -> unit
  end 
=
  struct
   module CacheOfCookedObjects :
    sig
     val mem  : UriManager.uri -> bool
     val find : UriManager.uri -> Cic.obj
     val add  : UriManager.uri -> Cic.obj -> unit
     val remove : UriManager.uri -> unit

      (** (de)serialization of type checker cache *)
     val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
     val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
     val empty : unit -> 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 =
      try
       HT.mem hashtable uri
      with
       Not_found -> false
     ;;
     let find uri = HT.find hashtable uri
     ;;
     let add uri obj =
      HT.add hashtable uri obj
     ;;
     let remove uri =
       if mem uri then
         HT.remove hashtable uri
       else
         raise (Term_not_found uri);
     ;;

      (* used to hash cons uris on restore to grant URI structure unicity *)
     let restore_uris =
       let module C = Cic in
       let recons uri =
         UriManager.uri_of_string (UriManager.string_of_uri uri)
       in
       let rec restore_in_term =
         function
            (C.Rel _) as t -> t
          | C.Var (uri,exp_named_subst) ->
             let uri' = recons uri in
             let exp_named_subst' =
              List.map
               (function (uri,t) ->(recons uri,restore_in_term t)) exp_named_subst
             in
              C.Var (uri',exp_named_subst')
          | C.Meta (i,l) ->
             let l' =
              List.map
               (function
                   None -> None
                 | Some t -> Some (restore_in_term t)
               ) l
             in
              C.Meta(i,l')
          | C.Sort _ as t -> t
          | C.Implicit _ as t -> t
          | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
          | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
          | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
          | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
          | C.Appl l -> C.Appl (List.map restore_in_term l)
          | C.Const (uri,exp_named_subst) ->
             let uri' = recons uri in
             let exp_named_subst' = 
              List.map
               (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
             in
              C.Const (uri',exp_named_subst')
          | C.MutInd (uri,tyno,exp_named_subst) ->
             let uri' = recons uri in
             let exp_named_subst' = 
              List.map
               (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
             in
              C.MutInd (uri',tyno,exp_named_subst')
          | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
             let uri' = recons uri in
             let exp_named_subst' = 
              List.map
               (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
             in
              C.MutConstruct (uri',tyno,consno,exp_named_subst')
          | C.MutCase (uri,i,outty,t,pl) ->
             C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
              List.map restore_in_term pl)
          | C.Fix (i, fl) ->
             let len = List.length fl in
             let liftedfl =
              List.map
               (fun (name, i, ty, bo) ->
                 (name, i, restore_in_term ty, restore_in_term bo))
                fl
             in
              C.Fix (i, liftedfl)
          | C.CoFix (i, fl) ->
             let len = List.length fl in
             let liftedfl =
              List.map
               (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
                fl
             in
              C.CoFix (i, liftedfl)
       in
       function
          C.Constant (name,bo,ty,params) ->
            let bo' =
              match bo with
                None -> None
              | Some bo -> Some (restore_in_term bo)
            in
            let ty' = restore_in_term ty in
            let params' = List.map recons params in
            C.Constant (name, bo', ty', params')
        | C.CurrentProof (name,conjs,bo,ty,params) ->
            let conjs' =
              List.map
                (function (i,hyps,ty) ->
                  (i,
                  List.map (function
                      None -> None
                    | Some (name,C.Decl t) ->
                        Some (name,C.Decl (restore_in_term t))
                    | Some (name,C.Def (bo,ty)) ->
                        let ty' =
                          match ty with
                            None -> None
                          | Some ty'' -> Some (restore_in_term ty'')
                        in
                        Some (name,C.Def (restore_in_term bo, ty'))) hyps,
                  restore_in_term ty))
                conjs
            in
            let bo' = restore_in_term bo in
            let ty' = restore_in_term ty in
            let params' = List.map recons params in
            C.CurrentProof (name, conjs', bo', ty', params')
        | C.Variable (name,bo,ty,params) ->
            let bo' =
              match bo with
                None -> None
              | Some bo -> Some (restore_in_term bo)
            in
            let ty' = restore_in_term ty in
            let params' = List.map recons params in
            C.Variable (name, bo', ty', params')
        | C.InductiveDefinition (tl,params,paramsno) ->
            let params' = List.map recons params in
            let tl' =
              List.map (function (name, inductive, ty, constructors) ->
                name,
                inductive,
                restore_in_term ty,
                (List.map
                  (function (name, ty) -> name, restore_in_term ty)
                  constructors))
                tl
            in
            C.InductiveDefinition (tl', params', paramsno)

     let dump_to_channel ?(callback = ignore) oc =
       HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable;
       Marshal.to_channel oc hashtable [] ;;
     let empty () = HT.clear hashtable ;;
     let restore_from_channel ?(callback = ignore) ic =
       let restored = Marshal.from_channel ic in
       empty ();
       HT.iter
        (fun k v ->
          callback (UriManager.string_of_uri k);
          HT.add hashtable
            (UriManager.uri_of_string (UriManager.string_of_uri k))
            (restore_uris v))
        restored
     ;;

    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 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 =
    try
     let obj = List.assq uri !frozen_list in
      frozen_list := List.remove_assq uri !frozen_list ;
       CacheOfCookedObjects.add uri obj
    with
     Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
   ;;
   let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
   let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;;
   let remove uri =
     if (!unchecked_list <> []) || (!frozen_list <> []) then
       failwith "CicEnvironment.remove while type checking"
     else
       CacheOfCookedObjects.remove uri
   ;;
   let dump_to_channel = CacheOfCookedObjects.dump_to_channel;;
   let restore_from_channel = CacheOfCookedObjects.restore_from_channel;;
   let empty = CacheOfCookedObjects.empty;;
  end
;;

let dump_to_channel = Cache.dump_to_channel;;
let restore_from_channel = Cache.restore_from_channel;;
let empty = Cache.empty;;

let find_or_add_unchecked_to_cache uri =
 Cache.find_or_add_unchecked uri
  ~get_object_to_add:
   (function () ->
     let filename = Http_getter.getxml' uri in
     let bodyfilename =
      match UriManager.bodyuri_of_uri uri with
         None -> None
       | Some bodyuri ->
          try
           ignore (Http_getter.resolve' bodyuri) ;
           (* The body exists ==> it is not an axiom *)
           Some (Http_getter.getxml' bodyuri)
          with
           Http_getter_types.Key_not_found _ ->
            (* The body does not exist ==> we consider it an axiom *)
            None
     in
     let cleanup () =
       if cleanup_tmp then
        begin
         if Sys.file_exists filename then Unix.unlink filename ;
         match bodyfilename with
            Some f -> if Sys.file_exists f then Unix.unlink f
          | None -> ()
        end ;
      in
      CicUniv.directly_to_env_begin ();
      let obj =
        try
          CicParser.obj_of_xml filename bodyfilename
        with exn ->
          cleanup ();
          raise exn
      in
      CicUniv.directly_to_env_end ();
      cleanup ();
       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
;;

(* 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 ?(trust=true) uri =
 try
  CheckedObj (Cache.find_cooked uri)
 with
  Not_found ->
   let obj = find_or_add_unchecked_to_cache uri in
    Cache.unchecked_to_frozen uri ;
    if trust && trust_obj uri then
     begin
      CicLogger.log (`Trusting uri) ;
      set_type_checking_info uri ;
      CheckedObj (Cache.find_cooked uri)
     end
    else
     UncheckedObj obj
;;

(* get_cooked_obj ~trust uri *)
(* returns the object if it is already type-checked or if it can be *)
(* trusted (if [trust] = true and the trusting function accepts it) *)
(* Otherwise it raises Not_found                                    *)
let get_cooked_obj ?(trust=true) uri =
 try
  Cache.find_cooked uri
 with Not_found ->
  if trust && trust_obj uri then
   begin
    match is_type_checked uri with
       CheckedObj obj -> obj
     | _ -> assert false
   end
  else
   begin
    prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ;
    raise Not_found
   end
;;

(* 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
 with
  Not_found ->
   find_or_add_unchecked_to_cache uri
;; 

exception OnlyPutOfInductiveDefinitionsIsAllowed

let put_inductive_definition uri obj =
 match obj with
    Cic.InductiveDefinition _ -> Cache.add_cooked uri obj
  | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
;;

let in_cache uri = 
 try
  ignore (Cache.find_cooked uri);true
 with Not_found -> false
;;

let add_type_checked_term uri obj =
  match obj with 
  Cic.Constant (s,(Some bo),ty,ul) ->
    Cache.add_cooked ~key:uri obj
  | _ -> assert false 
  Cache.add_cooked 
;;

let remove_term = Cache.remove