helm/ocaml/mathql_interpreter/mQILib.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 module M = MathQL
  30 module P = MQueryUtil
  31 module U = MQIUtil
  32 module C = MQIConn
  33
  34 (* external function specification ******************************************)
  35
  36 type arity_t = Const of int
  37              | Positive
  38              | Any
  39
  40 type eval_spec = {eval   : M.query -> M.result;
  41                   handle : C.handle
  42                  }
  43
  44 type txt_out_spec = {out    : string -> unit;
  45                      path   : M.path -> unit;
  46                      query  : M.query -> unit;
  47                      result : M.result -> unit
  48                     }
  49
  50 type fun_spec = {arity_p : arity_t;
  51                  arity_s : arity_t;
  52                  body    : eval_spec -> txt_out_spec ->
  53                            M.path list -> M.query list -> M.result;
  54                  txt_out : txt_out_spec ->
  55                            M.path list -> M.query list -> unit
  56                 }
  57
  58 exception ArityError of M.path * arity_t * int
  59
  60 exception NameError of M.path
  61
  62 exception NumberError of M.result
  63
  64 (* external functions implementation ****************************************)
  65
  66 let int_of_set s =
  67    try match s with
  68       | [s, _] -> int_of_string s
  69       | _      -> raise (Failure "int_of_string")
  70    with Failure "int_of_string" -> raise (NumberError s)
  71
  72 let out_txt2 out commit n x1 x2 =
  73    out "(" ; commit x1; out (" " ^ n ^ " "); commit x2; out ")"
  74
  75 let out_txt_ out path commit p xl =
  76    path p; out " {"; P.flat_list out commit ", " xl; out "}"
  77
  78 let out_txt_full out path commit p pl xl =
  79    path p; out " {"; P.flat_list out path ", " pl; out "} {";
  80    P.flat_list out commit ", " xl; out "}"
  81
  82 let arity0 n r =
  83    let arity_p = Const 0 in
  84    let arity_s = Const 0 in
  85    let body _ _ _ _ = U.mql_true in
  86    let txt_out s _ _ = s.out n in
  87    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
  88
  89 let arity1 n f =
  90    let arity_p = Const 0 in
  91    let arity_s = Const 1 in
  92    let body eval _ _ = function
  93       | [x] -> f (eval x)
  94       | _   -> assert false
  95    in
  96    let txt_out out _ commit _ = function
  97       | [x] -> out (n ^ " "); commit x
  98       | _   -> assert false
  99    in
 100    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 101
 102 let arity2 n f =
 103    let arity_p = Const 0 in
 104    let arity_s = Const 2 in
 105    let body eval _ _ = function
 106       | [x1; x2] -> f (eval x1) (eval x2)
 107       | _        -> assert false
 108    in
 109    let txt_out out _ commit _ = function
 110       | [x1; x2] -> out_txt2 out commit n x1 x2
 111       | _        -> assert false
 112    in
 113    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 114
 115 let false_fun = arity0 "false" U.mql_false
 116
 117 let true_fun = arity0 "true" U.mql_true
 118
 119 let not_fun =
 120    let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
 121    arity1 "not" aux
 122
 123 let count_fun =
 124    let aux r = [string_of_int (List.length r), []] in
 125    arity1 "count" aux
 126
 127 let diff_fun = arity2 "diff" U.mql_diff
 128
 129 let xor_fun = arity2 "xor" U.xor
 130
 131 let sub_fun = arity2 "sub" U.set_sub
 132
 133 let meet_fun = arity2 "meet" U.set_meet
 134
 135 let eq_fun = arity2 "eq" U.set_eq
 136
 137 let le_fun =
 138    let le v1 v2 =
 139       if int_of_set v1 <= int_of_set v2 then U.mql_true else U.mql_false
 140    in
 141    arity2 "le" le
 142
 143 let lt_fun =
 144    let lt v1 v2 =
 145       if int_of_set v1 < int_of_set v2 then U.mql_true else U.mql_false
 146    in
 147    arity2 "lt" lt
 148
 149 let stat_fun =
 150    let arity_p = Const 0 in
 151    let arity_s = Const 1 in
 152    let body eval h _ = function
 153       | [x] ->
 154          let t = P.start_time () in
 155          let r = (eval x) in
 156          let s = P.stop_time t in
 157          C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
 158          r
 159       | _   -> assert false
 160    in
 161    let txt_out out _ commit _ = function
 162       | [x] -> out "stat "; commit x
 163       | _   -> assert false
 164    in
 165    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 166
 167 let align_fun =
 168    let aux l (v, g) =
 169       let c = String.length v in
 170       if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
 171    in
 172    let arity_p = Const 0 in
 173    let arity_s = Const 2 in
 174    let body eval _ _ = function
 175       | [y; x] ->
 176          let l = int_of_set (eval y) in
 177          U.mql_iter (aux l) (eval x)
 178       | _      -> assert false
 179    in
 180    let txt_out out _ commit _ = function
 181       | [y; x] -> out "align "; commit y; out " in "; commit x
 182       | _      -> assert false
 183    in
 184    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 185
 186 let if_fun =
 187    let arity_p = Const 0 in
 188    let arity_s = Const 3 in
 189    let body eval _ _ = function
 190       | [y; x1; x2] ->
 191          if (eval y) = U.mql_false then (eval x2) else (eval x1)
 192       | _           -> assert false
 193    in
 194    let txt_out out _ commit _ = function
 195       | [y; x1; x2] ->
 196          out "if "; commit y; out " then "; commit x1; out " else "; commit x2
 197       | _           -> assert false
 198    in
 199    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 200
 201 let intersect_fun =
 202    let rec iter f = function
 203       | []           -> assert false
 204       | [head]       -> f head
 205       | head :: tail -> U.mql_intersect (f head) (iter f tail)
 206    in
 207    let arity_p = Const 0 in
 208    let arity_s = Positive in
 209    let body eval _ _ xl = iter eval xl in
 210    let txt_out out path commit _ = function
 211       | []           -> assert false
 212       | [x1; x2]     -> out_txt2 out commit "intersect" x1 x2
 213       | xl           -> out_txt_ out path commit ["intersect"] xl
 214    in
 215    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 216
 217 let union_fun =
 218    let arity_p = Const 0 in
 219    let arity_s = Any in
 220    let body eval _ _ xl = U.mql_iter eval xl in
 221    let txt_out out path commit _ = function
 222       | [x1; x2]     -> out_txt2 out commit "union" x1 x2
 223       | xl           -> out_txt_ out path commit ["union"] xl
 224    in
 225    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 226
 227 let or_fun =
 228    let rec iter f = function
 229       | []           -> U.mql_false
 230       | head :: tail ->
 231          let r1 = f head in
 232          if r1 = U.mql_false then (iter f tail) else r1
 233    in
 234    let arity_p = Const 0 in
 235    let arity_s = Any in
 236    let body eval _ _ xl = iter eval xl in
 237    let txt_out out path commit _ = function
 238       | [x1; x2]     -> out_txt2 out commit "or" x1 x2
 239       | xl           -> out_txt_ out path commit ["or"] xl
 240    in
 241    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 242
 243 let and_fun =
 244    let rec iter f = function
 245       | []           -> U.mql_true
 246       | head :: tail ->
 247          if f head = U.mql_false then U.mql_false else (iter f tail)
 248    in
 249    let arity_p = Const 0 in
 250    let arity_s = Any in
 251    let body eval _ _ xl = iter eval xl in
 252    let txt_out out path commit _ = function
 253       | [x1; x2]     -> out_txt2 out commit "and" x1 x2
 254       | xl           -> out_txt_ out path commit ["and"] xl
 255    in
 256    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 257
 258 (* external functions interface *********************************************)
 259
 260 let get_spec = function
 261    | ["false"]     -> false_fun
 262    | ["true"]      -> true_fun
 263    | ["not"]       -> not_fun
 264    | ["count"]     -> count_fun
 265    | ["stat"]      -> stat_fun
 266    | ["diff"]      -> diff_fun
 267    | ["xor"]       -> xor_fun
 268    | ["sub"]       -> sub_fun
 269    | ["meet"]      -> meet_fun
 270    | ["eq"]        -> eq_fun
 271    | ["le"]        -> le_fun
 272    | ["lt"]        -> lt_fun
 273    | ["align"]     -> align_fun
 274    | ["if"]        -> if_fun
 275    | ["intersect"] -> intersect_fun
 276    | ["union"]     -> union_fun
 277    | ["or"]        -> or_fun
 278    | ["and"]       -> and_fun
 279    | p             -> raise (NameError p)
 280
 281 let check_arity p m n =
 282    let aux i = function
 283       | Const k when i = k  -> ()
 284       | Positive when i > 0 -> ()
 285       | Any                 -> ()
 286       | a                     -> raise (ArityError (p, a, i))
 287    in
 288    aux m (get_spec p).arity_p; aux n (get_spec p).arity_s
 289
 290 let exec eval h p pl xl = (get_spec p).body eval h pl xl
 291
 292 let txt_out out path commit p pl xl =
 293    try (get_spec p).txt_out out path commit pl xl
 294    with NameError q when q = p -> out_txt_full out path commit p pl xl
 295
 296 (*
 297       | M.Proj (Some p) x -> out "proj "; txt_path out p; out "of "; txt_set x
 298       | M.Log a b x       -> out "log "; txt_log a b; txt_set x
 299       | M.Keep b l x      -> out "keep "; txt_allbut b; txt_path_list l;
 300                              txt_set x
 301    let txt_path_list l = P.flat_list out (txt_path out) ", " l in
 302    let txt_log a b =
 303       if a then out "xml ";
 304       if b then out "source "
 305    in
 306    let txt_allbut b = if b then out "allbut " in
 307
 308       | M.Proj None x -> List.map (fun (r, _) -> (r, [])) (eval_query c x)
 309       | M.Proj (Some p) x ->
 310          let proj_group_aux (q, v) = if q = p then subj v else [] in
 311          let proj_group a = U.mql_iter proj_group_aux a in
 312          let proj_set (_, g) = U.mql_iter proj_group g in
 313          U.mql_iter proj_set (eval_query c x)
 314
 315
 316       | M.Log _ b x ->
 317          if b then begin
 318             let t = P.start_time () in
 319             F.text_of_query (C.log h) x "\n";
 320             let s = P.stop_time t in
 321             if C.set h C.Stat then
 322                C.log h (Printf.sprintf "Log source: %s\n" s);
 323             eval_query c x
 324          end else begin
 325             let s = (eval_query c x) in
 326             let t = P.start_time () in
 327             F.text_of_result (C.log h) s "\n";
 328             let r = P.stop_time t in
 329             if C.set h C.Stat then
 330                C.log h (Printf.sprintf "Log: %s\n" r);
 331             s
 332          end
 333
 334       | M.Keep b l x ->
 335          let keep_path (p, v) t =
 336             if List.mem p l = b then t else (p, v) :: t in
 337          let keep_grp a = List.fold_right keep_path a [] in
 338          let keep_set a g =
 339             let kg = keep_grp a in
 340             if kg = [] then g else kg :: g
 341          in
 342          let keep_av (s, g) = (s, List.fold_right keep_set g []) in
 343          List.map keep_av (eval_query c x)
 344
 345
 346 *)