Mercurial > urweb

annotate src/mono_opt.sml @ 758:8323c1beef2e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Subforms type-checks; lists urlified and unurlified
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Apr 2009 11:48:56 -0400
parents 8688e01ae469
children efceae06df17
rev   line source
adamc@96 1 (* Copyright (c) 2008, Adam Chlipala
adamc@96 2 * All rights reserved.
adamc@96 3 *
adamc@96 4 * Redistribution and use in source and binary forms, with or without
adamc@96 5 * modification, are permitted provided that the following conditions are met:
adamc@96 6 *
adamc@96 7 * - Redistributions of source code must retain the above copyright notice,
adamc@96 8 * this list of conditions and the following disclaimer.
adamc@96 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@96 10 * this list of conditions and the following disclaimer in the documentation
adamc@96 11 * and/or other materials provided with the distribution.
adamc@96 12 * - The names of contributors may not be used to endorse or promote products
adamc@96 13 * derived from this software without specific prior written permission.
adamc@96 14 *
adamc@96 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@96 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@96 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@96 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@96 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@96 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@96 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@96 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@96 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@96 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@96 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@96 26 *)
adamc@96 27
adamc@96 28 structure MonoOpt :> MONO_OPT = struct
adamc@96 29
adamc@96 30 open Mono
adamc@96 31 structure U = MonoUtil
adamc@96 32
adamc@717 33 val bless = ref (fn _ : string => true)
adamc@741 34 val blessMime = ref (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"-" orelse ch = #"/" orelse ch = #"."))
adamc@717 35
adamc@96 36 fun typ t = t
adamc@96 37 fun decl d = d
adamc@96 38
adamc@107 39 fun attrifyInt n =
adamc@107 40 if n < 0 then
adamc@107 41 "-" ^ Int64.toString (Int64.~ n)
adamc@107 42 else
adamc@107 43 Int64.toString n
adamc@107 44
adamc@107 45 fun attrifyFloat n =
adamc@107 46 if n < 0.0 then
adamc@107 47 "-" ^ Real.toString (Real.~ n)
adamc@107 48 else
adamc@107 49 Real.toString n
adamc@107 50
adamc@107 51 val attrifyString = String.translate (fn #"\"" => "&quot;"
adamc@135 52 | #"&" => "&amp;"
adamc@107 53 | ch => if Char.isPrint ch then
adamc@107 54 str ch
adamc@107 55 else
adamc@107 56 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@107 57
adamc@120 58 val urlifyInt = attrifyInt
adamc@120 59 val urlifyFloat = attrifyFloat
adamc@120 60
adamc@286 61 val htmlifyInt = attrifyInt
adamc@286 62 val htmlifyFloat = attrifyFloat
adamc@135 63 val htmlifyString = String.translate (fn ch => case ch of
adamc@135 64 #"<" => "&lt;"
adamc@135 65 | #"&" => "&amp;"
adamc@135 66 | _ =>
adamc@135 67 if Char.isPrint ch orelse Char.isSpace ch then
adamc@135 68 str ch
adamc@135 69 else
adamc@135 70 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@135 71
adamc@120 72 fun hexIt ch =
adamc@120 73 let
adamc@120 74 val s = Int.fmt StringCvt.HEX (ord ch)
adamc@120 75 in
adamc@120 76 case size s of
adamc@120 77 0 => "00"
adamc@120 78 | 1 => "0" ^ s
adamc@120 79 | _ => s
adamc@120 80 end
adamc@120 81
adamc@120 82 val urlifyString = String.translate (fn #" " => "+"
adamc@120 83 | ch => if Char.isAlphaNum ch then
adamc@120 84 str ch
adamc@120 85 else
adamc@120 86 "%" ^ hexIt ch)
adamc@253 87
adamc@253 88
adamc@281 89 fun sqlifyInt n = attrifyInt n ^ "::int8"
adamc@281 90 fun sqlifyFloat n = attrifyFloat n ^ "::float8"
adamc@253 91
adamc@259 92 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
adamc@714 93 | #"\\" => "\\\\"
adamc@714 94 | ch =>
adamc@714 95 if Char.isPrint ch then
adamc@714 96 str ch
adamc@714 97 else
adamc@714 98 "\\" ^ StringCvt.padLeft #"0" 3
adamc@714 99 (Int.fmt StringCvt.OCT (ord ch)))
adamc@281 100 (String.toString s) ^ "'::text"
adamc@453 101
adamc@96 102 fun exp e =
adamc@96 103 case e of
adamc@96 104 EPrim (Prim.String s) =>
adamc@96 105 let
adamc@96 106 val (_, chs) =
adamc@96 107 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96 108 let
adamc@96 109 val isSpace = Char.isSpace ch
adamc@96 110 in
adamc@96 111 if isSpace andalso lastSpace then
adamc@96 112 (true, chs)
adamc@96 113 else
adamc@96 114 (isSpace, ch :: chs)
adamc@96 115 end)
adamc@96 116 (false, []) s
adamc@96 117 in
adamc@96 118 EPrim (Prim.String (String.implode (rev chs)))
adamc@96 119 end
adamc@96 120
adamc@96 121 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 122 let
adamc@96 123 val s =
adamc@96 124 if size s1 > 0 andalso size s2 > 0
adamc@96 125 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 126 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 127 s1 ^ String.extract (s2, 1, NONE)
adamc@96 128 else
adamc@96 129 s1 ^ s2
adamc@96 130 in
adamc@96 131 EPrim (Prim.String s)
adamc@96 132 end
adamc@105 133
adamc@105 134 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 135 let
adamc@105 136 val s =
adamc@105 137 if size s1 > 0 andalso size s2 > 0
adamc@105 138 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 139 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 140 s1 ^ String.extract (s2, 1, NONE)
adamc@105 141 else
adamc@105 142 s1 ^ s2
adamc@105 143 in
adamc@105 144 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 145 end
adamc@105 146
adamc@105 147 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 148 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 149
adamc@106 150 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 151 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 152 (optExp (EWrite e2, loc), loc))
adamc@106 153
adamc@183 154 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183 155 (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183 156 EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196 157 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196 158 (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196 159 e), _)) =>
adamc@196 160 ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196 161 e)
adamc@183 162
adamc@286 163 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
adamc@286 164 EPrim (Prim.String (htmlifyInt n))
adamc@286 165 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
adamc@286 166 EFfiApp ("Basis", "htmlifyInt", es)
adamc@320 167 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 168 (EPrim (Prim.Int n), _)), _)]) =>
adamc@320 169 EPrim (Prim.String (htmlifyInt n))
adamc@320 170 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 171 e), _)]) =>
adamc@320 172 EFfiApp ("Basis", "htmlifyInt", [e])
adamc@286 173 | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286 174 EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286 175
adamc@286 176 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
adamc@286 177 EPrim (Prim.String (htmlifyFloat n))
adamc@286 178 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
adamc@286 179 EFfiApp ("Basis", "htmlifyFloat", es)
adamc@320 180 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 181 (EPrim (Prim.Float n), _)), _)]) =>
adamc@320 182 EPrim (Prim.String (htmlifyFloat n))
adamc@320 183 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 184 e), _)]) =>
adamc@320 185 EFfiApp ("Basis", "htmlifyFloat", [e])
adamc@286 186 | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286 187 EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286 188
adamc@286 189 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 190 [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
adamc@286 191 EPrim (Prim.String "True")
adamc@286 192 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 193 [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
adamc@286 194 EPrim (Prim.String "False")
adamc@286 195 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
adamc@286 196 EFfiApp ("Basis", "htmlifyBool", es)
adamc@320 197 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 198 (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
adamc@320 199 EPrim (Prim.String "True")
adamc@320 200 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 201 (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
adamc@320 202 EPrim (Prim.String "False")
adamc@320 203 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 204 e), _)]) =>
adamc@320 205 EFfiApp ("Basis", "htmlifyBool", [e])
adamc@286 206 | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286 207 EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286 208
adamc@436 209 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 210 EFfiApp ("Basis", "htmlifyTime", [e])
adamc@436 211 | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 212 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 213 | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436 214 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 215
adamc@135 216 | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@135 217 EPrim (Prim.String (htmlifyString s))
adamc@135 218 | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@135 219 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 220 | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135 221 EFfiApp ("Basis", "htmlifyString_w", [e])
adamc@196 222 | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
adamc@196 223 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 224
adamc@107 225 | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107 226 EPrim (Prim.String (attrifyInt n))
adamc@107 227 | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107 228 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 229 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 230 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 231
adamc@107 232 | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107 233 EPrim (Prim.String (attrifyFloat n))
adamc@107 234 | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107 235 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 236 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 237 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 238
adamc@107 239 | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107 240 EPrim (Prim.String (attrifyString s))
adamc@107 241 | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107 242 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 243 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 244 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 245
adamc@721 246 | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) =>
adamc@721 247 EPrim (Prim.String s)
adamc@721 248 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) =>
adamc@721 249 EWrite (EPrim (Prim.String s), loc)
adamc@721 250 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
adamc@721 251 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@721 252
adamc@120 253 | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120 254 EPrim (Prim.String (urlifyInt n))
adamc@120 255 | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120 256 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 257 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 258 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 259
adamc@120 260 | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120 261 EPrim (Prim.String (urlifyFloat n))
adamc@120 262 | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120 263 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 264 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 265 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 266
adamc@120 267 | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120 268 EPrim (Prim.String (urlifyString s))
adamc@120 269 | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120 270 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 271 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 272 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 273
adamc@188 274 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
adamc@187 275 EPrim (Prim.String "1")
adamc@188 276 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
adamc@187 277 EPrim (Prim.String "0")
adamc@188 278 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
adamc@187 279 EWrite (EPrim (Prim.String "1"), loc)
adamc@188 280 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
adamc@187 281 EWrite (EPrim (Prim.String "0"), loc)
adamc@187 282 | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187 283 EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187 284
adamc@253 285 | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@253 286 EPrim (Prim.String (sqlifyInt n))
adamc@467 287 | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
adamc@467 288 EPrim (Prim.String "NULL")
adamc@467 289 | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
adamc@467 290 EPrim (Prim.String (sqlifyInt n))
adamc@467 291
adamc@253 292 | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@253 293 EPrim (Prim.String (sqlifyFloat n))
adamc@253 294 | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
adamc@253 295 optExp (ECase (b,
adamc@253 296 [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
adamc@253 297 (EPrim (Prim.String "TRUE"), loc)),
adamc@253 298 ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@253 299 (EPrim (Prim.String "FALSE"), loc))],
adamc@253 300 {disc = (TFfi ("Basis", "bool"), loc),
adamc@253 301 result = (TFfi ("Basis", "string"), loc)}), loc)
adamc@253 302 | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
adamc@253 303 EPrim (Prim.String (sqlifyString n))
adamc@253 304
adamc@184 305 | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
adamc@184 306 optExp (ECase (discE,
adamc@184 307 map (fn (p, e) => (p, (EWrite e, loc))) pes,
adamc@184 308 {disc = disc,
adamc@184 309 result = (TRecord [], loc)}), loc)
adamc@184 310
adamc@495 311 | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) =>
adamc@453 312 let
adamc@453 313 fun doBody e =
adamc@453 314 case #1 e of
adamc@453 315 EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body
adamc@453 316 | _ => (EApp (e, arg), loc)
adamc@453 317 in
adamc@453 318 optExp (ECase (discE,
adamc@453 319 map (fn (p, e) => (p, doBody e)) pes,
adamc@453 320 {disc = disc,
adamc@495 321 result = ran}), loc)
adamc@453 322 end
adamc@453 323
adamc@331 324 | EWrite (EQuery {exps, tables, state, query,
adamc@331 325 initial = (EPrim (Prim.String ""), _),
adamc@331 326 body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331 327 (EStrcat ((ERel 0, _),
adamc@331 328 e'), _)), _)}, loc) =>
adamc@331 329 if CharVector.all Char.isSpace s then
adamc@331 330 EQuery {exps = exps, tables = tables, query = query,
adamc@331 331 state = (TRecord [], loc),
adamc@331 332 initial = (ERecord [], loc),
adamc@331 333 body = (optExp (EWrite e', loc), loc)}
adamc@331 334 else
adamc@331 335 e
adamc@331 336
adamc@334 337 | EWrite (EQuery {exps, tables, state, query,
adamc@334 338 initial = (EPrim (Prim.String ""), _),
adamc@486 339 body}, loc) =>
adamc@486 340 let
adamc@486 341 fun passLets (depth, (e', _), lets) =
adamc@486 342 case e' of
adamc@486 343 EStrcat ((ERel x, _), e'') =>
adamc@486 344 if x = depth then
adamc@486 345 let
adamc@486 346 val body = (optExp (EWrite e'', loc), loc)
adamc@486 347 val body = foldl (fn ((x, t, e'), e) =>
adamc@486 348 (ELet (x, t, e', e), loc))
adamc@486 349 body lets
adamc@486 350 in
adamc@486 351 EQuery {exps = exps, tables = tables, query = query,
adamc@486 352 state = (TRecord [], loc),
adamc@486 353 initial = (ERecord [], loc),
adamc@486 354 body = body}
adamc@486 355 end
adamc@486 356 else
adamc@486 357 e
adamc@486 358 | ELet (x, t, e', e'') =>
adamc@486 359 passLets (depth + 1, e'', (x, t, e') :: lets)
adamc@486 360 | _ => e
adamc@486 361 in
adamc@486 362 passLets (0, body, [])
adamc@486 363 end
adamc@486 364
adamc@486 365 (*| EWrite (EQuery {exps, tables, state, query,
adamc@486 366 initial = (EPrim (Prim.String ""), _),
adamc@334 367 body = (EStrcat ((ERel 0, _), e'), _)}, loc) =>
adamc@334 368 EQuery {exps = exps, tables = tables, query = query,
adamc@334 369 state = (TRecord [], loc),
adamc@334 370 initial = (ERecord [], loc),
adamc@486 371 body = (optExp (EWrite e', loc), loc)}*)
adamc@334 372
adamc@340 373 | EWrite (ELet (x, t, e1, e2), loc) =>
adamc@340 374 optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
adamc@340 375
adamc@451 376 | EWrite (EPrim (Prim.String ""), loc) =>
adamc@451 377 ERecord []
adamc@451 378
adamc@572 379 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 380 optExp (EApp (e2, e1), loc)
adamc@572 381
adamc@578 382 | EJavaScript (_, _, SOME (e, _)) => e
adamc@578 383
adamc@717 384 | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
adamc@717 385 (if !bless s then
adamc@717 386 ()
adamc@717 387 else
adamc@717 388 ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
adamc@717 389 se)
adamc@741 390 | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
adamc@741 391 (if !blessMime s then
adamc@741 392 ()
adamc@741 393 else
adamc@741 394 ErrorMsg.errorAt loc "Invalid string passed to 'blessMime'";
adamc@741 395 se)
adamc@717 396
adamc@714 397 | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
adamc@714 398 let
adamc@714 399 fun uwify (cs, acc) =
adamc@714 400 case cs of
adamc@714 401 [] => String.concat (rev acc)
adamc@714 402 | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
adamc@714 403 | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
adamc@714 404 | #"'" :: cs =>
adamc@714 405 let
adamc@714 406 fun waitItOut (cs, acc) =
adamc@714 407 case cs of
adamc@714 408 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@714 409 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@714 410 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@714 411 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@714 412 | c :: cs => waitItOut (cs, str c :: acc)
adamc@714 413 in
adamc@714 414 waitItOut (cs, "'" :: acc)
adamc@714 415 end
adamc@714 416 | c :: cs => uwify (cs, str c :: acc)
adamc@714 417
adamc@714 418 val s = case String.explode s of
adamc@714 419 #"_" :: cs => uwify (cs, ["uw_"])
adamc@714 420 | cs => uwify (cs, [])
adamc@714 421 in
adamc@714 422 EPrim (Prim.String s)
adamc@714 423 end
adamc@714 424
adamc@754 425 | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) =>
adamc@754 426 let
adamc@754 427 fun uwify (cs, acc) =
adamc@754 428 case cs of
adamc@754 429 [] => String.concat (rev acc)
adamc@754 430 | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc)
adamc@754 431 | #"'" :: cs =>
adamc@754 432 let
adamc@754 433 fun waitItOut (cs, acc) =
adamc@754 434 case cs of
adamc@754 435 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@754 436 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@754 437 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@754 438 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@754 439 | c :: cs => waitItOut (cs, str c :: acc)
adamc@754 440 in
adamc@754 441 waitItOut (cs, "'" :: acc)
adamc@754 442 end
adamc@754 443 | c :: cs => uwify (cs, str c :: acc)
adamc@754 444
adamc@754 445 val s = uwify (String.explode s, [])
adamc@754 446 in
adamc@754 447 EPrim (Prim.String s)
adamc@754 448 end
adamc@754 449
adamc@96 450 | _ => e
adamc@96 451
adamc@105 452 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 453
adamc@96 454 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 455
adamc@506 456 val optExp = U.Exp.map {typ = typ, exp = exp}
adamc@506 457
adamc@96 458 end