Mercurial > urweb
diff src/mono_opt.sml @ 714:0f42461273cf
CHECK constraints
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 09 Apr 2009 15:30:15 -0400 |
parents | bab524996fca |
children | e28637743279 |
line wrap: on
line diff
--- a/src/mono_opt.sml Thu Apr 09 14:59:29 2009 -0400 +++ b/src/mono_opt.sml Thu Apr 09 15:30:15 2009 -0400 @@ -87,7 +87,13 @@ 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 @@ | 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)