CHECK constraints

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,