src/gen_cxx.ml

   1 (* C++ code generation *)
   2
   3 open ExtLib
   4 open Prelude
   5 open Printf
   6
   7 open Gen
   8 open Sql
   9
  10 module Values = struct
  11
  12 let names = List.map fst
  13 let join = String.concat ", "
  14 let inline = join $ names
  15 let to_string = join $ (List.map (fun (n,t) -> t ^ " " ^ n))
  16
  17 end
  18
  19 let rec freshname name scope =
  20   match List.find_all ((=) name) scope with
  21   | [] -> name
  22   | _ -> freshname (name ^ "_") scope
  23
  24 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
  25 let quote s = "\"" ^ quote s ^ "\""
  26
  27 let quote_comment_inline = String.replace_chars (function '\n' -> "\n// " | c -> String.make 1 c)
  28 let comment () fmt = Printf.kprintf (indent_endline $ quote_comment_inline $ (^) "// ") fmt
  29 let empty_line () = print_newline ()
  30 let open_curly () = output "{"; inc_indent ()
  31 let close_curly fmt = dec_indent (); indent "}"; print fmt
  32 let start_struct name =
  33    output "struct %s" name;
  34    open_curly ()
  35 let end_struct name =
  36    close_curly "; // struct %s" name;
  37    empty_line ()
  38 let out_public () = dec_indent(); output "public:"; inc_indent()
  39 let out_private () = dec_indent(); output "private:"; inc_indent()
  40
  41 module L = struct
  42   let as_api_type = Type.to_string
  43   let as_lang_type t = "typename Traits::" ^ (as_api_type t)
  44 end
  45
  46 module T = Translate(L)
  47
  48 open L
  49 open T
  50
  51 let column_action action attr index =
  52   let typ = as_api_type attr.domain in
  53   let name = name_of attr index in
  54   output "Traits::%s_column_%s(row, %u, %s);" action typ index name
  55
  56 let func head name args ?tail k =
  57   let tail = match tail with
  58   | Some s -> " " ^ s
  59   | None -> ""
  60   in
  61   let head = match head with "" -> "" | s -> s ^ " " in
  62   output "%s%s(%s)%s" head name (Values.to_string args) tail;
  63   open_curly ();
  64   k ();
  65   close_curly ""
  66
  67 let set_param arg index param =
  68   let (id,_) = param in
  69   output "Traits::set_param(%s, %s, %u);"
  70 (*     (param_type_to_string t) *)
  71     arg
  72     (param_name_to_string id index)
  73     index
  74
  75 let output_value_defs vals =
  76   vals |> List.iter (fun (name,t) -> output "%s %s;" t name)
  77
  78 let output_schema_binder _ schema =
  79   out_private ();
  80   let name = "output" in
  81   output "template <class T>";
  82   start_struct name;
  83
  84   let vals = schema_to_values schema in
  85   output_value_defs vals;
  86   empty_line ();
  87
  88   output "enum { count = %u };" (List.length schema);
  89   empty_line ();
  90
  91   let mthd action active =
  92     func "void" action
  93       (["row","typename Traits::row"] @ (if active then ["result","T"] else []))
  94       (fun () ->
  95         List.iteri (fun index attr -> column_action action attr index) schema;
  96         if active then output "result(%s);" (Values.inline vals)
  97       )
  98   in
  99
 100   mthd "get" true;
 101   mthd "bind" false;
 102
 103   end_struct name;
 104   name
 105
 106 let output_schema_binder index schema =
 107   match schema with
 108   | [] -> None
 109   | _ -> Some (output_schema_binder index schema)
 110
 111 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
 112
 113 (*
 114 let output_schema_data index schema =
 115   out_public ();
 116   let name = "data" in
 117   start_struct name;
 118   schema |> schema_to_values |> output_value_defs;
 119   end_struct name
 120 *)
 121
 122 let value_inits vals =
 123   match vals with
 124   | [] -> ""
 125   | _ -> sprintf ": %s" (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 126
 127 let struct_params name values k =
 128   start_struct name;
 129   output_value_defs values;
 130   empty_line ();
 131   k ();
 132   end_struct name
 133
 134 let struct_ctor name values k =
 135   struct_params name values (fun () ->
 136     func "" name values ~tail:(value_inits values) identity;
 137     empty_line ();
 138     k ())
 139
 140 let output_params_binder _ params =
 141   out_private ();
 142   let name = "params" in
 143   let values = params_to_values params in
 144   struct_ctor name (make_const_values values) (fun () ->
 145     comment () "binding slots in a query (one param may be bound several times)";
 146     output "enum { count = %u };" (List.length params);
 147     empty_line ();
 148     let arg = freshname "target" (name :: Values.names values) in
 149     output "template <class T>";
 150     func "void" "set_params" [arg,"T&"] (fun () -> List.iteri (set_param arg) params);
 151     empty_line ()
 152   );
 153   name
 154
 155 let output_params_binder index params =
 156   match params with
 157   | [] -> "typename Traits::no_params"
 158   | _ -> output_params_binder index params
 159
 160 type t = unit
 161
 162 let start () = ()
 163
 164 let make_stmt index stmt =
 165    let name = choose_name stmt.props stmt.kind index in
 166    let sql = quote (get_sql stmt) in
 167    struct_params name ["stmt","typename Traits::statement"] (fun () ->
 168     func "" name ["db","typename Traits::connection"] ~tail:(sprintf ": stmt(db,SQLGG_STR(%s))" sql) identity;
 169    let schema_binder_name = output_schema_binder index stmt.schema in
 170    let params_binder_name = output_params_binder index stmt.params in
 171 (*    if (Option.is_some schema_binder_name) then output_schema_data index stmt.schema; *)
 172    out_public ();
 173    if (Option.is_some schema_binder_name) then output "template<class T>";
 174    let values = params_to_values stmt.params in
 175    let result = match schema_binder_name with None -> [] | Some _ -> ["result","T"] in
 176    let all_params = (make_const_values values) @ result in
 177    let inline_params = Values.inline (make_const_values values) in
 178    func "bool" "operator()" all_params (fun () ->
 179     begin match schema_binder_name with
 180     | None -> output "return stmt.execute(%s(%s));" params_binder_name inline_params
 181     | Some schema_name -> output "return stmt.select(result,%s<T>(),%s(%s));"
 182           schema_name params_binder_name inline_params
 183     end);
 184    );
 185    name
 186
 187 let make_all name names =
 188   List.iter (fun name -> output "%s %s;" name name) names;
 189   empty_line ();
 190   let tail = match names with
 191   | [] -> ""
 192   | _ -> ": " ^ (String.concat ", " (List.map (fun name -> sprintf "%s(db)" name) names))
 193   in
 194   func "" name ["db","typename Traits::connection"] ~tail identity
 195
 196 let generate () name stmts =
 197   output "#pragma once";
 198   empty_line ();
 199   output "template <class Traits>";
 200   start_struct name;
 201   let names = List.mapi make_stmt stmts in
 202   make_all name names;
 203   end_struct name