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 adam@2048: EPrim (Prim.String (_, s)) => adamc@883: SOME (s :: ss, n) adam@1663: | 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)) adam@1663: | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int adam@1663: | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float adam@1663: | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String adam@1663: | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool adam@1663: | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time adam@1663: | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob adam@1663: | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel adam@1663: | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client adamc@883: adamc@883: | ECase (e, adamc@883: [((PNone _, _), adam@2048: (EPrim (Prim.String (_, "NULL")), _)), adamc@883: ((PSome (_, (PVar _, _)), _), adam@1663: (EFfiApp (m, x, [((ERel 0, _), _)]), _))], adam@1663: {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n) adamc@883: adamc@883: | ECase (e, adamc@883: [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), adam@2048: (EPrim (Prim.String (_, "TRUE")), _)), adamc@883: ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), adam@2048: (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 adam@1663: val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => adam@1663: let adam@1663: val (e, st) = prepExp (e, st) adam@1663: in adam@1663: ((e, t), st) adam@1663: end) 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 adam@1932: val (blob, st) = case blob of adam@1932: NONE => (blob, st) adam@1932: | SOME blob => adam@1932: let adam@1932: val (b, st) = prepExp (blob, st) adam@1932: in adam@1932: (SOME b, st) adam@1932: end 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@1065: | ERedirect (e, t) => adamc@1065: let adamc@1065: val (e, st) = prepExp (e, st) adamc@1065: in adamc@1065: ((ERedirect (e, t), loc), st) adamc@1065: end adamc@1065: 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: adam@1293: | EDml {dml, mode, ...} => adamc@883: (case prepString (dml, st) of adamc@883: NONE => (e, st) adamc@883: | SOME (id, s, st) => adam@1293: ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, 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 adam@2048: (EPrim (Prim.String (_, s)), loc) => adam@2048: (EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('" ^ s ^ "')")), loc) adamc@878: | _ => adamc@878: let adam@1663: val t = (TFfi ("Basis", "string"), loc) adam@2048: val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String (Prim.Normal, "')")), loc), t)]), loc) adamc@878: in adam@2048: (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('")), loc), t), (s', t)]), 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@1073: | ESetval {seq = e1, count = e2} => adamc@1073: let adamc@1073: val (e1, st) = prepExp (e1, st) adamc@1073: val (e2, st) = prepExp (e2, st) adamc@1073: in adamc@1073: ((ESetval {seq = e1, count = e2}, loc), st) adamc@1073: end adamc@1073: adamc@1112: | EUnurlify (e, t, b) => adamc@463: let adamc@883: val (e, st) = prepExp (e, st) adamc@463: in adamc@1112: ((EUnurlify (e, t, b), 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) adam@1348: | DTask (tk, x1, x2, e) => adamc@1073: let adamc@1073: val (e, st) = prepExp (e, st) adamc@1073: in adam@1348: ((DTask (tk, x1, x2, e), loc), st) adamc@1073: end adam@1294: | DOnError _ => (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