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