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
  33 (* external function specification ******************************************)
  34
  35 type arity_t = Const of int
  36              | Positive
  37              | Any
  38
  39 type eval_spec = {eval : M.query -> M.result;
  40                   conn : C.handle
  41                  }
  42
  43 type text_out_spec = {out    : string -> unit;
  44                       path   : (string -> unit) -> M.path -> unit;
  45                       query  : (string -> unit) -> string -> M.query -> unit;
  46                       result : (string -> unit) -> string -> M.result -> unit
  47                      }
  48
  49 type text_in_spec = {result_in : Lexing.lexbuf -> M.result}
  50
  51 type fun_spec = {arity_p : arity_t;
  52                  arity_s : arity_t;
  53                  body    : eval_spec -> text_out_spec -> text_in_spec ->
  54                            M.path list -> M.query list -> M.result;
  55                  txt_out : text_out_spec ->
  56                            M.path list -> M.query list -> unit
  57                 }
  58
  59 type gen_spec = {arity : arity_t;
  60                  code  : eval_spec -> M.query list -> M.query
  61                 }
  62
  63 exception ArityError of M.path * arity_t * int
  64
  65 exception NameError of M.path
  66
  67 exception NumberError of M.result
  68
  69 type std_text_out_spec = {s_out    : string -> unit;
  70                           s_path   : M.path -> unit;
  71                           s_query  : M.query -> unit;
  72                           s_result : M.result -> unit
  73 }
  74
  75 let check_arity p i = function
  76    | Const k when i = k  -> ()
  77    | Positive when i > 0 -> ()
  78    | Any                 -> ()
  79    | a                   -> raise (ArityError (p, a, i))
  80
  81 (* external functions implementation ****************************************)
  82
  83 let std o =
  84    {s_out = o.out; s_path = o.path o.out;
  85     s_query = o.query o.out ""; s_result = o.result o.out "\n"
  86    }
  87
  88 let out_txt2 o n x1 x2 =
  89    o.s_out "(" ; o.s_query x1; o.s_out (" " ^ n ^ " "); o.s_query x2; o.s_out ")"
  90
  91 let out_txt_ o p xl =
  92    if p <> [] then begin o.s_path p; o.s_out " " end;
  93    o.s_out "{"; P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
  94
  95 let out_txt_full o p pl xl =
  96    o.s_path p; o.s_out " {"; P.flat_list o.s_out o.s_path ", " pl; o.s_out "} {";
  97    P.flat_list o.s_out o.s_query ", " xl; o.s_out "}"
  98
  99 let fun_arity0 p n r =
 100    let arity_p = Const 0 in
 101    let arity_s = Const 0 in
 102    let body _ _ _ _ _ = r in
 103    let txt_out o _ _ =
 104       if n = "" then out_txt_full (std o) p [] [] else (std o).s_out n
 105    in
 106    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 107
 108 let fun_arity1 p n f =
 109    let arity_p = Const 0 in
 110    let arity_s = Const 1 in
 111    let body e _ _ _ = function
 112       | [x] -> f (e.eval x)
 113       | _   -> assert false
 114    in
 115    let txt_out o _ = function
 116       | [x] ->
 117          let o = std o in
 118          if n = "" then out_txt_full o p [] [x] else
 119          begin o.s_out (n ^ " "); o.s_query x end
 120       | _   -> assert false
 121    in
 122    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 123
 124 let fun_arity2 p n f =
 125    let arity_p = Const 0 in
 126    let arity_s = Const 2 in
 127    let body e _ _ _ = function
 128       | [x1; x2] -> f (e.eval x1) (e.eval x2)
 129       | _        -> assert false
 130    in
 131    let txt_out o _ = function
 132       | [x1; x2] ->
 133          let o = std o in
 134          if n = "" then out_txt_full o p [] [x1; x2] else out_txt2 o n x1 x2
 135       | _        -> assert false
 136    in
 137    {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
 138
 139 (* external functions interface *********************************************)
 140
 141 let funs = Hashtbl.create 11
 142
 143 let fun_register path spec = Hashtbl.add funs path spec
 144
 145 let fun_get_spec path =
 146    try Hashtbl.find funs path
 147    with Not_found -> raise (NameError path)
 148
 149 let fun_arity p m n =
 150    check_arity p m (fun_get_spec p).arity_p;
 151    check_arity p n (fun_get_spec p).arity_s
 152
 153 let fun_eval e o i p pl xl = (fun_get_spec p).body e o i pl xl
 154
 155 let fun_txt_out o p pl xl =
 156    try (fun_get_spec p).txt_out o pl xl
 157    with NameError q when q = p -> out_txt_full (std o) p pl xl
 158
 159 (* generator functions implementation ***************************************)
 160
 161 (* generator functions interface ********************************************)
 162
 163 let gens = Hashtbl.create 11
 164
 165 let gen_register path spec = Hashtbl.add gens path spec
 166
 167 let gen_get_spec path =
 168    try Hashtbl.find gens path
 169    with Not_found -> raise (NameError path)
 170
 171 let gen_arity p n = check_arity p n (gen_get_spec p).arity
 172
 173 let gen_eval e p xl = (gen_get_spec p).code e xl