# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1239305415 14400
# Node ID 0f42461273cfd7ac4195986697ffc6d6af8a7948
# Parent  baaae037e7f60c8ea18b957d3915c3dbdf63fe37
CHECK constraints

diff -r baaae037e7f6 -r 0f42461273cf lib/ur/basis.urs
--- 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})}
diff -r baaae037e7f6 -r 0f42461273cf src/elisp/urweb-mode.el
--- 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.")
 
diff -r baaae037e7f6 -r 0f42461273cf src/mono_opt.sml
--- 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)
diff -r baaae037e7f6 -r 0f42461273cf src/monoize.sml
--- 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
diff -r baaae037e7f6 -r 0f42461273cf src/urweb.grm
--- 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)
diff -r baaae037e7f6 -r 0f42461273cf src/urweb.lex
--- 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));
diff -r baaae037e7f6 -r 0f42461273cf tests/cst.ur
--- 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,