# HG changeset patch # User Adam Chlipala # Date 1260721727 18000 # Node ID 26197c957ad6a2daf2f4552b6b02958ae38a5844 # Parent e933297c4e241b44aab496eb2dc79d50e2fd1d5d Better record summary error messages; more tweaking SQL usability diff -r e933297c4e24 -r 26197c957ad6 lib/ur/basis.urs --- a/lib/ur/basis.urs Sun Dec 13 10:13:06 2009 -0500 +++ b/lib/ur/basis.urs Sun Dec 13 11:28:47 2009 -0500 @@ -344,6 +344,9 @@ -> sql_query1 tables1 selectedFields selectedExps -> sql_query1 tables2 selectedFields selectedExps -> sql_query1 selectedFields selectedFields selectedExps +val sql_forget_tables : tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} + -> sql_query1 tables selectedFields selectedExps + -> sql_query1 selectedFields selectedFields selectedExps type sql_direction val sql_asc : sql_direction diff -r e933297c4e24 -r 26197c957ad6 src/elab_err.sig --- a/src/elab_err.sig Sun Dec 13 10:13:06 2009 -0500 +++ b/src/elab_err.sig Sun Dec 13 11:28:47 2009 -0500 @@ -55,7 +55,7 @@ | CIncompatible of Elab.con * Elab.con | CExplicitness of Elab.con * Elab.con | CKindof of Elab.kind * Elab.con * string - | CRecordFailure of Elab.con * Elab.con + | CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con) option val cunifyError : ElabEnv.env -> cunify_error -> unit diff -r e933297c4e24 -r 26197c957ad6 src/elab_err.sml --- a/src/elab_err.sml Sun Dec 13 10:13:06 2009 -0500 +++ b/src/elab_err.sml Sun Dec 13 11:28:47 2009 -0500 @@ -119,7 +119,7 @@ | CIncompatible of con * con | CExplicitness of con * con | CKindof of kind * con * string - | CRecordFailure of con * con + | CRecordFailure of con * con * (con * con * con) option fun cunifyError env err = case err of @@ -144,10 +144,16 @@ eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")") [("Kind", p_kind env k), ("Con", p_con env c)] - | CRecordFailure (c1, c2) => + | CRecordFailure (c1, c2, fo) => eprefaces "Can't unify record constructors" - [("Summary 1", p_con env c1), - ("Summary 2", p_con env c2)] + (("Summary 1", p_con env c1) + :: ("Summary 2", p_con env c2) + :: (case fo of + NONE => [] + | SOME (nm, t1, t2) => + [("Field", p_con env nm), + ("Value 1", p_con env t1), + ("Value 2", p_con env t2)])) datatype exp_error = UnboundExp of ErrorMsg.span * string diff -r e933297c4e24 -r 26197c957ad6 src/elaborate.sml --- a/src/elaborate.sml Sun Dec 13 10:13:06 2009 -0500 +++ b/src/elaborate.sml Sun Dec 13 11:28:47 2009 -0500 @@ -817,7 +817,24 @@ ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) val empty = (L'.CRecord (k, []), loc) - fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2)) + fun failure () = + let + val fs2 = #fields s2 + + fun findPointwise fs1 = + case fs1 of + [] => NONE + | (nm1, c1) :: fs1 => + case List.find (fn (nm2, _) => consEq env loc (nm1, nm2)) fs2 of + NONE => findPointwise fs1 + | SOME (_, c2) => + if consEq env loc (c1, c2) then + findPointwise fs1 + else + SOME (nm1, c1, c2) + in + raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2, findPointwise (#fields s1))) + end in (case (unifs1, fs1, others1, unifs2, fs2, others2) of (_, [], [], [], [], []) => diff -r e933297c4e24 -r 26197c957ad6 src/elisp/urweb-mode.el --- a/src/elisp/urweb-mode.el Sun Dec 13 10:13:06 2009 -0500 +++ b/src/elisp/urweb-mode.el Sun Dec 13 11:28:47 2009 -0500 @@ -150,7 +150,7 @@ "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE" "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK" "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL" - "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS") + "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1") "A regexp that matches SQL keywords.") (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>" @@ -530,7 +530,7 @@ (current-indentation))) (defconst urweb-sql-main-starters - '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE")) + '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE")) (defconst urweb-sql-starters (append urweb-sql-main-starters diff -r e933297c4e24 -r 26197c957ad6 src/monoize.sml --- a/src/monoize.sml Sun Dec 13 10:13:06 2009 -0500 +++ b/src/monoize.sml Sun Dec 13 11:28:47 2009 -0500 @@ -2292,6 +2292,20 @@ sc "))"]), loc)), loc)), loc), fm) end + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_forget_tables"), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun sc s = (L'.EPrim (Prim.String s), loc) + in + ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), + fm) + end | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm) | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm) diff -r e933297c4e24 -r 26197c957ad6 src/urweb.grm --- a/src/urweb.grm Sun Dec 13 10:13:06 2009 -0500 +++ b/src/urweb.grm Sun Dec 13 11:28:47 2009 -0500 @@ -199,7 +199,7 @@ | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET | LET | IN - | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL + | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1 | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW | COOKIE | STYLE | CASE | IF | THEN | ELSE | ANDALSO | ORELSE @@ -1170,6 +1170,7 @@ | LPAREN CWHERE sqlexp RPAREN (sqlexp) | LPAREN SQL sqlexp RPAREN (sqlexp) | LPAREN FROM tables RPAREN (#2 tables) + | LPAREN SELECT1 query1 RPAREN (query1) | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN (let @@ -1540,6 +1541,7 @@ end) fitem : table' ([#1 table'], #2 table') + | LBRACE LBRACE eexp RBRACE RBRACE ([], eexp) | fitem JOIN fitem ON sqlexp (let val loc = s (fitem1left, sqlexpright) diff -r e933297c4e24 -r 26197c957ad6 src/urweb.lex --- a/src/urweb.lex Sun Dec 13 10:13:06 2009 -0500 +++ b/src/urweb.lex Sun Dec 13 11:28:47 2009 -0500 @@ -420,6 +420,7 @@ "LIMIT" => (Tokens.LIMIT (pos yypos, pos yypos + size yytext)); "OFFSET" => (Tokens.OFFSET (pos yypos, pos yypos + size yytext)); "ALL" => (Tokens.ALL (pos yypos, pos yypos + size yytext)); + "SELECT1" => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext)); "JOIN" => (Tokens.JOIN (pos yypos, pos yypos + size yytext)); "INNER" => (Tokens.INNER (pos yypos, pos yypos + size yytext));