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 empty_line () = print_newline ()
  19 let output fmt = kprintf indent_endline fmt
  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   | Select   -> sprintf "select_%u" index
  43   in
  44   make_name props name
  45
  46 let get_sql props kind params =
  47   let sql = Props.get props "sql" >> Option.get in
  48   (* fill VALUES *)
  49   match kind with
  50   | Insert _ -> sql ^ " (" ^ (String.concat "," (List.map (fun _ -> "?") params)) ^ ")"
  51   | Select | Update _ | Delete _ | Create _ -> sql
  52
  53 module type Lang = sig
  54   val generate_code : int -> RA.Scheme.t -> Stmt.params -> Stmt.kind -> Props.t -> unit
  55   val start_output : unit -> unit
  56   val finish_output : unit -> unit
  57   val comment : ('a,unit,string,unit) format4 -> 'a
  58 end
  59
  60 module Make(S : Lang) = struct
  61
  62 let generate_code index stmt =
  63   let ((scheme,params,kind),props) = stmt in
  64   let sql = Props.get props "sql" >> Option.default "" in
  65   S.comment "%s" sql;
  66   if not (RA.Scheme.is_unique scheme) then
  67     Error.log "Error: this SQL statement will produce rowset with duplicate column names:\n%s\n" sql
  68   else
  69   begin
  70     S.generate_code index scheme params kind props
  71   end
  72
  73 let generate_header () =
  74   S.comment "DO NOT EDIT MANUALLY";
  75   empty_line ();
  76   S.comment "generated by sqlgg %s" Config.version;
  77   empty_line ()
  78
  79 let process stmts =
  80   generate_header ();
  81   S.start_output ();
  82   List.iteri generate_code stmts;
  83   S.finish_output ()
  84
  85 end
  86