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" | '\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 sql2cpp %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 make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
 122
 123 let output_value_defs vals =
 124   vals >> List.iter (fun (name,t) -> output "%s %s;" t name)
 125
 126 let scheme_to_values = List.mapi (fun i attr -> name_of attr i, Type.to_cpp_string attr.RA.domain)
 127
 128 let output_scheme_data index scheme =
 129   out_public ();
 130   let name = default_name "data" index in
 131   start_struct name;
 132   scheme >> scheme_to_values >> output_value_defs;
 133   end_struct name
 134
 135 let output_value_inits vals =
 136   match vals with
 137   | [] -> ()
 138   | _ ->
 139     output " : %s"
 140     (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 141
 142 let output_params_binder index params =
 143   out_private ();
 144   let name = default_name "params" index in
 145   start_struct name;
 146   let values = params_to_values params in
 147   values >> make_const_values >> output_value_defs;
 148   empty_line ();
 149   output "%s(%s)" name (Cpp.to_string (make_const_values values));
 150   output_value_inits values;
 151   open_curly ();
 152   close_curly "";
 153   empty_line ();
 154   output "void set_params(typename Traits::statement stmt)";
 155   open_curly ();
 156   List.iteri set_param params;
 157   close_curly "";
 158   empty_line ();
 159   end_struct name;
 160   name
 161
 162 let output_params_binder index params =
 163   match params with
 164   | [] -> "typename Traits::no_params"
 165   | _ -> output_params_binder index params
 166
 167 let choose_name props kind index =
 168 (*   let name = default_name (Show.show<Stmt.Raw.kind>(kind) >> String.lowercase) index in *)
 169   let name = match kind with
 170   | Create t -> sprintf "create_%s" t
 171   | Update t -> sprintf "update_%s_%u" t index
 172   | Insert t -> sprintf "insert_%s_%u" t index
 173   | Delete t -> sprintf "delete_%s_%u" t index
 174   | Select   -> sprintf "select_%u" index
 175   in
 176   make_name props name
 177
 178 let generate_code index scheme params kind props =
 179    let scheme_binder_name = output_scheme_binder index scheme in
 180    let params_binder_name = output_params_binder index params in
 181    if (Option.is_some scheme_binder_name) then output_scheme_data index scheme;
 182    out_public ();
 183    if (Option.is_some scheme_binder_name) then output "template<class T>";
 184    let values = params_to_values params in
 185    let result = match scheme_binder_name with None -> [] | Some _ -> ["result","T&"] in
 186    let all_params = Cpp.to_string
 187      (["db","typename Traits::connection"] @ result @ (make_const_values values))
 188    in
 189    let name = choose_name props kind index in
 190    let sql = Props.get props "sql" >> Option.get in
 191    (* fill VALUES *)
 192    let sql = match kind with
 193              | Insert _ -> sql ^ " (" ^ (String.concat "," (List.map (fun _ -> "?") params)) ^ ")"
 194              | Select | Update _ | Delete _ | Create _ -> sql
 195    in
 196    let sql = Cpp.quote sql in
 197    let inline_params = Cpp.inline (make_const_values values) in
 198    output "static bool %s(%s)" name all_params;
 199    open_curly ();
 200    begin match scheme_binder_name with
 201    | None -> output "return Traits::do_execute(db,_T(%s),%s(%s));" sql params_binder_name inline_params
 202    | Some scheme_name ->output "return Traits::do_select(db,result,_T(%s),%s(),%s(%s));"
 203           sql (scheme_name ^ "<typename T::value_type>") params_binder_name inline_params
 204    end;
 205    close_curly "";
 206    empty_line ()
 207
 208 let generate_code index stmt =
 209   let ((scheme,params,kind),props) = stmt in
 210   begin match Props.get props "sql" with
 211   | Some s -> comment "%s" s
 212   | None -> ()
 213   end;
 214   generate_code index scheme params kind props
 215
 216 let process stmts =
 217   generate_header ();
 218   output "template <class Traits>";
 219   start_struct "sql2cpp";
 220   List.iteri generate_code stmts;
 221   end_struct "sql2cpp"