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

open Dbconn;;
open Union;;
open Intersect;;
open Meet;;
open Property;;
open Sub;;
open Context;;
open Diff;;
open Relation;;
open Func;;
open Pattern;;

exception SVarUnbound of string;;
exception RVarUnbound of string;;
exception VVarUnbound of string;;
exception PathUnbound of (string * string list);;

exception InvalidConnection
exception ConnectionFailed of string

exception BooleExpTrue
  
(* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)

let galax_char = 'G'
let stat_char = 'S'

let execute_aux log m x =
   let module M = MathQL in
   let module X = MQueryMisc in
let rec exec_set_exp c = function
     M.SVar svar ->
      (try
        List.assoc svar c.svars
       with Not_found ->
        raise (SVarUnbound svar))
   | M.RVar rvar ->
      (try
        [List.assoc rvar c.rvars]  
       with Not_found ->
        raise (RVarUnbound rvar))
   | M.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
   | M.Pattern vexp -> pattern_ex (exec_val_exp c vexp)
   | M.Intersect (sexp1, sexp2) ->    
        let before = X.start_time() in
	let rs1 = exec_set_exp c sexp1 in
	let rs2 = exec_set_exp c sexp2 in
        let res = intersect_ex rs1 rs2 in
        let diff = X.stop_time before in
        let ll1 = string_of_int (List.length rs1) in
        let ll2 = string_of_int (List.length rs2) in
	if String.contains m stat_char then
        log ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
         ": " ^ diff ^ "\n");
        res
   | M.Union (sexp1, sexp2) -> 
        let before = X.start_time () in
	let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
	let diff = X.stop_time before in
        if String.contains m stat_char then log ("UNION: " ^ diff ^ "\n");
        res		      	
   | M.LetSVar (svar, sexp1, sexp2) ->
        let before = X.start_time() in
        let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in 
	let res = exec_set_exp c1 sexp2 in
	if String.contains m stat_char then begin
	   log ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
	   log (X.stop_time before ^ "\n");
        end;
	res			
   | M.LetVVar (vvar, vexp, sexp) ->
        let before = X.start_time() in
	let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
	let res = exec_set_exp c1 sexp in
	if String.contains m stat_char then begin
	   log ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
           log (X.stop_time before ^ "\n");
        end;
	res
   | M.Relation (inv, rop, path, sexp, assl) -> 
        let before = X.start_time() in
	if String.contains m galax_char then begin
           let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
           if String.contains m stat_char then begin
              log  ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
              log (X.stop_time before ^ "\n")
          end;
          res
        end else begin 
           let res = relation_ex inv rop path (exec_set_exp c sexp) assl in
	   if String.contains m stat_char then begin 
	      log ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
              log (X.stop_time before ^ "\n")
           end;
           res
	end
   | M.Select (rvar, sexp, bexp) ->
        let before = X.start_time() in
        let rset = (exec_set_exp c sexp) in
        let rec select_ex =
         function
	    [] -> []
	  | r::tl -> 
             let c1 = upd_rvars c ((rvar,r)::c.rvars) in                      
              if (exec_boole_exp c1 bexp) then
               r::(select_ex tl)
              else
               select_ex tl
        in 
	let res = select_ex rset in
	if String.contains m stat_char then begin
	   log ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
	   log (X.stop_time before ^ "\n");
        end;
	res
   | M.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
   
(* valuta una MathQL.boole_exp e ritorna un boole *)

and exec_boole_exp c =
 function
    M.False      -> false
  | M.True       -> true
  | M.Not x      -> not (exec_boole_exp c x)
  | M.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
  | M.Or (x, y)  -> (exec_boole_exp c x) || (exec_boole_exp c y)
  | M.Sub (vexp1, vexp2) ->
     sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
  | M.Meet (vexp1, vexp2) ->
     meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
  | M.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
  | M.Ex l bexp -> 
     if l = [] then
      (exec_boole_exp c bexp)
     else
   	 let latt =
          List.map
           (fun uri -> 
             let (r,attl) =
              (try
                List.assoc uri c.rvars
               with Not_found -> assert false)
             in
              (uri,attl)
           ) l (*latt = l + attributi*)
	 in
	  try
	   let rec prod c =
            function
	       [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue 
	     | (uri,attl)::tail1 ->
                 (*per ogni el. di attl devo andare in ric. su tail1*)
                 let rec sub_prod attl =
                  match attl with
                     [] -> () 
                   | att::tail2 ->
                      let c1 = upd_groups c ((uri,att)::c.groups) in
                       prod c1 tail1; sub_prod tail2 
                 in	      
                  sub_prod attl 
   	   in
	    prod c latt;
            false
	  with BooleExpTrue -> true

(* valuta una MathQL.val_exp e ritorna un MathQL.value *)

and exec_val_exp c = function
     M.Const x -> let
        ol = List.sort compare x in 
   			let rec edup = function
			
			   [] -> [] 
			 | s::tl -> if tl <> [] then  
			                         if s = (List.hd tl) then edup tl
			                         else s::(edup tl)
				    else s::[]
	                in
			 edup ol
   | M.Record (rvar, path) ->
      (try
        List.assoc path
         (try
           List.assoc rvar c.groups
          with Not_found ->
           raise (RVarUnbound rvar))
       with Not_found ->
        raise (PathUnbound path))
   | M.VVar s ->
      (try
        List.assoc s c.vvars
       with Not_found ->
        raise (VVarUnbound s))
   | M.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
   | M.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
   | M.Property (inv, rop, path, vexp) -> property_ex rop path inv (exec_val_exp c vexp) 

(* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
in
   exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x 

(* new interface  ***********************************************************)

module type Callbacks = 
   sig
      val log : string -> unit (* logging function *)
   end

module Make (C: Callbacks) =
   struct
      
      let postgres = "P"
      let galax = "G"
      let stat = "S"
      let quiet = "Q"
      let warn = "W"

      let execute m x = execute_aux C.log m x

      let init m =
        let default_connection_string =
            "host=mowgli.cs.unibo.it dbname=helm_mowgli_new_schema user=helm"
	in
	let connection_string =
            try Sys.getenv "POSTGRESQL_CONNECTION_STRING"
            with Not_found -> default_connection_string 
        in
	if String.contains m galax_char then true else
	   try Dbconn.init connection_string; true
	   with ConnectionFailed s -> false

      let close m =
         if String.contains m galax_char then () else Dbconn.close ()
   
      let check m =
         if String.contains m galax_char then false else
	 try ignore (Dbconn.pgc ()); true with InvalidConnection -> false 
	 
   end