Mercurial > urweb

comparison src/prepare.sml @ 282:0236d9412ad2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Ran a prepared statement with one string parameter
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 09:28:13 -0400
parents
children c0e4ac23522d
comparison
equal deleted inserted replaced
281:7d5860add50f 282:0236d9412ad2
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Prepare :> PREPARE = struct
29
30 open Cjr
31
32 fun prepString (e, ss, n) =
33 case #1 e of
34 EPrim (Prim.String s) =>
35 SOME (s :: ss, n)
36 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
37 (case prepString (e1, ss, n) of
38 NONE => NONE
39 | SOME (ss, n) => prepString (e2, ss, n))
40 | EFfiApp ("Basis", "sqlifyInt", [e]) =>
41 SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
42 | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
43 SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
44 | EFfiApp ("Basis", "sqlifyString", [e]) =>
45 SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
46 | EFfiApp ("Basis", "sqlifyBool", [e]) =>
47 SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
48
49 | _ => NONE
50
51 fun prepExp (e as (_, loc), sns) =
52 case #1 e of
53 EPrim _ => (e, sns)
54 | ERel _ => (e, sns)
55 | ENamed _ => (e, sns)
56 | ECon (_, _, NONE) => (e, sns)
57 | ECon (dk, pc, SOME e) =>
58 let
59 val (e, sns) = prepExp (e, sns)
60 in
61 ((ECon (dk, pc, SOME e), loc), sns)
62 end
63 | EFfi _ => (e, sns)
64 | EFfiApp (m, x, es) =>
65 let
66 val (es, sns) = ListUtil.foldlMap prepExp sns es
67 in
68 ((EFfiApp (m, x, es), loc), sns)
69 end
70 | EApp (e1, e2) =>
71 let
72 val (e1, sns) = prepExp (e1, sns)
73 val (e2, sns) = prepExp (e2, sns)
74 in
75 ((EApp (e1, e2), loc), sns)
76 end
77
78 | ERecord (rn, xes) =>
79 let
80 val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
81 let
82 val (e, sns) = prepExp (e, sns)
83 in
84 ((x, e), sns)
85 end) sns xes
86 in
87 ((ERecord (rn, xes), loc), sns)
88 end
89 | EField (e, s) =>
90 let
91 val (e, sns) = prepExp (e, sns)
92 in
93 ((EField (e, s), loc), sns)
94 end
95
96 | ECase (e, pes, ts) =>
97 let
98 val (e, sns) = prepExp (e, sns)
99 val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
100 let
101 val (e, sns) = prepExp (e, sns)
102 in
103 ((p, e), sns)
104 end) sns pes
105 in
106 ((ECase (e, pes, ts), loc), sns)
107 end
108
109 | EWrite e =>
110 let
111 val (e, sns) = prepExp (e, sns)
112 in
113 ((EWrite e, loc), sns)
114 end
115 | ESeq (e1, e2) =>
116 let
117 val (e1, sns) = prepExp (e1, sns)
118 val (e2, sns) = prepExp (e2, sns)
119 in
120 ((ESeq (e1, e2), loc), sns)
121 end
122 | ELet (x, t, e1, e2) =>
123 let
124 val (e1, sns) = prepExp (e1, sns)
125 val (e2, sns) = prepExp (e2, sns)
126 in
127 ((ELet (x, t, e1, e2), loc), sns)
128 end
129
130 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
131 (case prepString (query, [], 0) of
132 NONE => (e, sns)
133 | SOME (ss, n) =>
134 ((EQuery {exps = exps, tables = tables, rnum = rnum,
135 state = state, query = query, body = body,
136 initial = initial, prepared = SOME (#2 sns)}, loc),
137 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
138
139 fun prepDecl (d as (_, loc), sns) =
140 case #1 d of
141 DStruct _ => (d, sns)
142 | DDatatype _ => (d, sns)
143 | DDatatypeForward _ => (d, sns)
144 | DVal (x, n, t, e) =>
145 let
146 val (e, sns) = prepExp (e, sns)
147 in
148 ((DVal (x, n, t, e), loc), sns)
149 end
150 | DFun (x, n, xts, t, e) =>
151 let
152 val (e, sns) = prepExp (e, sns)
153 in
154 ((DFun (x, n, xts, t, e), loc), sns)
155 end
156 | DFunRec fs =>
157 let
158 val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
159 let
160 val (e, sns) = prepExp (e, sns)
161 in
162 ((x, n, xts, t, e), sns)
163 end) sns fs
164 in
165 ((DFunRec fs, loc), sns)
166 end
167
168 | DTable _ => (d, sns)
169 | DDatabase _ => (d, sns)
170 | DPreparedStatements _ => (d, sns)
171
172 fun prepare (ds, ps) =
173 let
174 val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
175 in
176 ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
177 end
178
179 end
180