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)
|
adamc@883
|
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))
|
adamc@883
|
74 | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int
|
adamc@883
|
75 | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float
|
adamc@883
|
76 | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String
|
adamc@883
|
77 | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool
|
adamc@883
|
78 | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time
|
adamc@883
|
79 | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob
|
adamc@883
|
80 | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel
|
adamc@883
|
81 | EFfiApp ("Basis", "sqlifyClient", [e]) => 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 _, _)), _),
|
adamc@883
|
87 (EFfiApp (m, x, [(ERel 0, _)]), _))],
|
adamc@883
|
88 _) => prepString' ((EFfiApp (m, x, [e]), #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
|
adamc@883
|
133 val (es, st) = ListUtil.foldlMap prepExp st es
|
adamc@282
|
134 in
|
adamc@883
|
135 ((EFfiApp (m, x, es), loc), st)
|
adamc@282
|
136 end
|
adamc@316
|
137 | EApp (e1, es) =>
|
adamc@282
|
138 let
|
adamc@883
|
139 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
140 val (es, st) = ListUtil.foldlMap prepExp st es
|
adamc@282
|
141 in
|
adamc@883
|
142 ((EApp (e1, es), loc), st)
|
adamc@282
|
143 end
|
adamc@282
|
144
|
adamc@387
|
145 | EUnop (s, e1) =>
|
adamc@387
|
146 let
|
adamc@883
|
147 val (e1, st) = prepExp (e1, st)
|
adamc@387
|
148 in
|
adamc@883
|
149 ((EUnop (s, e1), loc), st)
|
adamc@387
|
150 end
|
adamc@387
|
151 | EBinop (s, e1, e2) =>
|
adamc@387
|
152 let
|
adamc@883
|
153 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
154 val (e2, st) = prepExp (e2, st)
|
adamc@387
|
155 in
|
adamc@883
|
156 ((EBinop (s, e1, e2), loc), st)
|
adamc@387
|
157 end
|
adamc@387
|
158
|
adamc@282
|
159 | ERecord (rn, xes) =>
|
adamc@282
|
160 let
|
adamc@883
|
161 val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) =>
|
adamc@282
|
162 let
|
adamc@883
|
163 val (e, st) = prepExp (e, st)
|
adamc@282
|
164 in
|
adamc@883
|
165 ((x, e), st)
|
adamc@883
|
166 end) st xes
|
adamc@282
|
167 in
|
adamc@883
|
168 ((ERecord (rn, xes), loc), st)
|
adamc@282
|
169 end
|
adamc@282
|
170 | EField (e, s) =>
|
adamc@282
|
171 let
|
adamc@883
|
172 val (e, st) = prepExp (e, st)
|
adamc@282
|
173 in
|
adamc@883
|
174 ((EField (e, s), loc), st)
|
adamc@282
|
175 end
|
adamc@282
|
176
|
adamc@282
|
177 | ECase (e, pes, ts) =>
|
adamc@282
|
178 let
|
adamc@883
|
179 val (e, st) = prepExp (e, st)
|
adamc@883
|
180 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@282
|
181 let
|
adamc@883
|
182 val (e, st) = prepExp (e, st)
|
adamc@282
|
183 in
|
adamc@883
|
184 ((p, e), st)
|
adamc@883
|
185 end) st pes
|
adamc@282
|
186 in
|
adamc@883
|
187 ((ECase (e, pes, ts), loc), st)
|
adamc@282
|
188 end
|
adamc@282
|
189
|
adamc@283
|
190 | EError (e, t) =>
|
adamc@283
|
191 let
|
adamc@883
|
192 val (e, st) = prepExp (e, st)
|
adamc@283
|
193 in
|
adamc@883
|
194 ((EError (e, t), loc), st)
|
adamc@283
|
195 end
|
adamc@283
|
196
|
adamc@741
|
197 | EReturnBlob {blob, mimeType, t} =>
|
adamc@741
|
198 let
|
adamc@883
|
199 val (blob, st) = prepExp (blob, st)
|
adamc@883
|
200 val (mimeType, st) = prepExp (mimeType, st)
|
adamc@741
|
201 in
|
adamc@883
|
202 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
|
adamc@741
|
203 end
|
adamc@741
|
204
|
adamc@282
|
205 | EWrite e =>
|
adamc@282
|
206 let
|
adamc@883
|
207 val (e, st) = prepExp (e, st)
|
adamc@282
|
208 in
|
adamc@883
|
209 ((EWrite e, loc), st)
|
adamc@282
|
210 end
|
adamc@282
|
211 | ESeq (e1, e2) =>
|
adamc@282
|
212 let
|
adamc@883
|
213 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
214 val (e2, st) = prepExp (e2, st)
|
adamc@282
|
215 in
|
adamc@883
|
216 ((ESeq (e1, e2), loc), st)
|
adamc@282
|
217 end
|
adamc@282
|
218 | ELet (x, t, e1, e2) =>
|
adamc@282
|
219 let
|
adamc@883
|
220 val (e1, st) = prepExp (e1, st)
|
adamc@883
|
221 val (e2, st) = prepExp (e2, st)
|
adamc@282
|
222 in
|
adamc@883
|
223 ((ELet (x, t, e1, e2), loc), st)
|
adamc@282
|
224 end
|
adamc@282
|
225
|
adamc@282
|
226 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
|
adamc@486
|
227 let
|
adamc@883
|
228 val (body, st) = prepExp (body, st)
|
adamc@486
|
229 in
|
adamc@883
|
230 case prepString (query, st) of
|
adamc@486
|
231 NONE =>
|
adamc@486
|
232 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@486
|
233 state = state, query = query, body = body,
|
adamc@491
|
234 initial = initial, prepared = NONE}, loc),
|
adamc@883
|
235 st)
|
adamc@883
|
236 | SOME (id, s, st) =>
|
adamc@883
|
237 ((EQuery {exps = exps, tables = tables, rnum = rnum,
|
adamc@883
|
238 state = state, query = query, body = body,
|
adamc@883
|
239 initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st)
|
adamc@486
|
240 end
|
adamc@282
|
241
|
adamc@307
|
242 | EDml {dml, ...} =>
|
adamc@883
|
243 (case prepString (dml, st) of
|
adamc@883
|
244 NONE => (e, st)
|
adamc@883
|
245 | SOME (id, s, st) =>
|
adamc@883
|
246 ((EDml {dml = dml, prepared = SOME {id = id, dml = s}}, loc), st))
|
adamc@307
|
247
|
adamc@338
|
248 | ENextval {seq, ...} =>
|
adamc@878
|
249 if #supportsNextval (Settings.currentDbms ()) then
|
adamc@878
|
250 let
|
adamc@878
|
251 val s = case seq of
|
adamc@878
|
252 (EPrim (Prim.String s), loc) =>
|
adamc@878
|
253 (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
|
adamc@878
|
254 | _ =>
|
adamc@878
|
255 let
|
adamc@878
|
256 val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc)
|
adamc@878
|
257 in
|
adamc@878
|
258 (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc)
|
adamc@878
|
259 end
|
adamc@878
|
260 in
|
adamc@883
|
261 case prepString (s, st) of
|
adamc@883
|
262 NONE => (e, st)
|
adamc@883
|
263 | SOME (id, s, st) =>
|
adamc@883
|
264 ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st)
|
adamc@878
|
265 end
|
adamc@878
|
266 else
|
adamc@883
|
267 (e, st)
|
adamc@338
|
268
|
adamc@463
|
269 | EUnurlify (e, t) =>
|
adamc@463
|
270 let
|
adamc@883
|
271 val (e, st) = prepExp (e, st)
|
adamc@463
|
272 in
|
adamc@883
|
273 ((EUnurlify (e, t), loc), st)
|
adamc@463
|
274 end
|
adamc@463
|
275
|
adamc@883
|
276 fun prepDecl (d as (_, loc), st) =
|
adamc@282
|
277 case #1 d of
|
adamc@883
|
278 DStruct _ => (d, st)
|
adamc@883
|
279 | DDatatype _ => (d, st)
|
adamc@883
|
280 | DDatatypeForward _ => (d, st)
|
adamc@282
|
281 | DVal (x, n, t, e) =>
|
adamc@282
|
282 let
|
adamc@883
|
283 val (e, st) = prepExp (e, st)
|
adamc@282
|
284 in
|
adamc@883
|
285 ((DVal (x, n, t, e), loc), st)
|
adamc@282
|
286 end
|
adamc@282
|
287 | DFun (x, n, xts, t, e) =>
|
adamc@282
|
288 let
|
adamc@883
|
289 val (e, st) = prepExp (e, st)
|
adamc@282
|
290 in
|
adamc@883
|
291 ((DFun (x, n, xts, t, e), loc), st)
|
adamc@282
|
292 end
|
adamc@282
|
293 | DFunRec fs =>
|
adamc@282
|
294 let
|
adamc@883
|
295 val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) =>
|
adamc@282
|
296 let
|
adamc@883
|
297 val (e, st) = prepExp (e, st)
|
adamc@282
|
298 in
|
adamc@883
|
299 ((x, n, xts, t, e), st)
|
adamc@883
|
300 end) st fs
|
adamc@282
|
301 in
|
adamc@883
|
302 ((DFunRec fs, loc), st)
|
adamc@282
|
303 end
|
adamc@282
|
304
|
adamc@883
|
305 | DTable _ => (d, st)
|
adamc@883
|
306 | DSequence _ => (d, st)
|
adamc@883
|
307 | DView _ => (d, st)
|
adamc@883
|
308 | DDatabase _ => (d, st)
|
adamc@883
|
309 | DPreparedStatements _ => (d, st)
|
adamc@883
|
310 | DJavaScript _ => (d, st)
|
adamc@883
|
311 | DCookie _ => (d, st)
|
adamc@883
|
312 | DStyle _ => (d, st)
|
adamc@282
|
313
|
adamc@282
|
314 fun prepare (ds, ps) =
|
adamc@282
|
315 let
|
adamc@883
|
316 val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds
|
adamc@282
|
317 in
|
adamc@883
|
318 ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps)
|
adamc@282
|
319 end
|
adamc@282
|
320
|
adamc@282
|
321 end
|