gen.ml

   1 (* Code generation *)
   2
   3 open Printf
   4 open ExtList
   5 open ExtString
   6 open Operators
   7 open Stmt
   8
   9 let (inc_indent,dec_indent,make_indent) =
  10   let v = ref 0 in
  11   (fun () -> v := !v + 2),
  12   (fun () -> v := !v - 2),
  13   (fun () -> String.make !v ' ')
  14
  15 let print_indent () = print_string (make_indent ())
  16 let indent s = print_indent (); print_string s
  17 let indent_endline s = print_indent (); print_endline s
  18 let output fmt = kprintf indent_endline fmt
  19 let output_l = List.iter indent_endline
  20 let print fmt = kprintf print_endline fmt
  21
  22 let name_of attr index =
  23   match attr.RA.name with
  24   | "" -> sprintf "_%u" index
  25   | s -> s
  26
  27 let param_name_to_string id index =
  28   match id with
  29   | Next -> sprintf "_%u" index
  30   | Numbered x -> sprintf "_%u" x
  31   | Named s -> s
  32
  33 let make_name props default = Option.default default (Props.get props "name")
  34 let default_name str index = sprintf "%s_%u" str index
  35
  36 let choose_name props kind index =
  37   let name = match kind with
  38   | Create t -> sprintf "create_%s" t
  39   | Update t -> sprintf "update_%s_%u" t index
  40   | Insert (_,t) -> sprintf "insert_%s_%u" t index
  41   | Delete t -> sprintf "delete_%s_%u" t index
  42   | Alter t -> sprintf "alter_%s_%u" t index
  43   | Drop t -> sprintf "drop_%s" t
  44   | Select   -> sprintf "select_%u" index
  45   in
  46   make_name props name
  47
  48 let get_sql stmt =
  49   let sql = Props.get stmt.props "sql" >> Option.get in
  50   (* fill VALUES *)
  51   match stmt.kind with
  52   | Insert (true,_) -> sql ^ " (" ^ (String.concat "," (List.map (fun _ -> "?") stmt.params)) ^ ")"
  53   | _ -> sql
  54
  55 module type Lang = sig
  56   type t
  57   val generate : t -> string -> Stmt.t Enum.t -> unit
  58   val start : unit -> t
  59   val comment : t -> ('a,unit,string,unit) format4 -> 'a
  60   val empty_line : t -> unit
  61 end
  62
  63 module Make(S : Lang) = struct
  64
  65 let time_string () =
  66   let module U = Unix in
  67   let t = U.time () >> U.gmtime in
  68   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
  69
  70 let generate_header out =
  71   S.comment out "DO NOT EDIT MANUALLY";
  72   S.comment out "";
  73   S.comment out "generated by sqlgg %s on %s" Config.version (time_string ());
  74   S.comment out "visit http://ygrek.org.ua/p/sqlgg/";
  75   S.empty_line out
  76
  77 let process name stmts =
  78   let out = S.start () in
  79   generate_header out;
  80   S.generate out name stmts
  81
  82 end
  83