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