Mercurial > urweb

annotate src/mono_opt.sml @ 1034:a779402841f6

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