diff options
| -rw-r--r-- | .hgignore | 1 | ||||
| -rw-r--r-- | CHANGELOG | 24 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | debian/changelog | 15 | ||||
| -rwxr-xr-x | debian/rules | 3 | ||||
| -rw-r--r-- | debian/urweb.1 | 4 | ||||
| -rw-r--r-- | debian/watch | 2 | ||||
| -rw-r--r-- | doc/manual.tex | 6 | ||||
| -rw-r--r-- | lib/js/urweb.js | 88 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 10 | ||||
| -rw-r--r-- | src/c/static.c | 5 | ||||
| -rw-r--r-- | src/c/urweb.c | 5 | ||||
| -rw-r--r-- | src/cjr_print.sml | 3 | ||||
| -rw-r--r-- | src/compiler.sml | 3 | ||||
| -rw-r--r-- | src/elisp/urweb-defs.el | 6 | ||||
| -rw-r--r-- | src/elisp/urweb-mode.el | 21 | ||||
| -rw-r--r-- | src/mono_opt.sml | 4 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 39 | ||||
| -rw-r--r-- | src/monoize.sml | 50 | ||||
| -rw-r--r-- | src/settings.sml | 13 | ||||
| -rw-r--r-- | src/urweb.grm | 32 | ||||
| -rw-r--r-- | src/urweb.lex | 16 | ||||
| -rw-r--r-- | tests/docevents.ur | 7 | ||||
| -rw-r--r-- | tests/dynClassB.ur | 17 | ||||
| -rw-r--r-- | tests/dynClassB.urp | 5 | ||||
| -rw-r--r-- | tests/files.urp | 2 | ||||
| -rw-r--r-- | tests/nomangle.ur | 7 | ||||
| -rw-r--r-- | tests/nomangle.urp | 5 | ||||
| -rw-r--r-- | tests/style.css | 7 |
29 files changed, 341 insertions, 61 deletions
@@ -34,6 +34,7 @@ demo/more/out/*.html demo/more/demo.* doc/*.html +doc/*.out *.sql *mlmon.out @@ -1,4 +1,28 @@ ======== +20150520 +======== + +- Change default behavior of client-side GUI event handlers: + By default, events are now passed to handlers on parent DOM nodes as well, + just like in normal JavaScript. + Call [preventDefault] or [stopPropagation] to tweak that behavior. + WARNING: This change may break backward compatibility! +- URIs specified with 'file' .urp directive are implicitly allowed to be referenced. +- New HTML tags: <fieldset>, <legend> +- New urweb-mode Emacs command: 'urweb-close-matching-tag' +- Bug fixes + +======== +20150412 +======== + +- Several new infix operators for function composition, etc. +- Hexadecimal integer literals +- New HTML events: 'oncontextmenu', 'onmouseenter', and 'onmouseleave' +- New HTML attributes: 'download' +- Bug fixes and optimization improvements + +======== 20150214 ======== diff --git a/configure.ac b/configure.ac index 1991c463..89620c40 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20150214]) +AC_INIT([urweb], [20150520]) WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS diff --git a/debian/changelog b/debian/changelog index 791bb2c1..c7a888ce 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,18 @@ +urweb (20150520+dfsg-1) unstable; urgency=medium + + * New upstream release. + * Make static linking work on multiarch systems. (Closes: #791551) + * Correct manual page with respect to the behaviour of the -static flag. + + -- Benjamin Barenblat <bbaren@mit.edu> Mon, 06 Jul 2015 00:34:39 -0400 + +urweb (20150412+dfsg-1) unstable; urgency=medium + + * New upstream release. + * Fix debian/watch file. + + -- Benjamin Barenblat <bbaren@mit.edu> Tue, 14 Apr 2015 16:24:31 -0400 + urweb (20150214+dfsg-1) unstable; urgency=medium * Initial release. diff --git a/debian/rules b/debian/rules index 103cb760..b9419d7d 100755 --- a/debian/rules +++ b/debian/rules @@ -18,7 +18,8 @@ export MLTONARGS := \ .PHONY: override_dh_auto_configure override_dh_auto_configure: - SRCLIB=/usr/share/urweb dh_auto_configure -- + LIB=/usr/lib/$(DEB_HOST_MULTIARCH) \ + SRCLIB=/usr/share/urweb dh_auto_configure -- .PHONY: override_dh_auto_build override_dh_auto_build: diff --git a/debian/urweb.1 b/debian/urweb.1 index 7df6cd8d..0419c83a 100644 --- a/debian/urweb.1 +++ b/debian/urweb.1 @@ -262,9 +262,7 @@ you must do that yourself. .TP \fB\-static\fP -Instructs \fBurweb\fP to statically link the generated executable with the -Ur/Web runtime system. Note, however, that the executable will still be -dynamically linked with any other supporting libraries (e.g., OpenSSL). +Instructs \fBurweb\fP to statically link the generated executable. .TP \fB\-timing\fP diff --git a/debian/watch b/debian/watch index 0f4a0aed..70157dab 100644 --- a/debian/watch +++ b/debian/watch @@ -1,3 +1,3 @@ version=3 opts=dversionmangle=s/\+dfsg-\d+$// \ - http://impredicative.com/ur/urweb-(.+).tgz + http://impredicative.com/ur/main.html urweb-(.+).tgz diff --git a/doc/manual.tex b/doc/manual.tex index bcdb7f35..1ff3f7aa 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -9,6 +9,8 @@ \newcommand{\rcut}{\; \texttt{-{}-} \;} \newcommand{\rcutM}{\; \texttt{-{}-{}-} \;} +\usepackage{hyperref} + \begin{document} \title{The Ur/Web Manual} @@ -632,6 +634,10 @@ A signature item $\mt{table} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Bas It is possible to write a $\mt{let}$ expression with its constituents in reverse order, along the lines of Haskell's \cd{where}. An expression $\mt{let} \; e \; \mt{where} \; ed^* \; \mt{end}$ desugars to $\mt{let} \; ed^* \; \mt{in} \; e \; \mt{end}$. +Ur/Web also includes a few more infix operators: $f \; \texttt{<|} \; x$ desugars to $f \; x$, $x \; \texttt{|>} \; f$ to $f \; x$, $f \; \texttt{<{}<{}<} \; g$ to $\mt{Top}.\mt{compose} \; f \; g$, and $g \; \texttt{>{}>{}>} \; f$ to $\mt{Top}.\mt{compose} \; f \; g$. (The latter two are doing function composition in the usual way.) Furthermore, any identifier may be changed into an infix operator by placing it between backticks, e.g. a silly way to do addition is $x \; \texttt{`}\mt{plus}\texttt{`} \; y$ instead of $x + y$. + +Hexadecimal integer literals are supported like \texttt{0xDEADBEEF}. Only capital letters are allowed. + \section{Static Semantics} diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 3bf21dd2..335cb525 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -537,6 +537,10 @@ function uw_onClick(f) { uw_handler("onclick", f); } +function uw_onContextmenu(f) { + uw_handler("oncontextmenu", f); +} + function uw_onDblclick(f) { uw_handler("ondblclick", f); } @@ -545,6 +549,14 @@ function uw_onMousedown(f) { uw_handler("onmousedown", f); } +function uw_onMouseenter(f) { + uw_handler("onmouseenter", f); +} + +function uw_onMouseleave(f) { + uw_handler("onmouseleave", f); +} + function uw_onMousemove(f) { uw_handler("onmousemove", f); } @@ -636,21 +648,25 @@ function cr(n) { return closures[n]; } -function flattenAcc(a, cls, tr) { - if (tr.cat1 != null) { - flattenAcc(a, cls, tr.cat1); - flattenAcc(a, cls, tr.cat2); - } else if (tr.closure != null) { - var cl = newClosure(tr.closure); - cls.v = cons(cl, cls.v); - a.push("cr(", cl.toString(), ")"); - } else - a.push(tr); +function flattenAcc(a, cls, trs) { + while (trs) { + var tr = trs.data; + trs = trs.next; + + if (tr.cat1 != null) { + trs = cons(tr.cat1, cons(tr.cat2, trs)); + } else if (tr.closure != null) { + var cl = newClosure(tr.closure); + cls.v = cons(cl, cls.v); + a.push("cr(", cl.toString(), ")"); + } else + a.push(tr); + } } function flatten(cls, tr) { var a = []; - flattenAcc(a, cls, tr); + flattenAcc(a, cls, cons(tr, null)); return a.join(""); } @@ -1237,6 +1253,56 @@ function dynClass(pnode, html, s_class, s_style) { } } +function bodyDynClass(s_class, s_style) { + if (suspendScripts) + return; + + var htmlCls = null; + + if (s_class) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s_class; + x.sources = null; + x.closures = htmlCls; + + x.recreate = function(v) { + for (var ls = x.closures; ls != htmlCls; ls = ls.next) + freeClosure(ls.data); + + var cls = {v : null}; + document.body.className = flatten(cls, v); + console.log("className to + " + document.body.className); + x.closures = concat(cls.v, htmlCls); + } + + document.body.appendChild(x); + populate(x); + } + + if (s_style) { + var htmlCls2 = s_class ? null : htmlCls; + var y = document.createElement("script"); + y.dead = false; + y.signal = s_style; + y.sources = null; + y.closures = htmlCls2; + + y.recreate = function(v) { + for (var ls = y.closures; ls != htmlCls2; ls = ls.next) + freeClosure(ls.data); + + var cls = {v : null}; + document.body.style.cssText = flatten(cls, v); + console.log("style to + " + document.body.style.cssText); + y.closures = concat(cls.v, htmlCls2); + } + + document.body.appendChild(y); + populate(y); + } +} + function addOnChange(x, f) { var old = x.onchange; if (old == null) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 326563d6..56c8d767 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -833,7 +833,7 @@ type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, Button : mouseButton } con mouseEvents = map (fn _ :: Unit => mouseEvent -> transaction unit) - [Onclick, Ondblclick, Onmousedown, Onmousemove, Onmouseout, Onmouseover, Onmouseup] + [Onclick, Oncontextmenu, Ondblclick, Onmousedown, Onmouseenter, Onmouseleave, Onmousemove, Onmouseout, Onmouseover, Onmouseup] type keyEvent = { KeyCode : int, CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool } @@ -914,7 +914,7 @@ val time : bodyTag boxAttrs val wbr : bodyTag boxAttrs val bdi : bodyTag boxAttrs -val a : bodyTag ([Link = transaction page, Href = url, Target = string, Rel = string] ++ boxAttrs) +val a : bodyTag ([Link = transaction page, Href = url, Target = string, Rel = string, Download = string] ++ boxAttrs) val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int, Onabort = transaction unit, Onerror = transaction unit, @@ -1028,6 +1028,9 @@ val image : ctx ::: {Unit} -> use ::: {Type} val label : bodyTag ([For = id, Accesskey = string] ++ tableAttrs) +val fieldset : bodyTag boxAttrs +val legend : bodyTag boxAttrs + (*** AJAX-oriented widgets *) @@ -1120,10 +1123,13 @@ val onServerError : (string -> transaction unit) -> transaction unit (* More standard document-level JavaScript handlers *) val onClick : (mouseEvent -> transaction unit) -> transaction unit val onDblclick : (mouseEvent -> transaction unit) -> transaction unit +val onContextmenu : (mouseEvent -> transaction unit) -> transaction unit val onKeydown : (keyEvent -> transaction unit) -> transaction unit val onKeypress : (keyEvent -> transaction unit) -> transaction unit val onKeyup : (keyEvent -> transaction unit) -> transaction unit val onMousedown : (mouseEvent -> transaction unit) -> transaction unit +val onMouseenter : (mouseEvent -> transaction unit) -> transaction unit +val onMouseleave : (mouseEvent -> transaction unit) -> transaction unit val onMousemove : (mouseEvent -> transaction unit) -> transaction unit val onMouseout : (mouseEvent -> transaction unit) -> transaction unit val onMouseover : (mouseEvent -> transaction unit) -> transaction unit diff --git a/src/c/static.c b/src/c/static.c index 8f35a2d4..c8fd5bc7 100644 --- a/src/c/static.c +++ b/src/c/static.c @@ -16,6 +16,10 @@ static void log_(void *data, const char *fmt, ...) { static uw_loggers loggers = {NULL, log_, log_}; +static char *get_header(void *data, const char *h) { + return NULL; +} + int main(int argc, char *argv[]) { uw_context ctx; failure_kind fk; @@ -27,6 +31,7 @@ int main(int argc, char *argv[]) { ctx = uw_init(0, &loggers); uw_set_app(ctx, &uw_application); + uw_set_headers(ctx, get_header, NULL); uw_initialize(ctx); while (1) { diff --git a/src/c/urweb.c b/src/c/urweb.c index 7ad58e1d..1e49dae0 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4220,7 +4220,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 b3b12fe8..9c456863 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3665,8 +3665,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 388cc7d2..8f6d1fad 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/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/mono_opt.sml b/src/mono_opt.sml index 2d40e0f0..04ef7f50 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -630,7 +630,9 @@ fun exp e = EFfiApp ("Basis", "writec", [e]) | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) - + | EBinop (_, "-", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.- (n1, n2))) + | EBinop (_, "*", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.* (n1, n2))) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 39d02b99..61866af7 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -330,7 +330,9 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false, U.Exp.RelE _ => n + 1 | _ => n} 0 -fun reduce (file : file) = +val yankedCase = ref false + +fun reduce' (file : file) = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => @@ -770,17 +772,18 @@ fun reduce (file : file) = Print.PD.string "}"] in if List.all (safe o #2) pes then - EAbs ("y", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | (p, (EError (e, (TFun (_, t), _)), loc)) => - (p, (EError (liftExpInExp (patBinds p) e, t), loc)) - | (p, e) => - (p, (EApp (liftExpInExp (patBinds p) e, - (ERel (patBinds p), loc)), loc))) - pes, - {disc = disc, result = result}), loc)) + (yankedCase := true; + EAbs ("y", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | (p, (EError (e, (TFun (_, t), _)), loc)) => + (p, (EError (liftExpInExp (patBinds p) e, t), loc)) + | (p, e) => + (p, (EApp (liftExpInExp (patBinds p) e, + (ERel (patBinds p), loc)), loc))) + pes, + {disc = disc, result = result}), loc))) else e end @@ -894,4 +897,16 @@ fun reduce (file : file) = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file end +fun reduce file = + let + val () = yankedCase := false + val file' = reduce' file + in + if !yankedCase then + reduce file' + else + file' + end + + end diff --git a/src/monoize.sml b/src/monoize.sml index 5727d997..bac82f55 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3267,6 +3267,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = else (NONE, NONE, attrs) + val (class, fm) = monoExp (env, st, fm) class + val (dynClass, fm) = monoExp (env, st, fm) dynClass + val (style, fm) = monoExp (env, st, fm) style + val (dynStyle, fm) = monoExp (env, st, fm) dynStyle + (* Special case for <button value=""> *) val (attrs, extraString) = case tag of "button" => @@ -3274,14 +3279,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ([(_, value, _)], rest) => (rest, SOME value) | _ => (attrs, NONE)) + | "body" => + (attrs, + if (case (#1 dynClass, #1 dynStyle) of + (L'.ESome _, _) => true + | (_, L'.ESome _) => true + | _ => false) then + let + fun jsify (e : L'.exp) = + case #1 e of + L'.ESome (_, ds) => strcat [str "execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str ")"] + | _ => str "null" + in + SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(", + jsify dynClass, + str ",", + jsify dynStyle, + str ")</script>"]) + end + else + NONE) | _ => (attrs, NONE) - val (class, fm) = monoExp (env, st, fm) class - val (dynClass, fm) = monoExp (env, st, fm) dynClass - val (style, fm) = monoExp (env, st, fm) style - val (dynStyle, fm) = monoExp (env, st, fm) dynStyle - val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] fun isSome (e, _) = @@ -3380,7 +3402,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 @@ -3825,10 +3847,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "tabl" => normal ("table", NONE) | _ => normal (tag, NONE) + + val (dynClass', dynStyle') = + case tag of + "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan), + (L'.ENone dummyTyp, ErrorMsg.dummySpan)) + | _ => (dynClass, dynStyle) in - case #1 dynClass of + case #1 dynClass' of L'.ENone _ => - (case #1 dynStyle of + (case #1 dynStyle' of L'.ENone _ => baseAll | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"", str (pnode ()), @@ -3842,7 +3870,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = baseAll)) | L'.ESome (_, dc) => let - val e = case #1 dynStyle of + val e = case #1 dynStyle' of L'.ENone _ => str "null" | L'.ESome (_, ds) => strcat [str "execD(", (L'.EJavaScript (L'.Script, ds), loc), @@ -4654,8 +4682,8 @@ fun monoize env file = (L'.EDml (str (foldl (fn ((x, _), s) => s ^ ", " ^ Settings.mangleSql x ^ " = NULL") - ("UPDATE uw_" - ^ tab + ("UPDATE " + ^ Settings.mangleSql tab ^ " SET " ^ Settings.mangleSql x ^ " = NULL") diff --git a/src/settings.sml b/src/settings.sml index 19ee0b4a..cd2de8a9 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -176,10 +176,13 @@ val benignBase = basis ["get_cookie", "spawn", "onClick", "onDblclick", + "onContextmenu", "onKeydown", "onKeypress", "onKeyup", "onMousedown", + "onMouseenter", + "onMouseleave", "onMousemove", "onMouseout", "onMouseover", @@ -212,11 +215,14 @@ val clientBase = basis ["get_client_source", "mouseEvent", "keyEvent", "onClick", + "onContextmenu", "onDblclick", "onKeydown", "onKeypress", "onKeyup", "onMousedown", + "onMouseenter", + "onMouseleave", "onMousemove", "onMouseout", "onMouseover", @@ -349,11 +355,14 @@ val jsFuncsBase = basisM [("alert", "alert"), ("onClick", "uw_onClick"), + ("onContextmenu", "uw_onContextmenu"), ("onDblclick", "uw_onDblclick"), ("onKeydown", "uw_onKeydown"), ("onKeypress", "uw_onKeypress"), ("onKeyup", "uw_onKeyup"), ("onMousedown", "uw_onMousedown"), + ("onMouseenter", "uw_onMouseenter"), + ("onMouseleave", "uw_onMouseleave"), ("onMousemove", "uw_onMousemove"), ("onMouseout", "uw_onMouseout"), ("onMouseover", "uw_onMouseover"), @@ -764,7 +773,7 @@ fun mangleSqlTable s = fun mangleSql s = if #name (currentDbms ()) = "mysql" then if !mangle then - "uw_" ^ allLower s + "uw_" ^ allLower s else allLower s else @@ -867,7 +876,7 @@ fun setFilePath path = filePath := path fun addFile {Uri, LoadFromFilename} = let - val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename} + val path = OS.Path.concat (!filePath, LoadFromFilename) in case SM.find (!files, Uri) of SOME (path', _) => diff --git a/src/urweb.grm b/src/urweb.grm index 56e6d2ac..7fc34793 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -216,6 +216,14 @@ fun native_op (oper, e1, e2, loc) = (EApp (e, e2), loc) end +fun top_binop (oper, e1, e2, loc) = + let + val e = (EVar (["Top"], oper, Infer), loc) + val e = (EApp (e, e1), loc) + in + (EApp (e, e2), loc) + end + val inDml = ref false fun tagIn bt = @@ -395,6 +403,8 @@ fun patternOut (e : exp) = | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL | CIF | CTHEN | CELSE + | FWDAPP | REVAPP | COMPOSE | ANDTHEN + | BACKTICK_PATH of string %nonterm file of decl list @@ -565,6 +575,12 @@ fun patternOut (e : exp) = %right CAND %nonassoc EQ NE LT LE GT GE IS %right ARROW + +%left REVAPP +%right FWDAPP +%left BACKTICK_PATH +%right COMPOSE ANDTHEN + %right CARET PLUSPLUS %left MINUSMINUS MINUSMINUSMINUS %left PLUS MINUS @@ -1202,6 +1218,22 @@ eexp : eapps (case #1 eapps of | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right))) | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp FWDAPP eexp (EApp (eexp1, eexp2), s (eexp1left, eexp2right)) + | eexp REVAPP eexp (EApp (eexp2, eexp1), s (eexp1left, eexp2right)) + | eexp COMPOSE eexp (top_binop ("compose", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp ANDTHEN eexp (top_binop ("compose", eexp2, eexp1, s (eexp1left, eexp2right))) + | eexp BACKTICK_PATH eexp (let + val path = String.tokens (fn ch => ch = #".") BACKTICK_PATH + val pathModules = List.take (path, (length path -1)) + val pathOp = List.last path + + val e = (EVar (pathModules, pathOp, Infer) + , s (BACKTICK_PATHleft, BACKTICK_PATHright)) + val e = (EApp (e, eexp1), s (eexp1left, BACKTICK_PATHright)) + in + (EApp (e, eexp2), s (eexp1left, eexp2right)) + end) + | eexp ANDALSO eexp (let val loc = s (eexp1left, eexp2right) in diff --git a/src/urweb.lex b/src/urweb.lex index 195fd735..e1ffd1c3 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -182,6 +182,7 @@ 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}; notags = ([^<{\n(]|(\([^\*<{\n]))+; xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; @@ -376,6 +377,15 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <INITIAL> "&&" => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext)); <INITIAL> "||" => (Tokens.ORELSE (pos yypos, pos yypos + size yytext)); +<INITIAL> "<<<" => (Tokens.COMPOSE (pos yypos, pos yypos + size yytext)); +<INITIAL> ">>>" => (Tokens.ANDTHEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "<|" => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext)); +<INITIAL> "|>" => (Tokens.REVAPP (pos yypos, pos yypos + size yytext)); + +<INITIAL> "`" ({cid} ".")* {id} "`" => (Tokens.BACKTICK_PATH ( (* strip backticks *) + substring (yytext,1,size yytext -2), + pos yypos, pos yypos + size yytext)); + <INITIAL> "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); <INITIAL> "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); <INITIAL> "<" => (Tokens.LT (pos yypos, pos yypos + size yytext)); @@ -532,6 +542,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <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 + SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected hexInt, received: " ^ yytext); + continue ())); + <INITIAL> {intconst} => (case Int64.fromString yytext of SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) diff --git a/tests/docevents.ur b/tests/docevents.ur index eed38868..906afa2b 100644 --- a/tests/docevents.ur +++ b/tests/docevents.ur @@ -1,6 +1,7 @@ fun main () : transaction page = return <xml> - <body onload={onDblclick (alert "Double click"); - onKeypress (fn k => alert ("Keypress: " ^ show k))}> + <body onload={onDblclick (fn _ => alert "Double click"); + onContextmenu (fn _ => alert "Context menu"); + onKeypress (fn k => alert ("Keypress: " ^ show k.KeyCode))}> Nothing here. - </body> + </body> </xml> diff --git a/tests/dynClassB.ur b/tests/dynClassB.ur new file mode 100644 index 00000000..fc7aeb43 --- /dev/null +++ b/tests/dynClassB.ur @@ -0,0 +1,17 @@ +style style1 +style style2 + +fun main () : transaction page = + toggle <- source False; + return <xml> + <head> + <link rel="stylesheet" type="text/css" href="/style.css"/> + </head> + <body dynClass={b <- signal toggle; + return (if b then style1 else style2)} + dynStyle={b <- signal toggle; + return (if b then STYLE "margin: 100px" else STYLE "")}> + Body + <button onclick={fn _ => b <- get toggle; set toggle (not b)}>TOGGLE</button> + </body> + </xml> diff --git a/tests/dynClassB.urp b/tests/dynClassB.urp new file mode 100644 index 00000000..e580b035 --- /dev/null +++ b/tests/dynClassB.urp @@ -0,0 +1,5 @@ +rewrite all DynClassB/* +file /style.css style.css +allow url /style.css + +dynClassB diff --git a/tests/files.urp b/tests/files.urp index 100992e5..3683f1a8 100644 --- a/tests/files.urp +++ b/tests/files.urp @@ -1,6 +1,6 @@ rewrite all Files/* file /hello_world.txt hello.txt file /img/web.png web.png -file /files.urp files.urp +file /files.urp ./files.urp files diff --git a/tests/nomangle.ur b/tests/nomangle.ur new file mode 100644 index 00000000..b853a690 --- /dev/null +++ b/tests/nomangle.ur @@ -0,0 +1,7 @@ +table foo : { Bar : int, Baz : string } + PRIMARY KEY Baz + +fun main () : transaction page = + rs <- queryX1 (SELECT foo.Bar FROM foo WHERE foo.Baz = 'Hi') + (fn r => <xml>{[r.Bar]}</xml>); + return <xml><body>{rs}</body></xml> diff --git a/tests/nomangle.urp b/tests/nomangle.urp new file mode 100644 index 00000000..7fab4b03 --- /dev/null +++ b/tests/nomangle.urp @@ -0,0 +1,5 @@ +database dbname=test +noMangleSql +sql nomangle.sql + +nomangle diff --git a/tests/style.css b/tests/style.css new file mode 100644 index 00000000..78b33fc2 --- /dev/null +++ b/tests/style.css @@ -0,0 +1,7 @@ +body.style1 { + background-color: blue; +} + +body.style2 { + background-color: green; +} |