summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-07-19 19:05:16 -0700
committerGravatar Ziv Scully <ziv@mit.edu>2015-07-19 19:05:16 -0700
commita197d648e075a696f5ca86b23913b668f2baf940 (patch)
tree4c044e00c2df8ca6fd76d072f05bf1e3ff202140
parentbc38beafd07b7ae6106a2fffda82084a08af7f06 (diff)
parentc6e4d352f01eff2ddcdcc53c0f2a14666c2af8b2 (diff)
Merge.
-rw-r--r--CHANGELOG14
-rw-r--r--configure.ac2
-rw-r--r--doc/manual.tex19
-rw-r--r--lib/ur/basis.urs42
-rw-r--r--lib/ur/top.ur3
-rw-r--r--lib/ur/top.urs7
-rw-r--r--src/c/static.c2
-rw-r--r--src/c/urweb.c5
-rw-r--r--src/cjr_print.sml3
-rw-r--r--src/compiler.sml3
-rw-r--r--src/core_util.sml22
-rw-r--r--src/elisp/urweb-defs.el6
-rw-r--r--src/elisp/urweb-mode.el21
-rw-r--r--src/monoize.sml17
-rw-r--r--src/urweb.grm1
-rw-r--r--src/urweb.lex26
-rw-r--r--tests/align.ur4
-rw-r--r--tests/bodyClick.ur6
-rw-r--r--tests/classy_form.ur9
-rw-r--r--tests/nomangle.ur7
-rw-r--r--tests/nomangle.urp5
21 files changed, 165 insertions, 59 deletions
diff --git a/CHANGELOG b/CHANGELOG
index e4eae28e..838da410 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -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