Mercurial > urweb

annotate src/mono_opt.sml @ 2176:d2a98983f502

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