gen.ml

   1 (* C++ code generation *)
   2
   3 open Sql
   4 open Printf
   5 open ExtList
   6 open ExtString
   7 open Operators
   8 open Stmt
   9
  10 module Cpp =
  11 struct
  12   type value = string * string
  13   type t = value list
  14
  15   let to_string x =
  16     String.concat ", " (List.map (fun (n,t) -> t ^ " " ^ n) x)
  17
  18   let inline x =
  19     String.concat ", " (List.map (fun (n,t) -> n) x)
  20
  21   let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
  22   let quote s = "\"" ^ quote s ^ "\""
  23 end
  24
  25 let (inc_indent,dec_indent,make_indent) =
  26   let v = ref 0 in
  27   (fun () -> v := !v + 2),
  28   (fun () -> v := !v - 2),
  29   (fun () -> String.make !v ' ')
  30
  31 let print_indent () = print_string (make_indent ())
  32 let indent s = print_indent (); print_string s
  33 let indent_endline s = print_indent (); print_endline s
  34 let empty_line () = print_newline ()
  35 let output fmt = Printf.kprintf indent_endline fmt
  36 let print fmt = Printf.kprintf print_endline fmt
  37 let quote_comment_inline = String.replace_chars (function '\n' -> "\n// " | c -> String.make 1 c)
  38 let comment fmt = Printf.kprintf (indent_endline & quote_comment_inline & (^) "// ") fmt
  39 let open_curly () = output "{"; inc_indent ()
  40 let close_curly fmt = dec_indent (); indent "}"; print fmt
  41 let start_struct name =
  42    output "struct %s" name;
  43    open_curly ()
  44 let end_struct name =
  45    close_curly "; // struct %s" name;
  46    empty_line ()
  47 let out_public () = dec_indent(); output "public:"; inc_indent()
  48 let out_private () = dec_indent(); output "private:"; inc_indent()
  49 let in_namespace name f =
  50   output "namespace %s" name;
  51   open_curly ();
  52   let result = f () in
  53   close_curly " // namespace %s" name;
  54   empty_line ();
  55   result
  56
  57 let generate_header () =
  58     output "// DO NOT EDIT MANUALLY";
  59     output "";
  60     output "// generated by sqlgg %s" Config.version;
  61     output "";
  62     output "#pragma once";
  63     output ""
  64
  65 let name_of attr index =
  66   match attr.RA.name with
  67   | "" -> sprintf "_%u" index
  68   | s -> s
  69
  70 let set_column attr index =
  71   output "Traits::set_column_%s(stmt, %u, obj.%s);"
  72     (Type.to_string attr.RA.domain)
  73     index
  74     (name_of attr index)
  75
  76 let get_column attr index =
  77   output "Traits::get_column_%s(stmt, %u, obj.%s);"
  78     (Type.to_string attr.RA.domain)
  79     index
  80     (name_of attr (index+1))
  81
  82 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  83 let param_type_to_cpp_string t = "typename Traits::" ^ (param_type_to_string t)
  84
  85 let param_name_to_string id index =
  86   match id with
  87   | Next -> sprintf "_%u" index
  88   | Numbered x -> sprintf "_%u" x
  89   | Named s -> s
  90
  91 let make_name props default = Option.default default (Props.get props "name")
  92 let default_name str index = sprintf "%s_%u" str index
  93
  94 let set_param index param =
  95   let (id,t) = param in
  96   output "Traits::set_param_%s(stmt, %s, %u);"
  97     (param_type_to_string t)
  98     (param_name_to_string id index)
  99     index
 100
 101 let output_scheme_binder index scheme =
 102   out_private ();
 103   let name = default_name "output" index in
 104   output "template <class T>";
 105   start_struct name;
 106
 107   output "static void of_stmt(typename Traits::statement stmt, T& obj)";
 108   open_curly ();
 109   List.iteri (fun index attr -> get_column attr index) scheme;
 110   close_curly "";
 111
 112   end_struct name;
 113   name
 114
 115 let output_scheme_binder index scheme =
 116   match scheme with
 117   | [] -> None
 118   | _ -> Some (output_scheme_binder index scheme)
 119
 120 let params_to_values = List.mapi (fun i (n,t) -> param_name_to_string n i, param_type_to_cpp_string t)
 121 let params_to_values = List.unique & params_to_values
 122 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
 123
 124 let output_value_defs vals =
 125   vals >> List.iter (fun (name,t) -> output "%s %s;" t name)
 126
 127 let scheme_to_values = List.mapi (fun i attr -> name_of attr i, Type.to_cpp_string attr.RA.domain)
 128
 129 let output_scheme_data index scheme =
 130   out_public ();
 131   let name = default_name "data" index in
 132   start_struct name;
 133   scheme >> scheme_to_values >> output_value_defs;
 134   end_struct name
 135
 136 let output_value_inits vals =
 137   match vals with
 138   | [] -> ()
 139   | _ ->
 140     output " : %s"
 141     (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 142
 143 let output_params_binder index params =
 144   out_private ();
 145   let name = default_name "params" index in
 146   start_struct name;
 147   let values = params_to_values params in
 148   values >> make_const_values >> output_value_defs;
 149   empty_line ();
 150   output "%s(%s)" name (values >> make_const_values >> Cpp.to_string);
 151   output_value_inits values;
 152   open_curly ();
 153   close_curly "";
 154   empty_line ();
 155   output "void set_params(typename Traits::statement stmt)";
 156   open_curly ();
 157   List.iteri set_param params;
 158   close_curly "";
 159   empty_line ();
 160   end_struct name;
 161   name
 162
 163 let output_params_binder index params =
 164   match params with
 165   | [] -> "typename Traits::no_params"
 166   | _ -> output_params_binder index params
 167
 168 let choose_name props kind index =
 169 (*   let name = default_name (Show.show<Stmt.Raw.kind>(kind) >> String.lowercase) index in *)
 170   let name = match kind with
 171   | Create t -> sprintf "create_%s" t
 172   | Update t -> sprintf "update_%s_%u" t index
 173   | Insert t -> sprintf "insert_%s_%u" t index
 174   | Delete t -> sprintf "delete_%s_%u" t index
 175   | Select   -> sprintf "select_%u" index
 176   in
 177   make_name props name
 178
 179 let generate_code index scheme params kind props =
 180    let scheme_binder_name = output_scheme_binder index scheme in
 181    let params_binder_name = output_params_binder index params in
 182    if (Option.is_some scheme_binder_name) then output_scheme_data index scheme;
 183    out_public ();
 184    if (Option.is_some scheme_binder_name) then output "template<class T>";
 185    let values = params_to_values params in
 186    let result = match scheme_binder_name with None -> [] | Some _ -> ["result","T&"] in
 187    let all_params = Cpp.to_string
 188      (["db","typename Traits::connection"] @ result @ (make_const_values values))
 189    in
 190    let name = choose_name props kind index in
 191    let sql = Props.get props "sql" >> Option.get in
 192    (* fill VALUES *)
 193    let sql = match kind with
 194              | Insert _ -> sql ^ " (" ^ (String.concat "," (List.map (fun _ -> "?") params)) ^ ")"
 195              | Select | Update _ | Delete _ | Create _ -> sql
 196    in
 197    let sql = Cpp.quote sql in
 198    let inline_params = Cpp.inline (make_const_values values) in
 199    output "static bool %s(%s)" name all_params;
 200    open_curly ();
 201    begin match scheme_binder_name with
 202    | None -> output "return Traits::do_execute(db,_T(%s),%s(%s));" sql params_binder_name inline_params
 203    | Some scheme_name ->output "return Traits::do_select(db,result,_T(%s),%s(),%s(%s));"
 204           sql (scheme_name ^ "<typename T::value_type>") params_binder_name inline_params
 205    end;
 206    close_curly "";
 207    empty_line ()
 208
 209 let generate_code index stmt =
 210   let ((scheme,params,kind),props) = stmt in
 211   begin match Props.get props "sql" with
 212   | Some s -> comment "%s" s
 213   | None -> ()
 214   end;
 215   generate_code index scheme params kind props
 216
 217 let process stmts =
 218   generate_header ();
 219   output "template <class Traits>";
 220   start_struct "sqlgg";
 221   List.iteri generate_code stmts;
 222   end_struct "sqlgg"