adamc@1259: (* Copyright (c) 2008-2010, Adam Chlipala adamc@96: * All rights reserved. adamc@96: * adamc@96: * Redistribution and use in source and binary forms, with or without adamc@96: * modification, are permitted provided that the following conditions are met: adamc@96: * adamc@96: * - Redistributions of source code must retain the above copyright notice, adamc@96: * this list of conditions and the following disclaimer. adamc@96: * - Redistributions in binary form must reproduce the above copyright notice, adamc@96: * this list of conditions and the following disclaimer in the documentation adamc@96: * and/or other materials provided with the distribution. adamc@96: * - The names of contributors may not be used to endorse or promote products adamc@96: * derived from this software without specific prior written permission. adamc@96: * adamc@96: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@96: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@96: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@96: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@96: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@96: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@96: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@96: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@96: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@96: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@96: * POSSIBILITY OF SUCH DAMAGE. adamc@96: *) adamc@96: adamc@96: structure MonoOpt :> MONO_OPT = struct adamc@96: adamc@96: open Mono adamc@96: structure U = MonoUtil adamc@96: adamc@96: fun typ t = t adamc@96: fun decl d = d adamc@96: adamc@107: fun attrifyInt n = adamc@107: if n < 0 then adamc@107: "-" ^ Int64.toString (Int64.~ n) adamc@107: else adamc@107: Int64.toString n adamc@107: adamc@107: fun attrifyFloat n = adamc@107: if n < 0.0 then adamc@107: "-" ^ Real.toString (Real.~ n) adamc@107: else adamc@107: Real.toString n adamc@107: adamc@1011: fun attrifyChar ch = adamc@1011: case ch of adamc@1011: #"\"" => """ adamc@1011: | #"&" => "&" adamc@1059: | ch => str ch adamc@1059: adamc@1059: val attrifyString = String.translate attrifyChar adamc@1059: adamc@1011: adamc@120: val urlifyInt = attrifyInt adamc@120: val urlifyFloat = attrifyFloat adamc@120: adamc@286: val htmlifyInt = attrifyInt adamc@286: val htmlifyFloat = attrifyFloat adamc@1053: adamc@1059: val htmlifyString = String.translate (fn #"<" => "<" adamc@1059: | #"&" => "&" adamc@1059: | ch => str ch) adamc@135: adam@1358: fun htmlifySpecialChar ch = "&#" ^ Int.toString (ord ch) ^ ";" adam@1358: adamc@120: fun hexIt ch = adamc@120: let adamc@120: val s = Int.fmt StringCvt.HEX (ord ch) adamc@120: in adamc@120: case size s of adamc@120: 0 => "00" adamc@120: | 1 => "0" ^ s adamc@120: | _ => s adamc@120: end adamc@120: adamc@925: fun urlifyString s = adamc@925: case s of adamc@925: "" => "_" adamc@925: | _ => adamc@925: (if String.sub (s, 0) = #"_" then adamc@925: "_" adamc@925: else adamc@925: "") adamc@925: ^ String.translate (fn #" " => "+" adamc@925: | ch => if Char.isAlphaNum ch then adamc@925: str ch adamc@925: else adamc@1259: "." ^ hexIt ch) s adamc@253: adamc@253: adamc@877: fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int) adamc@877: fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float) adamc@253: adamc@874: fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s adamc@1011: fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch) adamc@874: adamc@874: fun unAs s = adamc@874: let adamc@874: fun doChars (cs, acc) = adamc@874: case cs of adamc@998: #"T" :: #"_" :: #"T" :: #"." :: cs => doChars (cs, acc) adam@1467: | #"'" :: cs => doString (cs, #"'" :: acc) adamc@874: | ch :: cs => doChars (cs, ch :: acc) adamc@874: | [] => String.implode (rev acc) adamc@874: adamc@874: and doString (cs, acc) = adamc@874: case cs of adamc@874: #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc) adamc@874: | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc) adamc@874: | #"'" :: cs => doChars (cs, #"'" :: acc) adamc@874: | ch :: cs => doString (cs, ch :: acc) adamc@874: | [] => String.implode (rev acc) adamc@874: in adamc@874: doChars (String.explode s, []) adamc@874: end adamc@453: adamc@1065: fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s adam@2008: val checkData = CharVector.all (fn ch => Char.isAlphaNum ch adam@2008: orelse ch = #"_" adam@2008: orelse ch = #"-") adam@1750: val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch adam@1750: orelse ch = #"+" adam@1750: orelse ch = #"-" adam@1750: orelse ch = #"." adam@1750: orelse ch = #"%" adam@1750: orelse ch = #"#") adam@1750: val checkCssUrl = CharVector.all (fn ch => Char.isAlphaNum ch adam@1750: orelse ch = #":" adam@1750: orelse ch = #"/" adam@1750: orelse ch = #"." adam@1750: orelse ch = #"_" adam@1755: orelse ch = #"+" adam@1750: orelse ch = #"-" adam@1750: orelse ch = #"%" adam@1750: orelse ch = #"?" adam@1750: orelse ch = #"&" adam@1750: orelse ch = #"=" adam@1750: orelse ch = #"#") adam@1750: fun checkProperty s = size s > 0 adam@1750: andalso (Char.isLower (String.sub (s, 0)) orelse String.sub (s, 0) = #"_") adam@1750: andalso CharVector.all (fn ch => Char.isLower ch orelse Char.isDigit ch orelse ch = #"_" orelse ch = #"-") s adamc@1065: adamc@96: fun exp e = adamc@96: case e of adam@2048: EPrim (Prim.String (Prim.Html, s)) => vshabanoff@1764: if CharVector.exists Char.isSpace s then vshabanoff@1764: let vshabanoff@1764: val (_, chs) = vshabanoff@1764: CharVector.foldl (fn (ch, (lastSpace, chs)) => vshabanoff@1764: let vshabanoff@1764: val isSpace = Char.isSpace ch vshabanoff@1764: in vshabanoff@1764: if isSpace andalso lastSpace then vshabanoff@1764: (true, chs) vshabanoff@1764: else vshabanoff@1764: (isSpace, ch :: chs) vshabanoff@1764: end) vshabanoff@1764: (false, []) s vshabanoff@1764: in adam@2048: EPrim (Prim.String (Prim.Html, String.implode (rev chs))) vshabanoff@1764: end vshabanoff@1764: else vshabanoff@1764: e adam@1318: adam@1663: | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) adam@2083: adam@2083: | EStrcat (e1, (EPrim (Prim.String (_, "")), _)) => #1 e1 adam@2083: | EStrcat ((EPrim (Prim.String (_, "")), _), e2) => #1 e2 adam@2048: adam@2048: | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => adamc@96: let adamc@96: val s = adamc@96: if size s1 > 0 andalso size s2 > 0 adamc@96: andalso Char.isSpace (String.sub (s1, size s1 - 1)) adamc@96: andalso Char.isSpace (String.sub (s2, 0)) then adamc@96: s1 ^ String.extract (s2, 1, NONE) adamc@96: else adamc@96: s1 ^ s2 adamc@96: in adam@2048: EPrim (Prim.String (Prim.Html, s)) adamc@96: end adam@2048: adam@2048: | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => adam@2048: EPrim (Prim.String (Prim.Normal, s1 ^ s2)) adamc@105: adam@2048: | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EStrcat ((EPrim (Prim.String (Prim.Html, s2)), _), rest), _)) => adamc@105: let adamc@105: val s = adamc@105: if size s1 > 0 andalso size s2 > 0 adamc@105: andalso Char.isSpace (String.sub (s1, size s1 - 1)) adamc@105: andalso Char.isSpace (String.sub (s2, 0)) then adamc@105: s1 ^ String.extract (s2, 1, NONE) adamc@105: else adamc@105: s1 ^ s2 adamc@105: in adam@2048: EStrcat ((EPrim (Prim.String (Prim.Html, s)), loc), rest) adamc@105: end adamc@105: adam@2048: | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EStrcat ((EPrim (Prim.String (_, s2)), _), rest), _)) => adam@2048: EStrcat ((EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), rest) adam@2048: adamc@105: | EStrcat ((EStrcat (e1, e2), loc), e3) => adamc@105: optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc) adamc@105: adamc@106: | EWrite (EStrcat (e1, e2), loc) => adamc@106: ESeq ((optExp (EWrite e1, loc), loc), adamc@106: (optExp (EWrite e2, loc), loc)) adamc@106: adam@2048: | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), adam@2048: (EWrite (EPrim (Prim.String (_, s2)), _), _)) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc) adam@2048: | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), adam@2048: (ESeq ((EWrite (EPrim (Prim.String (_, s2)), _), _), adamc@196: e), _)) => adam@2048: ESeq ((EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), loc), adamc@196: e) adamc@183: adam@1663: | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifySpecialChar ch)) adam@1358: | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) => adam@1358: EFfiApp ("Basis", "htmlifySpecialChar_w", [e]) adam@1358: adam@2082: | EWrite (EFfiApp ("Basis", "intToString", [e]), _) => adam@2082: EFfiApp ("Basis", "htmlifyInt_w", [e]) adam@2082: | EApp ((EFfi ("Basis", "intToString"), loc), e) => adam@2082: EFfiApp ("Basis", "intToString", [(e, (TFfi ("Basis", "int"), loc))]) adam@2082: adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifyInt n)) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) => adamc@286: EFfiApp ("Basis", "htmlifyInt", es) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), adam@1663: (EPrim (Prim.Int n), _)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifyInt n)) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), adam@1663: e), loc), _)]) => adam@1663: EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))]) adamc@286: | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) => adamc@286: EFfiApp ("Basis", "htmlifyInt_w", [e]) adamc@286: adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifyFloat n)) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) => adamc@286: EFfiApp ("Basis", "htmlifyFloat", es) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), adam@1663: (EPrim (Prim.Float n), _)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifyFloat n)) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), adam@1663: e), loc), _)]) => adam@1663: EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))]) adamc@286: | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) => adamc@286: EFfiApp ("Basis", "htmlifyFloat_w", [e]) adamc@286: adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", adam@1663: [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, "True")) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", adam@1663: [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, "False")) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) => adamc@286: EFfiApp ("Basis", "htmlifyBool", es) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), adam@1663: (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, "True")) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), adam@1663: (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, "False")) adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), adam@1663: e), loc), _)]) => adam@1663: EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))]) adamc@286: | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) => adamc@286: EFfiApp ("Basis", "htmlifyBool_w", [e]) adamc@286: adam@1663: | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "timeToString"), _), e), loc), _)]) => adam@1663: EFfiApp ("Basis", "htmlifyTime", [(e, (TFfi ("Basis", "time"), loc))]) adam@1663: | EFfiApp ("Basis", "htmlifyString_w", [((EApp ((EFfi ("Basis", "timeToString"), loc), e), _), _)]) => adam@1663: EFfiApp ("Basis", "htmlifyTime_w", [(e, (TFfi ("Basis", "time"), loc))]) adamc@436: | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => adamc@436: EFfiApp ("Basis", "htmlifyTime_w", [e]) adamc@436: adam@2048: | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, htmlifyString s)) adam@2048: | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) adamc@135: | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => adamc@135: EFfiApp ("Basis", "htmlifyString_w", [e]) adam@2048: | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String (_, s)), loc), _)]) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) adamc@135: adam@1446: | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) => adam@1446: EFfiApp ("Basis", "htmlifySource_w", [e]) adam@1446: adam@1663: | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, attrifyInt n)) adam@1663: | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, attrifyInt n)), loc) adamc@106: | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => adamc@106: EFfiApp ("Basis", "attrifyInt_w", [e]) adamc@107: adam@1663: | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, attrifyFloat n)) adam@1663: | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, attrifyFloat n)), loc) adamc@106: | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => adamc@106: EFfiApp ("Basis", "attrifyFloat_w", [e]) adamc@107: adam@2048: | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, attrifyString s)) adam@2048: | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, attrifyString s)), loc) adamc@106: | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => adamc@106: EFfiApp ("Basis", "attrifyString_w", [e]) adamc@106: adam@1663: | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, attrifyChar s)) adam@1663: | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, attrifyChar s)), loc) adamc@1011: | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => adamc@1011: EFfiApp ("Basis", "attrifyChar_w", [e]) adamc@1011: adam@2048: | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Html, s)) adam@2048: | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Html, s)), loc) adamc@721: | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => adamc@721: EFfiApp ("Basis", "attrifyString_w", [e]) adamc@721: adam@1663: | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, urlifyInt n)) adam@1663: | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, urlifyInt n)), loc) adamc@120: | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) => adamc@120: EFfiApp ("Basis", "urlifyInt_w", [e]) adamc@120: adam@1663: | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, urlifyFloat n)) adam@1663: | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, urlifyFloat n)), loc) adamc@120: | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) => adamc@120: EFfiApp ("Basis", "urlifyFloat_w", [e]) adamc@120: adam@2048: | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, urlifyString s)) adam@2048: | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (Prim.Normal, s)), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, urlifyString s)), loc) adamc@120: | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => adamc@120: EFfiApp ("Basis", "urlifyString_w", [e]) adamc@120: adam@1663: | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, "1")) adam@1663: | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, "0")) adam@1663: | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, "1")), loc) adam@1663: | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) => adam@2048: EWrite (EPrim (Prim.String (Prim.Normal, "0")), loc) adamc@187: | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) => adamc@187: EFfiApp ("Basis", "urlifyBool_w", [e]) adamc@187: adam@1663: | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, sqlifyInt n)) adam@1663: | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, "NULL")) adam@1663: | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, sqlifyInt n)) adamc@467: adam@1663: | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, sqlifyFloat n)) adam@1663: | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) => adamc@253: optExp (ECase (b, adamc@253: [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), adam@2048: (EPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc)), adamc@253: ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), adam@2048: (EPrim (Prim.String (Prim.Normal, #falseString (Settings.currentDbms ()))), loc))], adamc@253: {disc = (TFfi ("Basis", "bool"), loc), adamc@253: result = (TFfi ("Basis", "string"), loc)}), loc) adam@2048: | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String (_, n)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, sqlifyString n)) adam@1663: | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, sqlifyChar n)) adamc@253: adamc@184: | EWrite (ECase (discE, pes, {disc, ...}), loc) => adamc@184: optExp (ECase (discE, adamc@184: map (fn (p, e) => (p, (EWrite e, loc))) pes, adamc@184: {disc = disc, adamc@184: result = (TRecord [], loc)}), loc) adamc@184: adamc@495: | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) => adamc@453: let adamc@453: fun doBody e = adamc@453: case #1 e of adamc@453: EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body adamc@453: | _ => (EApp (e, arg), loc) adamc@453: in adamc@453: optExp (ECase (discE, adamc@453: map (fn (p, e) => (p, doBody e)) pes, adamc@453: {disc = disc, adamc@495: result = ran}), loc) adamc@453: end adamc@453: adamc@331: | EWrite (EQuery {exps, tables, state, query, adam@2048: initial = (EPrim (Prim.String (k, "")), _), adam@2048: body = (EStrcat ((EPrim (Prim.String (_, s)), _), adamc@331: (EStrcat ((ERel 0, _), adamc@331: e'), _)), _)}, loc) => adam@2048: if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then adamc@331: EQuery {exps = exps, tables = tables, query = query, adamc@331: state = (TRecord [], loc), adamc@331: initial = (ERecord [], loc), adamc@331: body = (optExp (EWrite e', loc), loc)} adamc@331: else adamc@331: e adamc@331: adamc@334: | EWrite (EQuery {exps, tables, state, query, adam@2048: initial = (EPrim (Prim.String (_, "")), _), adamc@486: body}, loc) => adamc@486: let adamc@486: fun passLets (depth, (e', _), lets) = adamc@486: case e' of adamc@486: EStrcat ((ERel x, _), e'') => adamc@486: if x = depth then adamc@486: let adamc@486: val body = (optExp (EWrite e'', loc), loc) adamc@486: val body = foldl (fn ((x, t, e'), e) => adamc@486: (ELet (x, t, e', e), loc)) adamc@486: body lets adamc@486: in adamc@486: EQuery {exps = exps, tables = tables, query = query, adamc@486: state = (TRecord [], loc), adamc@486: initial = (ERecord [], loc), adamc@486: body = body} adamc@486: end adamc@486: else adamc@486: e adamc@486: | ELet (x, t, e', e'') => adamc@486: passLets (depth + 1, e'', (x, t, e') :: lets) adamc@486: | _ => e adamc@486: in adamc@486: passLets (0, body, []) adamc@486: end adamc@486: adamc@486: (*| EWrite (EQuery {exps, tables, state, query, adamc@486: initial = (EPrim (Prim.String ""), _), adamc@334: body = (EStrcat ((ERel 0, _), e'), _)}, loc) => adamc@334: EQuery {exps = exps, tables = tables, query = query, adamc@334: state = (TRecord [], loc), adamc@334: initial = (ERecord [], loc), adamc@486: body = (optExp (EWrite e', loc), loc)}*) adamc@334: adamc@340: | EWrite (ELet (x, t, e1, e2), loc) => adamc@340: optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) adamc@340: adam@2048: | EWrite (EPrim (Prim.String (_, "")), loc) => adamc@451: ERecord [] adamc@451: adamc@572: | ESignalBind ((ESignalReturn e1, loc), e2) => adamc@572: optExp (EApp (e2, e1), loc) adamc@572: adam@2048: | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@2008: (if checkData s then adam@2008: () adam@2008: else adam@2008: ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s); adam@2008: se) adam@2008: adam@2048: | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adamc@1065: (if checkUrl s then adamc@717: () adamc@717: else adamc@769: ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); adamc@717: se) adam@2048: | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adamc@1065: (if checkUrl s then adamc@1065: ESome ((TFfi ("Basis", "string"), loc), (se, loc)) adamc@1065: else adamc@1065: ENone (TFfi ("Basis", "string"), loc)) adam@2048: | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adamc@769: (if Settings.checkMime s then adamc@741: () adamc@741: else adamc@769: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'"); adamc@741: se) adam@2048: | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1465: (if Settings.checkMime s then adam@1465: ESome ((TFfi ("Basis", "string"), loc), (se, loc)) adam@1465: else adam@1465: ENone (TFfi ("Basis", "string"), loc)) adam@2048: | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1750: (if checkAtom s then adam@1750: () adam@1750: else adam@1750: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'"); adam@1750: se) adam@2048: | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1750: (if checkCssUrl s then adam@1750: () adam@1750: else adam@1750: ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'"); adam@1750: se) adam@2048: | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1750: (if checkProperty s then adam@1750: () adam@1750: else adam@1750: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'"); adam@1750: se) adam@2048: | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1465: (if Settings.checkRequestHeader s then adam@1465: () adam@1465: else adam@1465: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'"); adam@1465: se) adam@2048: | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1465: (if Settings.checkRequestHeader s then adam@1465: ESome ((TFfi ("Basis", "string"), loc), (se, loc)) adam@1465: else adam@1465: ENone (TFfi ("Basis", "string"), loc)) adam@2048: | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1465: (if Settings.checkResponseHeader s then adam@1465: () adam@1465: else adam@1465: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'"); adam@1465: se) adam@2048: | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1465: (if Settings.checkResponseHeader s then adam@1465: ESome ((TFfi ("Basis", "string"), loc), (se, loc)) adam@1465: else adam@1465: ENone (TFfi ("Basis", "string"), loc)) adam@2048: | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1799: (if Settings.checkEnvVar s then adam@1799: () adam@1799: else adam@1799: ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'"); adam@1799: se) adam@2048: | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => adam@1799: (if Settings.checkEnvVar s then adam@1799: ESome ((TFfi ("Basis", "string"), loc), (se, loc)) adam@1799: else adam@1799: ENone (TFfi ("Basis", "string"), loc)) adamc@717: adam@2048: | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => adamc@714: let adamc@714: fun uwify (cs, acc) = adamc@714: case cs of adamc@714: [] => String.concat (rev acc) adamc@714: | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc) adamc@714: | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc) adamc@714: | #"'" :: cs => adamc@714: let adamc@714: fun waitItOut (cs, acc) = adamc@714: case cs of adamc@714: [] => raise Fail "MonoOpt: Unterminated SQL string literal" adamc@714: | #"'" :: cs => uwify (cs, "'" :: acc) adamc@714: | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) adamc@714: | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) adamc@714: | c :: cs => waitItOut (cs, str c :: acc) adamc@714: in adamc@714: waitItOut (cs, "'" :: acc) adamc@714: end adamc@714: | c :: cs => uwify (cs, str c :: acc) adamc@714: adamc@714: val s = case String.explode s of adamc@714: #"_" :: cs => uwify (cs, ["uw_"]) adamc@714: | cs => uwify (cs, []) adamc@714: in adam@2048: EPrim (Prim.String (Prim.Normal, s)) adamc@714: end adamc@714: adam@2048: | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => adamc@754: let adamc@754: fun uwify (cs, acc) = adamc@754: case cs of adamc@754: [] => String.concat (rev acc) adamc@754: | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc) adamc@754: | #"'" :: cs => adamc@754: let adamc@754: fun waitItOut (cs, acc) = adamc@754: case cs of adamc@754: [] => raise Fail "MonoOpt: Unterminated SQL string literal" adamc@754: | #"'" :: cs => uwify (cs, "'" :: acc) adamc@754: | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) adamc@754: | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) adamc@754: | c :: cs => waitItOut (cs, str c :: acc) adamc@754: in adamc@754: waitItOut (cs, "'" :: acc) adamc@754: end adamc@754: | c :: cs => uwify (cs, str c :: acc) adamc@754: adamc@754: val s = uwify (String.explode s, []) adamc@754: in adam@2048: EPrim (Prim.String (Prim.Normal, s)) adamc@754: end adamc@754: adam@2048: | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, unAs s)) adam@1663: | EFfiApp ("Basis", "unAs", [(e', _)]) => adamc@874: let adamc@874: fun parts (e as (_, loc)) = adamc@874: case #1 e of adamc@874: EStrcat (s1, s2) => adamc@874: (case (parts s1, parts s2) of adamc@874: (SOME p1, SOME p2) => SOME (p1 @ p2) adamc@874: | _ => NONE) adam@2048: | EPrim (Prim.String (_, s)) => SOME [(EPrim (Prim.String (Prim.Normal, unAs s)), loc)] adamc@874: | EFfiApp ("Basis", f, [_]) => adamc@874: if String.isPrefix "sqlify" f then adamc@874: SOME [e] adamc@874: else adamc@874: NONE adamc@874: | _ => NONE adamc@874: in adamc@874: case parts e' of adamc@874: SOME [e] => #1 e adamc@874: | SOME es => adamc@874: (case rev es of adamc@874: (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es) adamc@874: | [] => raise Fail "MonoOpt impossible nil") adamc@874: | NONE => e adamc@874: end adamc@1024: adam@1663: | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) => adam@2048: EPrim (Prim.String (Prim.Normal, str ch)) adam@1663: | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => adamc@1024: EFfiApp ("Basis", "attrifyChar", [e]) adam@1663: | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => adamc@1024: EFfiApp ("Basis", "attrifyChar_w", [e]) adam@2085: | EWrite (EFfiApp ("Basis", "str1", [e]), _) => adam@2085: EFfiApp ("Basis", "writec", [e]) adam@1287: adam@1360: | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) adam@2120: | EBinop (_, "-", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.- (n1, n2))) adam@2120: | EBinop (_, "*", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.* (n1, n2))) adam@2120: adamc@96: | _ => e adamc@96: adamc@105: and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) adamc@105: adamc@96: val optimize = U.File.map {typ = typ, exp = exp, decl = decl} adamc@96: adamc@506: val optExp = U.Exp.map {typ = typ, exp = exp} adamc@506: adamc@96: end