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