Mercurial > urweb

annotate src/mono_opt.sml @ 1591:20f898c29525

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