annotate src/prepare.sml @ 740:b302b6e35f93

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