Mercurial > urweb

annotate src/mono_opt.sml @ 1755:e9587120831a

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