diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-04-09 15:30:15 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-04-09 15:30:15 -0400 |
commit | 8f29d5ead0c09b99291f729001e6aabd24d8aa8c (patch) | |
tree | cbcd34725bd070adeedbc699a79682ccb0dc3867 /src | |
parent | 1852c67500474c5170a0b666ca68591dbbc29df3 (diff) |
CHECK constraints
Diffstat (limited to 'src')
-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 |
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)); |