Mercurial > urweb

annotate src/prepare.sml @ 1945:8b1692660dac

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
How embarrassing; didn't try compiling before committing
author Adam Chlipala <adam@chlipala.net>
date Sat, 28 Dec 2013 06:30:21 -0500
parents 98895243b5b6
children 4d64af730e35
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@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
adam@1932 204 val (blob, st) = case blob of
adam@1932 205 NONE => (blob, st)
adam@1932 206 | SOME blob =>
adam@1932 207 let
adam@1932 208 val (b, st) = prepExp (blob, st)
adam@1932 209 in
adam@1932 210 (SOME b, st)
adam@1932 211 end
adamc@883 212 val (mimeType, st) = prepExp (mimeType, st)
adamc@741 213 in
adamc@883 214 ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
adamc@741 215 end
adamc@741 216
adamc@1065 217 | ERedirect (e, t) =>
adamc@1065 218 let
adamc@1065 219 val (e, st) = prepExp (e, st)
adamc@1065 220 in
adamc@1065 221 ((ERedirect (e, t), loc), st)
adamc@1065 222 end
adamc@1065 223
adamc@282 224 | EWrite e =>
adamc@282 225 let
adamc@883 226 val (e, st) = prepExp (e, st)
adamc@282 227 in
adamc@883 228 ((EWrite e, loc), st)
adamc@282 229 end
adamc@282 230 | ESeq (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 ((ESeq (e1, e2), loc), st)
adamc@282 236 end
adamc@282 237 | ELet (x, t, e1, e2) =>
adamc@282 238 let
adamc@883 239 val (e1, st) = prepExp (e1, st)
adamc@883 240 val (e2, st) = prepExp (e2, st)
adamc@282 241 in
adamc@883 242 ((ELet (x, t, e1, e2), loc), st)
adamc@282 243 end
adamc@282 244
adamc@282 245 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
adamc@486 246 let
adamc@883 247 val (body, st) = prepExp (body, st)
adamc@486 248 in
adamc@883 249 case prepString (query, st) of
adamc@486 250 NONE =>
adamc@486 251 ((EQuery {exps = exps, tables = tables, rnum = rnum,
adamc@486 252 state = state, query = query, body = body,
adamc@491 253 initial = initial, prepared = NONE}, loc),
adamc@883 254 st)
adamc@883 255 | SOME (id, s, st) =>
adamc@883 256 ((EQuery {exps = exps, tables = tables, rnum = rnum,
adamc@883 257 state = state, query = query, body = body,
adamc@883 258 initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st)
adamc@486 259 end
adamc@282 260
adam@1293 261 | EDml {dml, mode, ...} =>
adamc@883 262 (case prepString (dml, st) of
adamc@883 263 NONE => (e, st)
adamc@883 264 | SOME (id, s, st) =>
adam@1293 265 ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, loc), st))
adamc@307 266
adamc@338 267 | ENextval {seq, ...} =>
adamc@878 268 if #supportsNextval (Settings.currentDbms ()) then
adamc@878 269 let
adamc@878 270 val s = case seq of
adamc@878 271 (EPrim (Prim.String s), loc) =>
adamc@878 272 (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
adamc@878 273 | _ =>
adamc@878 274 let
adam@1663 275 val t = (TFfi ("Basis", "string"), loc)
adam@1663 276 val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc)
adamc@878 277 in
adam@1663 278 (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc)
adamc@878 279 end
adamc@878 280 in
adamc@883 281 case prepString (s, st) of
adamc@883 282 NONE => (e, st)
adamc@883 283 | SOME (id, s, st) =>
adamc@883 284 ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st)
adamc@878 285 end
adamc@878 286 else
adamc@883 287 (e, st)
adamc@338 288
adamc@1073 289 | ESetval {seq = e1, count = e2} =>
adamc@1073 290 let
adamc@1073 291 val (e1, st) = prepExp (e1, st)
adamc@1073 292 val (e2, st) = prepExp (e2, st)
adamc@1073 293 in
adamc@1073 294 ((ESetval {seq = e1, count = e2}, loc), st)
adamc@1073 295 end
adamc@1073 296
adamc@1112 297 | EUnurlify (e, t, b) =>
adamc@463 298 let
adamc@883 299 val (e, st) = prepExp (e, st)
adamc@463 300 in
adamc@1112 301 ((EUnurlify (e, t, b), loc), st)
adamc@463 302 end
adamc@463 303
adamc@883 304 fun prepDecl (d as (_, loc), st) =
adamc@282 305 case #1 d of
adamc@883 306 DStruct _ => (d, st)
adamc@883 307 | DDatatype _ => (d, st)
adamc@883 308 | DDatatypeForward _ => (d, st)
adamc@282 309 | DVal (x, n, t, e) =>
adamc@282 310 let
adamc@883 311 val (e, st) = prepExp (e, st)
adamc@282 312 in
adamc@883 313 ((DVal (x, n, t, e), loc), st)
adamc@282 314 end
adamc@282 315 | DFun (x, n, xts, t, e) =>
adamc@282 316 let
adamc@883 317 val (e, st) = prepExp (e, st)
adamc@282 318 in
adamc@883 319 ((DFun (x, n, xts, t, e), loc), st)
adamc@282 320 end
adamc@282 321 | DFunRec fs =>
adamc@282 322 let
adamc@883 323 val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) =>
adamc@282 324 let
adamc@883 325 val (e, st) = prepExp (e, st)
adamc@282 326 in
adamc@883 327 ((x, n, xts, t, e), st)
adamc@883 328 end) st fs
adamc@282 329 in
adamc@883 330 ((DFunRec fs, loc), st)
adamc@282 331 end
adamc@282 332
adamc@883 333 | DTable _ => (d, st)
adamc@883 334 | DSequence _ => (d, st)
adamc@883 335 | DView _ => (d, st)
adamc@883 336 | DDatabase _ => (d, st)
adamc@883 337 | DPreparedStatements _ => (d, st)
adamc@883 338 | DJavaScript _ => (d, st)
adamc@883 339 | DCookie _ => (d, st)
adamc@883 340 | DStyle _ => (d, st)
adam@1348 341 | DTask (tk, x1, x2, e) =>
adamc@1073 342 let
adamc@1073 343 val (e, st) = prepExp (e, st)
adamc@1073 344 in
adam@1348 345 ((DTask (tk, x1, x2, e), loc), st)
adamc@1073 346 end
adam@1294 347 | DOnError _ => (d, st)
adamc@282 348
adamc@282 349 fun prepare (ds, ps) =
adamc@282 350 let
adamc@883 351 val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds
adamc@282 352 in
adamc@883 353 ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps)
adamc@282 354 end
adamc@282 355
adamc@282 356 end