Mercurial > urweb

annotate src/prepare.sml @ 1658:de0a34e28bfa

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