helm/ocaml/mathql_interpreter/mQueryInterpreter.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 open Dbconn;;
  27 open Union;;
  28 open Intersect;;
  29 open Meet;;
  30 open Property;;
  31 open Sub;;
  32 open Context;;
  33 open Diff;;
  34 open Relation;;
  35 open Func;;
  36 open Pattern;;
  37
  38 exception SVarUnbound of string;;
  39 exception RVarUnbound of string;;
  40 exception VVarUnbound of string;;
  41 exception PathUnbound of (string * string list);;
  42
  43 exception InvalidConnection
  44 exception ConnectionFailed of string
  45
  46 exception BooleExpTrue
  47
  48 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
  49
  50 let galax_char = 'G'
  51 let stat_char = 'S'
  52
  53 let execute_aux log m x =
  54    let module M = MathQL in
  55    let module X = MQueryMisc in
  56 let rec exec_set_exp c = function
  57      M.SVar svar ->
  58       (try
  59         List.assoc svar c.svars
  60        with Not_found ->
  61         raise (SVarUnbound svar))
  62    | M.RVar rvar ->
  63       (try
  64         [List.assoc rvar c.rvars]
  65        with Not_found ->
  66         raise (RVarUnbound rvar))
  67    | M.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
  68    | M.Pattern vexp -> pattern_ex (exec_val_exp c vexp)
  69    | M.Intersect (sexp1, sexp2) ->
  70         let before = X.start_time() in
  71         let rs1 = exec_set_exp c sexp1 in
  72         let rs2 = exec_set_exp c sexp2 in
  73         let res = intersect_ex rs1 rs2 in
  74         let diff = X.stop_time before in
  75         let ll1 = string_of_int (List.length rs1) in
  76         let ll2 = string_of_int (List.length rs2) in
  77         if String.contains m stat_char then
  78         log ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
  79          ": " ^ diff ^ "\n");
  80         res
  81    | M.Union (sexp1, sexp2) ->
  82         let before = X.start_time () in
  83         let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
  84         let diff = X.stop_time before in
  85         if String.contains m stat_char then log ("UNION: " ^ diff ^ "\n");
  86         res
  87    | M.LetSVar (svar, sexp1, sexp2) ->
  88         let before = X.start_time() in
  89         let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
  90         let res = exec_set_exp c1 sexp2 in
  91         if String.contains m stat_char then begin
  92            log ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
  93            log (X.stop_time before ^ "\n");
  94         end;
  95         res
  96    | M.LetVVar (vvar, vexp, sexp) ->
  97         let before = X.start_time() in
  98         let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
  99         let res = exec_set_exp c1 sexp in
 100         if String.contains m stat_char then begin
 101            log ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 102            log (X.stop_time before ^ "\n");
 103         end;
 104         res
 105    | M.Relation (inv, rop, path, sexp, assl) ->
 106         let before = X.start_time() in
 107         if String.contains m galax_char then begin
 108            let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
 109            if String.contains m stat_char then begin
 110               log  ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 111               log (X.stop_time before ^ "\n")
 112           end;
 113           res
 114         end else begin
 115            let res = relation_ex inv rop path (exec_set_exp c sexp) assl in
 116            if String.contains m stat_char then begin
 117               log ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 118               log (X.stop_time before ^ "\n")
 119            end;
 120            res
 121         end
 122    | M.Select (rvar, sexp, bexp) ->
 123         let before = X.start_time() in
 124         let rset = (exec_set_exp c sexp) in
 125         let rec select_ex =
 126          function
 127             [] -> []
 128           | r::tl ->
 129              let c1 = upd_rvars c ((rvar,r)::c.rvars) in
 130               if (exec_boole_exp c1 bexp) then
 131                r::(select_ex tl)
 132               else
 133                select_ex tl
 134         in
 135         let res = select_ex rset in
 136         if String.contains m stat_char then begin
 137            log ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 138            log (X.stop_time before ^ "\n");
 139         end;
 140         res
 141    | M.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
 142
 143 (* valuta una MathQL.boole_exp e ritorna un boole *)
 144
 145 and exec_boole_exp c =
 146  function
 147     M.False      -> false
 148   | M.True       -> true
 149   | M.Not x      -> not (exec_boole_exp c x)
 150   | M.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
 151   | M.Or (x, y)  -> (exec_boole_exp c x) || (exec_boole_exp c y)
 152   | M.Sub (vexp1, vexp2) ->
 153      sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
 154   | M.Meet (vexp1, vexp2) ->
 155      meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
 156   | M.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
 157   | M.Ex l bexp ->
 158      if l = [] then
 159       (exec_boole_exp c bexp)
 160      else
 161          let latt =
 162           List.map
 163            (fun uri ->
 164              let (r,attl) =
 165               (try
 166                 List.assoc uri c.rvars
 167                with Not_found -> assert false)
 168              in
 169               (uri,attl)
 170            ) l (*latt = l + attributi*)
 171          in
 172           try
 173            let rec prod c =
 174             function
 175                [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
 176              | (uri,attl)::tail1 ->
 177                  (*per ogni el. di attl devo andare in ric. su tail1*)
 178                  let rec sub_prod attl =
 179                   match attl with
 180                      [] -> ()
 181                    | att::tail2 ->
 182                       let c1 = upd_groups c ((uri,att)::c.groups) in
 183                        prod c1 tail1; sub_prod tail2
 184                  in
 185                   sub_prod attl
 186            in
 187             prod c latt;
 188             false
 189           with BooleExpTrue -> true
 190
 191 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
 192
 193 and exec_val_exp c = function
 194      M.Const x -> let
 195         ol = List.sort compare x in
 196                         let rec edup = function
 197
 198                            [] -> []
 199                          | s::tl -> if tl <> [] then
 200                                                  if s = (List.hd tl) then edup tl
 201                                                  else s::(edup tl)
 202                                     else s::[]
 203                         in
 204                          edup ol
 205    | M.Record (rvar, path) ->
 206       (try
 207         List.assoc path
 208          (try
 209            List.assoc rvar c.groups
 210           with Not_found ->
 211            raise (RVarUnbound rvar))
 212        with Not_found ->
 213         raise (PathUnbound path))
 214    | M.VVar s ->
 215       (try
 216         List.assoc s c.vvars
 217        with Not_found ->
 218         raise (VVarUnbound s))
 219    | M.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
 220    | M.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
 221    | M.Property (inv, rop, path, vexp) -> property_ex rop path inv (exec_val_exp c vexp)
 222
 223 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
 224 in
 225    exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x
 226
 227 (* new interface  ***********************************************************)
 228
 229 module type Callbacks =
 230    sig
 231       val log : string -> unit (* logging function *)
 232    end
 233
 234 module Make (C: Callbacks) =
 235    struct
 236
 237       let postgres = "P"
 238       let galax = "G"
 239       let stat = "S"
 240       let quiet = "Q"
 241       let warn = "W"
 242
 243       let execute m x = execute_aux C.log m x
 244
 245       let init m =
 246         let default_connection_string =
 247             "host=mowgli.cs.unibo.it dbname=helm_mowgli_new_schema user=helm"
 248         in
 249         let connection_string =
 250             try Sys.getenv "POSTGRESQL_CONNECTION_STRING"
 251             with Not_found -> default_connection_string
 252         in
 253         if String.contains m galax_char then true else
 254            try Dbconn.init connection_string; true
 255            with ConnectionFailed s -> false
 256
 257       let close m =
 258          if String.contains m galax_char then () else Dbconn.close ()
 259
 260       let check m =
 261          if String.contains m galax_char then false else
 262          try ignore (Dbconn.pgc ()); true with InvalidConnection -> false
 263
 264    end