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

(*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
 *)

module M = MathQL
module P = MQueryUtil 
module U = MQIUtil
module C = MQIConn

(* external function specification ******************************************)

type arity_t = Const of int 
             | Positive
	     | Any

type eval_spec = {eval   : M.query -> M.result;
                  handle : C.handle
		 }

type txt_out_spec = {out    : string -> unit;
                     path   : M.path -> unit;
		     query  : M.query -> unit;
		     result : M.result -> unit
		    }

type fun_spec = {arity_p : arity_t;
                 arity_s : arity_t;
                 body    : eval_spec -> txt_out_spec ->
		           M.path list -> M.query list -> M.result;
		 txt_out : txt_out_spec -> 
		           M.path list -> M.query list -> unit
		}

exception ArityError of M.path * arity_t * int

exception NameError of M.path

exception NumberError of M.result

(* external functions implementation ****************************************)

let int_of_set s =
   try match s with 
      | [s, _] -> int_of_string s
      | _      -> raise (Failure "int_of_string")
   with Failure "int_of_string" -> raise (NumberError s)

let out_txt2 out commit n x1 x2 =
   out "(" ; commit x1; out (" " ^ n ^ " "); commit x2; out ")"

let out_txt_ out path commit p xl = 
   path p; out " {"; P.flat_list out commit ", " xl; out "}"    

let out_txt_full out path commit p pl xl = 
   path p; out " {"; P.flat_list out path ", " pl; out "} {";
   P.flat_list out commit ", " xl; out "}"    

let arity0 n r =
   let arity_p = Const 0 in
   let arity_s = Const 0 in
   let body _ _ _ _ = U.mql_true in
   let txt_out s _ _ = s.out n in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let arity1 n f =
   let arity_p = Const 0 in
   let arity_s = Const 1 in
   let body eval _ _ = function
      | [x] -> f (eval x)
      | _   -> assert false
   in
   let txt_out out _ commit _ = function
      | [x] -> out (n ^ " "); commit x
      | _   -> assert false
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let arity2 n f =
   let arity_p = Const 0 in
   let arity_s = Const 2 in
   let body eval _ _ = function
      | [x1; x2] -> f (eval x1) (eval x2)
      | _        -> assert false
   in
   let txt_out out _ commit _ = function
      | [x1; x2] -> out_txt2 out commit n x1 x2
      | _        -> assert false
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let false_fun = arity0 "false" U.mql_false

let true_fun = arity0 "true" U.mql_true

let not_fun = 
   let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
   arity1 "not" aux 

let count_fun =
   let aux r = [string_of_int (List.length r), []] in
   arity1 "count" aux
   
let diff_fun = arity2 "diff" U.mql_diff

let xor_fun = arity2 "xor" U.xor

let sub_fun = arity2 "sub" U.set_sub

let meet_fun = arity2 "meet" U.set_meet

let eq_fun = arity2 "eq" U.set_eq

let le_fun = 
   let le v1 v2 =
      if int_of_set v1 <= int_of_set v2 then U.mql_true else U.mql_false
   in
   arity2 "le" le

let lt_fun = 
   let lt v1 v2 =
      if int_of_set v1 < int_of_set v2 then U.mql_true else U.mql_false
   in
   arity2 "lt" lt

let stat_fun =
   let arity_p = Const 0 in
   let arity_s = Const 1 in
   let body eval h _ = function
      | [x] -> 
         let t = P.start_time () in
	 let r = (eval x) in
	 let s = P.stop_time t in
         C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
	 r
      | _   -> assert false
   in
   let txt_out out _ commit _ = function
      | [x] -> out "stat "; commit x
      | _   -> assert false
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let align_fun =
   let aux l (v, g) =
      let c = String.length v in
      if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
   in   
   let arity_p = Const 0 in
   let arity_s = Const 2 in
   let body eval _ _ = function
      | [y; x] ->
         let l = int_of_set (eval y) in
         U.mql_iter (aux l) (eval x)      
      | _      -> assert false
   in
   let txt_out out _ commit _ = function
      | [y; x] -> out "align "; commit y; out " in "; commit x
      | _      -> assert false
   in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
   
let if_fun =
   let arity_p = Const 0 in
   let arity_s = Const 3 in
   let body eval _ _ = function
      | [y; x1; x2] ->
         if (eval y) = U.mql_false then (eval x2) else (eval x1)
      | _           -> assert false
   in
   let txt_out out _ commit _ = function
      | [y; x1; x2] ->
         out "if "; commit y; out " then "; commit x1; out " else "; commit x2
      | _           -> assert false
   in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let intersect_fun =
   let rec iter f = function
      | []           -> assert false
      | [head]       -> f head
      | head :: tail -> U.mql_intersect (f head) (iter f tail)  
   in
   let arity_p = Const 0 in
   let arity_s = Positive in
   let body eval _ _ xl = iter eval xl in
   let txt_out out path commit _ = function
      | []           -> assert false
      | [x1; x2]     -> out_txt2 out commit "intersect" x1 x2
      | xl           -> out_txt_ out path commit ["intersect"] xl  
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let union_fun = 
   let arity_p = Const 0 in
   let arity_s = Any in
   let body eval _ _ xl = U.mql_iter eval xl in
   let txt_out out path commit _ = function
      | [x1; x2]     -> out_txt2 out commit "union" x1 x2
      | xl           -> out_txt_ out path commit ["union"] xl  
   in      
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let or_fun = 
   let rec iter f = function
      | []           -> U.mql_false
      | head :: tail -> 
         let r1 = f head in
	 if r1 = U.mql_false then (iter f tail) else r1
   in
   let arity_p = Const 0 in
   let arity_s = Any in
   let body eval _ _ xl = iter eval xl in
   let txt_out out path commit _ = function
      | [x1; x2]     -> out_txt2 out commit "or" x1 x2
      | xl           -> out_txt_ out path commit ["or"] xl  
   in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let and_fun = 
   let rec iter f = function
      | []           -> U.mql_true
      | head :: tail -> 
         if f head = U.mql_false then U.mql_false else (iter f tail)
   in
   let arity_p = Const 0 in
   let arity_s = Any in
   let body eval _ _ xl = iter eval xl in
   let txt_out out path commit _ = function
      | [x1; x2]     -> out_txt2 out commit "and" x1 x2
      | xl           -> out_txt_ out path commit ["and"] xl  
   in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

(* external functions interface *********************************************)

let get_spec = function
   | ["false"]     -> false_fun
   | ["true"]      -> true_fun
   | ["not"]       -> not_fun
   | ["count"]     -> count_fun
   | ["stat"]      -> stat_fun
   | ["diff"]      -> diff_fun
   | ["xor"]       -> xor_fun
   | ["sub"]       -> sub_fun
   | ["meet"]      -> meet_fun
   | ["eq"]        -> eq_fun
   | ["le"]        -> le_fun
   | ["lt"]        -> lt_fun
   | ["align"]     -> align_fun
   | ["if"]        -> if_fun 
   | ["intersect"] -> intersect_fun
   | ["union"]     -> union_fun
   | ["or"]        -> or_fun
   | ["and"]       -> and_fun
   | p             -> raise (NameError p) 
   
let check_arity p m n =
   let aux i = function 
      | Const k when i = k  -> ()
      | Positive when i > 0 -> ()
      | Any                 -> ()
      | a                     -> raise (ArityError (p, a, i))
   in   
   aux m (get_spec p).arity_p; aux n (get_spec p).arity_s 

let exec eval h p pl xl = (get_spec p).body eval h pl xl

let txt_out out path commit p pl xl =
   try (get_spec p).txt_out out path commit pl xl 
   with NameError q when q = p -> out_txt_full out path commit p pl xl

(*
      | M.Proj (Some p) x -> out "proj "; txt_path out p; out "of "; txt_set x
      | M.Log a b x       -> out "log "; txt_log a b; txt_set x
      | M.Keep b l x      -> out "keep "; txt_allbut b; txt_path_list l;
                             txt_set x
   let txt_path_list l = P.flat_list out (txt_path out) ", " l in 
   let txt_log a b = 
      if a then out "xml ";
      if b then out "source "
   in
   let txt_allbut b = if b then out "allbut " in

      | M.Proj None x -> List.map (fun (r, _) -> (r, [])) (eval_query c x)
      | M.Proj (Some p) x -> 
         let proj_group_aux (q, v) = if q = p then subj v else [] in 
         let proj_group a = U.mql_iter proj_group_aux a in
         let proj_set (_, g) = U.mql_iter proj_group g in
         U.mql_iter proj_set (eval_query c x)


      | M.Log _ b x ->
         if b then begin
	    let t = P.start_time () in
	    F.text_of_query (C.log h) x "\n";
	    let s = P.stop_time t in
	    if C.set h C.Stat then 
	       C.log h (Printf.sprintf "Log source: %s\n" s);
	    eval_query c x
	 end else begin
            let s = (eval_query c x) in
	    let t = P.start_time () in
	    F.text_of_result (C.log h) s "\n"; 
	    let r = P.stop_time t in
	    if C.set h C.Stat then 
	       C.log h (Printf.sprintf "Log: %s\n" r);
	    s
	 end

      | M.Keep b l x -> 
         let keep_path (p, v) t = 
	    if List.mem p l = b then t else (p, v) :: t in
	 let keep_grp a = List.fold_right keep_path a [] in
         let keep_set a g = 
	    let kg = keep_grp a in
	    if kg = [] then g else kg :: g
	 in
	 let keep_av (s, g) = (s, List.fold_right keep_set g []) in
	 List.map keep_av (eval_query c x)


*)