Mercurial > urweb

changeset 1071:26197c957ad6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Better record summary error messages; more tweaking SQL usability
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Dec 2009 11:28:47 -0500
parents e933297c4e24
children 9001966ae1c8
files lib/ur/basis.urs src/elab_err.sig src/elab_err.sml src/elaborate.sml src/elisp/urweb-mode.el src/monoize.sml src/urweb.grm src/urweb.lex
diffstat 8 files changed, 52 insertions(+), 9 deletions(-) [+]
line wrap: on
line diff
--- 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
--- 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
 
--- 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
--- 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
               (_, [], [], [], [], []) =>
--- 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
--- 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)
--- 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)
                                                        
--- 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 @@
 <INITIAL> "LIMIT"     => (Tokens.LIMIT (pos yypos, pos yypos + size yytext));
 <INITIAL> "OFFSET"    => (Tokens.OFFSET (pos yypos, pos yypos + size yytext));
 <INITIAL> "ALL"       => (Tokens.ALL (pos yypos, pos yypos + size yytext));
+<INITIAL> "SELECT1"   => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));