Mercurial > urweb

annotate src/mono_opt.sml @ 2160:72fe1cc704c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tag NULLs with their types in SQL, to help the DBMS do type inference
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Jul 2015 19:24:26 -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