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 C = MQIConn
  32 module U = MQIUtil
  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                   conn : C.handle
  42                  }
  43
  44 type text_out_spec = {out    : string -> unit;
  45                       path   : (string -> unit) -> M.path -> unit;
  46                       query  : (string -> unit) -> string -> M.query -> unit;
  47                       result : (string -> unit) -> string -> M.result -> unit
  48                      }
  49
  50 type text_in_spec = {result_in : Lexing.lexbuf -> M.result}
  51
  52 type fun_spec = {arity_p : arity_t;
  53                  arity_s : arity_t;
  54                  body    : eval_spec -> text_out_spec -> text_in_spec ->
  55                            M.path list -> M.query list -> M.result;
  56                  txt_out : text_out_spec ->
  57                            M.path list -> M.query list -> unit
  58                 }
  59
  60 exception ArityError of M.path * arity_t * int
  61
  62 exception NameError of M.path
  63
  64 exception NumberError of M.result
  65
  66 type std_text_out_spec = {s_out    : string -> unit;
  67                           s_path   : M.path -> unit;
  68                           s_query  : M.query -> unit;
  69                           s_result : M.result -> unit
  70 }
  71
  72 (* external functions implementation ****************************************)
  73
  74 let std o =
  75    {s_out = o.out; s_path = o.path o.out;
  76     s_query = o.query o.out ""; s_result = o.result o.out "\n"
  77    }
  78
  79 type t = End
  80        | Space
  81        | Figure of int
  82        | Error
  83
  84 let my_int_of_string s =
  85    let l = String.length s in
  86    let get_t i =
  87       if i = l then End else
  88       match s.[i] with
  89          | ' ' | '\t' | '\r' | 'n' -> Space
  90          | '0' .. '9'              -> Figure (Char.code s.[i] - Char.code '0')
  91          | _                       -> Error
  92    in
  93    let rec aux i xv = match get_t i, xv with
  94       | Error, _
  95       | End, None        -> raise (Failure "int_of_string")
  96       | End, Some v      -> v
  97       | Space, xv        -> aux (succ i) xv
  98       | Figure f, None   -> aux (succ i) (Some f)
  99       | Figure f, Some v -> aux (succ i) (Some (10 * v + f))
 100    in
 101    aux 0 None
 102
 103 let int_of_set r =
 104    try match r with
 105       | [s, _] -> my_int_of_string s
 106       | _      -> raise (Failure "int_of_string")
 107    with Failure "int_of_string" -> raise (NumberError r)
 108
 109 let out_txt2 o n x1 x2 =
 110    o.s_out "(" ; o.s_query x1; o.s_out (" " ^ n ^ " "); o.s_query x2; o.s_out ")"
 111
 112 let out_txt_ o p xl =
 113    if p <> [] then begin o.s_path p; o.s_out " " end;
 114    o.s_out "{"; P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
 115
 116 let out_txt_full o p pl xl =
 117    o.s_path p; o.s_out " {"; P.flat_list o.s_out o.s_path ", " pl; o.s_out "} {";
 118    P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
 119
 120 let arity0 n r =
 121    let arity_p = Const 0 in
 122    let arity_s = Const 0 in
 123    let body _ _ _ _ _ = r in
 124    let txt_out o _ _ = (std o).s_out n in
 125    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 126
 127 let arity1 n f =
 128    let arity_p = Const 0 in
 129    let arity_s = Const 1 in
 130    let body e _ _ _ = function
 131       | [x] -> f (e.eval x)
 132       | _   -> assert false
 133    in
 134    let txt_out o _ = function
 135       | [x] -> let o = std o in o.s_out (n ^ " "); o.s_query x
 136       | _   -> assert false
 137    in
 138    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 139
 140 let arity2 n f =
 141    let arity_p = Const 0 in
 142    let arity_s = Const 2 in
 143    let body e _ _ _ = function
 144       | [x1; x2] -> f (e.eval x1) (e.eval x2)
 145       | _        -> assert false
 146    in
 147    let txt_out o _ = function
 148       | [x1; x2] -> let o = std o in out_txt2 o n x1 x2
 149       | _        -> assert false
 150    in
 151    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 152
 153 let false_fun b =
 154    let s = if b then "false" else "empty" in
 155    arity0 s U.mql_false
 156
 157 let true_fun = arity0 "true" U.mql_true
 158
 159 let not_fun =
 160    let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
 161    arity1 "!" aux
 162
 163 let count_fun =
 164    let aux r = [string_of_int (List.length r), []] in
 165    arity1 "#" aux
 166
 167 let peek_fun =
 168    let aux = function [] -> [] | hd :: _ -> [hd] in
 169    arity1 "peek" aux
 170
 171 let diff_fun = arity2 "diff" U.mql_diff
 172
 173 let xor_fun = arity2 "xor" U.xor
 174
 175 let sub_fun = arity2 "sub" U.set_sub
 176
 177 let meet_fun = arity2 "meet" U.set_meet
 178
 179 let eq_fun = arity2 "==" U.set_eq
 180
 181 let le_fun =
 182    let le v1 v2 =
 183       if int_of_set v1 <= int_of_set v2 then U.mql_true else U.mql_false
 184    in
 185    arity2 "<=" le
 186
 187 let lt_fun =
 188    let lt v1 v2 =
 189       if int_of_set v1 < int_of_set v2 then U.mql_true else U.mql_false
 190    in
 191    arity2 "<" lt
 192
 193 let stat_fun =
 194    let arity_p = Const 0 in
 195    let arity_s = Const 1 in
 196    let body e o _ _ = function
 197       | [x] ->
 198          let t = P.start_time () in
 199          let r = (e.eval x) in
 200          let s = P.stop_time t in
 201          o.out (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
 202          r
 203       | _   -> assert false
 204    in
 205    let txt_out o _ = function
 206       | [x] -> let o = std o in o.s_out "stat "; o.s_query x
 207       | _   -> assert false
 208    in
 209    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 210
 211 let log_fun xml src =
 212    let log_src e o x =
 213       let t = P.start_time () in o.s_query x;
 214       let s = P.stop_time t in
 215       if C.set e.conn C.Stat then o.s_out (Printf.sprintf "Log source: %s\n" s);
 216       e.eval x
 217    in
 218    let log_res e o x =
 219       let s = e.eval x in
 220       let t = P.start_time () in o.s_result s;
 221       let r = P.stop_time t in
 222       if C.set e.conn C.Stat then o.s_out (Printf.sprintf "Log: %s\n" r); s
 223    in
 224    let txt_log o =
 225       if xml then o.s_out "xml ";
 226       if src then o.s_out "source "
 227    in
 228    let arity_p = Const 0 in
 229    let arity_s = Const 1 in
 230    let body e o _ _ = function
 231       | [x] -> let o = std o in if src then log_src e o x else log_res e o x
 232       | _   -> assert false
 233    in
 234    let txt_out o _ = function
 235       | [x] -> let o = std o in o.s_out "log "; txt_log o; o.s_query x
 236       | _   -> assert false
 237    in
 238    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 239
 240 let render_fun =
 241    let arity_p = Const 0 in
 242    let arity_s = Const 1 in
 243    let body e o _ _ = function
 244       | [x] ->
 245          let rs = ref "" in
 246          let out s = rs := ! rs ^ s in
 247          o.result out " " (e.eval x);
 248          [! rs, []]
 249       | _   -> assert false
 250    in
 251    let txt_out o _ = function
 252       | [x] -> let o = std o in o.s_out "render "; o.s_query x
 253       | _   -> assert false
 254    in
 255    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 256
 257 let read_fun =
 258    let arity_p = Const 0 in
 259    let arity_s = Const 1 in
 260    let body e o i _ = function
 261       | [x] ->
 262          let aux av =
 263             let ich = open_in (fst av) in
 264             let r = i.result_in (Lexing.from_channel ich) in
 265             close_in ich; r
 266          in
 267          U.mql_iter aux (e.eval x)
 268       | _   -> assert false
 269    in
 270    let txt_out o _ = function
 271       | [x] -> let o = std o in o.s_out "read "; o.s_query x
 272       | _   -> assert false
 273    in
 274    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 275
 276 let align_fun =
 277    let aux l (v, g) =
 278       let c = String.length v in
 279       if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
 280    in
 281    let arity_p = Const 0 in
 282    let arity_s = Const 2 in
 283    let body e _ _ _ = function
 284       | [y; x] ->
 285          let l = int_of_set (e.eval y) in
 286          U.mql_iter (aux l) (e.eval x)
 287       | _      -> assert false
 288    in
 289    let txt_out o _ = function
 290       | [y; x] ->
 291          let o = std o in
 292          o.s_out "align "; o.s_query y; o.s_out " in "; o.s_query x
 293       | _      -> assert false
 294    in
 295    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 296
 297 let if_fun =
 298    let arity_p = Const 0 in
 299    let arity_s = Const 3 in
 300    let body e _ _ _ = function
 301       | [y; x1; x2] ->
 302          if (e.eval y) = U.mql_false then (e.eval x2) else (e.eval x1)
 303       | _           -> assert false
 304    in
 305    let txt_out o _ = function
 306       | [y; x1; x2] ->
 307          let o = std o in
 308          o.s_out "if "; o.s_query y; o.s_out " then "; o.s_query x1;
 309          o.s_out " else "; o.s_query x2
 310       | _           -> assert false
 311    in
 312    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 313
 314 let intersect_fun =
 315    let rec iter f = function
 316       | []           -> assert false
 317       | [head]       -> f head
 318       | head :: tail -> U.mql_intersect (f head) (iter f tail)
 319    in
 320    let arity_p = Const 0 in
 321    let arity_s = Positive in
 322    let body e _ _ _ xl = iter e.eval xl in
 323    let txt_out o _ = function
 324       | []           -> assert false
 325       | [x1; x2]     -> let o = std o in out_txt2 o "/\\" x1 x2
 326       | xl           -> let o = std o in out_txt_ o ["intersect"] xl
 327    in
 328    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 329
 330 let union_fun =
 331    let arity_p = Const 0 in
 332    let arity_s = Any in
 333    let body e _ _ _ xl = U.mql_iter e.eval xl in
 334    let txt_out o _ xl = let o = std o in out_txt_ o [] xl
 335    in
 336    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 337
 338 let or_fun =
 339    let rec iter f = function
 340       | []           -> U.mql_false
 341       | head :: tail ->
 342          let r1 = f head in
 343          if r1 = U.mql_false then (iter f tail) else r1
 344    in
 345    let arity_p = Const 0 in
 346    let arity_s = Any in
 347    let body e _ _ _ xl = iter e.eval xl in
 348    let txt_out o _ = function
 349       | [x1; x2]     -> let o = std o in out_txt2 o "||" x1 x2
 350       | xl           -> let o = std o in out_txt_ o ["or"] xl
 351    in
 352    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 353
 354 let and_fun =
 355    let rec iter f = function
 356       | []           -> U.mql_true
 357       | [head]       -> f head
 358       | head :: tail ->
 359          if f head = U.mql_false then U.mql_false else iter f tail
 360    in
 361    let arity_p = Const 0 in
 362    let arity_s = Any in
 363    let body e _ _ _ xl = iter e.eval xl in
 364    let txt_out o _ = function
 365       | [x1; x2]  -> let o = std o in out_txt2 o "&&" x1 x2
 366       | xl        -> let o = std o in out_txt_ o ["and"] xl
 367    in
 368    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 369
 370 let seq_fun =
 371    let rec iter f = function
 372       | []           -> U.mql_true
 373       | [head]       -> f head
 374       | head :: tail -> ignore (f head); iter f tail
 375    in
 376    let arity_p = Const 0 in
 377    let arity_s = Any in
 378    let body e _ _ _ xl = iter e.eval xl in
 379    let txt_out o _ = function
 380       | [x1; x2]  ->
 381          let o = std o in o.s_query x1; o.s_out " ;; "; o.s_query x2
 382       | xl        -> let o = std o in out_txt_ o ["seq"] xl
 383    in
 384    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 385
 386 let proj_fun =
 387    let proj_group_aux p (q, v) = if q = p then U.mql_subj v else [] in
 388    let proj_group p a = U.mql_iter (proj_group_aux p) a in
 389    let proj_set p (_, g) = U.mql_iter (proj_group p) g in
 390    let arity_p = Const 1 in
 391    let arity_s = Const 1 in
 392    let body e _ _ pl xl =
 393       match pl, xl with
 394          | [p], [x] -> U.mql_iter (proj_set p) (e.eval x)
 395          | _        -> assert false
 396    in
 397    let txt_out o pl xl =
 398       match pl, xl with
 399          | [p], [x] ->
 400             let o = std o in
 401             o.s_out "proj "; o.s_path p; o.s_out " of "; o.s_query x
 402          | _        -> assert false
 403    in
 404    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 405
 406 let keep_fun b =
 407    let proj (r, _) = (r, []) in
 408    let keep_path l (p, v) t = if List.mem p l = b then t else (p, v) :: t in
 409    let keep_grp l a = List.fold_right (keep_path l) a [] in
 410    let keep_set l a g =
 411       let kg = keep_grp l a in
 412       if kg = [] then g else kg :: g
 413    in
 414    let keep_av l (s, g) = (s, List.fold_right (keep_set l) g []) in
 415    let txt_allbut o = if b then o.s_out "allbut " in
 416    let txt_path_list o l = P.flat_list o.s_out o.s_path ", " l in
 417    let arity_p = Any in
 418    let arity_s = Const 1 in
 419    let body e _ _ pl xl =
 420       match b, pl, xl with
 421          | true, [], [x]  -> e.eval x
 422          | false, [], [x] -> List.map proj (e.eval x)
 423          | _, l, [x]      -> List.map (keep_av l) (e.eval x)
 424          | _              -> assert false
 425   in
 426   let txt_out o pl xl =
 427       match pl, xl with
 428          | [], [x] ->
 429             let o = std o in
 430             o.s_out "keep "; txt_allbut o; o.s_query x
 431          | l, [x]  ->
 432             let o = std o in
 433             o.s_out "keep "; txt_allbut o; txt_path_list o l;
 434             o.s_out " in "; o.s_query x
 435          | _      -> assert false
 436    in
 437    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 438
 439 (* external functions interface *********************************************)
 440
 441 let get_spec = function
 442    | ["empty"]                 -> false_fun false
 443    | ["false"]                 -> false_fun true
 444    | ["true"]                  -> true_fun
 445    | ["not"]                   -> not_fun
 446    | ["count"]                 -> count_fun
 447    | ["stat"]                  -> stat_fun
 448    | ["log"; "text"; "result"] -> log_fun false false
 449    | ["log"; "text"; "source"] -> log_fun false true
 450    | ["render"]                -> render_fun
 451    | ["read"]                  -> read_fun
 452    | ["peek"]                  -> peek_fun
 453    | ["diff"]                  -> diff_fun
 454    | ["xor"]                   -> xor_fun
 455    | ["sub"]                   -> sub_fun
 456    | ["meet"]                  -> meet_fun
 457    | ["eq"]                    -> eq_fun
 458    | ["le"]                    -> le_fun
 459    | ["lt"]                    -> lt_fun
 460    | ["align"]                 -> align_fun
 461    | ["if"]                    -> if_fun
 462    | ["intersect"]             -> intersect_fun
 463    | ["union"]                 -> union_fun
 464    | ["or"]                    -> or_fun
 465    | ["and"]                   -> and_fun
 466    | ["seq"]                   -> seq_fun
 467    | ["proj"]                  -> proj_fun
 468    | ["keep"; "these"]         -> keep_fun false
 469    | ["keep"; "allbut"]        -> keep_fun true
 470    | p                         -> raise (NameError p)
 471
 472 let check_arity p m n =
 473    let aux i = function
 474       | Const k when i = k  -> ()
 475       | Positive when i > 0 -> ()
 476       | Any                 -> ()
 477       | a                   -> raise (ArityError (p, a, i))
 478    in
 479    aux m (get_spec p).arity_p; aux n (get_spec p).arity_s
 480
 481 let eval e o i p pl xl = (get_spec p).body e o i pl xl
 482
 483 let txt_out o p pl xl =
 484    try (get_spec p).txt_out o pl xl
 485    with NameError q when q = p -> out_txt_full (std o) p pl xl