* 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 *)
+(* AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
+ *)
-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*)
+exception Found
+
+module U = AvsUtil
+module M = MathQL
+module I = M.I
+module P = MQueryUtil
+module C = MQIConn
+module L = MQILib
+module F = MQueryIO
+
+(* contexts *****************************************************************)
+
+type svar_context = (M.svar * M.result) list
+
+type avar_context = (M.avar * (string * M.group list)) list
+
+type group_context = (M.avar * M.group) list
+
+type context = {svars: svar_context;
+ avars: avar_context;
+ groups: group_context (* auxiliary context *)
+ }
+
+(* execute ******************************************************************)
+
+let execute h x =
+ let warn q =
+ if C.set h C.Warn then
+ begin
+ C.log h "MQIExecute: waring: reference to undefined variables: ";
+ F.text_of_query (C.log h) "\n" q
+ end
+ in
+ let rec eval_query c = function
+ | M.Const r ->
+ let aux2 s g = I.make s (eval_list c g) in
+ let aux (s, gl) =
+ if gl = [] then U.avs_of_string s else U.iter (aux2 s) gl
+ in
+ c, U.iter aux r
+ | M.Dot (i, p) ->
+ begin
+ try c, I.grp_read (List.assoc i c.groups) p
+ with Not_found -> warn (M.Dot (i, p)); c, I.empty
+ end
+ | M.Ex (l, y) ->
+ let rec ex_aux h = function
+ | [] ->
+ let d = {c with groups = h} in
+ if snd (eval_query d y) = U.val_false then () else raise Found
+ | i :: tail ->
+ begin
+ try
+ let (_, a) = List.assoc i c.avars in
+ let rec add_group = function
+ | [] -> ()
+ | g :: t -> ex_aux ((i, g) :: h) tail; add_group t
+ in
+ add_group a
+ with Not_found -> ()
+ end
+ in
+ begin try ex_aux [] l; c, U.val_false with Found -> c, U.val_true end
+ | M.SVar i ->
+ begin
+ try c, List.assoc i c.svars
+ with Not_found -> warn (M.SVar i); c, I.empty
+ end
+ | M.AVar i ->
+ begin
+ try
+ let s, gl = List.assoc i c.avars in
+ c, U.make_x s gl
+ with Not_found -> warn (M.AVar i); c, I.empty
+ end
+ | M.Let (Some i, x1, x2) ->
+ let d, r = eval_query c x1 in
+ let d = {d with svars = P.add_assoc (i, r) d.svars} in
+ eval_query d x2
+ | M.Let (None, x1, x2) ->
+ let d, r = eval_query c x1 in eval_query d x2
+ | M.For (k, i, x1, x2) ->
+ let f = match k with
+ | M.GenFJoin -> I.union
+ | M.GenFMeet -> I.intersect
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
+ let for_aux (d, r) s gl _ =
+ let d = {d with avars = P.add_assoc (i, (s, gl)) d.avars} in
+ let d, s = eval_query d x2 in
+ d, f r s
+ in
+ let d, r = eval_query c x1 in
+ I.x_iter for_aux (d, I.empty) (I.optimize r)
+ | M.While (k, x1, x2) ->
+ let f = match k with
+ | M.GenFJoin -> I.union
+ | M.GenFMeet -> I.intersect
+ in
+ let rec while_aux (d, r) =
+ let d, b = eval_query d x1 in
+ if b = U.val_false then d, r else
+ let d, s = eval_query d x2 in
+ while_aux (d, f r s)
+ in
+ while_aux (c, U.val_false)
+ | M.Add (b, z, x) ->
+ let f = if b then I.d_union else I.union in
+ let agl = eval_grp c z in
+ let aux r sj gl _ =
+ I.union r (f (U.make_x sj gl) (U.make_x sj agl))
+ in
+ let _, r = eval_query c x in
+ c, I.x_iter aux I.empty (I.optimize r)
+ | M.Property (q0, q1, q2, mc, ct, cfl, el, pat, y) ->
+ let _, r = eval_query c y in
+ let subj, mct =
+ if q0 then [], (pat, q2 @ mc, r) else (q2 @ mc), (pat, [], r)
+ in
+ let eval_cons (pat, p, y) =
+ let _, r = eval_query c y in (pat, q2 @ p, r)
+ in
+ let cons_true = mct :: List.map eval_cons ct in
+ let cons_false = List.map (List.map eval_cons) cfl in
+ let eval_exp (p, po) = (q2 @ p, po) in
+ let exp = List.map eval_exp el in
+ let t = P.start_time () in
+ let r = MQIProperty.exec h q1 subj cons_true cons_false exp in
+ let s = P.stop_time t in
+ if C.set h C.Stat then
+ C.log h (Printf.sprintf "Property: %s,%i\n" s (U.count r));
+ c, r
+ | M.Select (i, x, y) ->
+ let aux (d, r) sj gl _ =
+ let d = {d with avars = P.add_assoc (i, (sj, gl)) d.avars} in
+ let d, s = eval_query d y in
+ if s = U.val_false then d, r else d, (I.union r (U.make_x sj gl))
+ in
+ let d, r = eval_query c x in
+ I.x_iter aux (d, I.empty) (I.optimize r)
+ | M.Fun (p, pl, xl) ->
+ let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
+ c, L.fun_eval e (F.text_out_spec (C.log h) "\n") F.text_in_spec
+ p pl xl
+ | M.Gen (p, xl) ->
+ let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
+ eval_query c (L.gen_eval e p xl)
+ and eval_list c l =
+ let aux (p, y) =
+ let _, r = eval_query c y in
+ U.x_grp_make_x p r
+ in
+ U.grp_iter aux l
+ and eval_grp c = function
+ | M.Attr gs ->
+ let attr_auxs s l = I.grps_make s (eval_list c l) in
+ List.fold_left attr_auxs [] gs
+ | M.From i ->
+ try snd (List.assoc i c.avars)
+ with Not_found -> warn (M.AVar i); []
+ in
+ let c = {svars = []; avars = []; groups = []} in
+ let t = P.start_time () in
+ let _, r = eval_query c x in
+ let s = P.stop_time t in
+ if C.set h C.Stat then
+ C.log h (Printf.sprintf "MQIExecute: %s,%s\n" s
+ (C.string_of_flags (C.flags h)));
+ r