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@874
|
31 open Settings
|
adamc@282
|
32
|
adamc@883
|
33 structure SM = BinaryMapFn(struct
|
adamc@883
|
34 type ord_key = string
|
adamc@883
|
35 val compare = String.compare
|
adamc@883
|
36 end)
|
adamc@883
|
37
|
adamc@883
|
38 structure St :> sig
|
adamc@883
|
39 type t
|
adamc@883
|
40 val empty : t
|
adamc@883
|
41 val nameOf : t * string -> t * int
|
adamc@883
|
42 val list : t -> (string * int) list
|
adamc@883
|
43 val count : t -> int
|
adamc@883
|
44 end = struct
|
adamc@883
|
45
|
adamc@883
|
46 type t = {map : int SM.map, list : (string * int) list, count : int}
|
adamc@883
|
47
|
adamc@883
|
48 val empty = {map = SM.empty, list = [], count = 0}
|
adamc@883
|
49
|
adamc@883
|
50 fun nameOf (t as {map, list, count}, s) =
|
adamc@883
|
51 case SM.find (map, s) of
|
adamc@883
|
52 NONE => ({map = SM.insert (map, s, count), list = (s, count) :: list, count = count + 1}, count)
|
adamc@883
|
53 | SOME n => (t, n)
|
adamc@883
|
54
|
adamc@883
|
55 fun list (t : t) = rev (#list t)
|
adamc@883
|
56 fun count (t : t) = #count t
|
adamc@883
|
57
|
adamc@883
|
58 end
|
adamc@883
|
59
|
adamc@883
|
60 fun prepString (e, st) =
|
adamc@874
|
61 let
|
adamc@883
|
62 fun prepString' (e, ss, n) =
|
adamc@883
|
63 let
|
adamc@883
|
64 fun doOne t =
|
adamc@883
|
65 SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1)
|
adamc@883
|
66 in
|
adamc@883
|
67 case #1 e of
|
adamc@883
|
68 EPrim (Prim.String s) =>
|
adamc@883
|
69 SOME (s :: ss, n)
|
adam@1663
|
70 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
|
adamc@883
|
71 (case prepString' (e1, ss, n) of
|
adamc@883
|
72 NONE => NONE
|
adamc@883
|
73 | SOME (ss, n) => prepString' (e2, ss, n))
|
adam@1663
|
74 | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int
|
adam@1663
|
75 | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float
|
adam@1663
|
76 | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String
|
adam@1663
|
77 | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool
|
adam@1663
|
78 | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time
|
adam@1663
|
79 | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob
|
adam@1663
|
80 | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel
|
adam@1663
|
81 | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client
|
adamc@883
|
82
|
adamc@883
|
83 | ECase (e,
|
adamc@883
|
84 [((PNone _, _),
|
adamc@883
|
85 (EPrim (Prim.String "NULL"), _)),
|
adamc@883
|
86 ((PSome (_, (PVar _, _)), _),
|
adam@1663
|
87 (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
|
adam@1663
|
88 {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n)
|
adamc@883
|
89
|
adamc@883
|
90 | ECase (e,
|
adamc@883
|
91 [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
|
adamc@883
|
92 (EPrim (Prim.String "TRUE"), _)),
|
adamc@883
|
93 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
|
adamc@883
|
94 (EPrim (Prim.String "FALSE"), _))],
|
adamc@883
|
95 _) => doOne Bool
|
adamc@883
|
96
|
adamc@883
|
97 | _ => NONE
|
adamc@883
|
98 end
|
adamc@874
|
99 in
|
adamc@883
|
100 case prepString' (e, [], 0) of
|
adamc@883
|
101 NONE => NONE
|
adamc@883
|
102 | SOME (ss, n) =>
|
adamc@883
|
103 let
|
adamc@883
|
104 val s = String.concat (rev ss)
|
adamc@883
|
105 val (st, id) = St.nameOf (st, s)
|
adamc@883
|
106 in
|
adamc@883
|
107 SOME (id, s, st)
|
adamc@883
|
108 end
|
adamc@874
|
109 end
|
adamc@282
|
110
|
adamc@883
|
111 fun prepExp (e as (_, loc), st) =
|
adamc@282
|
112 case #1 e of
|
adamc@883
|
113 EPrim _ => (e, st)
|
adamc@883
|
114 | ERel _ => (e, st)
|
adamc@883
|
115 | ENamed _ => (e, st)
|
adamc@883
|
116 | ECon (_, _, NONE) => (e, st)
|
adamc@282
|
117 | ECon (dk, pc, SOME e) =>
|
adamc@282
|
118 let
|
adamc@883
|
119 val (e, st) = prepExp (e, st)
|
adamc@282
|
120 in
|
adamc@883
|
121 ((ECon (dk, pc, SOME e), loc), st)
|
adamc@282
|
122 end
|
adamc@883
|
123 | ENone t => (e, st)
|
adamc@291
|
124 | ESome (t, e) =>
|
adamc@291
|
125 let
|
adamc@883
|
126 val (e, st) = prepExp (e, st)
|
adamc@291
|
127 in
|
adamc@883
|
128 ((ESome (t, e), loc), st)
|
adamc@291
|
129 end
|
adamc@883
|
130 | EFfi _ => (e, st)
|
adamc@282
|
131 | EFfiApp (m, x, es) =>
|
adamc@282
|
132 let
|
adam@1663
|
133 val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
|
adam@1663
|
134 let
|
adam@1663
|
135 val (e, st) = prepExp (e, st)
|
adam@1663
|
136 in
|
adam@1663
|
137 ((e, t), st)
|
adam@1663
|
138 end) st es
|
adamc@282
|
139 in
|
adamc@883
|
140 ((EFfiApp (m, x, es), loc), st)
|
adamc@282
|
141 end
|
adamc@316
|
142 | EApp (e1, es) =>
|
adamc@282
|
143 let
|
adamc@883
|
144 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
145 val (es, st) = ListUtil.foldlMap prepExp st es
|
adamc@282
|
146 in
|
adamc@883
|
147 ((EApp (e1, es), loc), st)
|
adamc@282
|
148 end
|
adamc@282
|
149
|
adamc@387
|
150 | EUnop (s, e1) =>
|
adamc@387
|
151 let
|
adamc@883
|
152 val (e1, st) = prepExp (e1, st)
|
adamc@387
|
153 in
|
adamc@883
|
154 ((EUnop (s, e1), loc), st)
|
adamc@387
|
155 end
|
adamc@387
|
156 | EBinop (s, e1, e2) =>
|
adamc@387
|
157 let
|
adamc@883
|
158 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
159 val (e2, st) = prepExp (e2, st)
|
adamc@387
|
160 in
|
adamc@883
|
161 ((EBinop (s, e1, e2), loc), st)
|
adamc@387
|
162 end
|
adamc@387
|
163
|
adamc@282
|
164 | ERecord (rn, xes) =>
|
adamc@282
|
165 let
|
adamc@883
|
166 val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) =>
|
adamc@282
|
167 let
|
adamc@883
|
168 val (e, st) = prepExp (e, st)
|
adamc@282
|
169 in
|
adamc@883
|
170 ((x, e), st)
|
adamc@883
|
171 end) st xes
|
adamc@282
|
172 in
|
adamc@883
|
173 ((ERecord (rn, xes), loc), st)
|
adamc@282
|
174 end
|
adamc@282
|
175 | EField (e, s) =>
|
adamc@282
|
176 let
|
adamc@883
|
177 val (e, st) = prepExp (e, st)
|
adamc@282
|
178 in
|
adamc@883
|
179 ((EField (e, s), loc), st)
|
adamc@282
|
180 end
|
adamc@282
|
181
|
adamc@282
|
182 | ECase (e, pes, ts) =>
|
adamc@282
|
183 let
|
adamc@883
|
184 val (e, st) = prepExp (e, st)
|
adamc@883
|
185 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@282
|
186 let
|
adamc@883
|
187 val (e, st) = prepExp (e, st)
|
adamc@282
|
188 in
|
adamc@883
|
189 ((p, e), st)
|
adamc@883
|
190 end) st pes
|
adamc@282
|
191 in
|
adamc@883
|
192 ((ECase (e, pes, ts), loc), st)
|
adamc@282
|
193 end
|
adamc@282
|
194
|
adamc@283
|
195 | EError (e, t) =>
|
adamc@283
|
196 let
|
adamc@883
|
197 val (e, st) = prepExp (e, st)
|
adamc@283
|
198 in
|
adamc@883
|
199 ((EError (e, t), loc), st)
|
adamc@283
|
200 end
|
adamc@283
|
201
|
adamc@741
|
202 | EReturnBlob {blob, mimeType, t} =>
|
adamc@741
|
203 let
|
adamc@883
|
204 val (blob, st) = prepExp (blob, st)
|
adamc@883
|
205 val (mimeType, st) = prepExp (mimeType, st)
|
adamc@741
|
206 in
|
adamc@883
|
207 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
|
adamc@741
|
208 end
|
adamc@741
|
209
|
adamc@1065
|
210 | ERedirect (e, t) =>
|
adamc@1065
|
211 let
|
adamc@1065
|
212 val (e, st) = prepExp (e, st)
|
adamc@1065
|
213 in
|
adamc@1065
|
214 ((ERedirect (e, t), loc), st)
|
adamc@1065
|
215 end
|
adamc@1065
|
216
|
adamc@282
|
217 | EWrite e =>
|
adamc@282
|
218 let
|
adamc@883
|
219 val (e, st) = prepExp (e, st)
|
adamc@282
|
220 in
|
adamc@883
|
221 ((EWrite e, loc), st)
|
adamc@282
|
222 end
|
adamc@282
|
223 | ESeq (e1, e2) =>
|
adamc@282
|
224 let
|
adamc@883
|
225 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
226 val (e2, st) = prepExp (e2, st)
|
adamc@282
|
227 in
|
adamc@883
|
228 ((ESeq (e1, e2), loc), st)
|
adamc@282
|
229 end
|
adamc@282
|
230 | ELet (x, t, e1, e2) =>
|
adamc@282
|
231 let
|
adamc@883
|
232 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
233 val (e2, st) = prepExp (e2, st)
|
adamc@282
|
234 in
|
adamc@883
|
235 ((ELet (x, t, e1, e2), loc), st)
|
adamc@282
|
236 end
|
adamc@282
|
237
|
adamc@282
|
238 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
|
adamc@486
|
239 let
|
adamc@883
|
240 val (body, st) = prepExp (body, st)
|
adamc@486
|
241 in
|
adamc@883
|
242 case prepString (query, st) of
|
adamc@486
|
243 NONE =>
|
adamc@486
|
244 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@486
|
245 state = state, query = query, body = body,
|
adamc@491
|
246 initial = initial, prepared = NONE}, loc),
|
adamc@883
|
247 st)
|
adamc@883
|
248 | SOME (id, s, st) =>
|
adamc@883
|
249 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@883
|
250 state = state, query = query, body = body,
|
adamc@883
|
251 initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st)
|
adamc@486
|
252 end
|
adamc@282
|
253
|
adam@1293
|
254 | EDml {dml, mode, ...} =>
|
adamc@883
|
255 (case prepString (dml, st) of
|
adamc@883
|
256 NONE => (e, st)
|
adamc@883
|
257 | SOME (id, s, st) =>
|
adam@1293
|
258 ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, loc), st))
|
adamc@307
|
259
|
adamc@338
|
260 | ENextval {seq, ...} =>
|
adamc@878
|
261 if #supportsNextval (Settings.currentDbms ()) then
|
adamc@878
|
262 let
|
adamc@878
|
263 val s = case seq of
|
adamc@878
|
264 (EPrim (Prim.String s), loc) =>
|
adamc@878
|
265 (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
|
adamc@878
|
266 | _ =>
|
adamc@878
|
267 let
|
adam@1663
|
268 val t = (TFfi ("Basis", "string"), loc)
|
adam@1663
|
269 val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc)
|
adamc@878
|
270 in
|
adam@1663
|
271 (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc)
|
adamc@878
|
272 end
|
adamc@878
|
273 in
|
adamc@883
|
274 case prepString (s, st) of
|
adamc@883
|
275 NONE => (e, st)
|
adamc@883
|
276 | SOME (id, s, st) =>
|
adamc@883
|
277 ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st)
|
adamc@878
|
278 end
|
adamc@878
|
279 else
|
adamc@883
|
280 (e, st)
|
adamc@338
|
281
|
adamc@1073
|
282 | ESetval {seq = e1, count = e2} =>
|
adamc@1073
|
283 let
|
adamc@1073
|
284 val (e1, st) = prepExp (e1, st)
|
adamc@1073
|
285 val (e2, st) = prepExp (e2, st)
|
adamc@1073
|
286 in
|
adamc@1073
|
287 ((ESetval {seq = e1, count = e2}, loc), st)
|
adamc@1073
|
288 end
|
adamc@1073
|
289
|
adamc@1112
|
290 | EUnurlify (e, t, b) =>
|
adamc@463
|
291 let
|
adamc@883
|
292 val (e, st) = prepExp (e, st)
|
adamc@463
|
293 in
|
adamc@1112
|
294 ((EUnurlify (e, t, b), loc), st)
|
adamc@463
|
295 end
|
adamc@463
|
296
|
adamc@883
|
297 fun prepDecl (d as (_, loc), st) =
|
adamc@282
|
298 case #1 d of
|
adamc@883
|
299 DStruct _ => (d, st)
|
adamc@883
|
300 | DDatatype _ => (d, st)
|
adamc@883
|
301 | DDatatypeForward _ => (d, st)
|
adamc@282
|
302 | DVal (x, n, t, e) =>
|
adamc@282
|
303 let
|
adamc@883
|
304 val (e, st) = prepExp (e, st)
|
adamc@282
|
305 in
|
adamc@883
|
306 ((DVal (x, n, t, e), loc), st)
|
adamc@282
|
307 end
|
adamc@282
|
308 | DFun (x, n, xts, t, e) =>
|
adamc@282
|
309 let
|
adamc@883
|
310 val (e, st) = prepExp (e, st)
|
adamc@282
|
311 in
|
adamc@883
|
312 ((DFun (x, n, xts, t, e), loc), st)
|
adamc@282
|
313 end
|
adamc@282
|
314 | DFunRec fs =>
|
adamc@282
|
315 let
|
adamc@883
|
316 val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) =>
|
adamc@282
|
317 let
|
adamc@883
|
318 val (e, st) = prepExp (e, st)
|
adamc@282
|
319 in
|
adamc@883
|
320 ((x, n, xts, t, e), st)
|
adamc@883
|
321 end) st fs
|
adamc@282
|
322 in
|
adamc@883
|
323 ((DFunRec fs, loc), st)
|
adamc@282
|
324 end
|
adamc@282
|
325
|
adamc@883
|
326 | DTable _ => (d, st)
|
adamc@883
|
327 | DSequence _ => (d, st)
|
adamc@883
|
328 | DView _ => (d, st)
|
adamc@883
|
329 | DDatabase _ => (d, st)
|
adamc@883
|
330 | DPreparedStatements _ => (d, st)
|
adamc@883
|
331 | DJavaScript _ => (d, st)
|
adamc@883
|
332 | DCookie _ => (d, st)
|
adamc@883
|
333 | DStyle _ => (d, st)
|
adam@1348
|
334 | DTask (tk, x1, x2, e) =>
|
adamc@1073
|
335 let
|
adamc@1073
|
336 val (e, st) = prepExp (e, st)
|
adamc@1073
|
337 in
|
adam@1348
|
338 ((DTask (tk, x1, x2, e), loc), st)
|
adamc@1073
|
339 end
|
adam@1294
|
340 | DOnError _ => (d, st)
|
adamc@282
|
341
|
adamc@282
|
342 fun prepare (ds, ps) =
|
adamc@282
|
343 let
|
adamc@883
|
344 val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds
|
adamc@282
|
345 in
|
adamc@883
|
346 ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps)
|
adamc@282
|
347 end
|
adamc@282
|
348
|
adamc@282
|
349 end
|