]> matita.cs.unibo.it Git - helm.git/blob - mathql/mathql_interpreter/mQueryInterpreter.ml
removed bad guard that was always false (assert false in the line above)
[helm.git] / mathql / mathql_interpreter / mQueryInterpreter.ml
1 (* Copyright (C) 2000, HELM Team.
2  * 
3  * This file is part of HELM, an Hypertextual, Electronic
4  * Library of Mathematics, developed at the Computer Science
5  * Department, University of Bologna, Italy.
6  * 
7  * HELM is free software; you can redistribute it and/or
8  * modify it under the terms of the GNU General Public License
9  * as published by the Free Software Foundation; either version 2
10  * of the License, or (at your option) any later version.
11  * 
12  * HELM is distributed in the hope that it will be useful,
13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with HELM; if not, write to the Free Software
19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 (*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
27  *)
28
29 (* $Id$ *)
30
31 (* contexts *****************************************************************)
32
33 type svar_context = (MathQL.svar * MathQL.resource_set) list
34
35 type avar_context = (MathQL.avar * MathQL.resource) list
36
37 type group_context = (MathQL.avar * MathQL.attribute_group) list
38
39 type vvar_context = (MathQL.vvar * MathQL.value) list
40
41 type context = {svars: svar_context;   
42                 avars: avar_context;   
43                 groups: group_context; (* auxiliary context *)
44                 vvars: vvar_context  
45                }
46
47 (* execute  *****************************************************************)
48
49 exception Found
50
51 module M = MathQL
52 module P = MQueryUtil 
53 module C = MQIConn
54 module U = MQIUtil
55
56 let execute h x =
57    let warn q = 
58      if C.set h C.Warn then 
59      begin
60         C.log h "MQIExecute: waring: reference to undefined variables: ";
61         P.text_of_query (C.log h) "\n" q
62      end
63    in
64    let rec eval_val c = function
65       | M.False -> U.mql_false
66       | M.True -> U.mql_true
67       | M.Const s -> [s]
68       | M.Set l -> U.iter (eval_val c) l
69       | M.Test (k,y1,y2) ->
70          let cand y1 y2 =
71             if eval_val c y1 = U.mql_false then U.mql_false else eval_val c y2
72          in
73          let cor y1 y2 =
74             let v1 = eval_val c y1 in
75             if v1 = U.mql_false then eval_val c y2 else v1
76          in
77          let h f y1 y2 = f (eval_val c y1) (eval_val c y2) in
78          let f = match k with
79             | M.And  -> cand
80             | M.Or   -> cor
81             | M.Xor  -> h U.xor
82             | M.Sub  -> h U.set_sub
83             | M.Meet -> h U.set_meet
84             | M.Eq   -> h U.set_eq
85             | M.Le   -> h U.le
86             | M.Lt   -> h U.lt
87          in
88          f y1 y2 
89       | M.Not y -> 
90          if eval_val c y = U.mql_false then U.mql_true else U.mql_false
91       | M.VVar i -> begin
92          try List.assoc i c.vvars 
93          with Not_found -> warn (M.Subj (M.VVar i)); [] end
94       | M.Dot (i,p) -> begin
95          try List.assoc p (List.assoc i c.groups) 
96          with Not_found -> warn (M.Subj (M.Dot (i,p))); [] end
97       | M.Proj (None,x) -> List.map (fun (r, _) -> r) (eval_query c x)
98       | M.Proj ((Some p),x) -> 
99          let proj_group_aux (q, v) = if q = p then v else [] in 
100          let proj_group a = U.iter proj_group_aux a in
101          let proj_set (_, g) = U.iter proj_group g in
102          U.iter proj_set (eval_query c x)
103       | M.Ex (l,y) -> 
104          let rec ex_aux h = function
105             | []        -> 
106                let d = {c with groups = h} in
107                if eval_val d y = U.mql_false then () else raise Found 
108             | i :: tail -> 
109                begin
110                   try 
111                      let (_, a) = List.assoc i c.avars in 
112                      let rec add_group = function
113                         | []     -> ()
114                         | g :: t -> ex_aux ((i, g) :: h) tail; add_group t 
115                      in
116                      add_group a
117                   with Not_found -> ()
118                end
119          in
120          (try ex_aux [] l; U.mql_false with Found -> U.mql_true)
121       | M.StatVal y ->
122          let t = P.start_time () in
123          let r = (eval_val c y) in
124          let s = P.stop_time t in
125          C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
126          r
127       | M.Count y -> [string_of_int (List.length (eval_val c y))]
128       | M.Align (s,y) -> U.iter (U.align s) (eval_val c y)
129    and eval_query c = function
130       | M.Empty -> [] 
131       | M.Subj x ->
132          List.map (fun s -> (s, [])) (eval_val c x)
133       | M.Log (_,b,x) ->
134          if b then begin
135             let t = P.start_time () in
136             P.text_of_query (C.log h) "\n" x;
137             let s = P.stop_time t in
138             if C.set h C.Times then 
139                C.log h (Printf.sprintf "Log source: %s\n" s);
140             eval_query c x
141          end else begin
142             let s = (eval_query c x) in
143             let t = P.start_time () in
144             P.text_of_result (C.log h) "\n" s; 
145             let r = P.stop_time t in
146             if C.set h C.Times then 
147                C.log h (Printf.sprintf "Log: %s\n" r);
148             s
149          end
150       | M.If (y,x1,x2) ->
151          if (eval_val c y) = U.mql_false 
152             then (eval_query c x2) else (eval_query c x1)
153       | M.Bin (k,x1,x2) ->
154          let f = match k with
155             | M.BinFJoin -> U.mql_union
156             | M.BinFMeet -> U.mql_intersect
157             | M.BinFDiff -> U.mql_diff
158          in
159          f (eval_query c x1) (eval_query c x2) 
160       | M.SVar i -> begin
161          try List.assoc i c.svars 
162          with Not_found -> warn (M.SVar i); [] end  
163       | M.AVar i -> begin
164          try [List.assoc i c.avars] 
165          with Not_found -> warn (M.AVar i); [] end
166       | M.LetSVar (i,x1,x2) ->
167          let d = {c with svars = U.set (i, eval_query c x1) c.svars} in
168          eval_query d x2
169       | M.LetVVar (i,y,x) ->
170          let d = {c with vvars = U.set (i, eval_val c y) c.vvars} in
171          eval_query d x
172       | M.For (k,i,x1,x2) ->
173          let f = match k with
174             | M.GenFJoin -> U.mql_union
175             | M.GenFMeet -> U.mql_intersect
176          in
177          let rec for_aux = function
178             | []     -> []
179             | h :: t ->
180                let d = {c with avars = U.set (i, h) c.avars} in
181                f (eval_query d x2) (for_aux t)
182          in
183          for_aux (eval_query c x1)
184       | M.Add (b,z,x) ->
185          let f = if b then U.mql_prod else U.set_union in
186          let g a s = (fst a, f (snd a) (eval_grp c z)) :: s in
187          List.fold_right g (eval_query c x) []
188       | M.Property (q0,q1,q2,mc,ct,cfl,el,pat,y) ->
189          let subj, mct = 
190             if q0 then [], (pat, q2 @ mc, eval_val c y)
191                   else (q2 @ mc), (pat, [], eval_val c y)  
192          in
193          let eval_cons (pat, p, y) = (pat, q2 @ p, eval_val c y) in
194          let cons_true = mct :: List.map eval_cons ct in
195          let cons_false = List.map (List.map eval_cons) cfl in
196          let eval_exp (p, po) = (q2 @ p, po) in
197          let exp = List.map eval_exp el in
198          let t = P.start_time () in
199          let r = MQIProperty.exec h q1 subj cons_true cons_false exp in 
200          let s = P.stop_time t in
201          if C.set h C.Times then 
202             C.log h (Printf.sprintf "Property: %s,%i\n" s (List.length r));
203          r 
204       | M.StatQuery x ->
205          let t = P.start_time () in
206          let r = (eval_query c x) in
207          let s = P.stop_time t in
208          C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
209          r
210       | M.Select (i,x,y) ->
211          let rec select_aux = function
212             | []     -> []
213             | h :: t ->
214                let d = {c with avars = U.set (i, h) c.avars} in
215                if eval_val d y = U.mql_false 
216                   then select_aux t else h :: select_aux t
217          in
218          select_aux (eval_query c x)
219       | M.Keep (b,l,x) -> 
220          let keep_path (p, v) t = 
221             if List.mem p l = b then t else (p, v) :: t in
222          let keep_grp a = List.fold_right keep_path a [] in
223          let keep_set a g = 
224             let kg = keep_grp a in
225             if kg = [] then g else kg :: g
226          in
227          let keep_av (s, g) = (s, List.fold_right keep_set g []) in
228          List.map keep_av (eval_query c x) 
229    and eval_grp c = function
230       | M.Attr gs ->
231          let attr_aux g (p, y) = U.mql_union g [(p, eval_val c y)] in
232          let attr_auxs s l = U.set_union s [List.fold_left attr_aux [] l] in
233          List.fold_left attr_auxs [] gs
234       | M.From i ->
235          try snd (List.assoc i c.avars) 
236          with Not_found -> warn (M.AVar i); []
237    in
238    let c = {svars = []; avars = []; groups = []; vvars = []} in
239    let t = P.start_time () in   
240    if C.set h C.Source then P.text_of_query (C.log h) "\n" x;
241    let r = eval_query c x in
242    if C.set h C.Result then P.text_of_result (C.log h) "\n" r;
243    let s = P.stop_time t in
244    if C.set h C.Times then 
245       C.log h (Printf.sprintf "MQIExecute: %s,%s\n" s 
246          (C.string_of_flags (C.flags h)));
247    r