adamc@282: (* Copyright (c) 2008, Adam Chlipala adamc@282: * All rights reserved. adamc@282: * adamc@282: * Redistribution and use in source and binary forms, with or without adamc@282: * modification, are permitted provided that the following conditions are met: adamc@282: * adamc@282: * - Redistributions of source code must retain the above copyright notice, adamc@282: * this list of conditions and the following disclaimer. adamc@282: * - Redistributions in binary form must reproduce the above copyright notice, adamc@282: * this list of conditions and the following disclaimer in the documentation adamc@282: * and/or other materials provided with the distribution. adamc@282: * - The names of contributors may not be used to endorse or promote products adamc@282: * derived from this software without specific prior written permission. adamc@282: * adamc@282: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@282: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@282: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@282: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@282: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@282: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@282: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@282: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@282: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@282: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@282: * POSSIBILITY OF SUCH DAMAGE. adamc@282: *) adamc@282: adamc@282: structure Prepare :> PREPARE = struct adamc@282: adamc@282: open Cjr adamc@874: open Settings adamc@282: adamc@883: structure SM = BinaryMapFn(struct adamc@883: type ord_key = string adamc@883: val compare = String.compare adamc@883: end) adamc@883: adamc@883: structure St :> sig adamc@883: type t adamc@883: val empty : t adamc@883: val nameOf : t * string -> t * int adamc@883: val list : t -> (string * int) list adamc@883: val count : t -> int adamc@883: end = struct adamc@883: adamc@883: type t = {map : int SM.map, list : (string * int) list, count : int} adamc@883: adamc@883: val empty = {map = SM.empty, list = [], count = 0} adamc@883: adamc@883: fun nameOf (t as {map, list, count}, s) = adamc@883: case SM.find (map, s) of adamc@883: NONE => ({map = SM.insert (map, s, count), list = (s, count) :: list, count = count + 1}, count) adamc@883: | SOME n => (t, n) adamc@883: adamc@883: fun list (t : t) = rev (#list t) adamc@883: fun count (t : t) = #count t adamc@883: adamc@883: end adamc@883: adamc@883: fun prepString (e, st) = adamc@874: let adamc@883: fun prepString' (e, ss, n) = adamc@883: let adamc@883: fun doOne t = adamc@883: SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1) adamc@883: in adamc@883: case #1 e of adamc@883: EPrim (Prim.String s) => adamc@883: SOME (s :: ss, n) adamc@883: | EFfiApp ("Basis", "strcat", [e1, e2]) => adamc@883: (case prepString' (e1, ss, n) of adamc@883: NONE => NONE adamc@883: | SOME (ss, n) => prepString' (e2, ss, n)) adamc@883: | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int adamc@883: | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float adamc@883: | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String adamc@883: | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool adamc@883: | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time adamc@883: | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob adamc@883: | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel adamc@883: | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client adamc@883: adamc@883: | ECase (e, adamc@883: [((PNone _, _), adamc@883: (EPrim (Prim.String "NULL"), _)), adamc@883: ((PSome (_, (PVar _, _)), _), adamc@883: (EFfiApp (m, x, [(ERel 0, _)]), _))], adamc@883: _) => prepString' ((EFfiApp (m, x, [e]), #2 e), ss, n) adamc@883: adamc@883: | ECase (e, adamc@883: [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), adamc@883: (EPrim (Prim.String "TRUE"), _)), adamc@883: ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), adamc@883: (EPrim (Prim.String "FALSE"), _))], adamc@883: _) => doOne Bool adamc@883: adamc@883: | _ => NONE adamc@883: end adamc@874: in adamc@883: case prepString' (e, [], 0) of adamc@883: NONE => NONE adamc@883: | SOME (ss, n) => adamc@883: let adamc@883: val s = String.concat (rev ss) adamc@883: val (st, id) = St.nameOf (st, s) adamc@883: in adamc@883: SOME (id, s, st) adamc@883: end adamc@874: end adamc@282: adamc@883: fun prepExp (e as (_, loc), st) = adamc@282: case #1 e of adamc@883: EPrim _ => (e, st) adamc@883: | ERel _ => (e, st) adamc@883: | ENamed _ => (e, st) adamc@883: | ECon (_, _, NONE) => (e, st) adamc@282: | ECon (dk, pc, SOME e) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((ECon (dk, pc, SOME e), loc), st) adamc@282: end adamc@883: | ENone t => (e, st) adamc@291: | ESome (t, e) => adamc@291: let adamc@883: val (e, st) = prepExp (e, st) adamc@291: in adamc@883: ((ESome (t, e), loc), st) adamc@291: end adamc@883: | EFfi _ => (e, st) adamc@282: | EFfiApp (m, x, es) => adamc@282: let adamc@883: val (es, st) = ListUtil.foldlMap prepExp st es adamc@282: in adamc@883: ((EFfiApp (m, x, es), loc), st) adamc@282: end adamc@316: | EApp (e1, es) => adamc@282: let adamc@883: val (e1, st) = prepExp (e1, st) adamc@883: val (es, st) = ListUtil.foldlMap prepExp st es adamc@282: in adamc@883: ((EApp (e1, es), loc), st) adamc@282: end adamc@282: adamc@387: | EUnop (s, e1) => adamc@387: let adamc@883: val (e1, st) = prepExp (e1, st) adamc@387: in adamc@883: ((EUnop (s, e1), loc), st) adamc@387: end adamc@387: | EBinop (s, e1, e2) => adamc@387: let adamc@883: val (e1, st) = prepExp (e1, st) adamc@883: val (e2, st) = prepExp (e2, st) adamc@387: in adamc@883: ((EBinop (s, e1, e2), loc), st) adamc@387: end adamc@387: adamc@282: | ERecord (rn, xes) => adamc@282: let adamc@883: val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((x, e), st) adamc@883: end) st xes adamc@282: in adamc@883: ((ERecord (rn, xes), loc), st) adamc@282: end adamc@282: | EField (e, s) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((EField (e, s), loc), st) adamc@282: end adamc@282: adamc@282: | ECase (e, pes, ts) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@883: val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((p, e), st) adamc@883: end) st pes adamc@282: in adamc@883: ((ECase (e, pes, ts), loc), st) adamc@282: end adamc@282: adamc@283: | EError (e, t) => adamc@283: let adamc@883: val (e, st) = prepExp (e, st) adamc@283: in adamc@883: ((EError (e, t), loc), st) adamc@283: end adamc@283: adamc@741: | EReturnBlob {blob, mimeType, t} => adamc@741: let adamc@883: val (blob, st) = prepExp (blob, st) adamc@883: val (mimeType, st) = prepExp (mimeType, st) adamc@741: in adamc@883: ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) adamc@741: end adamc@741: adamc@282: | EWrite e => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((EWrite e, loc), st) adamc@282: end adamc@282: | ESeq (e1, e2) => adamc@282: let adamc@883: val (e1, st) = prepExp (e1, st) adamc@883: val (e2, st) = prepExp (e2, st) adamc@282: in adamc@883: ((ESeq (e1, e2), loc), st) adamc@282: end adamc@282: | ELet (x, t, e1, e2) => adamc@282: let adamc@883: val (e1, st) = prepExp (e1, st) adamc@883: val (e2, st) = prepExp (e2, st) adamc@282: in adamc@883: ((ELet (x, t, e1, e2), loc), st) adamc@282: end adamc@282: adamc@282: | EQuery {exps, tables, rnum, state, query, body, initial, ...} => adamc@486: let adamc@883: val (body, st) = prepExp (body, st) adamc@486: in adamc@883: case prepString (query, st) of adamc@486: NONE => adamc@486: ((EQuery {exps = exps, tables = tables, rnum = rnum, adamc@486: state = state, query = query, body = body, adamc@491: initial = initial, prepared = NONE}, loc), adamc@883: st) adamc@883: | SOME (id, s, st) => adamc@883: ((EQuery {exps = exps, tables = tables, rnum = rnum, adamc@883: state = state, query = query, body = body, adamc@883: initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st) adamc@486: end adamc@282: adamc@307: | EDml {dml, ...} => adamc@883: (case prepString (dml, st) of adamc@883: NONE => (e, st) adamc@883: | SOME (id, s, st) => adamc@883: ((EDml {dml = dml, prepared = SOME {id = id, dml = s}}, loc), st)) adamc@307: adamc@338: | ENextval {seq, ...} => adamc@878: if #supportsNextval (Settings.currentDbms ()) then adamc@878: let adamc@878: val s = case seq of adamc@878: (EPrim (Prim.String s), loc) => adamc@878: (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) adamc@878: | _ => adamc@878: let adamc@878: val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) adamc@878: in adamc@878: (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) adamc@878: end adamc@878: in adamc@883: case prepString (s, st) of adamc@883: NONE => (e, st) adamc@883: | SOME (id, s, st) => adamc@883: ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st) adamc@878: end adamc@878: else adamc@883: (e, st) adamc@338: adamc@463: | EUnurlify (e, t) => adamc@463: let adamc@883: val (e, st) = prepExp (e, st) adamc@463: in adamc@883: ((EUnurlify (e, t), loc), st) adamc@463: end adamc@463: adamc@883: fun prepDecl (d as (_, loc), st) = adamc@282: case #1 d of adamc@883: DStruct _ => (d, st) adamc@883: | DDatatype _ => (d, st) adamc@883: | DDatatypeForward _ => (d, st) adamc@282: | DVal (x, n, t, e) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((DVal (x, n, t, e), loc), st) adamc@282: end adamc@282: | DFun (x, n, xts, t, e) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((DFun (x, n, xts, t, e), loc), st) adamc@282: end adamc@282: | DFunRec fs => adamc@282: let adamc@883: val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) => adamc@282: let adamc@883: val (e, st) = prepExp (e, st) adamc@282: in adamc@883: ((x, n, xts, t, e), st) adamc@883: end) st fs adamc@282: in adamc@883: ((DFunRec fs, loc), st) adamc@282: end adamc@282: adamc@883: | DTable _ => (d, st) adamc@883: | DSequence _ => (d, st) adamc@883: | DView _ => (d, st) adamc@883: | DDatabase _ => (d, st) adamc@883: | DPreparedStatements _ => (d, st) adamc@883: | DJavaScript _ => (d, st) adamc@883: | DCookie _ => (d, st) adamc@883: | DStyle _ => (d, st) adamc@282: adamc@282: fun prepare (ds, ps) = adamc@282: let adamc@883: val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds adamc@282: in adamc@883: ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps) adamc@282: end adamc@282: adamc@282: end