Mercurial > urweb

annotate src/mono_opt.sml @ 1327:1cc67fdac4d3

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