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 #"\"" => """ adamc@135: | #"&" => "&" 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: #"<" => "<" adamc@135: | #"&" => "&" 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@453: 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@467: | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => adamc@467: EPrim (Prim.String "NULL") adamc@467: | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => adamc@467: EPrim (Prim.String (sqlifyInt n)) adamc@467: 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@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, 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@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: adamc@451: | 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: 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