Mercurial > urweb

annotate src/mono_opt.sml @ 1623:218e2a9a53d0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Better error messages about non-SQL-izability of types
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Dec 2011 15:59:21 -0500
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