summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-09 15:30:15 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-09 15:30:15 -0400
commit8f29d5ead0c09b99291f729001e6aabd24d8aa8c (patch)
treecbcd34725bd070adeedbc699a79682ccb0dc3867 /src
parent1852c67500474c5170a0b666ca68591dbbc29df3 (diff)
CHECK constraints
Diffstat (limited to 'src')
-rw-r--r--src/elisp/urweb-mode.el2
-rw-r--r--src/mono_opt.sml36
-rw-r--r--src/monoize.sml11
-rw-r--r--src/urweb.grm9
-rw-r--r--src/urweb.lex1
5 files changed, 56 insertions, 3 deletions
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 545902ac..1f2a52be 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -148,7 +148,7 @@ See doc for the variable `urweb-mode-info'."
"HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
"TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
"ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
- "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE"
+ "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
"FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL")
"A regexp that matches SQL keywords.")
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)
diff --git a/src/monoize.sml b/src/monoize.sml
index bc44c550..950de1e1 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1342,6 +1342,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
+ let
+ val string = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("e", string, string,
+ (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
+ (L'.EFfiApp ("Basis", "checkString",
+ [(L'.ERel 0, loc)]), loc)), loc)), loc),
+ fm)
+ end
+
| L.EFfiApp ("Basis", "dml", [e]) =>
let
val (e, fm) = monoExp (env, st, fm) e
diff --git a/src/urweb.grm b/src/urweb.grm
index 50fb6cb3..7e1f6757 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -210,7 +210,7 @@ datatype prop_kind = Delete | Update
| INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
| CURRENT_TIMESTAMP
| NE | LT | LE | GT | GE
- | CCONSTRAINT | UNIQUE | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
+ | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
%nonterm
file of decl list
@@ -511,6 +511,13 @@ cst : UNIQUE tnames (let
(EDisjointApp e, loc)
end)
+ | CHECK sqlexp (let
+ val loc = s (CHECKleft, sqlexpright)
+ in
+ (EApp ((EVar (["Basis"], "check", Infer), loc),
+ sqlexp), loc)
+ end)
+
| FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
(let
val loc = s (FOREIGNleft, pmodesright)
diff --git a/src/urweb.lex b/src/urweb.lex
index c01f018b..4b3eb2af 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -367,6 +367,7 @@ notags = [^<{\n]+;
<INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
<INITIAL> "UNIQUE" => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
+<INITIAL> "CHECK" => (Tokens.CHECK (pos yypos, pos yypos + size yytext));
<INITIAL> "PRIMARY" => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext));
<INITIAL> "FOREIGN" => (Tokens.FOREIGN (pos yypos, pos yypos + size yytext));
<INITIAL> "KEY" => (Tokens.KEY (pos yypos, pos yypos + size yytext));