helm/ocaml/mathql_interpreter/mQueryIO.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 I = M.I
  31 module P = MQueryUtil
  32 module L = MQILib
  33
  34 (* text linearization and parsing *******************************************)
  35
  36 let txt_quote s =
  37    let rec aux r i l s =
  38       let commit c =
  39          let l = pred (l - i) in
  40          aux (r ^ String.sub s 0 i ^ c) 0 l (String.sub s (succ i) l)
  41       in
  42       if i = l then r ^ s else
  43       match s.[i] with
  44          | '\\' -> commit "\\\\^"
  45          | '^'  -> commit "\\^^"
  46          | '\"' -> commit "\\\"^"
  47          | _    -> aux r (succ i) l s
  48    in
  49    aux "" 0 (String.length s) s
  50
  51 let txt_str out s = out ("\"" ^ txt_quote s ^ "\"")
  52
  53 let txt_path out p = out "/"; P.flat_list out (txt_str out) "/" p
  54
  55 let text_of_result out sep x =
  56    let txt_attr _ p l b =
  57       txt_path out p;
  58       begin match l with
  59          | []  -> ()
  60          | [s] -> out " = "; txt_str out s
  61          | l   -> out " = {"; P.flat_list out (txt_str out) ", " l; out "}"
  62       end;
  63       if b then out ("; ")
  64    in
  65    let txt_group l = out "{"; I.x_grp_iter txt_attr () l; out "}" in
  66    let txt_res _ s l b =
  67       txt_str out s;
  68       if l <> [] then begin
  69          out " attr "; P.flat_list out txt_group ", " l
  70       end;
  71       if b then out ("; " ^ sep)
  72    in
  73    I.x_iter txt_res () x; out sep
  74
  75 let rec xtext_of_groups out l =
  76    let txt_attr (p, x) = txt_path out p; out " = "; text_of_query out "" x in
  77    let txt_group l = out "{"; P.flat_list out txt_attr "; " l; out "}" in
  78    P.flat_list out txt_group ", " l
  79
  80 and xtext_of_result out x =
  81    let txt_res = function
  82       | (s, []) -> txt_str out s
  83       | (s, l)  -> txt_str out s; out " attr "; xtext_of_groups out l
  84    in
  85    P.flat_list out txt_res "; " x
  86
  87 and text_of_query out sep x =
  88    let txt_svar sv = out ("$" ^ sv) in
  89    let txt_avar av = out ("@" ^ av) in
  90    let txt_inv i = if i then out "inverse " in
  91    let txt_ref = function
  92       | M.RefineExact -> ()
  93       | M.RefineSub   -> out "sub "
  94       | M.RefineSuper -> out "super "
  95    in
  96    let txt_qualif i r p = txt_inv i; txt_ref r; txt_path out p in
  97    let main = function
  98       | [] -> ()
  99       | p  -> out " main "; txt_path out p
 100    in
 101    let txt_exp = function
 102       | (pl, None)    -> txt_path out pl
 103       | (pl, Some pr) -> txt_path out pl; out " as "; txt_path out pr
 104    in
 105    let txt_exp_list = function
 106       | [] -> ()
 107       | l  -> out " attr "; P.flat_list out txt_exp ", " l
 108    in
 109    let pattern b = if b then out "pattern " in
 110    let txt_distr d = if d then out "distr " in
 111    let txt_gen = function
 112       | M.GenFJoin -> out " sup "
 113       | M.GenFMeet -> out " inf "
 114    in
 115    let rec txt_con (pat, p, x) =
 116       txt_path out p;
 117       if pat then out " match " else out " in ";
 118       txt_set x
 119    and txt_con_list s = function
 120       | [] -> ()
 121       | l  -> out s; P.flat_list out txt_con ", " l
 122    and txt_istrue lt = txt_con_list " istrue " lt
 123    and txt_isfalse lf = txt_con_list " isfalse " lf
 124    and txt_grp = function
 125       | M.Attr g  -> xtext_of_groups out g
 126       | M.From av -> txt_avar av
 127    and txt_set = function
 128       | M.Fun (p, pl, xl)      ->
 129          let o = {L.out = out; L.sep = ""; L.path = txt_path;
 130                   L.query = text_of_query; L.result = text_of_result
 131                  }
 132          in
 133          L.fun_txt_out o p pl xl
 134       | M.Const [s, []]       -> txt_str out s
 135       | M.Const r             -> xtext_of_result out r
 136       | M.Dot (av, p)         -> txt_avar av; out "."; txt_path out p
 137       | M.Ex (b, x)           -> out "ex "; txt_set x
 138 (*    | M.Ex b x              -> out "ex ["; P.flat_list out txt_avar "," b;
 139                                  out "] "; txt_set x
 140 *)    | M.SVar sv             -> txt_svar sv
 141       | M.AVar av             -> txt_avar av
 142       | M.Property (q0, q1, q2, mc, ct, cfl, xl, b, x) ->
 143          out "property "; txt_qualif q0 q1 q2; main mc;
 144          txt_istrue ct; P.flat_list out txt_isfalse "" cfl; txt_exp_list xl;
 145          out " of "; pattern b; txt_set x
 146       | M.Let (Some sv, x, y) -> out "let "; txt_svar sv; out " = ";
 147                                  txt_set x; out " in "; txt_set y
 148       | M.Let (None, x, y)    -> txt_set x; out " ;; "; txt_set y
 149       | M.Select (av, x, y)   -> out "select "; txt_avar av; out " from ";
 150                                  txt_set x; out " where "; txt_set y
 151       | M.For (k, av, x, y)   -> out "for "; txt_avar av; out " in ";
 152                                  txt_set x; txt_gen k; txt_set y
 153       | M.While (k, x, y)     -> out "while "; txt_set x; txt_gen k; txt_set y
 154       | M.Add (d, g, x)       -> out "add "; txt_distr d; txt_grp g;
 155                                  out " in "; txt_set x
 156       | M.Gen (p, [x])        -> out "gen "; txt_path out p; out " in "; txt_set x
 157       | M.Gen (p, l)          -> out "gen "; txt_path out p; out " {";
 158                                  P.flat_list out txt_set ", " l; out "}"
 159    in
 160    txt_set x; out sep
 161
 162 let text_out_spec out sep =
 163    {L.out = out; L.sep = sep; L.path = txt_path;
 164     L.query = text_of_query; L.result = text_of_result
 165    }
 166
 167 let query_of_text lexbuf =
 168    MQueryTParser.query MQueryTLexer.query_token lexbuf
 169
 170 let result_of_text lexbuf =
 171    MQueryTParser.result MQueryTLexer.result_token lexbuf
 172
 173 let text_in_spec = {L.result_in = result_of_text}