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" | '"' -> "\\\"" | 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";
  61     output "";
  62     output "#pragma once";
  63     output ""
  64
  65 (*
  66 let ns_name table = table.Table.cpp_name
  67 let item_name _ = "row"
  68 let prefix_name _ = ""
  69 *)
  70
  71 let name_of attr index =
  72   match attr.RA.name with
  73   | "" -> sprintf "_%u" index
  74   | s -> s
  75
  76 let set_column attr index =
  77   output "Traits::set_column_%s(stmt, %u, obj.%s);"
  78     (Type.to_string attr.RA.domain)
  79     index
  80     (name_of attr index)
  81
  82 let get_column attr index =
  83   output "Traits::get_column_%s(stmt, %u, obj.%s);"
  84     (Type.to_string attr.RA.domain)
  85     index
  86     (name_of attr (index+1))
  87
  88 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  89 let param_type_to_cpp_string t = "typename Traits::" ^ (param_type_to_string t)
  90
  91 let param_name_to_string id index =
  92   match id with
  93   | Next -> sprintf "_%u" index
  94   | Numbered x -> sprintf "_%u" x
  95   | Named s -> s
  96
  97 let make_name props default = Option.default default (Props.get props "name")
  98 let default_name str index = sprintf "%s_%u" str index
  99
 100 let set_param index param =
 101   let (id,t) = param in
 102   output "Traits::set_param_%s(stmt, %s, %u);"
 103     (param_type_to_string t)
 104     (param_name_to_string id index)
 105     index
 106
 107 let output_scheme_binder index scheme =
 108   out_private ();
 109   let name = default_name "output" index in
 110   output "template <class T>";
 111   start_struct name;
 112
 113   output "static void of_stmt(typename Traits::statement stmt, T& obj)";
 114   open_curly ();
 115   List.iteri (fun index attr -> get_column attr index) scheme;
 116   close_curly "";
 117
 118   end_struct name;
 119   name
 120
 121 let output_scheme_binder index scheme =
 122   match scheme with
 123   | [] -> None
 124   | _ -> Some (output_scheme_binder index scheme)
 125
 126 let params_to_values = List.mapi (fun i (n,t) -> param_name_to_string n i, param_type_to_cpp_string t)
 127 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
 128
 129 let output_value_defs vals =
 130   vals >> List.iter (fun (name,t) -> output "%s %s;" t name)
 131
 132 let scheme_to_values = List.mapi (fun i attr -> name_of attr i, Type.to_cpp_string attr.RA.domain)
 133
 134 let output_scheme_data index scheme =
 135   out_public ();
 136   let name = default_name "data" index in
 137   start_struct name;
 138   scheme >> scheme_to_values >> output_value_defs;
 139   end_struct name
 140
 141 let output_value_inits vals =
 142   match vals with
 143   | [] -> ()
 144   | _ ->
 145     output " : %s"
 146     (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 147
 148 let output_params_binder index params =
 149   out_private ();
 150   let name = default_name "params" index in
 151   start_struct name;
 152   let values = params_to_values params in
 153   values >> make_const_values >> output_value_defs;
 154   empty_line ();
 155   output "%s(%s)" name (Cpp.to_string (make_const_values values));
 156   output_value_inits values;
 157   open_curly ();
 158   close_curly "";
 159   empty_line ();
 160   output "void set_params(typename Traits::statement stmt)";
 161   open_curly ();
 162   List.iteri set_param params;
 163   close_curly "";
 164   empty_line ();
 165   end_struct name;
 166   name
 167
 168 let output_params_binder index params =
 169   match params with
 170   | [] -> "typename Traits::no_params"
 171   | _ -> output_params_binder index params
 172
 173 let choose_name props kind index =
 174 (*   let name = default_name (Show.show<Stmt.Raw.kind>(kind) >> String.lowercase) index in *)
 175   let name = match kind with
 176   | Create t -> sprintf "create_%s" t
 177   | Update t -> sprintf "update_%s_%u" t index
 178   | Insert t -> sprintf "insert_%s_%u" t index
 179   | Delete t -> sprintf "delete_%s_%u" t index
 180   | Select   -> sprintf "select_%u" index
 181   in
 182   make_name props name
 183
 184 let generate_code index scheme params kind props =
 185    let scheme_binder_name = output_scheme_binder index scheme in
 186    let params_binder_name = output_params_binder index params in
 187    if (Option.is_some scheme_binder_name) then output_scheme_data index scheme;
 188    out_public ();
 189    if (Option.is_some scheme_binder_name) then output "template<class T>";
 190    let values = params_to_values params in
 191    let result = match scheme_binder_name with None -> [] | Some _ -> ["result","T&"] in
 192    let all_params = Cpp.to_string
 193      (["db","typename Traits::connection"] @ result @ (make_const_values values))
 194    in
 195    let name = choose_name props kind index in
 196    let sql = Props.get props "sql" >> Option.get in
 197    (* fill VALUES *)
 198    let sql = match kind with
 199              | Insert _ -> sql ^ " (" ^ (String.concat "," (List.map (fun _ -> "?") params)) ^ ")"
 200              | Select | Update _ | Delete _ | Create _ -> sql
 201    in
 202    let sql = Cpp.quote sql in
 203    let inline_params = Cpp.inline (make_const_values values) in
 204    output "static bool %s(%s)" name all_params;
 205    open_curly ();
 206    begin match scheme_binder_name with
 207    | None -> output "return Traits::do_execute(db,_T(%s),%s(%s));" sql params_binder_name inline_params
 208    | Some scheme_name ->output "return Traits::do_select(db,result,_T(%s),%s(),%s(%s));"
 209           sql (scheme_name ^ "<typename T::value_type>") params_binder_name inline_params
 210    end;
 211    close_curly "";
 212    empty_line ()
 213
 214 let generate_code index stmt =
 215   let ((scheme,params,kind),props) = stmt in
 216   begin match Props.get props "sql" with
 217   | Some s -> comment "%s" s
 218   | None -> ()
 219   end;
 220   generate_code index scheme params kind props
 221
 222 let process stmts =
 223   generate_header ();
 224   output "template <class Traits>";
 225   start_struct "sql2cpp";
 226   List.iteri generate_code stmts;
 227   end_struct "sql2cpp"