Mercurial > urweb

annotate src/mono_opt.sml @ 925:552c989c1601

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