summaryrefslogtreecommitdiff
path: root/src/mono_opt.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/mono_opt.sml')
-rw-r--r--src/mono_opt.sml36
1 files changed, 35 insertions, 1 deletions
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 7f23d8b1..dfa0420c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -87,7 +87,13 @@ fun sqlifyInt n = attrifyInt n ^ "::int8"
fun sqlifyFloat n = attrifyFloat n ^ "::float8"
fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
- | ch => str ch)
+ | #"\\" => "\\\\"
+ | ch =>
+ if Char.isPrint ch then
+ str ch
+ else
+ "\\" ^ StringCvt.padLeft #"0" 3
+ (Int.fmt StringCvt.OCT (ord ch)))
(String.toString s) ^ "'::text"
fun exp e =
@@ -365,6 +371,34 @@ fun exp e =
| EJavaScript (_, _, SOME (e, _)) => e
+ | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
+ let
+ fun uwify (cs, acc) =
+ case cs of
+ [] => String.concat (rev acc)
+ | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
+ | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
+ | #"'" :: cs =>
+ let
+ fun waitItOut (cs, acc) =
+ case cs of
+ [] => raise Fail "MonoOpt: Unterminated SQL string literal"
+ | #"'" :: cs => uwify (cs, "'" :: acc)
+ | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
+ | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
+ | c :: cs => waitItOut (cs, str c :: acc)
+ in
+ waitItOut (cs, "'" :: acc)
+ end
+ | c :: cs => uwify (cs, str c :: acc)
+
+ val s = case String.explode s of
+ #"_" :: cs => uwify (cs, ["uw_"])
+ | cs => uwify (cs, [])
+ in
+ EPrim (Prim.String s)
+ end
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)