Mercurial > urweb

annotate src/mono_opt.sml @ 2033:ea0ecd5fa9df

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add locking to enforce atomicity of message sends from one transaction
author Adam Chlipala <adam@chlipala.net>
date Fri, 27 Jun 2014 14:39:31 -0400
parents 93ff76058825
children 4d64af730e35
rev   line source
adamc@1259 1 (* Copyright (c) 2008-2010, 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@1011 48 fun attrifyChar ch =
adamc@1011 49 case ch of
adamc@1011 50 #"\"" => "&quot;"
adamc@1011 51 | #"&" => "&amp;"
adamc@1059 52 | ch => str ch
adamc@1059 53
adamc@1059 54 val attrifyString = String.translate attrifyChar
adamc@1059 55
adamc@1011 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@1053 62
adamc@1059 63 val htmlifyString = String.translate (fn #"<" => "&lt;"
adamc@1059 64 | #"&" => "&amp;"
adamc@1059 65 | ch => str ch)
adamc@135 66
adam@1358 67 fun htmlifySpecialChar ch = "&#" ^ Int.toString (ord ch) ^ ";"
adam@1358 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@1259 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@1011 98 fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch)
adamc@874 99
adamc@874 100 fun unAs s =
adamc@874 101 let
adamc@874 102 fun doChars (cs, acc) =
adamc@874 103 case cs of
adamc@998 104 #"T" :: #"_" :: #"T" :: #"." :: cs => doChars (cs, acc)
adam@1467 105 | #"'" :: cs => doString (cs, #"'" :: acc)
adamc@874 106 | ch :: cs => doChars (cs, ch :: acc)
adamc@874 107 | [] => String.implode (rev acc)
adamc@874 108
adamc@874 109 and doString (cs, acc) =
adamc@874 110 case cs of
adamc@874 111 #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc)
adamc@874 112 | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc)
adamc@874 113 | #"'" :: cs => doChars (cs, #"'" :: acc)
adamc@874 114 | ch :: cs => doString (cs, ch :: acc)
adamc@874 115 | [] => String.implode (rev acc)
adamc@874 116 in
adamc@874 117 doChars (String.explode s, [])
adamc@874 118 end
adamc@453 119
adamc@1065 120 fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s
adam@2008 121 val checkData = CharVector.all (fn ch => Char.isAlphaNum ch
adam@2008 122 orelse ch = #"_"
adam@2008 123 orelse ch = #"-")
adam@1750 124 val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch
adam@1750 125 orelse ch = #"+"
adam@1750 126 orelse ch = #"-"
adam@1750 127 orelse ch = #"."
adam@1750 128 orelse ch = #"%"
adam@1750 129 orelse ch = #"#")
adam@1750 130 val checkCssUrl = CharVector.all (fn ch => Char.isAlphaNum ch
adam@1750 131 orelse ch = #":"
adam@1750 132 orelse ch = #"/"
adam@1750 133 orelse ch = #"."
adam@1750 134 orelse ch = #"_"
adam@1755 135 orelse ch = #"+"
adam@1750 136 orelse ch = #"-"
adam@1750 137 orelse ch = #"%"
adam@1750 138 orelse ch = #"?"
adam@1750 139 orelse ch = #"&"
adam@1750 140 orelse ch = #"="
adam@1750 141 orelse ch = #"#")
adam@1750 142 fun checkProperty s = size s > 0
adam@1750 143 andalso (Char.isLower (String.sub (s, 0)) orelse String.sub (s, 0) = #"_")
adam@1750 144 andalso CharVector.all (fn ch => Char.isLower ch orelse Char.isDigit ch orelse ch = #"_" orelse ch = #"-") s
adamc@1065 145
adamc@96 146 fun exp e =
adamc@96 147 case e of
adamc@96 148 EPrim (Prim.String s) =>
vshabanoff@1764 149 if CharVector.exists Char.isSpace s then
vshabanoff@1764 150 let
vshabanoff@1764 151 val (_, chs) =
vshabanoff@1764 152 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
vshabanoff@1764 153 let
vshabanoff@1764 154 val isSpace = Char.isSpace ch
vshabanoff@1764 155 in
vshabanoff@1764 156 if isSpace andalso lastSpace then
vshabanoff@1764 157 (true, chs)
vshabanoff@1764 158 else
vshabanoff@1764 159 (isSpace, ch :: chs)
vshabanoff@1764 160 end)
vshabanoff@1764 161 (false, []) s
vshabanoff@1764 162 in
vshabanoff@1764 163 EPrim (Prim.String (String.implode (rev chs)))
vshabanoff@1764 164 end
vshabanoff@1764 165 else
vshabanoff@1764 166 e
adam@1318 167
adam@1663 168 | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
adamc@96 169
adamc@96 170 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 171 let
adamc@96 172 val s =
adamc@96 173 if size s1 > 0 andalso size s2 > 0
adamc@96 174 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 175 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 176 s1 ^ String.extract (s2, 1, NONE)
adamc@96 177 else
adamc@96 178 s1 ^ s2
adamc@96 179 in
adamc@96 180 EPrim (Prim.String s)
adamc@96 181 end
adamc@105 182
adamc@105 183 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 184 let
adamc@105 185 val s =
adamc@105 186 if size s1 > 0 andalso size s2 > 0
adamc@105 187 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 188 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 189 s1 ^ String.extract (s2, 1, NONE)
adamc@105 190 else
adamc@105 191 s1 ^ s2
adamc@105 192 in
adamc@105 193 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 194 end
adamc@105 195
adamc@105 196 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 197 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 198
adamc@106 199 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 200 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 201 (optExp (EWrite e2, loc), loc))
adamc@106 202
adamc@183 203 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183 204 (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183 205 EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196 206 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196 207 (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196 208 e), _)) =>
adamc@196 209 ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196 210 e)
adamc@183 211
adam@1663 212 | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) =>
adam@1358 213 EPrim (Prim.String (htmlifySpecialChar ch))
adam@1358 214 | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) =>
adam@1358 215 EFfiApp ("Basis", "htmlifySpecialChar_w", [e])
adam@1358 216
adam@1663 217 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) =>
adamc@286 218 EPrim (Prim.String (htmlifyInt n))
adam@1663 219 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) =>
adamc@286 220 EFfiApp ("Basis", "htmlifyInt", es)
adam@1663 221 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
adam@1663 222 (EPrim (Prim.Int n), _)), _), _)]) =>
adamc@320 223 EPrim (Prim.String (htmlifyInt n))
adam@1663 224 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
adam@1663 225 e), loc), _)]) =>
adam@1663 226 EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))])
adamc@286 227 | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286 228 EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286 229
adam@1663 230 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) =>
adamc@286 231 EPrim (Prim.String (htmlifyFloat n))
adam@1663 232 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) =>
adamc@286 233 EFfiApp ("Basis", "htmlifyFloat", es)
adam@1663 234 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
adam@1663 235 (EPrim (Prim.Float n), _)), _), _)]) =>
adamc@320 236 EPrim (Prim.String (htmlifyFloat n))
adam@1663 237 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
adam@1663 238 e), loc), _)]) =>
adam@1663 239 EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))])
adamc@286 240 | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286 241 EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286 242
adam@1663 243 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
adam@1663 244 [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) =>
adamc@286 245 EPrim (Prim.String "True")
adam@1663 246 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
adam@1663 247 [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) =>
adamc@286 248 EPrim (Prim.String "False")
adam@1663 249 | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) =>
adamc@286 250 EFfiApp ("Basis", "htmlifyBool", es)
adam@1663 251 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
adam@1663 252 (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) =>
adamc@320 253 EPrim (Prim.String "True")
adam@1663 254 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
adam@1663 255 (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) =>
adamc@320 256 EPrim (Prim.String "False")
adam@1663 257 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
adam@1663 258 e), loc), _)]) =>
adam@1663 259 EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))])
adamc@286 260 | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286 261 EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286 262
adam@1663 263 | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "timeToString"), _), e), loc), _)]) =>
adam@1663 264 EFfiApp ("Basis", "htmlifyTime", [(e, (TFfi ("Basis", "time"), loc))])
adam@1663 265 | EFfiApp ("Basis", "htmlifyString_w", [((EApp ((EFfi ("Basis", "timeToString"), loc), e), _), _)]) =>
adam@1663 266 EFfiApp ("Basis", "htmlifyTime_w", [(e, (TFfi ("Basis", "time"), loc))])
adamc@436 267 | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436 268 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 269
adam@1663 270 | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) =>
adamc@135 271 EPrim (Prim.String (htmlifyString s))
adam@1663 272 | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
adamc@135 273 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 274 | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135 275 EFfiApp ("Basis", "htmlifyString_w", [e])
adam@1663 276 | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) =>
adamc@196 277 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 278
adam@1446 279 | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) =>
adam@1446 280 EFfiApp ("Basis", "htmlifySource_w", [e])
adam@1446 281
adam@1663 282 | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) =>
adamc@107 283 EPrim (Prim.String (attrifyInt n))
adam@1663 284 | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
adamc@107 285 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 286 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 287 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 288
adam@1663 289 | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
adamc@107 290 EPrim (Prim.String (attrifyFloat n))
adam@1663 291 | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
adamc@107 292 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 293 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 294 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 295
adam@1663 296 | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) =>
adamc@107 297 EPrim (Prim.String (attrifyString s))
adam@1663 298 | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
adamc@107 299 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 300 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 301 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 302
adam@1663 303 | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) =>
adamc@1011 304 EPrim (Prim.String (attrifyChar s))
adam@1663 305 | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) =>
adamc@1011 306 EWrite (EPrim (Prim.String (attrifyChar s)), loc)
adamc@1011 307 | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) =>
adamc@1011 308 EFfiApp ("Basis", "attrifyChar_w", [e])
adamc@1011 309
adam@1663 310 | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) =>
adamc@721 311 EPrim (Prim.String s)
adam@1663 312 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) =>
adamc@721 313 EWrite (EPrim (Prim.String s), loc)
adamc@721 314 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
adamc@721 315 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@721 316
adam@1663 317 | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
adamc@120 318 EPrim (Prim.String (urlifyInt n))
adam@1663 319 | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
adamc@120 320 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 321 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 322 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 323
adam@1663 324 | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
adamc@120 325 EPrim (Prim.String (urlifyFloat n))
adam@1663 326 | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
adamc@120 327 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 328 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 329 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 330
adam@1663 331 | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) =>
adamc@120 332 EPrim (Prim.String (urlifyString s))
adam@1663 333 | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
adamc@120 334 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 335 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 336 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 337
adam@1663 338 | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) =>
adamc@187 339 EPrim (Prim.String "1")
adam@1663 340 | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) =>
adamc@187 341 EPrim (Prim.String "0")
adam@1663 342 | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) =>
adamc@187 343 EWrite (EPrim (Prim.String "1"), loc)
adam@1663 344 | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) =>
adamc@187 345 EWrite (EPrim (Prim.String "0"), loc)
adamc@187 346 | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187 347 EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187 348
adam@1663 349 | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
adamc@253 350 EPrim (Prim.String (sqlifyInt n))
adam@1663 351 | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) =>
adamc@467 352 EPrim (Prim.String "NULL")
adam@1663 353 | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) =>
adamc@467 354 EPrim (Prim.String (sqlifyInt n))
adamc@467 355
adam@1663 356 | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
adamc@253 357 EPrim (Prim.String (sqlifyFloat n))
adam@1663 358 | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) =>
adamc@253 359 optExp (ECase (b,
adamc@253 360 [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
adamc@1014 361 (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)),
adamc@253 362 ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@1014 363 (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))],
adamc@253 364 {disc = (TFfi ("Basis", "bool"), loc),
adamc@253 365 result = (TFfi ("Basis", "string"), loc)}), loc)
adam@1663 366 | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) =>
adamc@253 367 EPrim (Prim.String (sqlifyString n))
adam@1663 368 | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) =>
adamc@1011 369 EPrim (Prim.String (sqlifyChar n))
adamc@253 370
adamc@184 371 | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
adamc@184 372 optExp (ECase (discE,
adamc@184 373 map (fn (p, e) => (p, (EWrite e, loc))) pes,
adamc@184 374 {disc = disc,
adamc@184 375 result = (TRecord [], loc)}), loc)
adamc@184 376
adamc@495 377 | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) =>
adamc@453 378 let
adamc@453 379 fun doBody e =
adamc@453 380 case #1 e of
adamc@453 381 EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body
adamc@453 382 | _ => (EApp (e, arg), loc)
adamc@453 383 in
adamc@453 384 optExp (ECase (discE,
adamc@453 385 map (fn (p, e) => (p, doBody e)) pes,
adamc@453 386 {disc = disc,
adamc@495 387 result = ran}), loc)
adamc@453 388 end
adamc@453 389
adamc@331 390 | EWrite (EQuery {exps, tables, state, query,
adamc@331 391 initial = (EPrim (Prim.String ""), _),
adamc@331 392 body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331 393 (EStrcat ((ERel 0, _),
adamc@331 394 e'), _)), _)}, loc) =>
adamc@331 395 if CharVector.all Char.isSpace s then
adamc@331 396 EQuery {exps = exps, tables = tables, query = query,
adamc@331 397 state = (TRecord [], loc),
adamc@331 398 initial = (ERecord [], loc),
adamc@331 399 body = (optExp (EWrite e', loc), loc)}
adamc@331 400 else
adamc@331 401 e
adamc@331 402
adamc@334 403 | EWrite (EQuery {exps, tables, state, query,
adamc@334 404 initial = (EPrim (Prim.String ""), _),
adamc@486 405 body}, loc) =>
adamc@486 406 let
adamc@486 407 fun passLets (depth, (e', _), lets) =
adamc@486 408 case e' of
adamc@486 409 EStrcat ((ERel x, _), e'') =>
adamc@486 410 if x = depth then
adamc@486 411 let
adamc@486 412 val body = (optExp (EWrite e'', loc), loc)
adamc@486 413 val body = foldl (fn ((x, t, e'), e) =>
adamc@486 414 (ELet (x, t, e', e), loc))
adamc@486 415 body lets
adamc@486 416 in
adamc@486 417 EQuery {exps = exps, tables = tables, query = query,
adamc@486 418 state = (TRecord [], loc),
adamc@486 419 initial = (ERecord [], loc),
adamc@486 420 body = body}
adamc@486 421 end
adamc@486 422 else
adamc@486 423 e
adamc@486 424 | ELet (x, t, e', e'') =>
adamc@486 425 passLets (depth + 1, e'', (x, t, e') :: lets)
adamc@486 426 | _ => e
adamc@486 427 in
adamc@486 428 passLets (0, body, [])
adamc@486 429 end
adamc@486 430
adamc@486 431 (*| EWrite (EQuery {exps, tables, state, query,
adamc@486 432 initial = (EPrim (Prim.String ""), _),
adamc@334 433 body = (EStrcat ((ERel 0, _), e'), _)}, loc) =>
adamc@334 434 EQuery {exps = exps, tables = tables, query = query,
adamc@334 435 state = (TRecord [], loc),
adamc@334 436 initial = (ERecord [], loc),
adamc@486 437 body = (optExp (EWrite e', loc), loc)}*)
adamc@334 438
adamc@340 439 | EWrite (ELet (x, t, e1, e2), loc) =>
adamc@340 440 optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
adamc@340 441
adamc@451 442 | EWrite (EPrim (Prim.String ""), loc) =>
adamc@451 443 ERecord []
adamc@451 444
adamc@572 445 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 446 optExp (EApp (e2, e1), loc)
adamc@572 447
adam@2008 448 | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@2008 449 (if checkData s then
adam@2008 450 ()
adam@2008 451 else
adam@2008 452 ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s);
adam@2008 453 se)
adam@2008 454
adam@1663 455 | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) =>
adamc@1065 456 (if checkUrl s then
adamc@717 457 ()
adamc@717 458 else
adamc@769 459 ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
adamc@717 460 se)
adam@1663 461 | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) =>
adamc@1065 462 (if checkUrl s then
adamc@1065 463 ESome ((TFfi ("Basis", "string"), loc), (se, loc))
adamc@1065 464 else
adamc@1065 465 ENone (TFfi ("Basis", "string"), loc))
adam@1663 466 | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) =>
adamc@769 467 (if Settings.checkMime s then
adamc@741 468 ()
adamc@741 469 else
adamc@769 470 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
adamc@741 471 se)
adam@1663 472 | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1465 473 (if Settings.checkMime s then
adam@1465 474 ESome ((TFfi ("Basis", "string"), loc), (se, loc))
adam@1465 475 else
adam@1465 476 ENone (TFfi ("Basis", "string"), loc))
adam@1750 477 | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1750 478 (if checkAtom s then
adam@1750 479 ()
adam@1750 480 else
adam@1750 481 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'");
adam@1750 482 se)
adam@1750 483 | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1750 484 (if checkCssUrl s then
adam@1750 485 ()
adam@1750 486 else
adam@1750 487 ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'");
adam@1750 488 se)
adam@1750 489 | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1750 490 (if checkProperty s then
adam@1750 491 ()
adam@1750 492 else
adam@1750 493 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'");
adam@1750 494 se)
adam@1663 495 | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1465 496 (if Settings.checkRequestHeader s then
adam@1465 497 ()
adam@1465 498 else
adam@1465 499 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'");
adam@1465 500 se)
adam@1663 501 | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1465 502 (if Settings.checkRequestHeader s then
adam@1465 503 ESome ((TFfi ("Basis", "string"), loc), (se, loc))
adam@1465 504 else
adam@1465 505 ENone (TFfi ("Basis", "string"), loc))
adam@1663 506 | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1465 507 (if Settings.checkResponseHeader s then
adam@1465 508 ()
adam@1465 509 else
adam@1465 510 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'");
adam@1465 511 se)
adam@1663 512 | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1465 513 (if Settings.checkResponseHeader s then
adam@1465 514 ESome ((TFfi ("Basis", "string"), loc), (se, loc))
adam@1465 515 else
adam@1465 516 ENone (TFfi ("Basis", "string"), loc))
adam@1799 517 | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1799 518 (if Settings.checkEnvVar s then
adam@1799 519 ()
adam@1799 520 else
adam@1799 521 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'");
adam@1799 522 se)
adam@1799 523 | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String s), loc), _)]) =>
adam@1799 524 (if Settings.checkEnvVar s then
adam@1799 525 ESome ((TFfi ("Basis", "string"), loc), (se, loc))
adam@1799 526 else
adam@1799 527 ENone (TFfi ("Basis", "string"), loc))
adamc@717 528
adam@1663 529 | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) =>
adamc@714 530 let
adamc@714 531 fun uwify (cs, acc) =
adamc@714 532 case cs of
adamc@714 533 [] => String.concat (rev acc)
adamc@714 534 | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
adamc@714 535 | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
adamc@714 536 | #"'" :: cs =>
adamc@714 537 let
adamc@714 538 fun waitItOut (cs, acc) =
adamc@714 539 case cs of
adamc@714 540 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@714 541 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@714 542 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@714 543 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@714 544 | c :: cs => waitItOut (cs, str c :: acc)
adamc@714 545 in
adamc@714 546 waitItOut (cs, "'" :: acc)
adamc@714 547 end
adamc@714 548 | c :: cs => uwify (cs, str c :: acc)
adamc@714 549
adamc@714 550 val s = case String.explode s of
adamc@714 551 #"_" :: cs => uwify (cs, ["uw_"])
adamc@714 552 | cs => uwify (cs, [])
adamc@714 553 in
adamc@714 554 EPrim (Prim.String s)
adamc@714 555 end
adamc@714 556
adam@1663 557 | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) =>
adamc@754 558 let
adamc@754 559 fun uwify (cs, acc) =
adamc@754 560 case cs of
adamc@754 561 [] => String.concat (rev acc)
adamc@754 562 | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc)
adamc@754 563 | #"'" :: cs =>
adamc@754 564 let
adamc@754 565 fun waitItOut (cs, acc) =
adamc@754 566 case cs of
adamc@754 567 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@754 568 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@754 569 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@754 570 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@754 571 | c :: cs => waitItOut (cs, str c :: acc)
adamc@754 572 in
adamc@754 573 waitItOut (cs, "'" :: acc)
adamc@754 574 end
adamc@754 575 | c :: cs => uwify (cs, str c :: acc)
adamc@754 576
adamc@754 577 val s = uwify (String.explode s, [])
adamc@754 578 in
adamc@754 579 EPrim (Prim.String s)
adamc@754 580 end
adamc@754 581
adam@1663 582 | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) =>
adamc@874 583 EPrim (Prim.String (unAs s))
adam@1663 584 | EFfiApp ("Basis", "unAs", [(e', _)]) =>
adamc@874 585 let
adamc@874 586 fun parts (e as (_, loc)) =
adamc@874 587 case #1 e of
adamc@874 588 EStrcat (s1, s2) =>
adamc@874 589 (case (parts s1, parts s2) of
adamc@874 590 (SOME p1, SOME p2) => SOME (p1 @ p2)
adamc@874 591 | _ => NONE)
adamc@874 592 | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)]
adamc@874 593 | EFfiApp ("Basis", f, [_]) =>
adamc@874 594 if String.isPrefix "sqlify" f then
adamc@874 595 SOME [e]
adamc@874 596 else
adamc@874 597 NONE
adamc@874 598 | _ => NONE
adamc@874 599 in
adamc@874 600 case parts e' of
adamc@874 601 SOME [e] => #1 e
adamc@874 602 | SOME es =>
adamc@874 603 (case rev es of
adamc@874 604 (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es)
adamc@874 605 | [] => raise Fail "MonoOpt impossible nil")
adamc@874 606 | NONE => e
adamc@874 607 end
adamc@1024 608
adam@1663 609 | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) =>
adamc@1024 610 EPrim (Prim.String (str ch))
adam@1663 611 | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
adamc@1024 612 EFfiApp ("Basis", "attrifyChar", [e])
adam@1663 613 | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
adamc@1024 614 EFfiApp ("Basis", "attrifyChar_w", [e])
adam@1287 615
adam@1360 616 | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
adamc@874 617
adamc@96 618 | _ => e
adamc@96 619
adamc@105 620 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 621
adamc@96 622 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 623
adamc@506 624 val optExp = U.Exp.map {typ = typ, exp = exp}
adamc@506 625
adamc@96 626 end