diff options
| -rw-r--r-- | CHANGELOG | 14 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | doc/manual.tex | 19 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 42 | ||||
| -rw-r--r-- | lib/ur/top.ur | 3 | ||||
| -rw-r--r-- | lib/ur/top.urs | 7 | ||||
| -rw-r--r-- | src/c/static.c | 2 | ||||
| -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/core_util.sml | 22 | ||||
| -rw-r--r-- | src/elisp/urweb-defs.el | 6 | ||||
| -rw-r--r-- | src/elisp/urweb-mode.el | 21 | ||||
| -rw-r--r-- | src/monoize.sml | 17 | ||||
| -rw-r--r-- | src/urweb.grm | 1 | ||||
| -rw-r--r-- | src/urweb.lex | 26 | ||||
| -rw-r--r-- | tests/align.ur | 4 | ||||
| -rw-r--r-- | tests/bodyClick.ur | 6 | ||||
| -rw-r--r-- | tests/classy_form.ur | 9 | ||||
| -rw-r--r-- | tests/nomangle.ur | 7 | ||||
| -rw-r--r-- | tests/nomangle.urp | 5 |
21 files changed, 165 insertions, 59 deletions
@@ -1,4 +1,18 @@ ======== +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 ======== diff --git a/configure.ac b/configure.ac index 3adbdef2..f471eef7 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20150412]) +AC_INIT([urweb], [20150520]) WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS diff --git a/doc/manual.tex b/doc/manual.tex index 1ff3f7aa..e140fac1 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -509,8 +509,8 @@ $$\begin{array}{rrcll} &&& \ell & \textrm{constant} \\ &&& \hat{X} & \textrm{nullary constructor} \\ &&& \hat{X} \; p & \textrm{unary constructor} \\ - &&& \{(x = p,)^*\} & \textrm{rigid record pattern} \\ - &&& \{(x = p,)^+, \ldots\} & \textrm{flexible record pattern} \\ + &&& \{(X = p,)^*\} & \textrm{rigid record pattern} \\ + &&& \{(X = p,)^+, \ldots\} & \textrm{flexible record pattern} \\ &&& p : \tau & \textrm{type annotation} \\ &&& (p) & \textrm{explicit precedence} \\ \\ @@ -968,11 +968,11 @@ $$\infer{\Gamma \vdash M.X \; p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i & \Gamma \vdash p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau'' }$$ -$$\infer{\Gamma \vdash \{\overline{x = p}\} \leadsto \Gamma_n; \{\overline{x = \tau}\}}{ +$$\infer{\Gamma \vdash \{\overline{X = p}\} \leadsto \Gamma_n; \{\overline{X = \tau}\}}{ \Gamma_0 = \Gamma & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i } -\quad \infer{\Gamma \vdash \{\overline{x = p}, \ldots\} \leadsto \Gamma_n; \$([\overline{x = \tau}] \rc c)}{ +\quad \infer{\Gamma \vdash \{\overline{X = p}, \ldots\} \leadsto \Gamma_n; \$([\overline{X = \tau}] \rc c)}{ \Gamma_0 = \Gamma & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i }$$ @@ -1424,7 +1424,7 @@ $$\begin{array}{l} \hspace{.1in} \to (\mt{nm} :: \mt{Name} \to \mt{v} :: \mt{K} \to \mt{r} :: \{\mt{K}\} \to [[\mt{nm}] \sim \mt{r}] \Rightarrow \\ \hspace{.2in} \mt{tf} \; \mt{r} \to \mt{tf} \; ([\mt{nm} = \mt{v}] \rc \mt{r})) \\ \hspace{.1in} \to \mt{tf} \; [] \\ - \hspace{.1in} \to \mt{r} :: \{\mt{K}\} \to \mt{folder} \; \mt{r} \to \mt{tf} \; \mt{r} + \hspace{.1in} \to \mt{r} ::: \{\mt{K}\} \to \mt{folder} \; \mt{r} \to \mt{tf} \; \mt{r} \end{array}$$ For a type-level record $\mt{r}$, a $\mt{folder} \; \mt{r}$ encodes a permutation of $\mt{r}$'s elements. The $\mt{fold}$ function can be called on a $\mt{folder}$ to iterate over the elements of $\mt{r}$ in that order. $\mt{fold}$ is parameterized on a type-level function to be used to calculate the type of each intermediate result of folding. After processing a subset $\mt{r'}$ of $\mt{r}$'s entries, the type of the accumulator should be $\mt{tf} \; \mt{r'}$. The next two expression arguments to $\mt{fold}$ are the usual step function and initial accumulator, familiar from fold functions over lists. The final two arguments are the record to fold over and a $\mt{folder}$ for it. @@ -1861,7 +1861,7 @@ Any SQL query that returns single columns may be turned into a subquery expressi $$\begin{array}{l} \mt{val} \; \mt{sql\_subquery} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{nm} ::: \mt{Name} \to \mt{t} ::: \mt{Type} \to \mt{nt} ::: \mt{Type} \\ -\hspace{.1in} \to \mt{nullify} \; \mt{t} \; \mt{nt} \to \mt{sql\_query} \; \mt{tables} \; \mt{agg} \; [\mt{nm} = \mt{t}] \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{nt} +\hspace{.1in} \to \mt{nullify} \; \mt{t} \; \mt{nt} \to \mt{sql\_query} \; \mt{tables} \; \mt{agg} \; [] \; [\mt{nm} = \mt{t}] \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{nt} \end{array}$$ There is also an \cd{IF..THEN..ELSE..} construct that is compiled into standard SQL \cd{CASE} expressions. @@ -1990,7 +1990,7 @@ $$\begin{array}{l} \hspace{.1in} \to \$(\mt{map} \; (\mt{sql\_exp} \; [] \; [] \; []) \; \mt{fields}) \to \mt{dml} \end{array}$$ -An $\mt{UPDATE}$ command is formed from a choice of which table fields to leave alone and which to change, along with an expression to use to compute the new value of each changed field and a $\mt{WHERE}$ clause. Note that, in the table environment applied to expressions, the table being updated is hardcoded at the name $\mt{T}$. The parsing extension for $\mt{UPDATE}$ will elaborate all table-free field references to use table variable $\mt{T}$. +An $\mt{UPDATE}$ command is formed from a choice of which table fields to leave alone and which to change, along with an expression to use to compute the new value of each changed field and a $\mt{WHERE}$ clause. Note that, in the table environment applied to expressions, the table being updated is hardcoded at the name $\mt{T}$. The parsing extension for $\mt{UPDATE}$ will elaborate all table-free field references to use constant table name $\mt{T}$. $$\begin{array}{l} \mt{val} \; \mt{update} : \mt{unchanged} ::: \{\mt{Type}\} \to \mt{changed} :: \{\mt{Type}\} \to [\mt{changed} \sim \mt{unchanged}] \\ \hspace{.1in} \Rightarrow \$(\mt{map} \; (\mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; []) \; \mt{changed}) \\ @@ -2287,11 +2287,12 @@ $$\begin{array}{rrcll} \textrm{Tables} & T &::=& x & \textrm{table variable, named locally by its own capitalization} \\ &&& x \; \mt{AS} \; X & \textrm{table variable, with local name} \\ &&& x \; \mt{AS} \; \{c\} & \textrm{table variable, with computed local name} \\ - &&& \{\{e\}\} \; \mt{AS} \; t & \textrm{computed table expression, with local name} \\ + &&& \{\{e\}\} \; \mt{AS} \; X & \textrm{computed table expression, with local name} \\ &&& \{\{e\}\} \; \mt{AS} \; \{c\} & \textrm{computed table expression, with computed local name} \\ \textrm{$\mt{FROM}$ items} & F &::=& T \mid \{\{e\}\} \mid F \; J \; \mt{JOIN} \; F \; \mt{ON} \; E \\ &&& \mid F \; \mt{CROSS} \; \mt{JOIN} \ F \\ - &&& \mid (Q) \; \mt{AS} \; t \mid (\{\{e\}\}) \; \mt{AS} \; t \\ + &&& \mid (Q) \; \mt{AS} \; X \mid (Q) \; \mt{AS} \; \{c\} \\ + &&& \mid (\{\{e\}\}) \; \mt{AS} \; t \\ \textrm{Joins} & J &::=& [\mt{INNER}] \\ &&& \mid [\mt{LEFT} \mid \mt{RIGHT} \mid \mt{FULL}] \; [\mt{OUTER}] \\ \textrm{SQL expressions} & E &::=& t.f & \textrm{column references} \\ diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 28384c2c..ec6ef599 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -811,21 +811,6 @@ val head : unit -> tag [Data = data_attr] html head [] [] val title : unit -> tag [Data = data_attr] head [] [] [] val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] [] -val body : unit -> tag [Data = data_attr, Onload = transaction unit, Onresize = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit] - html body [] [] -con bodyTag = fn (attrs :: {Type}) => - ctx ::: {Unit} -> - [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] -con bodyTagStandalone = fn (attrs :: {Type}) => - ctx ::: {Unit} - -> [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) [] [] [] - -val br : bodyTagStandalone [Data = data_attr, Id = id] - -con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit] - datatype mouseButton = Left | Right | Middle type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, @@ -841,6 +826,24 @@ type keyEvent = { KeyCode : int, con keyEvents = map (fn _ :: Unit => keyEvent -> transaction unit) [Onkeydown, Onkeypress, Onkeyup] +val body : unit -> tag ([Data = data_attr, Onload = transaction unit, Onresize = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit] + ++ mouseEvents ++ keyEvents) + html body [] [] + +con bodyTag = fn (attrs :: {Type}) => + ctx ::: {Unit} -> + [[Body] ~ ctx] => + unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] +con bodyTagStandalone = fn (attrs :: {Type}) => + ctx ::: {Unit} + -> [[Body] ~ ctx] => + unit -> tag attrs ([Body] ++ ctx) [] [] [] + +val br : bodyTagStandalone [Data = data_attr, Id = id] + +con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit] + + (* Key arguments are character codes. *) con resizeEvents = [Onresize = transaction unit] con scrollEvents = [Onscroll = transaction unit] @@ -848,8 +851,8 @@ con scrollEvents = [Onscroll = transaction unit] con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents con tableEvents = focusEvents ++ mouseEvents ++ keyEvents -con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string] ++ boxEvents -con tableAttrs = [Data = data_attr, Id = id, Title = string] ++ tableEvents +con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string, Align = string] ++ boxEvents +con tableAttrs = [Data = data_attr, Id = id, Title = string, Align = string] ++ tableEvents val span : bodyTag boxAttrs val div : bodyTag boxAttrs @@ -1008,7 +1011,7 @@ val remainingFields : postField -> string con radio = [Body, Radio] val radio : formTag (option string) radio [Data = data_attr, Id = id] -val radioOption : unit -> tag ([Value = string, Checked = bool] ++ boxAttrs) radio [] [] [] +val radioOption : unit -> tag ([Value = string, Checked = bool, Onchange = transaction unit] ++ boxAttrs) radio [] [] [] con select = [Select] val select : formTag string select ([Onchange = transaction unit] ++ boxAttrs) @@ -1028,6 +1031,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 *) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 3250a5a3..e831b4f7 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -410,3 +410,6 @@ fun max [t] ( _ : ord t) (x : t) (y : t) : t = if x > y then x else y fun min [t] ( _ : ord t) (x : t) (y : t) : t = if x < y then x else y + +fun assert [a] (cond: bool) (msg: string) (loc: string) (x:a): a = + if cond then x else error <xml>{txt msg} at {txt loc}</xml> diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 15bc6a22..8273db0c 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -290,3 +290,10 @@ val postFields : postBody -> list (string * string) val max : t ::: Type -> ord t -> t -> t -> t val min : t ::: Type -> ord t -> t -> t -> t + +val assert : t ::: Type + -> bool (* Did we avoid something bad? *) + -> string (* Explanation of the bad thing *) + -> string (* Source location of the bad thing *) + -> t (* Return this value if all went well. *) + -> t 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) diff --git a/tests/align.ur b/tests/align.ur new file mode 100644 index 00000000..7d6664da --- /dev/null +++ b/tests/align.ur @@ -0,0 +1,4 @@ +fun main () : transaction page = return <xml><body> + <p align="left">Left</p> + <p align="right">Right</p> +</body></xml> diff --git a/tests/bodyClick.ur b/tests/bodyClick.ur new file mode 100644 index 00000000..9dcc64cf --- /dev/null +++ b/tests/bodyClick.ur @@ -0,0 +1,6 @@ +fun main () : transaction page = return <xml> + <body onclick={fn _ => alert "You clicked the body."} + onkeyup={fn _ => alert "Key"}> + <p>Text</p> + </body> +</xml> diff --git a/tests/classy_form.ur b/tests/classy_form.ur new file mode 100644 index 00000000..f9fafb6e --- /dev/null +++ b/tests/classy_form.ur @@ -0,0 +1,9 @@ +style form_inline + +val main : transaction page = return <xml> + <body> + <form class="form-inline"> + Problematic? + </form> + </body> +</xml> 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 |