adamc@282
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@282
|
2 * All rights reserved.
|
adamc@282
|
3 *
|
adamc@282
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@282
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@282
|
6 *
|
adamc@282
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@282
|
8 * this list of conditions and the following disclaimer.
|
adamc@282
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@282
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@282
|
11 * and/or other materials provided with the distribution.
|
adamc@282
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@282
|
13 * derived from this software without specific prior written permission.
|
adamc@282
|
14 *
|
adamc@282
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@282
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@282
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@282
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@282
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@282
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@282
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@282
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@282
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@282
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@282
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@282
|
26 *)
|
adamc@282
|
27
|
adamc@282
|
28 structure Prepare :> PREPARE = struct
|
adamc@282
|
29
|
adamc@282
|
30 open Cjr
|
adamc@282
|
31
|
adamc@282
|
32 fun prepString (e, ss, n) =
|
adamc@282
|
33 case #1 e of
|
adamc@282
|
34 EPrim (Prim.String s) =>
|
adamc@282
|
35 SOME (s :: ss, n)
|
adamc@282
|
36 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
|
adamc@282
|
37 (case prepString (e1, ss, n) of
|
adamc@282
|
38 NONE => NONE
|
adamc@282
|
39 | SOME (ss, n) => prepString (e2, ss, n))
|
adamc@282
|
40 | EFfiApp ("Basis", "sqlifyInt", [e]) =>
|
adamc@282
|
41 SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
|
adamc@282
|
42 | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
|
adamc@282
|
43 SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
|
adamc@282
|
44 | EFfiApp ("Basis", "sqlifyString", [e]) =>
|
adamc@282
|
45 SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
|
adamc@282
|
46 | EFfiApp ("Basis", "sqlifyBool", [e]) =>
|
adamc@282
|
47 SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
|
adamc@439
|
48 | EFfiApp ("Basis", "sqlifyTime", [e]) =>
|
adamc@439
|
49 SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1)
|
adamc@738
|
50 | EFfiApp ("Basis", "sqlifyBlob", [e]) =>
|
adamc@738
|
51 SOME ("$" ^ Int.toString (n + 1) ^ "::bytea" :: ss, n + 1)
|
adamc@678
|
52 | EFfiApp ("Basis", "sqlifyChannel", [e]) =>
|
adamc@682
|
53 SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
|
adamc@682
|
54 | EFfiApp ("Basis", "sqlifyClient", [e]) =>
|
adamc@678
|
55 SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1)
|
adamc@468
|
56
|
adamc@678
|
57 | ECase (e,
|
adamc@678
|
58 [((PNone _, _),
|
adamc@678
|
59 (EPrim (Prim.String "NULL"), _)),
|
adamc@678
|
60 ((PSome (_, (PVar _, _)), _),
|
adamc@678
|
61 (EFfiApp (m, x, [(ERel 0, _)]), _))],
|
adamc@678
|
62 _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n)
|
adamc@468
|
63
|
adamc@322
|
64 | ECase (e,
|
adamc@322
|
65 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
|
adamc@322
|
66 (EPrim (Prim.String "TRUE"), _)),
|
adamc@322
|
67 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
|
adamc@322
|
68 (EPrim (Prim.String "FALSE"), _))],
|
adamc@322
|
69 _) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
|
adamc@282
|
70
|
adamc@282
|
71 | _ => NONE
|
adamc@282
|
72
|
adamc@282
|
73 fun prepExp (e as (_, loc), sns) =
|
adamc@282
|
74 case #1 e of
|
adamc@282
|
75 EPrim _ => (e, sns)
|
adamc@282
|
76 | ERel _ => (e, sns)
|
adamc@282
|
77 | ENamed _ => (e, sns)
|
adamc@282
|
78 | ECon (_, _, NONE) => (e, sns)
|
adamc@282
|
79 | ECon (dk, pc, SOME e) =>
|
adamc@282
|
80 let
|
adamc@282
|
81 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
82 in
|
adamc@282
|
83 ((ECon (dk, pc, SOME e), loc), sns)
|
adamc@282
|
84 end
|
adamc@297
|
85 | ENone t => (e, sns)
|
adamc@291
|
86 | ESome (t, e) =>
|
adamc@291
|
87 let
|
adamc@291
|
88 val (e, sns) = prepExp (e, sns)
|
adamc@291
|
89 in
|
adamc@291
|
90 ((ESome (t, e), loc), sns)
|
adamc@291
|
91 end
|
adamc@282
|
92 | EFfi _ => (e, sns)
|
adamc@282
|
93 | EFfiApp (m, x, es) =>
|
adamc@282
|
94 let
|
adamc@282
|
95 val (es, sns) = ListUtil.foldlMap prepExp sns es
|
adamc@282
|
96 in
|
adamc@282
|
97 ((EFfiApp (m, x, es), loc), sns)
|
adamc@282
|
98 end
|
adamc@316
|
99 | EApp (e1, es) =>
|
adamc@282
|
100 let
|
adamc@282
|
101 val (e1, sns) = prepExp (e1, sns)
|
adamc@316
|
102 val (es, sns) = ListUtil.foldlMap prepExp sns es
|
adamc@282
|
103 in
|
adamc@316
|
104 ((EApp (e1, es), loc), sns)
|
adamc@282
|
105 end
|
adamc@282
|
106
|
adamc@387
|
107 | EUnop (s, e1) =>
|
adamc@387
|
108 let
|
adamc@387
|
109 val (e1, sns) = prepExp (e1, sns)
|
adamc@387
|
110 in
|
adamc@387
|
111 ((EUnop (s, e1), loc), sns)
|
adamc@387
|
112 end
|
adamc@387
|
113 | EBinop (s, e1, e2) =>
|
adamc@387
|
114 let
|
adamc@387
|
115 val (e1, sns) = prepExp (e1, sns)
|
adamc@387
|
116 val (e2, sns) = prepExp (e2, sns)
|
adamc@387
|
117 in
|
adamc@387
|
118 ((EBinop (s, e1, e2), loc), sns)
|
adamc@387
|
119 end
|
adamc@387
|
120
|
adamc@282
|
121 | ERecord (rn, xes) =>
|
adamc@282
|
122 let
|
adamc@282
|
123 val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
|
adamc@282
|
124 let
|
adamc@282
|
125 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
126 in
|
adamc@282
|
127 ((x, e), sns)
|
adamc@282
|
128 end) sns xes
|
adamc@282
|
129 in
|
adamc@282
|
130 ((ERecord (rn, xes), loc), sns)
|
adamc@282
|
131 end
|
adamc@282
|
132 | EField (e, s) =>
|
adamc@282
|
133 let
|
adamc@282
|
134 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
135 in
|
adamc@282
|
136 ((EField (e, s), loc), sns)
|
adamc@282
|
137 end
|
adamc@282
|
138
|
adamc@282
|
139 | ECase (e, pes, ts) =>
|
adamc@282
|
140 let
|
adamc@282
|
141 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
142 val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
|
adamc@282
|
143 let
|
adamc@282
|
144 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
145 in
|
adamc@282
|
146 ((p, e), sns)
|
adamc@282
|
147 end) sns pes
|
adamc@282
|
148 in
|
adamc@282
|
149 ((ECase (e, pes, ts), loc), sns)
|
adamc@282
|
150 end
|
adamc@282
|
151
|
adamc@283
|
152 | EError (e, t) =>
|
adamc@283
|
153 let
|
adamc@283
|
154 val (e, sns) = prepExp (e, sns)
|
adamc@283
|
155 in
|
adamc@283
|
156 ((EError (e, t), loc), sns)
|
adamc@283
|
157 end
|
adamc@283
|
158
|
adamc@282
|
159 | EWrite e =>
|
adamc@282
|
160 let
|
adamc@282
|
161 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
162 in
|
adamc@282
|
163 ((EWrite e, loc), sns)
|
adamc@282
|
164 end
|
adamc@282
|
165 | ESeq (e1, e2) =>
|
adamc@282
|
166 let
|
adamc@282
|
167 val (e1, sns) = prepExp (e1, sns)
|
adamc@282
|
168 val (e2, sns) = prepExp (e2, sns)
|
adamc@282
|
169 in
|
adamc@282
|
170 ((ESeq (e1, e2), loc), sns)
|
adamc@282
|
171 end
|
adamc@282
|
172 | ELet (x, t, e1, e2) =>
|
adamc@282
|
173 let
|
adamc@282
|
174 val (e1, sns) = prepExp (e1, sns)
|
adamc@282
|
175 val (e2, sns) = prepExp (e2, sns)
|
adamc@282
|
176 in
|
adamc@282
|
177 ((ELet (x, t, e1, e2), loc), sns)
|
adamc@282
|
178 end
|
adamc@282
|
179
|
adamc@282
|
180 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
|
adamc@486
|
181 let
|
adamc@486
|
182 val (body, sns) = prepExp (body, sns)
|
adamc@486
|
183 in
|
adamc@486
|
184 case prepString (query, [], 0) of
|
adamc@486
|
185 NONE =>
|
adamc@486
|
186 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@486
|
187 state = state, query = query, body = body,
|
adamc@491
|
188 initial = initial, prepared = NONE}, loc),
|
adamc@486
|
189 sns)
|
adamc@486
|
190 | SOME (ss, n) =>
|
adamc@486
|
191 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@486
|
192 state = state, query = query, body = body,
|
adamc@486
|
193 initial = initial, prepared = SOME (#2 sns)}, loc),
|
adamc@486
|
194 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))
|
adamc@486
|
195 end
|
adamc@282
|
196
|
adamc@307
|
197 | EDml {dml, ...} =>
|
adamc@307
|
198 (case prepString (dml, [], 0) of
|
adamc@307
|
199 NONE => (e, sns)
|
adamc@307
|
200 | SOME (ss, n) =>
|
adamc@307
|
201 ((EDml {dml = dml, prepared = SOME (#2 sns)}, loc),
|
adamc@307
|
202 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
|
adamc@307
|
203
|
adamc@338
|
204 | ENextval {seq, ...} =>
|
adamc@338
|
205 let
|
adamc@486
|
206 val s = case seq of
|
adamc@486
|
207 (EPrim (Prim.String s), loc) =>
|
adamc@486
|
208 (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
|
adamc@486
|
209 | _ =>
|
adamc@486
|
210 let
|
adamc@486
|
211 val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc)
|
adamc@486
|
212 in
|
adamc@486
|
213 (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc)
|
adamc@486
|
214 end
|
adamc@338
|
215 in
|
adamc@338
|
216 case prepString (s, [], 0) of
|
adamc@338
|
217 NONE => (e, sns)
|
adamc@338
|
218 | SOME (ss, n) =>
|
adamc@338
|
219 ((ENextval {seq = seq, prepared = SOME (#2 sns)}, loc),
|
adamc@338
|
220 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))
|
adamc@338
|
221 end
|
adamc@338
|
222
|
adamc@463
|
223 | EUnurlify (e, t) =>
|
adamc@463
|
224 let
|
adamc@463
|
225 val (e, sns) = prepExp (e, sns)
|
adamc@463
|
226 in
|
adamc@463
|
227 ((EUnurlify (e, t), loc), sns)
|
adamc@463
|
228 end
|
adamc@463
|
229
|
adamc@282
|
230 fun prepDecl (d as (_, loc), sns) =
|
adamc@282
|
231 case #1 d of
|
adamc@282
|
232 DStruct _ => (d, sns)
|
adamc@282
|
233 | DDatatype _ => (d, sns)
|
adamc@282
|
234 | DDatatypeForward _ => (d, sns)
|
adamc@282
|
235 | DVal (x, n, t, e) =>
|
adamc@282
|
236 let
|
adamc@282
|
237 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
238 in
|
adamc@282
|
239 ((DVal (x, n, t, e), loc), sns)
|
adamc@282
|
240 end
|
adamc@282
|
241 | DFun (x, n, xts, t, e) =>
|
adamc@282
|
242 let
|
adamc@282
|
243 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
244 in
|
adamc@282
|
245 ((DFun (x, n, xts, t, e), loc), sns)
|
adamc@282
|
246 end
|
adamc@282
|
247 | DFunRec fs =>
|
adamc@282
|
248 let
|
adamc@282
|
249 val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
|
adamc@282
|
250 let
|
adamc@282
|
251 val (e, sns) = prepExp (e, sns)
|
adamc@282
|
252 in
|
adamc@282
|
253 ((x, n, xts, t, e), sns)
|
adamc@282
|
254 end) sns fs
|
adamc@282
|
255 in
|
adamc@282
|
256 ((DFunRec fs, loc), sns)
|
adamc@282
|
257 end
|
adamc@282
|
258
|
adamc@282
|
259 | DTable _ => (d, sns)
|
adamc@338
|
260 | DSequence _ => (d, sns)
|
adamc@282
|
261 | DDatabase _ => (d, sns)
|
adamc@282
|
262 | DPreparedStatements _ => (d, sns)
|
adamc@569
|
263 | DJavaScript _ => (d, sns)
|
adamc@725
|
264 | DCookie _ => (d, sns)
|
adamc@718
|
265 | DStyle _ => (d, sns)
|
adamc@282
|
266
|
adamc@282
|
267 fun prepare (ds, ps) =
|
adamc@282
|
268 let
|
adamc@282
|
269 val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
|
adamc@282
|
270 in
|
adamc@282
|
271 ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
|
adamc@282
|
272 end
|
adamc@282
|
273
|
adamc@282
|
274 end
|
adamc@282
|
275
|