adamc@96: (* Copyright (c) 2008, 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@107: val attrifyString = String.translate (fn #"\"" => "&quot;"
adamc@135:                                        | #"&" => "&amp;"
adamc@107:                                        | ch => if Char.isPrint ch then
adamc@107:                                                    str ch
adamc@107:                                                else
adamc@107:                                                    "&#" ^ Int.toString (ord ch) ^ ";")
adamc@107: 
adamc@120: val urlifyInt = attrifyInt
adamc@120: val urlifyFloat = attrifyFloat
adamc@120: 
adamc@286: val htmlifyInt = attrifyInt
adamc@286: val htmlifyFloat = attrifyFloat
adamc@135: val htmlifyString = String.translate (fn ch => case ch of
adamc@135:                                                    #"<" => "&lt;"
adamc@135:                                                  | #"&" => "&amp;"
adamc@135:                                                  | _ =>   
adamc@135:                                                    if Char.isPrint ch orelse Char.isSpace ch then
adamc@135:                                                        str ch
adamc@135:                                                    else
adamc@135:                                                        "&#" ^ Int.toString (ord ch) ^ ";")
adamc@135: 
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@120: val urlifyString = String.translate (fn #" " => "+"
adamc@120:                                       | ch => if Char.isAlphaNum ch then
adamc@120:                                                   str ch
adamc@120:                                               else
adamc@120:                                                   "%" ^ hexIt ch)
adamc@253: 
adamc@253: 
adamc@281: fun sqlifyInt n = attrifyInt n ^ "::int8"
adamc@281: fun sqlifyFloat n = attrifyFloat n ^ "::float8"
adamc@253: 
adamc@259: fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
adamc@259:                                                | ch => str ch)
adamc@281:                                              (String.toString s) ^ "'::text"
adamc@183:         
adamc@96: fun exp e =
adamc@96:     case e of
adamc@96:         EPrim (Prim.String s) =>
adamc@96:         let
adamc@96:             val (_, chs) =
adamc@96:                 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96:                                      let
adamc@96:                                          val isSpace = Char.isSpace ch
adamc@96:                                      in
adamc@96:                                          if isSpace andalso lastSpace then
adamc@96:                                              (true, chs)
adamc@96:                                          else
adamc@96:                                              (isSpace, ch :: chs)
adamc@96:                                      end)
adamc@96:                                  (false, []) s
adamc@96:         in
adamc@96:             EPrim (Prim.String (String.implode (rev chs)))
adamc@96:         end
adamc@96:                                        
adamc@96:       | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String 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
adamc@96:             EPrim (Prim.String s)
adamc@96:         end
adamc@105: 
adamc@105:       | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String 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
adamc@105:             EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105:         end
adamc@105: 
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: 
adamc@183:       | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183:               (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183:         EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196:       | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196:               (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196:                      e), _)) =>
adamc@196:         ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196:               e)
adamc@183: 
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
adamc@286:         EPrim (Prim.String (htmlifyInt n))
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
adamc@286:         EFfiApp ("Basis", "htmlifyInt", es)
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320:                                                    (EPrim (Prim.Int n), _)), _)]) =>
adamc@320:         EPrim (Prim.String (htmlifyInt n))
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320:                                                    e), _)]) =>
adamc@320:         EFfiApp ("Basis", "htmlifyInt", [e])
adamc@286:       | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286:         EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286: 
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
adamc@286:         EPrim (Prim.String (htmlifyFloat n))
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
adamc@286:         EFfiApp ("Basis", "htmlifyFloat", es)
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320:                                                    (EPrim (Prim.Float n), _)), _)]) =>
adamc@320:         EPrim (Prim.String (htmlifyFloat n))
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320:                                                    e), _)]) =>
adamc@320:         EFfiApp ("Basis", "htmlifyFloat", [e])
adamc@286:       | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286:         EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286: 
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286:                                                       [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
adamc@286:         EPrim (Prim.String "True")
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286:                                                       [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
adamc@286:         EPrim (Prim.String "False")
adamc@286:       | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
adamc@286:         EFfiApp ("Basis", "htmlifyBool", es)
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320:                                                    (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
adamc@320:         EPrim (Prim.String "True")
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320:                                                    (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
adamc@320:         EPrim (Prim.String "False")
adamc@320:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320:                                                    e), _)]) =>
adamc@320:         EFfiApp ("Basis", "htmlifyBool", [e])
adamc@286:       | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286:         EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286: 
adamc@436:       | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436:         EFfiApp ("Basis", "htmlifyTime", [e])
adamc@436:       | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436:         EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436:       | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436:         EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436: 
adamc@135:       | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@135:         EPrim (Prim.String (htmlifyString s))
adamc@135:       | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@135:         EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135:       | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135:         EFfiApp ("Basis", "htmlifyString_w", [e])
adamc@196:       | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
adamc@196:         EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135: 
adamc@107:       | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107:         EPrim (Prim.String (attrifyInt n))
adamc@107:       | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107:         EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106:       | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106:         EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107: 
adamc@107:       | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107:         EPrim (Prim.String (attrifyFloat n))
adamc@107:       | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107:         EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106:       | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106:         EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107: 
adamc@107:       | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107:         EPrim (Prim.String (attrifyString s))
adamc@107:       | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107:         EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106:       | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106:         EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106: 
adamc@120:       | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120:         EPrim (Prim.String (urlifyInt n))
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120:         EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120:         EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120: 
adamc@120:       | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120:         EPrim (Prim.String (urlifyFloat n))
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120:         EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120:         EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120: 
adamc@120:       | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120:         EPrim (Prim.String (urlifyString s))
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120:         EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120:       | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120:         EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120: 
adamc@188:       | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
adamc@187:         EPrim (Prim.String "1")
adamc@188:       | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
adamc@187:         EPrim (Prim.String "0")
adamc@188:       | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
adamc@187:         EWrite (EPrim (Prim.String "1"), loc)
adamc@188:       | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
adamc@187:         EWrite (EPrim (Prim.String "0"), loc)
adamc@187:       | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187:         EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187: 
adamc@253:       | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@253:         EPrim (Prim.String (sqlifyInt n))
adamc@253:       | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@253:         EPrim (Prim.String (sqlifyFloat n))
adamc@253:       | 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),
adamc@253:                          (EPrim (Prim.String "TRUE"), loc)),
adamc@253:                         ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@253:                          (EPrim (Prim.String "FALSE"), loc))],
adamc@253:                        {disc = (TFfi ("Basis", "bool"), loc),
adamc@253:                         result = (TFfi ("Basis", "string"), loc)}), loc)
adamc@253:       | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
adamc@253:         EPrim (Prim.String (sqlifyString 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@331:       | EWrite (EQuery {exps, tables, state, query,
adamc@331:                         initial = (EPrim (Prim.String ""), _),
adamc@331:                         body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331:                                          (EStrcat ((ERel 0, _),
adamc@331:                                                    e'), _)), _)}, loc) =>
adamc@331:         if 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,
adamc@334:                         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@334:                 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: 
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@96: end