Mercurial > urweb

annotate src/prepare.sml @ 907:5fe49effbc83

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
JavaScript urlifying of bools; correct Link attribute escaping
author Adam Chlipala <adamc@hcoop.net>
date Tue, 11 Aug 2009 12:01:54 -0400
parents 467285bb5578
children 217eb87dde31
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)
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