gen_cxx.ml

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