diff options
| -rw-r--r-- | lib/ur/basis.urs | 8 | ||||
| -rw-r--r-- | src/elisp/urweb-mode.el | 2 | ||||
| -rw-r--r-- | src/mono_opt.sml | 36 | ||||
| -rw-r--r-- | src/monoize.sml | 11 | ||||
| -rw-r--r-- | src/urweb.grm | 9 | ||||
| -rw-r--r-- | src/urweb.lex | 1 | ||||
| -rw-r--r-- | tests/cst.ur | 8 |
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, |