summaryrefslogtreecommitdiff
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
commitf4227a1adad5be299eb80dc4e5baab4ea46169b1 (patch)
treecbcd34725bd070adeedbc699a79682ccb0dc3867
parentda10cbf6f232203ba7c798906ba8101078e2a9c9 (diff)
CHECK constraints
-rw-r--r--lib/ur/basis.urs8
-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
-rw-r--r--tests/cst.ur8
7 files changed, 69 insertions, 6 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 454b10b2..f652165d 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -198,12 +198,18 @@ val foreign_key : mine1 ::: Name -> t ::: Type -> mine ::: {Type} -> munused :::
OnUpdate : propagation_mode ([mine1 = t] ++ mine)}
-> sql_constraint ([mine1 = t] ++ mine ++ munused) []
+con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+
+val check : fs ::: {Type}
+ -> sql_exp [] [] fs bool
+ -> sql_constraint fs []
+
+
(*** Queries *)
con sql_query :: {{Type}} -> {Type} -> Type
con sql_query1 :: {{Type}} -> {{Type}} -> {Type} -> Type
-con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
con sql_subset :: {{Type}} -> {{Type}} -> Type
val sql_subset : keep_drop :: {({Type} * {Type})}
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));
diff --git a/tests/cst.ur b/tests/cst.ur
index 2db083f7..a0ccf539 100644
--- a/tests/cst.ur
+++ b/tests/cst.ur
@@ -1,7 +1,11 @@
-table u : {C : int, D : int, E : option int}
+table u : {C : int, D : int, E : option int, F : string}
PRIMARY KEY C,
CONSTRAINT U UNIQUE (C, D),
- CONSTRAINT U2 UNIQUE E
+ CONSTRAINT U2 UNIQUE E,
+
+ CONSTRAINT Pos CHECK D > 0,
+ CONSTRAINT NoNo CHECK C + D <> 2,
+ CONSTRAINT Known CHECK F = "_E = 6"
table t : {A : int, B : int, C : option int}
PRIMARY KEY B,