src/gen_cxx.ml

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