gen_cxx.ml

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