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 end
  21
  22 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
  23 let quote s = "\"" ^ quote s ^ "\""
  24
  25 let quote_comment_inline = String.replace_chars (function '\n' -> "\n// " | c -> String.make 1 c)
  26 let comment fmt = Printf.kprintf (indent_endline & quote_comment_inline & (^) "// ") fmt
  27 let open_curly () = output "{"; inc_indent ()
  28 let close_curly fmt = dec_indent (); indent "}"; print fmt
  29 let start_struct name =
  30    output "struct %s" name;
  31    open_curly ()
  32 let end_struct name =
  33    close_curly "; // struct %s" name;
  34    empty_line ()
  35 let out_public () = dec_indent(); output "public:"; inc_indent()
  36 let out_private () = dec_indent(); output "private:"; inc_indent()
  37 let in_namespace name f =
  38   output "namespace %s" name;
  39   open_curly ();
  40   let result = f () in
  41   close_curly " // namespace %s" name;
  42   empty_line ();
  43   result
  44
  45 let name_of attr index =
  46   match attr.RA.name with
  47   | "" -> sprintf "_%u" index
  48   | s -> s
  49
  50 let set_column attr index =
  51   output "Traits::set_column_%s(stmt, %u, obj.%s);"
  52     (Type.to_string attr.RA.domain)
  53     index
  54     (name_of attr index)
  55
  56 let get_column attr index =
  57   output "Traits::get_column_%s(stmt, %u, obj.%s);"
  58     (Type.to_string attr.RA.domain)
  59     index
  60     (name_of attr index)
  61
  62 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  63 let as_cxx_type str = "typename Traits::" ^ str
  64
  65 let set_param index param =
  66   let (id,t) = param in
  67   output "Traits::set_param_%s(stmt, %s, %u);"
  68     (param_type_to_string t)
  69     (param_name_to_string id index)
  70     index
  71
  72 let output_scheme_binder index scheme =
  73   out_private ();
  74   let name = default_name "output" index in
  75   output "template <class T>";
  76   start_struct name;
  77
  78   output "static void of_stmt(typename Traits::statement stmt, T& obj)";
  79   open_curly ();
  80   List.iteri (fun index attr -> get_column attr index) scheme;
  81   close_curly "";
  82
  83   end_struct name;
  84   name
  85
  86 let output_scheme_binder index scheme =
  87   match scheme with
  88   | [] -> None
  89   | _ -> Some (output_scheme_binder index scheme)
  90
  91 let params_to_values = List.mapi (fun i (n,t) -> param_name_to_string n i, t >> param_type_to_string >> as_cxx_type)
  92 let params_to_values = List.unique & params_to_values
  93 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
  94
  95 let output_value_defs vals =
  96   vals >> List.iter (fun (name,t) -> output "%s %s;" t name)
  97
  98 let scheme_to_values = List.mapi (fun i attr -> name_of attr i, attr.RA.domain >> Type.to_string >> as_cxx_type)
  99
 100 let output_scheme_data index scheme =
 101   out_public ();
 102   let name = default_name "data" index in
 103   start_struct name;
 104   scheme >> scheme_to_values >> output_value_defs;
 105   end_struct name
 106
 107 let output_value_inits vals =
 108   match vals with
 109   | [] -> ()
 110   | _ ->
 111     output " : %s"
 112     (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 113
 114 let output_params_binder index params =
 115   out_private ();
 116   let name = default_name "params" index in
 117   start_struct name;
 118   let values = params_to_values params in
 119   values >> make_const_values >> output_value_defs;
 120   empty_line ();
 121   output "%s(%s)" name (values >> make_const_values >> Values.to_string);
 122   output_value_inits values;
 123   open_curly ();
 124   close_curly "";
 125   empty_line ();
 126   output "void set_params(typename Traits::statement stmt)";
 127   open_curly ();
 128   List.iteri set_param params;
 129   close_curly "";
 130   empty_line ();
 131   end_struct name;
 132   name
 133
 134 let output_params_binder index params =
 135   match params with
 136   | [] -> "typename Traits::no_params"
 137   | _ -> output_params_binder index params
 138
 139 let generate_code index scheme params kind props =
 140    let scheme_binder_name = output_scheme_binder index scheme in
 141    let params_binder_name = output_params_binder index params in
 142    if (Option.is_some scheme_binder_name) then output_scheme_data index scheme;
 143    out_public ();
 144    if (Option.is_some scheme_binder_name) then output "template<class T>";
 145    let values = params_to_values params in
 146    let result = match scheme_binder_name with None -> [] | Some _ -> ["result","T&"] in
 147    let all_params = Values.to_string
 148      (["db","typename Traits::connection"] @ result @ (make_const_values values))
 149    in
 150    let name = choose_name props kind index in
 151    let sql = quote (get_sql props kind params) in
 152    let inline_params =Values.inline (make_const_values values) in
 153    output "static bool %s(%s)" name all_params;
 154    open_curly ();
 155    begin match scheme_binder_name with
 156    | None -> output "return Traits::do_execute(db,_T(%s),%s(%s));" sql params_binder_name inline_params
 157    | Some scheme_name ->output "return Traits::do_select(db,result,_T(%s),%s(),%s(%s));"
 158           sql (scheme_name ^ "<typename T::value_type>") params_binder_name inline_params
 159    end;
 160    close_curly "";
 161    empty_line ()
 162
 163 let start_output () =
 164   output "#pragma once";
 165   empty_line ();
 166   output "template <class Traits>";
 167   start_struct "sqlgg"
 168
 169 let finish_output () = end_struct "sqlgg"
 170