Mercurial > urweb
changeset 714:0f42461273cf
CHECK constraints
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 09 Apr 2009 15:30:15 -0400 |
| parents | baaae037e7f6 |
| children | 1db127b245ed |
| files | lib/ur/basis.urs src/elisp/urweb-mode.el src/mono_opt.sml src/monoize.sml src/urweb.grm src/urweb.lex tests/cst.ur |
| diffstat | 7 files changed, 69 insertions(+), 6 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Thu Apr 09 14:59:29 2009 -0400 +++ b/lib/ur/basis.urs Thu Apr 09 15:30:15 2009 -0400 @@ -198,12 +198,18 @@ 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})}
--- a/src/elisp/urweb-mode.el Thu Apr 09 14:59:29 2009 -0400 +++ b/src/elisp/urweb-mode.el Thu Apr 09 15:30:15 2009 -0400 @@ -148,7 +148,7 @@ "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.")
--- 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)
--- a/src/monoize.sml Thu Apr 09 14:59:29 2009 -0400 +++ b/src/monoize.sml Thu Apr 09 15:30:15 2009 -0400 @@ -1342,6 +1342,17 @@ 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
--- a/src/urweb.grm Thu Apr 09 14:59:29 2009 -0400 +++ b/src/urweb.grm Thu Apr 09 15:30:15 2009 -0400 @@ -210,7 +210,7 @@ | 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 @@ (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)
--- a/src/urweb.lex Thu Apr 09 14:59:29 2009 -0400 +++ b/src/urweb.lex Thu Apr 09 15:30:15 2009 -0400 @@ -367,6 +367,7 @@ <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));
--- a/tests/cst.ur Thu Apr 09 14:59:29 2009 -0400 +++ b/tests/cst.ur Thu Apr 09 15:30:15 2009 -0400 @@ -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,