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 module type Lang = sig
  47   val generate_code : int -> RA.Scheme.t -> Stmt.params -> Stmt.kind -> Props.t -> unit
  48   val start_output : unit -> unit
  49   val finish_output : unit -> unit
  50   val comment : ('a,unit,string,unit) format4 -> 'a
  51 end
  52
  53 module Make(S : Lang) = struct
  54
  55 let generate_code index stmt =
  56   let ((scheme,params,kind),props) = stmt in
  57   let sql = Props.get props "sql" >> Option.default "" in
  58   S.comment "%s" sql;
  59   if not (RA.Scheme.is_unique scheme) then
  60     Error.log "Error: this SQL statement will produce rowset with duplicate column names:\n%s\n" sql
  61   else
  62   begin
  63     S.generate_code index scheme params kind props
  64   end
  65
  66 let generate_header () =
  67   S.comment "DO NOT EDIT MANUALLY";
  68   empty_line ();
  69   S.comment "generated by sqlgg %s" Config.version;
  70   empty_line ()
  71
  72 let process stmts =
  73   generate_header ();
  74   S.start_output ();
  75   List.iteri generate_code stmts;
  76   S.finish_output ()
  77
  78 end
  79