(* 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 C = MQIConn 
module U = MQIUtil

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

type arity_t = Const of int 
             | Positive
	     | Any

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

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

type text_in_spec = {result_in : Lexing.lexbuf -> M.result}

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

type gen_spec = {arity : arity_t;
                 code  : eval_spec -> M.query list -> M.query
                }

exception ArityError of M.path * arity_t * int

exception NameError of M.path

exception NumberError of M.result

type std_text_out_spec = {s_out    : string -> unit;
                          s_path   : M.path -> unit;
	 	          s_query  : M.query -> unit;
		          s_result : M.result -> unit
}

let check_arity p i = function 
   | Const k when i = k  -> ()
   | Positive when i > 0 -> ()
   | Any                 -> ()
   | a                   -> raise (ArityError (p, a, i))

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

let std o = 
   {s_out = o.out; s_path = o.path o.out; 
    s_query = o.query o.out ""; s_result = o.result o.out "\n"
   }

let out_txt2 o n x1 x2 =
   o.s_out "(" ; o.s_query x1; o.s_out (" " ^ n ^ " "); o.s_query x2; o.s_out ")"

let out_txt_ o p xl =
   if p <> [] then begin o.s_path p; o.s_out " " end;
   o.s_out "{"; P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"    

let out_txt_full o p pl xl = 
   o.s_path p; o.s_out " {"; P.flat_list o.s_out o.s_path ", " pl; o.s_out "} {";
   P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"    

let fun_arity0 p n r =
   let arity_p = Const 0 in
   let arity_s = Const 0 in
   let body _ _ _ _ _ = r in
   let txt_out o _ _ = 
      if n = "" then out_txt_full (std o) p [] [] else (std o).s_out n
   in
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let fun_arity1 p n f =
   let arity_p = Const 0 in
   let arity_s = Const 1 in
   let body e _ _ _ = function
      | [x] -> f (e.eval x)
      | _   -> assert false
   in
   let txt_out o _ = function
      | [x] ->
         let o = std o in
         if n = "" then out_txt_full o p [] [x] else
	 begin o.s_out (n ^ " "); o.s_query x end
      | _   -> assert false
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

let fun_arity2 p n f =
   let arity_p = Const 0 in
   let arity_s = Const 2 in
   let body e _ _ _ = function
      | [x1; x2] -> f (e.eval x1) (e.eval x2)
      | _        -> assert false
   in
   let txt_out o _ = function
      | [x1; x2] -> 
         let o = std o in
	 if n = "" then out_txt_full o p [] [x1; x2] else out_txt2 o n x1 x2 
      | _        -> assert false
   in   
   {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}

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

let funs = Hashtbl.create 11

let fun_register path spec = Hashtbl.add funs path spec 

let fun_get_spec path =
   try Hashtbl.find funs path
   with Not_found -> raise (NameError path) 
   
let fun_arity p m n =
   check_arity p m (fun_get_spec p).arity_p; 
   check_arity p n (fun_get_spec p).arity_s 

let fun_eval e o i p pl xl = (fun_get_spec p).body e o i pl xl

let fun_txt_out o p pl xl =
   try (fun_get_spec p).txt_out o pl xl 
   with NameError q when q = p -> out_txt_full (std o) p pl xl

(* generator functions implementation ***************************************)

(* generator functions interface ********************************************)

let gens = Hashtbl.create 11

let gen_register path spec = Hashtbl.add gens path spec 

let gen_get_spec path =
   try Hashtbl.find gens path
   with Not_found -> raise (NameError path) 

let gen_arity p n = check_arity p n (gen_get_spec p).arity 

let gen_eval e p xl = (gen_get_spec p).code e xl