Mercurial > urweb

comparison src/prepare.sml @ 883:467285bb5578

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