Mercurial > urweb

annotate src/mono_opt.sml @ 2067:88841212f0ba

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