Mercurial > urweb

annotate src/mono_opt.sml @ 907:5fe49effbc83

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
JavaScript urlifying of bools; correct Link attribute escaping
author Adam Chlipala <adamc@hcoop.net>
date Tue, 11 Aug 2009 12:01:54 -0400
parents 7a4b026e45dd
children 8e540df3294d
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@905 33 val removeServerCalls = ref false
adamc@905 34
adamc@96 35 fun typ t = t
adamc@96 36 fun decl d = d
adamc@96 37
adamc@107 38 fun attrifyInt n =
adamc@107 39 if n < 0 then
adamc@107 40 "-" ^ Int64.toString (Int64.~ n)
adamc@107 41 else
adamc@107 42 Int64.toString n
adamc@107 43
adamc@107 44 fun attrifyFloat n =
adamc@107 45 if n < 0.0 then
adamc@107 46 "-" ^ Real.toString (Real.~ n)
adamc@107 47 else
adamc@107 48 Real.toString n
adamc@107 49
adamc@107 50 val attrifyString = String.translate (fn #"\"" => "&quot;"
adamc@135 51 | #"&" => "&amp;"
adamc@107 52 | ch => if Char.isPrint ch then
adamc@107 53 str ch
adamc@107 54 else
adamc@107 55 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@107 56
adamc@120 57 val urlifyInt = attrifyInt
adamc@120 58 val urlifyFloat = attrifyFloat
adamc@120 59
adamc@286 60 val htmlifyInt = attrifyInt
adamc@286 61 val htmlifyFloat = attrifyFloat
adamc@135 62 val htmlifyString = String.translate (fn ch => case ch of
adamc@135 63 #"<" => "&lt;"
adamc@135 64 | #"&" => "&amp;"
adamc@135 65 | _ =>
adamc@135 66 if Char.isPrint ch orelse Char.isSpace ch then
adamc@135 67 str ch
adamc@135 68 else
adamc@135 69 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@135 70
adamc@120 71 fun hexIt ch =
adamc@120 72 let
adamc@120 73 val s = Int.fmt StringCvt.HEX (ord ch)
adamc@120 74 in
adamc@120 75 case size s of
adamc@120 76 0 => "00"
adamc@120 77 | 1 => "0" ^ s
adamc@120 78 | _ => s
adamc@120 79 end
adamc@120 80
adamc@120 81 val urlifyString = String.translate (fn #" " => "+"
adamc@120 82 | ch => if Char.isAlphaNum ch then
adamc@120 83 str ch
adamc@120 84 else
adamc@120 85 "%" ^ hexIt ch)
adamc@253 86
adamc@253 87
adamc@877 88 fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int)
adamc@877 89 fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float)
adamc@253 90
adamc@874 91 fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s
adamc@874 92
adamc@874 93 fun unAs s =
adamc@874 94 let
adamc@874 95 fun doChars (cs, acc) =
adamc@874 96 case cs of
adamc@874 97 #"T" :: #"." :: cs => doChars (cs, acc)
adamc@874 98 | #"'" :: cs => doString (cs, acc)
adamc@874 99 | ch :: cs => doChars (cs, ch :: acc)
adamc@874 100 | [] => String.implode (rev acc)
adamc@874 101
adamc@874 102 and doString (cs, acc) =
adamc@874 103 case cs of
adamc@874 104 #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc)
adamc@874 105 | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc)
adamc@874 106 | #"'" :: cs => doChars (cs, #"'" :: acc)
adamc@874 107 | ch :: cs => doString (cs, ch :: acc)
adamc@874 108 | [] => String.implode (rev acc)
adamc@874 109 in
adamc@874 110 doChars (String.explode s, [])
adamc@874 111 end
adamc@453 112
adamc@96 113 fun exp e =
adamc@96 114 case e of
adamc@96 115 EPrim (Prim.String s) =>
adamc@96 116 let
adamc@96 117 val (_, chs) =
adamc@96 118 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96 119 let
adamc@96 120 val isSpace = Char.isSpace ch
adamc@96 121 in
adamc@96 122 if isSpace andalso lastSpace then
adamc@96 123 (true, chs)
adamc@96 124 else
adamc@96 125 (isSpace, ch :: chs)
adamc@96 126 end)
adamc@96 127 (false, []) s
adamc@96 128 in
adamc@96 129 EPrim (Prim.String (String.implode (rev chs)))
adamc@96 130 end
adamc@96 131
adamc@96 132 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 133 let
adamc@96 134 val s =
adamc@96 135 if size s1 > 0 andalso size s2 > 0
adamc@96 136 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 137 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 138 s1 ^ String.extract (s2, 1, NONE)
adamc@96 139 else
adamc@96 140 s1 ^ s2
adamc@96 141 in
adamc@96 142 EPrim (Prim.String s)
adamc@96 143 end
adamc@105 144
adamc@105 145 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 146 let
adamc@105 147 val s =
adamc@105 148 if size s1 > 0 andalso size s2 > 0
adamc@105 149 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 150 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 151 s1 ^ String.extract (s2, 1, NONE)
adamc@105 152 else
adamc@105 153 s1 ^ s2
adamc@105 154 in
adamc@105 155 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 156 end
adamc@105 157
adamc@105 158 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 159 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 160
adamc@106 161 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 162 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 163 (optExp (EWrite e2, loc), loc))
adamc@106 164
adamc@183 165 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183 166 (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183 167 EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196 168 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196 169 (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196 170 e), _)) =>
adamc@196 171 ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196 172 e)
adamc@183 173
adamc@286 174 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
adamc@286 175 EPrim (Prim.String (htmlifyInt n))
adamc@286 176 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
adamc@286 177 EFfiApp ("Basis", "htmlifyInt", es)
adamc@320 178 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 179 (EPrim (Prim.Int n), _)), _)]) =>
adamc@320 180 EPrim (Prim.String (htmlifyInt n))
adamc@320 181 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 182 e), _)]) =>
adamc@320 183 EFfiApp ("Basis", "htmlifyInt", [e])
adamc@286 184 | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286 185 EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286 186
adamc@286 187 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
adamc@286 188 EPrim (Prim.String (htmlifyFloat n))
adamc@286 189 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
adamc@286 190 EFfiApp ("Basis", "htmlifyFloat", es)
adamc@320 191 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 192 (EPrim (Prim.Float n), _)), _)]) =>
adamc@320 193 EPrim (Prim.String (htmlifyFloat n))
adamc@320 194 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 195 e), _)]) =>
adamc@320 196 EFfiApp ("Basis", "htmlifyFloat", [e])
adamc@286 197 | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286 198 EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286 199
adamc@286 200 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 201 [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
adamc@286 202 EPrim (Prim.String "True")
adamc@286 203 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 204 [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
adamc@286 205 EPrim (Prim.String "False")
adamc@286 206 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
adamc@286 207 EFfiApp ("Basis", "htmlifyBool", es)
adamc@320 208 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 209 (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
adamc@320 210 EPrim (Prim.String "True")
adamc@320 211 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 212 (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
adamc@320 213 EPrim (Prim.String "False")
adamc@320 214 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 215 e), _)]) =>
adamc@320 216 EFfiApp ("Basis", "htmlifyBool", [e])
adamc@286 217 | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286 218 EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286 219
adamc@436 220 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 221 EFfiApp ("Basis", "htmlifyTime", [e])
adamc@436 222 | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 223 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 224 | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436 225 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 226
adamc@135 227 | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@135 228 EPrim (Prim.String (htmlifyString s))
adamc@135 229 | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@135 230 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 231 | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135 232 EFfiApp ("Basis", "htmlifyString_w", [e])
adamc@196 233 | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
adamc@196 234 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 235
adamc@107 236 | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107 237 EPrim (Prim.String (attrifyInt n))
adamc@107 238 | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107 239 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 240 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 241 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 242
adamc@107 243 | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107 244 EPrim (Prim.String (attrifyFloat n))
adamc@107 245 | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107 246 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 247 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 248 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 249
adamc@107 250 | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107 251 EPrim (Prim.String (attrifyString s))
adamc@107 252 | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107 253 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 254 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 255 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 256
adamc@721 257 | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) =>
adamc@721 258 EPrim (Prim.String s)
adamc@721 259 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) =>
adamc@721 260 EWrite (EPrim (Prim.String s), loc)
adamc@721 261 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
adamc@721 262 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@721 263
adamc@120 264 | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120 265 EPrim (Prim.String (urlifyInt n))
adamc@120 266 | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120 267 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 268 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 269 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 270
adamc@120 271 | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120 272 EPrim (Prim.String (urlifyFloat n))
adamc@120 273 | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120 274 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 275 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 276 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 277
adamc@120 278 | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120 279 EPrim (Prim.String (urlifyString s))
adamc@120 280 | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120 281 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 282 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 283 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 284
adamc@188 285 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
adamc@187 286 EPrim (Prim.String "1")
adamc@188 287 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
adamc@187 288 EPrim (Prim.String "0")
adamc@188 289 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
adamc@187 290 EWrite (EPrim (Prim.String "1"), loc)
adamc@188 291 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
adamc@187 292 EWrite (EPrim (Prim.String "0"), loc)
adamc@187 293 | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187 294 EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187 295
adamc@253 296 | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@253 297 EPrim (Prim.String (sqlifyInt n))
adamc@467 298 | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
adamc@467 299 EPrim (Prim.String "NULL")
adamc@467 300 | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
adamc@467 301 EPrim (Prim.String (sqlifyInt n))
adamc@467 302
adamc@253 303 | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@253 304 EPrim (Prim.String (sqlifyFloat n))
adamc@253 305 | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
adamc@253 306 optExp (ECase (b,
adamc@253 307 [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
adamc@253 308 (EPrim (Prim.String "TRUE"), loc)),
adamc@253 309 ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@253 310 (EPrim (Prim.String "FALSE"), loc))],
adamc@253 311 {disc = (TFfi ("Basis", "bool"), loc),
adamc@253 312 result = (TFfi ("Basis", "string"), loc)}), loc)
adamc@253 313 | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
adamc@253 314 EPrim (Prim.String (sqlifyString n))
adamc@253 315
adamc@184 316 | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
adamc@184 317 optExp (ECase (discE,
adamc@184 318 map (fn (p, e) => (p, (EWrite e, loc))) pes,
adamc@184 319 {disc = disc,
adamc@184 320 result = (TRecord [], loc)}), loc)
adamc@184 321
adamc@495 322 | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) =>
adamc@453 323 let
adamc@453 324 fun doBody e =
adamc@453 325 case #1 e of
adamc@453 326 EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body
adamc@453 327 | _ => (EApp (e, arg), loc)
adamc@453 328 in
adamc@453 329 optExp (ECase (discE,
adamc@453 330 map (fn (p, e) => (p, doBody e)) pes,
adamc@453 331 {disc = disc,
adamc@495 332 result = ran}), loc)
adamc@453 333 end
adamc@453 334
adamc@331 335 | EWrite (EQuery {exps, tables, state, query,
adamc@331 336 initial = (EPrim (Prim.String ""), _),
adamc@331 337 body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331 338 (EStrcat ((ERel 0, _),
adamc@331 339 e'), _)), _)}, loc) =>
adamc@331 340 if CharVector.all Char.isSpace s then
adamc@331 341 EQuery {exps = exps, tables = tables, query = query,
adamc@331 342 state = (TRecord [], loc),
adamc@331 343 initial = (ERecord [], loc),
adamc@331 344 body = (optExp (EWrite e', loc), loc)}
adamc@331 345 else
adamc@331 346 e
adamc@331 347
adamc@334 348 | EWrite (EQuery {exps, tables, state, query,
adamc@334 349 initial = (EPrim (Prim.String ""), _),
adamc@486 350 body}, loc) =>
adamc@486 351 let
adamc@486 352 fun passLets (depth, (e', _), lets) =
adamc@486 353 case e' of
adamc@486 354 EStrcat ((ERel x, _), e'') =>
adamc@486 355 if x = depth then
adamc@486 356 let
adamc@486 357 val body = (optExp (EWrite e'', loc), loc)
adamc@486 358 val body = foldl (fn ((x, t, e'), e) =>
adamc@486 359 (ELet (x, t, e', e), loc))
adamc@486 360 body lets
adamc@486 361 in
adamc@486 362 EQuery {exps = exps, tables = tables, query = query,
adamc@486 363 state = (TRecord [], loc),
adamc@486 364 initial = (ERecord [], loc),
adamc@486 365 body = body}
adamc@486 366 end
adamc@486 367 else
adamc@486 368 e
adamc@486 369 | ELet (x, t, e', e'') =>
adamc@486 370 passLets (depth + 1, e'', (x, t, e') :: lets)
adamc@486 371 | _ => e
adamc@486 372 in
adamc@486 373 passLets (0, body, [])
adamc@486 374 end
adamc@486 375
adamc@486 376 (*| EWrite (EQuery {exps, tables, state, query,
adamc@486 377 initial = (EPrim (Prim.String ""), _),
adamc@334 378 body = (EStrcat ((ERel 0, _), e'), _)}, loc) =>
adamc@334 379 EQuery {exps = exps, tables = tables, query = query,
adamc@334 380 state = (TRecord [], loc),
adamc@334 381 initial = (ERecord [], loc),
adamc@486 382 body = (optExp (EWrite e', loc), loc)}*)
adamc@334 383
adamc@340 384 | EWrite (ELet (x, t, e1, e2), loc) =>
adamc@340 385 optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
adamc@340 386
adamc@451 387 | EWrite (EPrim (Prim.String ""), loc) =>
adamc@451 388 ERecord []
adamc@451 389
adamc@572 390 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 391 optExp (EApp (e2, e1), loc)
adamc@572 392
adamc@717 393 | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
adamc@769 394 (if Settings.checkUrl s then
adamc@717 395 ()
adamc@717 396 else
adamc@769 397 ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
adamc@717 398 se)
adamc@741 399 | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
adamc@769 400 (if Settings.checkMime s then
adamc@741 401 ()
adamc@741 402 else
adamc@769 403 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
adamc@741 404 se)
adamc@717 405
adamc@714 406 | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
adamc@714 407 let
adamc@714 408 fun uwify (cs, acc) =
adamc@714 409 case cs of
adamc@714 410 [] => String.concat (rev acc)
adamc@714 411 | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
adamc@714 412 | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
adamc@714 413 | #"'" :: cs =>
adamc@714 414 let
adamc@714 415 fun waitItOut (cs, acc) =
adamc@714 416 case cs of
adamc@714 417 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@714 418 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@714 419 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@714 420 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@714 421 | c :: cs => waitItOut (cs, str c :: acc)
adamc@714 422 in
adamc@714 423 waitItOut (cs, "'" :: acc)
adamc@714 424 end
adamc@714 425 | c :: cs => uwify (cs, str c :: acc)
adamc@714 426
adamc@714 427 val s = case String.explode s of
adamc@714 428 #"_" :: cs => uwify (cs, ["uw_"])
adamc@714 429 | cs => uwify (cs, [])
adamc@714 430 in
adamc@714 431 EPrim (Prim.String s)
adamc@714 432 end
adamc@714 433
adamc@754 434 | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) =>
adamc@754 435 let
adamc@754 436 fun uwify (cs, acc) =
adamc@754 437 case cs of
adamc@754 438 [] => String.concat (rev acc)
adamc@754 439 | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc)
adamc@754 440 | #"'" :: cs =>
adamc@754 441 let
adamc@754 442 fun waitItOut (cs, acc) =
adamc@754 443 case cs of
adamc@754 444 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@754 445 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@754 446 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@754 447 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@754 448 | c :: cs => waitItOut (cs, str c :: acc)
adamc@754 449 in
adamc@754 450 waitItOut (cs, "'" :: acc)
adamc@754 451 end
adamc@754 452 | c :: cs => uwify (cs, str c :: acc)
adamc@754 453
adamc@754 454 val s = uwify (String.explode s, [])
adamc@754 455 in
adamc@754 456 EPrim (Prim.String s)
adamc@754 457 end
adamc@754 458
adamc@874 459 | EFfiApp ("Basis", "unAs", [(EPrim (Prim.String s), _)]) =>
adamc@874 460 EPrim (Prim.String (unAs s))
adamc@874 461 | EFfiApp ("Basis", "unAs", [e']) =>
adamc@874 462 let
adamc@874 463 fun parts (e as (_, loc)) =
adamc@874 464 case #1 e of
adamc@874 465 EStrcat (s1, s2) =>
adamc@874 466 (case (parts s1, parts s2) of
adamc@874 467 (SOME p1, SOME p2) => SOME (p1 @ p2)
adamc@874 468 | _ => NONE)
adamc@874 469 | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)]
adamc@874 470 | EFfiApp ("Basis", f, [_]) =>
adamc@874 471 if String.isPrefix "sqlify" f then
adamc@874 472 SOME [e]
adamc@874 473 else
adamc@874 474 NONE
adamc@874 475 | _ => NONE
adamc@874 476 in
adamc@874 477 case parts e' of
adamc@874 478 SOME [e] => #1 e
adamc@874 479 | SOME es =>
adamc@874 480 (case rev es of
adamc@874 481 (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es)
adamc@874 482 | [] => raise Fail "MonoOpt impossible nil")
adamc@874 483 | NONE => e
adamc@874 484 end
adamc@905 485
adamc@905 486 | EServerCall (_, _, _, _, ue) =>
adamc@905 487 if !removeServerCalls then
adamc@905 488 optExp ue
adamc@905 489 else
adamc@905 490 e
adamc@874 491
adamc@96 492 | _ => e
adamc@96 493
adamc@105 494 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 495
adamc@96 496 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 497
adamc@506 498 val optExp = U.Exp.map {typ = typ, exp = exp}
adamc@506 499
adamc@96 500 end