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@282: adamc@282: fun prepString (e, ss, n) = adamc@282: case #1 e of adamc@282: EPrim (Prim.String s) => adamc@282: SOME (s :: ss, n) adamc@282: | EFfiApp ("Basis", "strcat", [e1, e2]) => adamc@282: (case prepString (e1, ss, n) of adamc@282: NONE => NONE adamc@282: | SOME (ss, n) => prepString (e2, ss, n)) adamc@282: | EFfiApp ("Basis", "sqlifyInt", [e]) => adamc@282: SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1) adamc@282: | EFfiApp ("Basis", "sqlifyFloat", [e]) => adamc@282: SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1) adamc@282: | EFfiApp ("Basis", "sqlifyString", [e]) => adamc@282: SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1) adamc@282: | EFfiApp ("Basis", "sqlifyBool", [e]) => adamc@282: SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) adamc@439: | EFfiApp ("Basis", "sqlifyTime", [e]) => adamc@439: SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) adamc@678: | EFfiApp ("Basis", "sqlifyChannel", [e]) => adamc@682: SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1) adamc@682: | EFfiApp ("Basis", "sqlifyClient", [e]) => adamc@678: SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1) adamc@468: adamc@678: | ECase (e, adamc@678: [((PNone _, _), adamc@678: (EPrim (Prim.String "NULL"), _)), adamc@678: ((PSome (_, (PVar _, _)), _), adamc@678: (EFfiApp (m, x, [(ERel 0, _)]), _))], adamc@678: _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n) adamc@468: adamc@322: | ECase (e, adamc@322: [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), adamc@322: (EPrim (Prim.String "TRUE"), _)), adamc@322: ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), adamc@322: (EPrim (Prim.String "FALSE"), _))], adamc@322: _) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) adamc@282: adamc@282: | _ => NONE adamc@282: adamc@282: fun prepExp (e as (_, loc), sns) = adamc@282: case #1 e of adamc@282: EPrim _ => (e, sns) adamc@282: | ERel _ => (e, sns) adamc@282: | ENamed _ => (e, sns) adamc@282: | ECon (_, _, NONE) => (e, sns) adamc@282: | ECon (dk, pc, SOME e) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((ECon (dk, pc, SOME e), loc), sns) adamc@282: end adamc@297: | ENone t => (e, sns) adamc@291: | ESome (t, e) => adamc@291: let adamc@291: val (e, sns) = prepExp (e, sns) adamc@291: in adamc@291: ((ESome (t, e), loc), sns) adamc@291: end adamc@282: | EFfi _ => (e, sns) adamc@282: | EFfiApp (m, x, es) => adamc@282: let adamc@282: val (es, sns) = ListUtil.foldlMap prepExp sns es adamc@282: in adamc@282: ((EFfiApp (m, x, es), loc), sns) adamc@282: end adamc@316: | EApp (e1, es) => adamc@282: let adamc@282: val (e1, sns) = prepExp (e1, sns) adamc@316: val (es, sns) = ListUtil.foldlMap prepExp sns es adamc@282: in adamc@316: ((EApp (e1, es), loc), sns) adamc@282: end adamc@282: adamc@387: | EUnop (s, e1) => adamc@387: let adamc@387: val (e1, sns) = prepExp (e1, sns) adamc@387: in adamc@387: ((EUnop (s, e1), loc), sns) adamc@387: end adamc@387: | EBinop (s, e1, e2) => adamc@387: let adamc@387: val (e1, sns) = prepExp (e1, sns) adamc@387: val (e2, sns) = prepExp (e2, sns) adamc@387: in adamc@387: ((EBinop (s, e1, e2), loc), sns) adamc@387: end adamc@387: adamc@282: | ERecord (rn, xes) => adamc@282: let adamc@282: val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((x, e), sns) adamc@282: end) sns xes adamc@282: in adamc@282: ((ERecord (rn, xes), loc), sns) adamc@282: end adamc@282: | EField (e, s) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((EField (e, s), loc), sns) adamc@282: end adamc@282: adamc@282: | ECase (e, pes, ts) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((p, e), sns) adamc@282: end) sns pes adamc@282: in adamc@282: ((ECase (e, pes, ts), loc), sns) adamc@282: end adamc@282: adamc@283: | EError (e, t) => adamc@283: let adamc@283: val (e, sns) = prepExp (e, sns) adamc@283: in adamc@283: ((EError (e, t), loc), sns) adamc@283: end adamc@283: adamc@282: | EWrite e => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((EWrite e, loc), sns) adamc@282: end adamc@282: | ESeq (e1, e2) => adamc@282: let adamc@282: val (e1, sns) = prepExp (e1, sns) adamc@282: val (e2, sns) = prepExp (e2, sns) adamc@282: in adamc@282: ((ESeq (e1, e2), loc), sns) adamc@282: end adamc@282: | ELet (x, t, e1, e2) => adamc@282: let adamc@282: val (e1, sns) = prepExp (e1, sns) adamc@282: val (e2, sns) = prepExp (e2, sns) adamc@282: in adamc@282: ((ELet (x, t, e1, e2), loc), sns) adamc@282: end adamc@282: adamc@282: | EQuery {exps, tables, rnum, state, query, body, initial, ...} => adamc@486: let adamc@486: val (body, sns) = prepExp (body, sns) adamc@486: in adamc@486: case prepString (query, [], 0) 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@486: sns) adamc@486: | SOME (ss, n) => adamc@486: ((EQuery {exps = exps, tables = tables, rnum = rnum, adamc@486: state = state, query = query, body = body, adamc@486: initial = initial, prepared = SOME (#2 sns)}, loc), adamc@486: ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) adamc@486: end adamc@282: adamc@307: | EDml {dml, ...} => adamc@307: (case prepString (dml, [], 0) of adamc@307: NONE => (e, sns) adamc@307: | SOME (ss, n) => adamc@307: ((EDml {dml = dml, prepared = SOME (#2 sns)}, loc), adamc@307: ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))) adamc@307: adamc@338: | ENextval {seq, ...} => adamc@338: let adamc@486: val s = case seq of adamc@486: (EPrim (Prim.String s), loc) => adamc@486: (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) adamc@486: | _ => adamc@486: let adamc@486: val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) adamc@486: in adamc@486: (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) adamc@486: end adamc@338: in adamc@338: case prepString (s, [], 0) of adamc@338: NONE => (e, sns) adamc@338: | SOME (ss, n) => adamc@338: ((ENextval {seq = seq, prepared = SOME (#2 sns)}, loc), adamc@338: ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) adamc@338: end adamc@338: adamc@463: | EUnurlify (e, t) => adamc@463: let adamc@463: val (e, sns) = prepExp (e, sns) adamc@463: in adamc@463: ((EUnurlify (e, t), loc), sns) adamc@463: end adamc@463: adamc@282: fun prepDecl (d as (_, loc), sns) = adamc@282: case #1 d of adamc@282: DStruct _ => (d, sns) adamc@282: | DDatatype _ => (d, sns) adamc@282: | DDatatypeForward _ => (d, sns) adamc@282: | DVal (x, n, t, e) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((DVal (x, n, t, e), loc), sns) adamc@282: end adamc@282: | DFun (x, n, xts, t, e) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((DFun (x, n, xts, t, e), loc), sns) adamc@282: end adamc@282: | DFunRec fs => adamc@282: let adamc@282: val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) => adamc@282: let adamc@282: val (e, sns) = prepExp (e, sns) adamc@282: in adamc@282: ((x, n, xts, t, e), sns) adamc@282: end) sns fs adamc@282: in adamc@282: ((DFunRec fs, loc), sns) adamc@282: end adamc@282: adamc@282: | DTable _ => (d, sns) adamc@338: | DSequence _ => (d, sns) adamc@282: | DDatabase _ => (d, sns) adamc@282: | DPreparedStatements _ => (d, sns) adamc@569: | DJavaScript _ => (d, sns) adamc@718: | DStyle _ => (d, sns) adamc@282: adamc@282: fun prepare (ds, ps) = adamc@282: let adamc@282: val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds adamc@282: in adamc@282: ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps) adamc@282: end adamc@282: adamc@282: end adamc@282: