src/main.ml

   1 (**
   2   Main
   3 *)
   4
   5 open ExtLib
   6 open Sqlgg
   7
   8 module L = List
   9 module S = String
  10
  11 let parse_one' (sql,props) =
  12     if Sqlgg_config.debug1 () then Printf.eprintf "------\n%s\n%!" sql;
  13     let (sql,schema,vars,kind) = Syntax.parse sql in
  14     begin match kind, !Gen.params_mode with
  15     | Insert (Some _,_), None -> Error.log "Cannot use `-params none` with autogenerated parameters"
  16     | _ -> ()
  17     end;
  18     let props = Props.set props "sql" sql in
  19     { Gen.schema; vars; kind; props }
  20
  21 (* Printexc.raise_with_backtrace is only available since 4.05.0 *)
  22 exception With_backtrace of exn * Printexc.raw_backtrace
  23
  24 let () = Printexc.(register_printer begin function
  25   | With_backtrace (exn,bt) when raw_backtrace_length bt = 0 -> Some (to_string exn)
  26   | With_backtrace (exn,bt) -> Some (Printf.sprintf "%s\nBacktrace:\n%s" (to_string exn) (raw_backtrace_to_string bt))
  27   | _ -> None
  28 end)
  29
  30 (** @return parsed statement or [None] in case of parsing failure.
  31     @raise exn for other errors (typing etc)
  32 *)
  33 let parse_one (sql, props as x) =
  34   try
  35     Some (parse_one' x)
  36   with
  37   | Parser_utils.Error (exn,(line,cnum,tok,tail)) ->
  38     begin
  39      let extra = match exn with
  40      | Sql.Schema.Error (_,msg) -> msg
  41      | exn -> Printexc.to_string exn
  42      in
  43      Error.log "==> %s" sql;
  44      if cnum = String.length sql && tok = "" then
  45        Error.log "Error: %s" extra
  46      else
  47        Error.log "Position %u:%u Tokens: %s%s\nError: %s" line cnum tok (String.slice ~last:32 tail) extra;
  48      None
  49     end
  50   | exn ->
  51     let bt = Printexc.get_raw_backtrace () in
  52     Error.log "Failed %s: %s" (Option.default "" @@ Props.get props "name") sql;
  53     let exn =
  54       match exn with
  55       | Prelude.At ((p1,p2),exn) -> Error.log "At : %s" (String.slice ~first:p1 ~last:p2 sql); exn
  56       | _ -> exn
  57     in
  58 (*     Printexc.raise_with_backtrace exn bt *)
  59     raise @@ With_backtrace (exn,bt)
  60
  61 let parse_one (sql,props as x) =
  62   match Props.get props "noparse" with
  63   | Some _ -> Some { Gen.schema=[]; vars=[]; kind=Stmt.Other; props=Props.set props "sql" sql }
  64   | None -> parse_one x
  65
  66 let drop_while p e =
  67   while Option.map p (Enum.peek e) = Some true do
  68     Enum.junk e
  69   done
  70
  71 type token = [`Comment of string | `Token of string | `Char of char |
  72               `Space of string | `Prop of string * string | `Semicolon ]
  73
  74 let get_statements ch =
  75   let lexbuf = Lexing.from_channel ch in
  76   let tokens = Enum.from (fun () ->
  77     if lexbuf.Lexing.lex_eof_reached then raise Enum.No_more_elements else
  78     match Sql_lexer.ruleStatement lexbuf with
  79     | `Eof -> raise Enum.No_more_elements
  80     | #token as x -> x)
  81   in
  82   let extract () =
  83     let b = Buffer.create 1024 in
  84     let props = ref Props.empty in
  85     let answer () = Buffer.contents b, !props in
  86     let rec loop smth =
  87       match Enum.get tokens with
  88       | None -> if smth then Some (answer ()) else None
  89       | Some x ->
  90         match x with
  91         | `Comment s -> ignore s; loop smth (* do not include comments (option?) *)
  92         | `Char c -> Buffer.add_char b c; loop true
  93         | `Space _ when smth = false -> loop smth (* drop leading whitespaces *)
  94         | `Token s | `Space s -> Buffer.add_string b s; loop true
  95         | `Prop (n,v) -> props := Props.set !props n v; loop smth
  96         | `Semicolon -> Some (answer ())
  97     in
  98     loop false
  99   in
 100   let extract () = try extract () with e -> Error.log "lexer failed (%s)" (Printexc.to_string e); None in
 101   let rec next () =
 102     match extract () with
 103     | None -> raise Enum.No_more_elements
 104     | Some sql ->
 105       begin match parse_one sql with
 106       | None -> next ()
 107       | Some stmt ->
 108           let open Sql in
 109           if not (Sql.Schema.is_unique stmt.schema) then
 110             Printf.eprintf "Warning: this SQL statement will produce rowset with duplicate column names:\n%s\n" (fst sql);
 111           match List.exists (fun a -> Type.is_unit a.domain) stmt.schema with
 112           | true -> Error.log "Output schema contains column of type Unit, which is not allowed"; next ()
 113           | false ->
 114           (* FIXME iterate choice *)
 115           match List.filter_map (function (i,Single p) when Type.is_unit p.typ -> Some (Gen.show_param_name p i) | _ -> None) @@ List.mapi (fun i p -> i,p)  stmt.vars with
 116           | _::_ as l -> Error.log "Input parameter(s) of type Unit not allowed : %s" (String.concat " " l); next ()
 117           | [] ->
 118             stmt
 119       end
 120   in
 121   Enum.from next |> List.of_enum
 122
 123 let with_channel filename f =
 124   match try Some (open_in filename) with _ -> None with
 125   | None -> Error.log "cannot open file : %s" filename; f None
 126   | Some ch -> Std.finally (fun () -> close_in_noerr ch) f (Some ch)