Mercurial > urweb

annotate src/prepare.sml @ 878:a8952047e1d3

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