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: