Mercurial > urweb

annotate src/mono_opt.sml @ 1053:4eb1c4a1b057

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