Mercurial > urweb

annotate src/prepare.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -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