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 empty_line () = print_newline ()
  28 let open_curly () = output "{"; inc_indent ()
  29 let close_curly fmt = dec_indent (); indent "}"; print fmt
  30 let start_struct name =
  31    output "struct %s" name;
  32    open_curly ()
  33 let end_struct name =
  34    close_curly "; // struct %s" name;
  35    empty_line ()
  36 let out_public () = dec_indent(); output "public:"; inc_indent()
  37 let out_private () = dec_indent(); output "private:"; inc_indent()
  38 let in_namespace name f =
  39   output "namespace %s" name;
  40   open_curly ();
  41   let result = f () in
  42   close_curly " // namespace %s" name;
  43   empty_line ();
  44   result
  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(row, %u, obj.%s);"
  53     action
  54 (*     (Type.to_string attr.RA.domain) *)
  55     index
  56     (name_of attr index)
  57
  58 (*
  59 let get_column = column_action "get"
  60 let bind_column = column_action "bind"
  61 *)
  62
  63 let param_type_to_string t = Option.map_default Type.to_string "Any" t
  64 let as_cxx_type str = "typename Traits::" ^ str
  65
  66 let set_param index param =
  67   let (id,t) = param in
  68   output "Traits::set_param(x, %s, %u);"
  69 (*     (param_type_to_string t) *)
  70     (param_name_to_string id index)
  71     index
  72
  73 let output_schema_binder index schema =
  74   out_private ();
  75   let name = default_name "output" index in
  76   output "template <class T>";
  77   start_struct name;
  78
  79   output "enum { count = %u };" (List.length schema);
  80   empty_line ();
  81
  82   let mthd action =
  83     output "static void %s(typename Traits::row row, T& obj)" action;
  84     open_curly ();
  85     List.iteri (fun index attr -> column_action action attr index) schema;
  86     close_curly ""
  87   in
  88
  89   mthd "get";
  90   mthd "bind";
  91
  92   end_struct name;
  93   name
  94
  95 let output_schema_binder index schema =
  96   match schema with
  97   | [] -> None
  98   | _ -> Some (output_schema_binder index schema)
  99
 100 let params_to_values = List.mapi (fun i (n,t) -> param_name_to_string n i, t >> param_type_to_string >> as_cxx_type)
 101 let params_to_values = List.unique & params_to_values
 102 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const&" t)
 103
 104 let output_value_defs vals =
 105   vals >> List.iter (fun (name,t) -> output "%s %s;" t name)
 106
 107 let schema_to_values = List.mapi (fun i attr -> name_of attr i, attr.RA.domain >> Type.to_string >> as_cxx_type)
 108
 109 let output_schema_data index schema =
 110   out_public ();
 111   let name = default_name "data" index in
 112   start_struct name;
 113   schema >> schema_to_values >> output_value_defs;
 114   end_struct name
 115
 116 let output_value_inits vals =
 117   match vals with
 118   | [] -> ()
 119   | _ ->
 120     output " : %s"
 121     (String.concat "," (List.map (fun (name,_) -> sprintf "%s(%s)" name name) vals))
 122
 123 let output_params_binder index params =
 124   out_private ();
 125   let name = default_name "params" index in
 126   start_struct name;
 127   let values = params_to_values params in
 128   values >> make_const_values >> output_value_defs;
 129   empty_line ();
 130   output "%s(%s)" name (values >> make_const_values >> Values.to_string);
 131   output_value_inits values;
 132   open_curly ();
 133   close_curly "";
 134   empty_line ();
 135   output "enum { count = %u };" (List.length values);
 136   empty_line ();
 137   output "template <class T>";
 138   output "void set_params(T& x)";
 139   open_curly ();
 140   List.iteri set_param params;
 141   close_curly "";
 142   empty_line ();
 143   end_struct name;
 144   name
 145
 146 let output_params_binder index params =
 147   match params with
 148   | [] -> "typename Traits::no_params"
 149   | _ -> output_params_binder index params
 150
 151 type t = unit
 152
 153 let start () = ()
 154
 155 let generate_code () index schema params kind props =
 156    let schema_binder_name = output_schema_binder index schema in
 157    let params_binder_name = output_params_binder index params in
 158    if (Option.is_some schema_binder_name) then output_schema_data index schema;
 159    out_public ();
 160    if (Option.is_some schema_binder_name) then output "template<class T>";
 161    let values = params_to_values params in
 162    let result = match schema_binder_name with None -> [] | Some _ -> ["result","T&"] in
 163    let all_params = Values.to_string
 164      (["db","typename Traits::connection"] @ result @ (make_const_values values))
 165    in
 166    let name = choose_name props kind index in
 167    let sql = quote (get_sql props kind params) in
 168    let inline_params =Values.inline (make_const_values values) in
 169    output "static bool %s(%s)" name all_params;
 170    open_curly ();
 171    begin match schema_binder_name with
 172    | None -> output "return Traits::do_execute(db,SQLGG_STR(%s),%s(%s));" sql params_binder_name inline_params
 173    | Some schema_name ->output "return Traits::do_select(db,result,SQLGG_STR(%s),%s(),%s(%s));"
 174           sql (schema_name ^ "<typename T::value_type>") params_binder_name inline_params
 175    end;
 176    close_curly "";
 177    empty_line ()
 178
 179 let start_output () =
 180   output "#pragma once";
 181   empty_line ();
 182   output "template <class Traits>";
 183   start_struct "sqlgg"
 184
 185 let finish_output () = end_struct "sqlgg"
 186