Mercurial > urweb

annotate src/mono_opt.sml @ 1054:b06a2a65e670

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
UTF-8 in dynamic escaping
author Adam Chlipala <adamc@hcoop.net>
date Thu, 03 Dec 2009 11:50:51 -0500
parents 4eb1c4a1b057
children 03a81e26e5fe
rev   line source
adamc@96 1 (* Copyright (c) 2008, 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@1054 48 fun attrifyString s =
adamc@1054 49 let
adamc@1054 50 fun hs (pos, acc) =
adamc@1054 51 if pos >= size s then
adamc@1054 52 String.concat (rev acc)
adamc@1054 53 else
adamc@1054 54 case String.sub (s, pos) of
adamc@1054 55 #"\"" => hs (pos+1, "&quot;" :: acc)
adamc@1054 56 | #"&" => hs (pos+1, "&amp;" :: acc)
adamc@1054 57 | ch =>
adamc@1054 58 let
adamc@1054 59 val n = ord ch
adamc@1054 60 fun isCont k = pos + k < size s
adamc@1054 61 andalso ord (String.sub (s, pos + k)) div 64 = 2
adamc@1054 62 fun unicode k = hs (pos+k+1, String.substring (s, pos, k+1) :: acc)
adamc@1054 63 in
adamc@1054 64 if Char.isPrint ch orelse Char.isSpace ch then
adamc@1054 65 hs (pos+1, str ch :: acc)
adamc@1054 66 else if n div 32 = 6 andalso isCont 1 then
adamc@1054 67 unicode 1
adamc@1054 68 else if n div 16 = 14 andalso isCont 1 andalso isCont 2 then
adamc@1054 69 unicode 2
adamc@1054 70 else if n div 8 = 30 andalso isCont 1 andalso isCont 2 andalso isCont 3 then
adamc@1054 71 unicode 3
adamc@1054 72 else
adamc@1054 73 hs (pos+1, "&#" ^ Int.toString (ord ch) ^ ";" :: acc)
adamc@1054 74 end
adamc@1054 75 in
adamc@1054 76 hs (0, [])
adamc@1054 77 end
adamc@1054 78
adamc@1011 79 fun attrifyChar ch =
adamc@1011 80 case ch of
adamc@1011 81 #"\"" => "&quot;"
adamc@1011 82 | #"&" => "&amp;"
adamc@1011 83 | ch => if Char.isPrint ch then
adamc@1011 84 str ch
adamc@1011 85 else
adamc@1011 86 "&#" ^ Int.toString (ord ch) ^ ";"
adamc@1011 87
adamc@120 88 val urlifyInt = attrifyInt
adamc@120 89 val urlifyFloat = attrifyFloat
adamc@120 90
adamc@286 91 val htmlifyInt = attrifyInt
adamc@286 92 val htmlifyFloat = attrifyFloat
adamc@1053 93
adamc@1053 94 fun htmlifyString s =
adamc@1053 95 let
adamc@1053 96 fun hs (pos, acc) =
adamc@1053 97 if pos >= size s then
adamc@1053 98 String.concat (rev acc)
adamc@1053 99 else
adamc@1053 100 case String.sub (s, pos) of
adamc@1053 101 #"<" => hs (pos+1, "&lt;" :: acc)
adamc@1053 102 | #"&" => hs (pos+1, "&amp;" :: acc)
adamc@1053 103 | ch =>
adamc@1053 104 let
adamc@1053 105 val n = ord ch
adamc@1053 106 fun isCont k = pos + k < size s
adamc@1053 107 andalso ord (String.sub (s, pos + k)) div 64 = 2
adamc@1053 108 fun unicode k = hs (pos+k+1, String.substring (s, pos, k+1) :: acc)
adamc@1053 109 in
adamc@1054 110 if Char.isPrint ch then
adamc@1053 111 hs (pos+1, str ch :: acc)
adamc@1053 112 else if n div 32 = 6 andalso isCont 1 then
adamc@1053 113 unicode 1
adamc@1053 114 else if n div 16 = 14 andalso isCont 1 andalso isCont 2 then
adamc@1053 115 unicode 2
adamc@1053 116 else if n div 8 = 30 andalso isCont 1 andalso isCont 2 andalso isCont 3 then
adamc@1053 117 unicode 3
adamc@1053 118 else
adamc@1053 119 hs (pos+1, "&#" ^ Int.toString (ord ch) ^ ";" :: acc)
adamc@1053 120 end
adamc@1053 121 in
adamc@1053 122 hs (0, [])
adamc@1053 123 end
adamc@135 124
adamc@120 125 fun hexIt ch =
adamc@120 126 let
adamc@120 127 val s = Int.fmt StringCvt.HEX (ord ch)
adamc@120 128 in
adamc@120 129 case size s of
adamc@120 130 0 => "00"
adamc@120 131 | 1 => "0" ^ s
adamc@120 132 | _ => s
adamc@120 133 end
adamc@120 134
adamc@925 135 fun urlifyString s =
adamc@925 136 case s of
adamc@925 137 "" => "_"
adamc@925 138 | _ =>
adamc@925 139 (if String.sub (s, 0) = #"_" then
adamc@925 140 "_"
adamc@925 141 else
adamc@925 142 "")
adamc@925 143 ^ String.translate (fn #" " => "+"
adamc@925 144 | ch => if Char.isAlphaNum ch then
adamc@925 145 str ch
adamc@925 146 else
adamc@925 147 "%" ^ hexIt ch) s
adamc@253 148
adamc@253 149
adamc@877 150 fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int)
adamc@877 151 fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float)
adamc@253 152
adamc@874 153 fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s
adamc@1011 154 fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch)
adamc@874 155
adamc@874 156 fun unAs s =
adamc@874 157 let
adamc@874 158 fun doChars (cs, acc) =
adamc@874 159 case cs of
adamc@998 160 #"T" :: #"_" :: #"T" :: #"." :: cs => doChars (cs, acc)
adamc@874 161 | #"'" :: cs => doString (cs, acc)
adamc@874 162 | ch :: cs => doChars (cs, ch :: acc)
adamc@874 163 | [] => String.implode (rev acc)
adamc@874 164
adamc@874 165 and doString (cs, acc) =
adamc@874 166 case cs of
adamc@874 167 #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc)
adamc@874 168 | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc)
adamc@874 169 | #"'" :: cs => doChars (cs, #"'" :: acc)
adamc@874 170 | ch :: cs => doString (cs, ch :: acc)
adamc@874 171 | [] => String.implode (rev acc)
adamc@874 172 in
adamc@874 173 doChars (String.explode s, [])
adamc@874 174 end
adamc@453 175
adamc@96 176 fun exp e =
adamc@96 177 case e of
adamc@96 178 EPrim (Prim.String s) =>
adamc@96 179 let
adamc@96 180 val (_, chs) =
adamc@96 181 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96 182 let
adamc@96 183 val isSpace = Char.isSpace ch
adamc@96 184 in
adamc@96 185 if isSpace andalso lastSpace then
adamc@96 186 (true, chs)
adamc@96 187 else
adamc@96 188 (isSpace, ch :: chs)
adamc@96 189 end)
adamc@96 190 (false, []) s
adamc@96 191 in
adamc@96 192 EPrim (Prim.String (String.implode (rev chs)))
adamc@96 193 end
adamc@96 194
adamc@96 195 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 196 let
adamc@96 197 val s =
adamc@96 198 if size s1 > 0 andalso size s2 > 0
adamc@96 199 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 200 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 201 s1 ^ String.extract (s2, 1, NONE)
adamc@96 202 else
adamc@96 203 s1 ^ s2
adamc@96 204 in
adamc@96 205 EPrim (Prim.String s)
adamc@96 206 end
adamc@105 207
adamc@105 208 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 209 let
adamc@105 210 val s =
adamc@105 211 if size s1 > 0 andalso size s2 > 0
adamc@105 212 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 213 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 214 s1 ^ String.extract (s2, 1, NONE)
adamc@105 215 else
adamc@105 216 s1 ^ s2
adamc@105 217 in
adamc@105 218 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 219 end
adamc@105 220
adamc@105 221 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 222 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 223
adamc@106 224 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 225 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 226 (optExp (EWrite e2, loc), loc))
adamc@106 227
adamc@183 228 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183 229 (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183 230 EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196 231 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196 232 (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196 233 e), _)) =>
adamc@196 234 ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196 235 e)
adamc@183 236
adamc@286 237 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
adamc@286 238 EPrim (Prim.String (htmlifyInt n))
adamc@286 239 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
adamc@286 240 EFfiApp ("Basis", "htmlifyInt", es)
adamc@320 241 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 242 (EPrim (Prim.Int n), _)), _)]) =>
adamc@320 243 EPrim (Prim.String (htmlifyInt n))
adamc@320 244 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 245 e), _)]) =>
adamc@320 246 EFfiApp ("Basis", "htmlifyInt", [e])
adamc@286 247 | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286 248 EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286 249
adamc@286 250 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
adamc@286 251 EPrim (Prim.String (htmlifyFloat n))
adamc@286 252 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
adamc@286 253 EFfiApp ("Basis", "htmlifyFloat", es)
adamc@320 254 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 255 (EPrim (Prim.Float n), _)), _)]) =>
adamc@320 256 EPrim (Prim.String (htmlifyFloat n))
adamc@320 257 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 258 e), _)]) =>
adamc@320 259 EFfiApp ("Basis", "htmlifyFloat", [e])
adamc@286 260 | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286 261 EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286 262
adamc@286 263 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 264 [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
adamc@286 265 EPrim (Prim.String "True")
adamc@286 266 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 267 [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
adamc@286 268 EPrim (Prim.String "False")
adamc@286 269 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
adamc@286 270 EFfiApp ("Basis", "htmlifyBool", es)
adamc@320 271 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 272 (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
adamc@320 273 EPrim (Prim.String "True")
adamc@320 274 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 275 (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
adamc@320 276 EPrim (Prim.String "False")
adamc@320 277 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 278 e), _)]) =>
adamc@320 279 EFfiApp ("Basis", "htmlifyBool", [e])
adamc@286 280 | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286 281 EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286 282
adamc@436 283 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 284 EFfiApp ("Basis", "htmlifyTime", [e])
adamc@436 285 | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 286 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 287 | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436 288 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 289
adamc@135 290 | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@135 291 EPrim (Prim.String (htmlifyString s))
adamc@135 292 | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@135 293 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 294 | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135 295 EFfiApp ("Basis", "htmlifyString_w", [e])
adamc@196 296 | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
adamc@196 297 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 298
adamc@107 299 | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107 300 EPrim (Prim.String (attrifyInt n))
adamc@107 301 | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107 302 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 303 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 304 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 305
adamc@107 306 | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107 307 EPrim (Prim.String (attrifyFloat n))
adamc@107 308 | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107 309 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 310 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 311 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 312
adamc@107 313 | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107 314 EPrim (Prim.String (attrifyString s))
adamc@107 315 | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107 316 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 317 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 318 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 319
adamc@1011 320 | EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]) =>
adamc@1011 321 EPrim (Prim.String (attrifyChar s))
adamc@1011 322 | EWrite (EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]), loc) =>
adamc@1011 323 EWrite (EPrim (Prim.String (attrifyChar s)), loc)
adamc@1011 324 | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) =>
adamc@1011 325 EFfiApp ("Basis", "attrifyChar_w", [e])
adamc@1011 326
adamc@721 327 | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) =>
adamc@721 328 EPrim (Prim.String s)
adamc@721 329 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) =>
adamc@721 330 EWrite (EPrim (Prim.String s), loc)
adamc@721 331 | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
adamc@721 332 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@721 333
adamc@120 334 | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120 335 EPrim (Prim.String (urlifyInt n))
adamc@120 336 | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120 337 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 338 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 339 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 340
adamc@120 341 | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120 342 EPrim (Prim.String (urlifyFloat n))
adamc@120 343 | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120 344 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 345 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 346 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 347
adamc@120 348 | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120 349 EPrim (Prim.String (urlifyString s))
adamc@120 350 | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120 351 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 352 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 353 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 354
adamc@188 355 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
adamc@187 356 EPrim (Prim.String "1")
adamc@188 357 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
adamc@187 358 EPrim (Prim.String "0")
adamc@188 359 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
adamc@187 360 EWrite (EPrim (Prim.String "1"), loc)
adamc@188 361 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
adamc@187 362 EWrite (EPrim (Prim.String "0"), loc)
adamc@187 363 | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187 364 EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187 365
adamc@253 366 | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@253 367 EPrim (Prim.String (sqlifyInt n))
adamc@467 368 | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
adamc@467 369 EPrim (Prim.String "NULL")
adamc@467 370 | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
adamc@467 371 EPrim (Prim.String (sqlifyInt n))
adamc@467 372
adamc@253 373 | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@253 374 EPrim (Prim.String (sqlifyFloat n))
adamc@253 375 | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
adamc@253 376 optExp (ECase (b,
adamc@253 377 [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
adamc@1014 378 (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)),
adamc@253 379 ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@1014 380 (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))],
adamc@253 381 {disc = (TFfi ("Basis", "bool"), loc),
adamc@253 382 result = (TFfi ("Basis", "string"), loc)}), loc)
adamc@253 383 | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
adamc@253 384 EPrim (Prim.String (sqlifyString n))
adamc@1011 385 | EFfiApp ("Basis", "sqlifyChar", [(EPrim (Prim.Char n), _)]) =>
adamc@1011 386 EPrim (Prim.String (sqlifyChar n))
adamc@253 387
adamc@184 388 | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
adamc@184 389 optExp (ECase (discE,
adamc@184 390 map (fn (p, e) => (p, (EWrite e, loc))) pes,
adamc@184 391 {disc = disc,
adamc@184 392 result = (TRecord [], loc)}), loc)
adamc@184 393
adamc@495 394 | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) =>
adamc@453 395 let
adamc@453 396 fun doBody e =
adamc@453 397 case #1 e of
adamc@453 398 EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body
adamc@453 399 | _ => (EApp (e, arg), loc)
adamc@453 400 in
adamc@453 401 optExp (ECase (discE,
adamc@453 402 map (fn (p, e) => (p, doBody e)) pes,
adamc@453 403 {disc = disc,
adamc@495 404 result = ran}), loc)
adamc@453 405 end
adamc@453 406
adamc@331 407 | EWrite (EQuery {exps, tables, state, query,
adamc@331 408 initial = (EPrim (Prim.String ""), _),
adamc@331 409 body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331 410 (EStrcat ((ERel 0, _),
adamc@331 411 e'), _)), _)}, loc) =>
adamc@331 412 if CharVector.all Char.isSpace s then
adamc@331 413 EQuery {exps = exps, tables = tables, query = query,
adamc@331 414 state = (TRecord [], loc),
adamc@331 415 initial = (ERecord [], loc),
adamc@331 416 body = (optExp (EWrite e', loc), loc)}
adamc@331 417 else
adamc@331 418 e
adamc@331 419
adamc@334 420 | EWrite (EQuery {exps, tables, state, query,
adamc@334 421 initial = (EPrim (Prim.String ""), _),
adamc@486 422 body}, loc) =>
adamc@486 423 let
adamc@486 424 fun passLets (depth, (e', _), lets) =
adamc@486 425 case e' of
adamc@486 426 EStrcat ((ERel x, _), e'') =>
adamc@486 427 if x = depth then
adamc@486 428 let
adamc@486 429 val body = (optExp (EWrite e'', loc), loc)
adamc@486 430 val body = foldl (fn ((x, t, e'), e) =>
adamc@486 431 (ELet (x, t, e', e), loc))
adamc@486 432 body lets
adamc@486 433 in
adamc@486 434 EQuery {exps = exps, tables = tables, query = query,
adamc@486 435 state = (TRecord [], loc),
adamc@486 436 initial = (ERecord [], loc),
adamc@486 437 body = body}
adamc@486 438 end
adamc@486 439 else
adamc@486 440 e
adamc@486 441 | ELet (x, t, e', e'') =>
adamc@486 442 passLets (depth + 1, e'', (x, t, e') :: lets)
adamc@486 443 | _ => e
adamc@486 444 in
adamc@486 445 passLets (0, body, [])
adamc@486 446 end
adamc@486 447
adamc@486 448 (*| EWrite (EQuery {exps, tables, state, query,
adamc@486 449 initial = (EPrim (Prim.String ""), _),
adamc@334 450 body = (EStrcat ((ERel 0, _), e'), _)}, loc) =>
adamc@334 451 EQuery {exps = exps, tables = tables, query = query,
adamc@334 452 state = (TRecord [], loc),
adamc@334 453 initial = (ERecord [], loc),
adamc@486 454 body = (optExp (EWrite e', loc), loc)}*)
adamc@334 455
adamc@340 456 | EWrite (ELet (x, t, e1, e2), loc) =>
adamc@340 457 optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
adamc@340 458
adamc@451 459 | EWrite (EPrim (Prim.String ""), loc) =>
adamc@451 460 ERecord []
adamc@451 461
adamc@572 462 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 463 optExp (EApp (e2, e1), loc)
adamc@572 464
adamc@717 465 | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
adamc@769 466 (if Settings.checkUrl s then
adamc@717 467 ()
adamc@717 468 else
adamc@769 469 ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
adamc@717 470 se)
adamc@741 471 | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
adamc@769 472 (if Settings.checkMime s then
adamc@741 473 ()
adamc@741 474 else
adamc@769 475 ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
adamc@741 476 se)
adamc@717 477
adamc@714 478 | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
adamc@714 479 let
adamc@714 480 fun uwify (cs, acc) =
adamc@714 481 case cs of
adamc@714 482 [] => String.concat (rev acc)
adamc@714 483 | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
adamc@714 484 | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
adamc@714 485 | #"'" :: cs =>
adamc@714 486 let
adamc@714 487 fun waitItOut (cs, acc) =
adamc@714 488 case cs of
adamc@714 489 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@714 490 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@714 491 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@714 492 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@714 493 | c :: cs => waitItOut (cs, str c :: acc)
adamc@714 494 in
adamc@714 495 waitItOut (cs, "'" :: acc)
adamc@714 496 end
adamc@714 497 | c :: cs => uwify (cs, str c :: acc)
adamc@714 498
adamc@714 499 val s = case String.explode s of
adamc@714 500 #"_" :: cs => uwify (cs, ["uw_"])
adamc@714 501 | cs => uwify (cs, [])
adamc@714 502 in
adamc@714 503 EPrim (Prim.String s)
adamc@714 504 end
adamc@714 505
adamc@754 506 | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) =>
adamc@754 507 let
adamc@754 508 fun uwify (cs, acc) =
adamc@754 509 case cs of
adamc@754 510 [] => String.concat (rev acc)
adamc@754 511 | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc)
adamc@754 512 | #"'" :: cs =>
adamc@754 513 let
adamc@754 514 fun waitItOut (cs, acc) =
adamc@754 515 case cs of
adamc@754 516 [] => raise Fail "MonoOpt: Unterminated SQL string literal"
adamc@754 517 | #"'" :: cs => uwify (cs, "'" :: acc)
adamc@754 518 | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
adamc@754 519 | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
adamc@754 520 | c :: cs => waitItOut (cs, str c :: acc)
adamc@754 521 in
adamc@754 522 waitItOut (cs, "'" :: acc)
adamc@754 523 end
adamc@754 524 | c :: cs => uwify (cs, str c :: acc)
adamc@754 525
adamc@754 526 val s = uwify (String.explode s, [])
adamc@754 527 in
adamc@754 528 EPrim (Prim.String s)
adamc@754 529 end
adamc@754 530
adamc@874 531 | EFfiApp ("Basis", "unAs", [(EPrim (Prim.String s), _)]) =>
adamc@874 532 EPrim (Prim.String (unAs s))
adamc@874 533 | EFfiApp ("Basis", "unAs", [e']) =>
adamc@874 534 let
adamc@874 535 fun parts (e as (_, loc)) =
adamc@874 536 case #1 e of
adamc@874 537 EStrcat (s1, s2) =>
adamc@874 538 (case (parts s1, parts s2) of
adamc@874 539 (SOME p1, SOME p2) => SOME (p1 @ p2)
adamc@874 540 | _ => NONE)
adamc@874 541 | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)]
adamc@874 542 | EFfiApp ("Basis", f, [_]) =>
adamc@874 543 if String.isPrefix "sqlify" f then
adamc@874 544 SOME [e]
adamc@874 545 else
adamc@874 546 NONE
adamc@874 547 | _ => NONE
adamc@874 548 in
adamc@874 549 case parts e' of
adamc@874 550 SOME [e] => #1 e
adamc@874 551 | SOME es =>
adamc@874 552 (case rev es of
adamc@874 553 (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es)
adamc@874 554 | [] => raise Fail "MonoOpt impossible nil")
adamc@874 555 | NONE => e
adamc@874 556 end
adamc@1024 557
adamc@1024 558 | EFfiApp ("Basis", "str1", [(EPrim (Prim.Char ch), _)]) =>
adamc@1024 559 EPrim (Prim.String (str ch))
adamc@1024 560 | EFfiApp ("Basis", "attrifyString", [(EFfiApp ("Basis", "str1", [e]), _)]) =>
adamc@1024 561 EFfiApp ("Basis", "attrifyChar", [e])
adamc@1024 562 | EFfiApp ("Basis", "attrifyString_w", [(EFfiApp ("Basis", "str1", [e]), _)]) =>
adamc@1024 563 EFfiApp ("Basis", "attrifyChar_w", [e])
adamc@874 564
adamc@96 565 | _ => e
adamc@96 566
adamc@105 567 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 568
adamc@96 569 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 570
adamc@506 571 val optExp = U.Exp.map {typ = typ, exp = exp}
adamc@506 572
adamc@96 573 end