Mercurial > urweb

annotate src/prepare.sml @ 1795:d28adceef22a

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