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