Merge.

10 files changed, 75 insertions, 31 deletions

diff --git a/src/c/static.c b/src/c/static.c
index c8fd5bc7..7f63d393 100644
--- a/src/c/static.c
+++ b/src/c/static.c
@@ -37,7 +37,7 @@ int main(int argc, char *argv[]) {
   while (1) {
     fk = uw_begin(ctx, argv[1]);
 
-    if (fk == SUCCESS) {
+    if (fk == SUCCESS || fk == RETURN_INDIRECTLY) {
       uw_print(ctx, 1);
       puts("");
       return 0;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 3993448b..faef4d3a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4235,7 +4235,10 @@ void uw_check_deadline(uw_context ctx) {
 size_t uw_database_max = SIZE_MAX;
 
 uw_Basis_int uw_Basis_naughtyDebug(uw_context ctx, uw_Basis_string s) {
-  fprintf(stderr, "%s\n", s);
+  if (ctx->loggers->log_debug)
+    ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s);
+  else
+    fprintf(stderr, "%s\n", s);
   return 0;
 }
 
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e6ecedde..9e046d84 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3672,8 +3672,7 @@ fun p_sql env (ds, _) =
                                                             let
                                                                 val t = sql_type_in env t
                                                             in
-                                                                box [string "uw_",
-                                                                     string (CharVector.map Char.toLower x),
+                                                                box [string (Settings.mangleSql (CharVector.map Char.toLower x)),
                                                                      space,
                                                                      string (#p_sql_type (Settings.currentDbms ()) t),
                                                                      case t of
diff --git a/src/compiler.sml b/src/compiler.sml
index a45b8c69..814c48d3 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -875,7 +875,8 @@ fun parseUrp' accLibs fname =
                                      (case String.fields Char.isSpace arg of
                                           [uri, fname] => (Settings.setFilePath thisPath;
                                                            Settings.addFile {Uri = uri,
-                                                                             LoadFromFilename = fname})
+                                                                             LoadFromFilename = fname};
+                                                           url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url)
                                         | _ => ErrorMsg.error "Bad 'file' arguments")
 
                                    | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
diff --git a/src/core_util.sml b/src/core_util.sml
index 152ba7ac..9ca85c37 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -203,7 +203,7 @@ fun compare ((c1, _), (c2, _)) =
       | (_, CConcat _) => GREATER
 
       | (CMap (d1, r1), CMap (d2, r2)) =>
-        join (Kind.compare (d1, r2),
+        join (Kind.compare (d1, d2),
               fn () => Kind.compare (r1, r2))
       | (CMap _, _) => LESS
       | (_, CMap _) => GREATER
@@ -607,15 +607,19 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
               | ERel _ => S.return2 eAll
               | ENamed _ => S.return2 eAll
               | ECon (dk, pc, cs, NONE) =>
-                S.map2 (ListUtil.mapfold (mfc ctx) cs,
-                        fn cs' =>
-                           (ECon (dk, pc, cs', NONE), loc))
-              | ECon (dk, n, cs, SOME e) =>
-                S.bind2 (mfe ctx e,
-                      fn e' =>
+                S.bind2 (mfpc ctx pc,
+                      fn pc' =>
                          S.map2 (ListUtil.mapfold (mfc ctx) cs,
-                                 fn cs' =>
-                                    (ECon (dk, n, cs', SOME e'), loc)))
+                              fn cs' =>
+                                 (ECon (dk, pc', cs', NONE), loc)))
+              | ECon (dk, pc, cs, SOME e) =>
+                S.bind2 (mfpc ctx pc,
+                      fn pc' =>
+                         S.bind2 (mfe ctx e,
+                               fn e' =>
+                                  S.map2 (ListUtil.mapfold (mfc ctx) cs,
+                                       fn cs' =>
+                                          (ECon (dk, pc', cs', SOME e'), loc))))
               | EFfi _ => S.return2 eAll
               | EFfiApp (m, x, es) =>
                 S.map2 (ListUtil.mapfold (mfet ctx) es,
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index 8054d829..1b21cba0 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
                  "con" "map" "where" "extern" "constraint" "constraints"
-                 "table" "sequence" "class" "cookie" "task" "policy")
+                 "table" "sequence" "class" "cookie" "style" "task" "policy")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -135,7 +135,7 @@ notion of \"the end of an outline\".")
      (("case" "datatype" "if" "then" "else"
        "let" "open" "sig" "struct" "type" "val"
        "con" "constraint" "table" "sequence" "class" "cookie"
-       "task" "policy")))))
+       "style" "task" "policy")))))
 
 (defconst urweb-starters-indent-after
   (urweb-syms-re "let" "in" "struct" "sig")
@@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol."
 	  '("datatype" "fun"
 	    "open" "type" "val" "and"
 	    "con" "constraint" "table" "sequence" "class" "cookie"
-            "task" "policy"))
+            "style" "task" "policy"))
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index fb9d18b5..5eb36bc4 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -179,11 +179,11 @@ See doc for the variable `urweb-mode-info'."
         (let ((xml-tag (length (or (match-string 3) "")))
               (ch (match-string 2)))
          (cond
-          ((equal ch ?\{)
+          ((equal ch "{")
            (if (> depth 0)
                (decf depth)
              (setq finished t)))
-          ((equal ch ?\})
+          ((equal ch "}")
            (incf depth))
           ((= xml-tag 3)
            (if (> depth 0)
@@ -194,14 +194,14 @@ See doc for the variable `urweb-mode-info'."
           ((= xml-tag 4)
            (incf depth))
 
-          ((equal ch ?-)
+          ((equal ch "-")
            (if (looking-at "->")
                (setq finished (= depth 0))))
 
           ((and (= depth 0)
                 (not (looking-at "<xml")) ;; ignore <xml/>
-                (eq font-lock-tag-face
-                    (get-text-property (point) 'face)))
+                (let ((face (get-text-property (point) 'face)))
+                  (funcall (if (listp face) #'member #'equal) 'font-lock-tag-face face)))
            ;; previous code was highlighted as tag, seems we are in xml
            (progn
              (setq answer t)
@@ -401,6 +401,7 @@ This mode runs `urweb-mode-hook' just before exiting.
   (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
 
   (local-set-key (kbd "C-c C-c") 'compile)
+  (local-set-key (kbd "C-c /") 'urweb-close-matching-tag)
 
   (urweb-mode-variables))
 
@@ -542,6 +543,16 @@ If anyone has a good algorithm for this..."
     (beginning-of-line)
     (current-indentation)))
 
+(defun urweb-close-matching-tag ()
+  "Insert a closing XML tag for whatever tag is open at the point."
+  (interactive)
+  (assert (urweb-in-xml))
+  (save-excursion
+   (urweb-tag-matcher)
+   (re-search-forward "<\\([^ ={/>]+\\)" nil t))
+  (let ((tag (match-string-no-properties 1)))
+    (insert "</" tag ">")))
+
 (defconst urweb-sql-main-starters
   '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE"))
 
diff --git a/src/monoize.sml b/src/monoize.sml
index 8c1a4e3c..d8c4d276 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2225,6 +2225,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             let
                 val t = monoType env t
                 val s = (L'.TFfi ("Basis", "string"), loc)
+
+                fun toSqlType (t : L'.typ) =
+                    case #1 t of
+                        L'.TFfi ("Basis", "int") => Settings.Int
+                      | L'.TFfi ("Basis", "float") => Settings.Float
+                      | L'.TFfi ("Basis", "string") => Settings.String
+                      | L'.TFfi ("Basis", "char") => Settings.Char
+                      | L'.TFfi ("Basis", "bool") => Settings.Bool
+                      | L'.TFfi ("Basis", "time") => Settings.Time
+                      | L'.TFfi ("Basis", "blob") => Settings.Blob
+                      | L'.TFfi ("Basis", "channel") => Settings.Channel
+                      | L'.TFfi ("Basis", "client") => Settings.Client
+                      | _ => raise Fail "Monoize/sql_option_prim: invalid SQL type"
             in
                 ((L'.EAbs ("f",
                            (L'.TFun (t, s), loc),
@@ -2234,7 +2247,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                      s,
                                      (L'.ECase ((L'.ERel 0, loc),
                                                 [((L'.PNone t, loc),
-                                                  str "NULL"),
+                                                  str (#p_cast (Settings.currentDbms ()) ("NULL", toSqlType t))),
                                                  ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
                                                   (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
                                                 {disc = (L'.TOption t, loc),
@@ -3413,7 +3426,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                                        strH s',
                                                                        (L'.EStrcat (
                                                                         (L'.EJavaScript (L'.Attribute, e), loc),
-                                                                        strH ");return false'"), loc)),
+                                                                        strH ")'"), loc)),
                                                                        loc)), loc),
                                                          fm)
                                                     end
diff --git a/src/urweb.grm b/src/urweb.grm
index 7fc34793..50dacf21 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1624,6 +1624,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                          val e = (EVar (["Basis"], "form", Infer), pos)
                                                          val e = (EApp (e, case #2 tag of
                                                                                NONE => (EVar (["Basis"], "None", Infer), pos)
+                                                                             | SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos)
                                                                              | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
                                                      in
                                                          case #3 tag of
diff --git a/src/urweb.lex b/src/urweb.lex
index 8b109727..ca45eb6d 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -178,11 +178,11 @@ fun unescape loc s =
 
 id = [a-z_][A-Za-z0-9_']*;
 xmlid = [A-Za-z][A-Za-z0-9_-]*;
-cid = [A-Z][A-Za-z0-9_]*;
+cid = [A-Z][A-Za-z0-9_']*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-hexconst = 0x[0-9A-F]{1,8};
+hexconst = 0x[0-9A-F]+;
 notags = ([^<{\n(]|(\([^\*<{\n]))+;
 xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
@@ -537,22 +537,34 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
+<INITIAL> "_LOC_" => (let val strLoc = ErrorMsg.spanToString (ErrorMsg.spanOf
+                                            (pos yypos, pos yypos + size yytext))
+                      in
+                          Tokens.STRING (strLoc, pos yypos, pos yypos + size yytext)
+                      end);
 
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
-<INITIAL> {hexconst}  => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of
+<INITIAL> {hexconst}  => (let val digits = String.extract (yytext, 2, NONE)
+                              val v = (StringCvt.scanString (Int64.scan StringCvt.HEX) digits)
+                                      handle Overflow => NONE
+                          in
+                          case v of
                               SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
                             | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                                            ("Expected hexInt, received: " ^ yytext);
-                                         continue ()));
+                                         continue ())
+                         end);
 
-<INITIAL> {intconst}  => (case Int64.fromString yytext of
+<INITIAL> {intconst}  => (let val v = (Int64.fromString yytext) handle Overflow => NONE
+                          in 
+                          case v of
                               SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
                             | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                                            ("Expected int, received: " ^ yytext);
-                                         continue ()));
+                                         continue ())
+                         end);
 <INITIAL> {realconst} => (case Real64.fromString yytext of
                             SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext)
                           | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)