helm/ocaml/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