9 let (inc_indent
,dec_indent
,make_indent
) =
11 (fun () -> v := !v + 2),
12 (fun () -> v := !v - 2),
13 (fun () -> String.make
!v ' '
)
15 let print_indent () = print_string
(make_indent
())
16 let indent s
= print_indent (); print_string s
17 let indent_endline s
= print_indent (); print_endline s
18 let empty_line () = print_newline
()
19 let output fmt
= kprintf
indent_endline fmt
20 let print fmt
= kprintf print_endline fmt
22 let name_of attr index
=
23 match attr
.RA.name
with
24 | "" -> sprintf
"_%u" index
27 let param_name_to_string id index
=
29 | Next
-> sprintf
"_%u" index
30 | Numbered x
-> sprintf
"_%u" x
33 let make_name props default
= Option.default default
(Props.get props
"name")
34 let default_name str index
= sprintf
"%s_%u" str index
36 let choose_name props kind index
=
37 let name = match kind
with
38 | Create t
-> sprintf
"create_%s" t
39 | Update t
-> sprintf
"update_%s_%u" t index
40 | Insert t
-> sprintf
"insert_%s_%u" t index
41 | Delete t
-> sprintf
"delete_%s_%u" t index
42 | Select
-> sprintf
"select_%u" index
46 let get_sql props kind params
=
47 let sql = Props.get props
"sql" >> Option.get
in
50 | Insert _
-> sql ^
" (" ^
(String.concat
"," (List.map
(fun _
-> "?") params
)) ^
")"
51 | Select
| Update _
| Delete _
| Create _
-> sql
53 module type Lang
= sig
54 val generate_code
: int -> RA.Scheme.t
-> Stmt.params
-> Stmt.kind
-> Props.t
-> unit
55 val start_output
: unit -> unit
56 val finish_output
: unit -> unit
57 val comment
: ('a
,unit,string,unit) format4
-> 'a
60 module Make
(S
: Lang
) = struct
62 let generate_code index stmt
=
63 let ((scheme
,params
,kind
),props
) = stmt
in
64 let sql = Props.get props
"sql" >> Option.default
"" in
66 if not
(RA.Scheme.is_unique scheme
) then
67 Error.log
"Error: this SQL statement will produce rowset with duplicate column names:\n%s\n" sql
70 S.generate_code index scheme params kind props
73 let generate_header () =
74 S.comment
"DO NOT EDIT MANUALLY";
76 S.comment
"generated by sqlgg %s" Config.version
;
82 List.iteri
generate_code stmts
;