1 (* C++ code generation *)
12 module Values
= struct
15 String.concat
", " (List.map
(fun (n
,t
) -> t ^
" " ^ n
) x
)
18 String.concat
", " (List.map
(fun (n
,t
) -> n
) x
)
20 let names = List.map fst
24 let rec freshname name scope
=
25 match List.find_all
((=) name
) scope
with
27 | _
-> freshname (name ^
"_") scope
29 let quote = String.replace_chars
(function '
\n'
-> "\\n\\\n" | '
\r'
-> "" | '
"' -> "\\\"" | c -> String.make 1 c)
30 let quote s = "\"" ^ quote s ^ "\""
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;
41 close_curly "; // struct %s
" name;
43 let out_public () = dec_indent(); output "public
:"; inc_indent()
44 let out_private () = dec_indent(); output "private:"; inc_indent()
46 let name_of attr index =
47 match attr.RA.name with
48 | "" -> sprintf "_%u
" index
51 let column_action action attr index =
52 output "Traits
::%s_column_%s
(row
, %u
, obj
.%s
);"
54 (Type.to_string attr.RA.domain)
58 let func head name args ?tail k =
59 let tail = match tail with
63 let head = match head with "" -> "" | s -> s ^ " " in
64 output "%s%s
(%s
)%s
" head name (Values.to_string args) tail;
70 let get_column = column_action "get
"
71 let bind_column = column_action "bind
"
74 let param_type_to_string t = Option.map_default Type.to_string "Any
" t
75 let as_cxx_type str = "typename Traits
::" ^ str
77 let set_param arg index param =
79 output "Traits
::set_param(%s
, %s
, %u
);"
80 (* (param_type_to_string t) *)
82 (param_name_to_string id index)
85 let output_schema_binder index schema =
87 let name = "output
" in
88 output "template
<class T
>";
91 output "enum
{ count
= %u
};" (List.length schema);
95 func "static void
" action ["row
","typename Traits
::row
"; "obj
","T
&"] (fun () ->
96 List.iteri (fun index attr -> column_action action attr index) schema)
105 let output_schema_binder index schema =
108 | _ -> Some (output_schema_binder index schema)
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)
114 let output_value_defs vals =
115 vals >> List.iter (fun (name,t) -> output "%s %s
;" t name)
117 let schema_to_values = List.mapi (fun i attr -> name_of attr i, attr.RA.domain >> Type.to_string >> as_cxx_type)
119 let output_schema_data index schema =
123 schema >> schema_to_values >> output_value_defs;
126 let value_inits vals =
129 | _ -> sprintf ": %s
" (String.concat "," (List.map (fun (name,_) -> sprintf "%s
(%s
)" name name) vals))
131 let struct_params name values k =
133 output_value_defs values;
138 let struct_ctor name values k =
139 struct_params name values (fun () ->
140 func "" name values ~tail:(value_inits values) Apply.id;
144 let output_params_binder index params =
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);
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);
159 let output_params_binder index params =
161 | [] -> "typename Traits
::no_params
"
162 | _ -> output_params_binder index params
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;
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
193 let start_output () name =
194 output "#pragma once
";
196 output "template
<class Traits
>";
199 let finish_output () name =
200 List.iter (fun name -> output "%s %s
;" name name) !names;
202 let tail = match !names with
204 | _ -> ": " ^ (String.concat ", " (List.map (fun name -> sprintf "%s
(db
)" name) !names))
206 func "" name ["db
","typename Traits
::connection
"] ~tail Apply.id;