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