Mercurial > urweb

annotate src/prepare.sml @ 291:550100a44cca

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'read' for strings
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 11:56:53 -0400
parents c0e4ac23522d
children 59dc042629b9
rev   line source
adamc@282 1 (* Copyright (c) 2008, Adam Chlipala
adamc@282 2 * All rights reserved.
adamc@282 3 *
adamc@282 4 * Redistribution and use in source and binary forms, with or without
adamc@282 5 * modification, are permitted provided that the following conditions are met:
adamc@282 6 *
adamc@282 7 * - Redistributions of source code must retain the above copyright notice,
adamc@282 8 * this list of conditions and the following disclaimer.
adamc@282 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@282 10 * this list of conditions and the following disclaimer in the documentation
adamc@282 11 * and/or other materials provided with the distribution.
adamc@282 12 * - The names of contributors may not be used to endorse or promote products
adamc@282 13 * derived from this software without specific prior written permission.
adamc@282 14 *
adamc@282 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@282 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@282 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@282 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@282 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@282 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@282 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@282 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@282 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@282 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@282 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@282 26 *)
adamc@282 27
adamc@282 28 structure Prepare :> PREPARE = struct
adamc@282 29
adamc@282 30 open Cjr
adamc@282 31
adamc@282 32 fun prepString (e, ss, n) =
adamc@282 33 case #1 e of
adamc@282 34 EPrim (Prim.String s) =>
adamc@282 35 SOME (s :: ss, n)
adamc@282 36 | EFfiApp ("Basis", "strcat", [e1, e2]) =>
adamc@282 37 (case prepString (e1, ss, n) of
adamc@282 38 NONE => NONE
adamc@282 39 | SOME (ss, n) => prepString (e2, ss, n))
adamc@282 40 | EFfiApp ("Basis", "sqlifyInt", [e]) =>
adamc@282 41 SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
adamc@282 42 | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
adamc@282 43 SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
adamc@282 44 | EFfiApp ("Basis", "sqlifyString", [e]) =>
adamc@282 45 SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
adamc@282 46 | EFfiApp ("Basis", "sqlifyBool", [e]) =>
adamc@282 47 SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
adamc@282 48
adamc@282 49 | _ => NONE
adamc@282 50
adamc@282 51 fun prepExp (e as (_, loc), sns) =
adamc@282 52 case #1 e of
adamc@282 53 EPrim _ => (e, sns)
adamc@282 54 | ERel _ => (e, sns)
adamc@282 55 | ENamed _ => (e, sns)
adamc@282 56 | ECon (_, _, NONE) => (e, sns)
adamc@282 57 | ECon (dk, pc, SOME e) =>
adamc@282 58 let
adamc@282 59 val (e, sns) = prepExp (e, sns)
adamc@282 60 in
adamc@282 61 ((ECon (dk, pc, SOME e), loc), sns)
adamc@282 62 end
adamc@291 63 | ESome (t, e) =>
adamc@291 64 let
adamc@291 65 val (e, sns) = prepExp (e, sns)
adamc@291 66 in
adamc@291 67 ((ESome (t, e), loc), sns)
adamc@291 68 end
adamc@282 69 | EFfi _ => (e, sns)
adamc@282 70 | EFfiApp (m, x, es) =>
adamc@282 71 let
adamc@282 72 val (es, sns) = ListUtil.foldlMap prepExp sns es
adamc@282 73 in
adamc@282 74 ((EFfiApp (m, x, es), loc), sns)
adamc@282 75 end
adamc@282 76 | EApp (e1, e2) =>
adamc@282 77 let
adamc@282 78 val (e1, sns) = prepExp (e1, sns)
adamc@282 79 val (e2, sns) = prepExp (e2, sns)
adamc@282 80 in
adamc@282 81 ((EApp (e1, e2), loc), sns)
adamc@282 82 end
adamc@282 83
adamc@282 84 | ERecord (rn, xes) =>
adamc@282 85 let
adamc@282 86 val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
adamc@282 87 let
adamc@282 88 val (e, sns) = prepExp (e, sns)
adamc@282 89 in
adamc@282 90 ((x, e), sns)
adamc@282 91 end) sns xes
adamc@282 92 in
adamc@282 93 ((ERecord (rn, xes), loc), sns)
adamc@282 94 end
adamc@282 95 | EField (e, s) =>
adamc@282 96 let
adamc@282 97 val (e, sns) = prepExp (e, sns)
adamc@282 98 in
adamc@282 99 ((EField (e, s), loc), sns)
adamc@282 100 end
adamc@282 101
adamc@282 102 | ECase (e, pes, ts) =>
adamc@282 103 let
adamc@282 104 val (e, sns) = prepExp (e, sns)
adamc@282 105 val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
adamc@282 106 let
adamc@282 107 val (e, sns) = prepExp (e, sns)
adamc@282 108 in
adamc@282 109 ((p, e), sns)
adamc@282 110 end) sns pes
adamc@282 111 in
adamc@282 112 ((ECase (e, pes, ts), loc), sns)
adamc@282 113 end
adamc@282 114
adamc@283 115 | EError (e, t) =>
adamc@283 116 let
adamc@283 117 val (e, sns) = prepExp (e, sns)
adamc@283 118 in
adamc@283 119 ((EError (e, t), loc), sns)
adamc@283 120 end
adamc@283 121
adamc@282 122 | EWrite e =>
adamc@282 123 let
adamc@282 124 val (e, sns) = prepExp (e, sns)
adamc@282 125 in
adamc@282 126 ((EWrite e, loc), sns)
adamc@282 127 end
adamc@282 128 | ESeq (e1, e2) =>
adamc@282 129 let
adamc@282 130 val (e1, sns) = prepExp (e1, sns)
adamc@282 131 val (e2, sns) = prepExp (e2, sns)
adamc@282 132 in
adamc@282 133 ((ESeq (e1, e2), loc), sns)
adamc@282 134 end
adamc@282 135 | ELet (x, t, e1, e2) =>
adamc@282 136 let
adamc@282 137 val (e1, sns) = prepExp (e1, sns)
adamc@282 138 val (e2, sns) = prepExp (e2, sns)
adamc@282 139 in
adamc@282 140 ((ELet (x, t, e1, e2), loc), sns)
adamc@282 141 end
adamc@282 142
adamc@282 143 | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
adamc@282 144 (case prepString (query, [], 0) of
adamc@282 145 NONE => (e, sns)
adamc@282 146 | SOME (ss, n) =>
adamc@282 147 ((EQuery {exps = exps, tables = tables, rnum = rnum,
adamc@282 148 state = state, query = query, body = body,
adamc@282 149 initial = initial, prepared = SOME (#2 sns)}, loc),
adamc@282 150 ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
adamc@282 151
adamc@282 152 fun prepDecl (d as (_, loc), sns) =
adamc@282 153 case #1 d of
adamc@282 154 DStruct _ => (d, sns)
adamc@282 155 | DDatatype _ => (d, sns)
adamc@282 156 | DDatatypeForward _ => (d, sns)
adamc@282 157 | DVal (x, n, t, e) =>
adamc@282 158 let
adamc@282 159 val (e, sns) = prepExp (e, sns)
adamc@282 160 in
adamc@282 161 ((DVal (x, n, t, e), loc), sns)
adamc@282 162 end
adamc@282 163 | DFun (x, n, xts, t, e) =>
adamc@282 164 let
adamc@282 165 val (e, sns) = prepExp (e, sns)
adamc@282 166 in
adamc@282 167 ((DFun (x, n, xts, t, e), loc), sns)
adamc@282 168 end
adamc@282 169 | DFunRec fs =>
adamc@282 170 let
adamc@282 171 val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
adamc@282 172 let
adamc@282 173 val (e, sns) = prepExp (e, sns)
adamc@282 174 in
adamc@282 175 ((x, n, xts, t, e), sns)
adamc@282 176 end) sns fs
adamc@282 177 in
adamc@282 178 ((DFunRec fs, loc), sns)
adamc@282 179 end
adamc@282 180
adamc@282 181 | DTable _ => (d, sns)
adamc@282 182 | DDatabase _ => (d, sns)
adamc@282 183 | DPreparedStatements _ => (d, sns)
adamc@282 184
adamc@282 185 fun prepare (ds, ps) =
adamc@282 186 let
adamc@282 187 val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
adamc@282 188 in
adamc@282 189 ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
adamc@282 190 end
adamc@282 191
adamc@282 192 end
adamc@282 193