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