gen.ml

   1 (* Code generation *)
   2
   3 open Printf
   4 open ExtList
   5 open ExtString
   6 open Operators
   7 open Stmt
   8
   9 type subst_mode = | Named | Unnamed
  10
  11 (** defines substitution function for parameter literals *)
  12 let params_mode = ref None
  13
  14 let (inc_indent,dec_indent,make_indent) =
  15   let v = ref 0 in
  16   (fun () -> v := !v + 2),
  17   (fun () -> v := !v - 2),
  18   (fun () -> String.make !v ' ')
  19
  20 let print_indent () = print_string (make_indent ())
  21 let indent s = print_indent (); print_string s
  22 let indent_endline s = print_indent (); print_endline s
  23 let output fmt = kprintf indent_endline fmt
  24 let output_l = List.iter indent_endline
  25 let print fmt = kprintf print_endline fmt
  26
  27 let name_of attr index =
  28   match attr.RA.name with
  29   | "" -> sprintf "_%u" index
  30   | s -> s
  31
  32 let param_name_to_string (name,_) index =
  33   match name with
  34   | None -> sprintf "_%u" index
  35   | Some s -> s
  36
  37 let make_name props default = Option.default default (Props.get props "name")
  38 let default_name str index = sprintf "%s_%u" str index
  39
  40 let choose_name props kind index =
  41   let name = match kind with
  42   | Create t -> sprintf "create_%s" t
  43   | Update t -> sprintf "update_%s_%u" t index
  44   | Insert (_,t) -> sprintf "insert_%s_%u" t index
  45   | Delete t -> sprintf "delete_%s_%u" t index
  46   | Alter t -> sprintf "alter_%s_%u" t index
  47   | Drop t -> sprintf "drop_%s" t
  48   | Select   -> sprintf "select_%u" index
  49   in
  50   make_name props name
  51
  52 let substitute_params s params f =
  53   let index = ref 0 in
  54   let b = Buffer.create (String.length s) in
  55   let last = List.fold_left (fun i ((_,(i1,i2)),_ as param) ->
  56     let prefix = String.slice ~first:i ~last:i1 s in
  57     Buffer.add_string b prefix;
  58     Buffer.add_string b (f !index param);
  59     incr index;
  60     i2) 0 params in
  61   Buffer.add_string b (String.slice ~first:last s);
  62   Buffer.contents b
  63
  64 let subst_named index (id,_) = "@" ^ (param_name_to_string id index)
  65 let subst_unnamed _ _ = "?"
  66
  67 let get_sql stmt =
  68   let sql = Props.get stmt.props "sql" >> Option.get in
  69   match !params_mode with
  70   | None -> sql
  71   | Some subst ->
  72     let f = match subst with Named -> subst_named | Unnamed -> subst_unnamed in
  73     substitute_params sql stmt.params f
  74
  75 let time_string () =
  76   let module U = Unix in
  77   let t = U.time () >> U.gmtime in
  78   sprintf "%04u-%02u-%02uT%02u:%02uZ" (1900 + t.U.tm_year) t.U.tm_mon t.U.tm_mday t.U.tm_hour t.U.tm_min
  79
  80 module type Lang = sig
  81   type t
  82   val generate : t -> string -> Stmt.t Enum.t -> unit
  83   val start : unit -> t
  84   val comment : t -> ('a,unit,string,unit) format4 -> 'a
  85   val empty_line : t -> unit
  86 end
  87
  88 module Make(S : Lang) = struct
  89
  90 let generate_header out =
  91   S.comment out "DO NOT EDIT MANUALLY";
  92   S.comment out "";
  93   S.comment out "generated by sqlgg %s on %s" Config.version (time_string ());
  94   S.comment out "visit http://ygrek.org.ua/p/sqlgg/";
  95   S.empty_line out
  96
  97 let process name stmts =
  98   let out = S.start () in
  99   generate_header out;
 100   S.generate out name stmts
 101
 102 end
 103