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 exception Found
  30
  31 module M = MathQL
  32 module P = MQueryUtil
  33 module C = MQIConn
  34 module U = MQIUtil
  35 module L = MQILib
  36 module F = MQueryIO
  37
  38 (* contexts *****************************************************************)
  39
  40 type svar_context = (M.svar * M.resource_set) list
  41
  42 type avar_context = (M.avar * M.resource) list
  43
  44 type group_context = (M.avar * M.attribute_group) list
  45
  46 type context = {svars: svar_context;
  47                 avars: avar_context;
  48                 groups: group_context (* auxiliary context *)
  49                }
  50
  51 (* execute ******************************************************************)
  52
  53 let execute h x =
  54    let warn q =
  55      if C.set h C.Warn then
  56      begin
  57         C.log h "MQIExecute: waring: reference to undefined variables: ";
  58         F.text_of_query (C.log h) "\n" q
  59      end
  60    in
  61    let proj v = List.map fst v in
  62    let rec eval_query c = function
  63       | M.Const r -> c, r
  64       | M.Dot i p ->
  65          begin
  66             try c, U.mql_subj (List.assoc p (List.assoc i c.groups))
  67             with Not_found -> warn (M.Dot i p); c, []
  68          end
  69       | M.Ex l y ->
  70          let rec ex_aux h = function
  71             | []        ->
  72                let d = {c with groups = h} in
  73                if snd (eval_query d y) = U.mql_false then () else raise Found
  74             | i :: tail ->
  75                begin
  76                   try
  77                      let (_, a) = List.assoc i c.avars in
  78                      let rec add_group = function
  79                         | []     -> ()
  80                         | g :: t -> ex_aux ((i, g) :: h) tail; add_group t
  81                      in
  82                      add_group a
  83                   with Not_found -> ()
  84                end
  85          in
  86          begin try ex_aux [] l; c, U.mql_false with Found -> c, U.mql_true end
  87       | M.SVar i ->
  88          begin
  89             try c, List.assoc i c.svars
  90             with Not_found -> warn (M.SVar i); c, []
  91          end
  92       | M.AVar i ->
  93          begin
  94             try c, [List.assoc i c.avars]
  95             with Not_found -> warn (M.AVar i); c, []
  96          end
  97       | M.Let (Some i) x1 x2 ->
  98          let d, r = eval_query c x1 in
  99          let d = {d with svars = P.add_assoc (i, r) d.svars} in
 100          eval_query d x2
 101       | M.Let None x1 x2 ->
 102          let d, r = eval_query c x1 in eval_query d x2
 103       | M.For k i x1 x2 ->
 104          let f = match k with
 105             | M.GenFJoin -> U.mql_union
 106             | M.GenFMeet -> U.mql_intersect
 107          in
 108          let rec for_aux (d, r) = match r with
 109             | []     -> d, []
 110             | h :: t ->
 111                let d = {d with avars = P.add_assoc (i, h) d.avars} in
 112                let d, r = eval_query d x2 in
 113                let d, s = for_aux (d, t) in
 114                d, f r s
 115          in
 116          for_aux (eval_query c x1)
 117       | M.While k x1 x2 ->
 118          let f = match k with
 119             | M.GenFJoin -> U.mql_union
 120             | M.GenFMeet -> U.mql_intersect
 121          in
 122          let rec while_aux (d, r) =
 123             let d, b = eval_query d x1 in
 124             if b = U.mql_false then d, r else
 125             let d, s = eval_query d x2 in
 126             while_aux (d, f r s)
 127          in
 128          while_aux (c, U.mql_false)
 129       | M.Add b z x ->
 130          let f = if b then U.mql_prod else U.set_union in
 131          let g a s = (fst a, f (snd a) (eval_grp c z)) :: s in
 132          let _, r = eval_query c x in
 133          c, List.fold_right g r []
 134       | M.Property q0 q1 q2 mc ct cfl el pat y ->
 135          let _, r = eval_query c y in
 136          let subj, mct =
 137             if q0 then [], (pat, q2 @ mc, r) else (q2 @ mc), (pat, [], r)
 138          in
 139          let eval_cons (pat, p, y) =
 140             let _, r = eval_query c y in (pat, q2 @ p, r)
 141          in
 142          let cons_true = mct :: List.map eval_cons ct in
 143          let cons_false = List.map (List.map eval_cons) cfl in
 144          let eval_exp (p, po) = (q2 @ p, po) in
 145          let exp = List.map eval_exp el in
 146          let t = P.start_time () in
 147          let r = MQIProperty.exec h q1 subj cons_true cons_false exp in
 148          let s = P.stop_time t in
 149          if C.set h C.Stat then
 150             C.log h (Printf.sprintf "Property: %s,%i\n" s (List.length r));
 151          c, r
 152       | M.Select i x y ->
 153          let rec select_aux (d, r) = match r with
 154             | []     -> d, []
 155             | h :: t ->
 156                let d = {d with avars = P.add_assoc (i, h) d.avars} in
 157                let d, r = eval_query d y in
 158                let d, s = select_aux (d, t) in
 159                if r = U.mql_false then d, s else d, (h :: s)
 160          in
 161          select_aux (eval_query c x)
 162       | M.Fun p pl xl ->
 163          let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
 164          c, L.fun_eval e (F.text_out_spec (C.log h) "\n") F.text_in_spec
 165             p pl xl
 166       | M.Gen p xl ->
 167          let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
 168          eval_query c (L.gen_eval e p xl)
 169    and eval_grp c = function
 170       | M.Attr gs ->
 171          let attr_aux g (p, y) =
 172             let _, r = eval_query c y in
 173             U.mql_union g [p, proj r]
 174          in
 175          let attr_auxs s l = U.set_union s [List.fold_left attr_aux [] l] in
 176          List.fold_left attr_auxs [] gs
 177       | M.From i ->
 178          try snd (List.assoc i c.avars)
 179          with Not_found -> warn (M.AVar i); []
 180    in
 181    let c = {svars = []; avars = []; groups = []} in
 182    let t = P.start_time () in
 183    let _, r = eval_query c x in
 184    let s = P.stop_time t in
 185    if C.set h C.Stat then
 186       C.log h (Printf.sprintf "MQIExecute: %s,%s\n" s
 187          (C.string_of_flags (C.flags h)));
 188    r