module M = MathQL
module P = MQueryUtil
-module U = MQIUtil
-module C = MQIConn
+module C = MQIConn
(* external function specification ******************************************)
| Positive
| Any
-type eval_spec = {eval : M.query -> M.result;
- handle : C.handle
+type eval_spec = {eval : M.query -> M.result;
+ conn : C.handle
}
-type txt_out_spec = {out : string -> unit;
- path : M.path -> unit;
- query : M.query -> unit;
- result : M.result -> unit
- }
+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 -> txt_out_spec ->
+ body : eval_spec -> text_out_spec -> text_in_spec ->
M.path list -> M.query list -> M.result;
- txt_out : txt_out_spec ->
+ 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 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 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 out commit n x1 x2 =
- out "(" ; commit x1; out (" " ^ n ^ " "); commit x2; out ")"
+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_ out path commit p xl =
- path p; out " {"; P.flat_list out commit ", " xl; 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 out path commit p pl xl =
- path p; out " {"; P.flat_list out path ", " pl; out "} {";
- P.flat_list out commit ", " xl; 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 arity0 n r =
+let fun_arity0 p 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
+ 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 arity1 n f =
+let fun_arity1 p n f =
let arity_p = Const 0 in
let arity_s = Const 1 in
- let body eval _ _ = function
- | [x] -> f (eval x)
+ let body e _ _ _ = function
+ | [x] -> f (e.eval x)
| _ -> assert false
in
- let txt_out out _ commit _ = function
- | [x] -> out (n ^ " "); commit x
+ 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 arity2 n f =
+let fun_arity2 p 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)
+ let body e _ _ _ = function
+ | [x1; x2] -> f (e.eval x1) (e.eval x2)
| _ -> assert false
in
- let txt_out out _ commit _ = function
- | [x1; x2] -> out_txt2 out commit n x1 x2
+ 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}
-let false_fun = arity0 "false" U.mql_false
+(* external functions interface *********************************************)
-let true_fun = arity0 "true" U.mql_true
+let funs = Hashtbl.create 11
-let not_fun =
- let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
- arity1 "not" aux
+let fun_register path spec = Hashtbl.add funs path spec
-let count_fun =
- let aux r = [string_of_int (List.length r), []] in
- arity1 "count" aux
+let fun_get_spec path =
+ try Hashtbl.find funs path
+ with Not_found -> raise (NameError path)
-let diff_fun = arity2 "diff" U.mql_diff
+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 xor_fun = arity2 "xor" U.xor
+let fun_eval e o i p pl xl = (fun_get_spec p).body e o i pl xl
-let sub_fun = arity2 "sub" U.set_sub
+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
-let meet_fun = arity2 "meet" U.set_meet
+(* generator functions implementation ***************************************)
-let eq_fun = arity2 "eq" U.set_eq
+(* generator functions interface ********************************************)
-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 gens = Hashtbl.create 11
-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 gen_register path spec = Hashtbl.add gens path spec
-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 gen_get_spec path =
+ try Hashtbl.find gens path
+ with Not_found -> raise (NameError path)
-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 gen_arity p n = check_arity p n (gen_get_spec p).arity
-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)
-
-
-*)
+let gen_eval e p xl = (gen_get_spec p).code e xl
projects / helm.git / blobdiff