CHECK constraints

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));