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
ziv@2221:  * 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:         #"\"" => "&quot;"
adamc@1011:       | #"&" => "&amp;"
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 #"<" => "&lt;"
adamc@1059:                                        | #"&" => "&amp;"
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
ziv@2224: 
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
ziv@2221: 
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, _),
ziv@2255:                                                    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),
ziv@2255:                     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 (_, "")), _),
ziv@2255:                         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),
ziv@2255:                                     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: 
ziv@2221:       | 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: 
ziv@2221:       | 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: 
ziv@2221:       | 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