From d4d053d05ae3e7d6974f98e28d6f60c837fc687a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 20 May 2015 12:44:28 -0400 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 89620c40..f471eef7 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20150520]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From eb9d168a2236eb6c892b11d6d30f065898a89762 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 28 May 2015 10:23:43 -0400 Subject: Handling overflow in integer literals (contributed by Gabriel Riba) --- src/urweb.lex | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/urweb.lex b/src/urweb.lex index e1ffd1c3..fcf10d94 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -182,7 +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}; +hexconst = 0x[0-9A-F]+; notags = ([^<{\n(]|(\([^\*<{\n]))+; xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; @@ -542,17 +542,25 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); - {hexconst} => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of + {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); - {intconst} => (case Int64.fromString yytext of + {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); {realconst} => (case Real64.fromString yytext of SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) -- cgit v1.2.3 From b609954bf0065f5acbc50dbfa7e28e7145f9a2e3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 28 May 2015 10:28:15 -0400 Subject: Remove duplicate lexer line --- src/urweb.lex | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/urweb.lex b/src/urweb.lex index fcf10d94..c44a4c1d 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -537,8 +537,6 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); - "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); - {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From f97ff31913211b5cd34278782285e920788583f9 Mon Sep 17 00:00:00 2001 From: Gabriel Riba Faura Date: Wed, 3 Jun 2015 08:34:23 +0200 Subject: location literal _LOC_ --- src/urweb.lex | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/urweb.lex b/src/urweb.lex index c44a4c1d..eada3611 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -537,6 +537,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); + "_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); + {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From e409acfa13f877ddae461cc2d711807ae74cd168 Mon Sep 17 00:00:00 2001 From: Gabriel Riba Faura Date: Wed, 3 Jun 2015 15:07:46 +0200 Subject: assert function to use with location literal _LOC_ --- lib/ur/top.ur | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 3250a5a3..06dcab5f 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 {[msg]} at {[loc]} -- cgit v1.2.3 From bc30b26207d28491b27ccc40aea7f89fd01c3571 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 3 Jun 2015 09:55:37 -0400 Subject: Adjust new [assert] to work properly from top.ur --- lib/ur/top.ur | 2 +- lib/ur/top.urs | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 06dcab5f..e831b4f7 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -412,4 +412,4 @@ 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 {[msg]} at {[loc]} + if cond then x else error {txt msg} at {txt loc} diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 15bc6a22..907b28b2 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -35,7 +35,7 @@ con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2 con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3 (* Convert a record of n Units into a type-level record where - each field has the same value (which describes a uniformly +o each field has the same value (which describes a uniformly typed record) *) con mapU = K ==> fn f :: K => map (fn _ :: Unit => f) @@ -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 -- cgit v1.2.3 From 81d24bdd643e6ad7be78e69c5c0fca8c096c2c9a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 8 Jun 2015 11:11:46 -0400 Subject: Apply syntax sugar for 'class' attribute to
as well --- src/urweb.grm | 1 + tests/classy_form.ur | 9 +++++++++ 2 files changed, 10 insertions(+) create mode 100644 tests/classy_form.ur 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/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 + + + Problematic? + + +
-- cgit v1.2.3 From b05e8f99ab66b5ee490db0c83426173d6c8ae66f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 11 Jun 2015 19:06:32 -0400 Subject: Allow apostrophes in capitalized identifiers --- src/urweb.lex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/urweb.lex b/src/urweb.lex index eada3611..f32ddf1e 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -178,7 +178,7 @@ 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]*; -- cgit v1.2.3 From 9e06bc7fb086af288c0c6646d411dbc20bb5b628 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 11 Jun 2015 19:38:03 -0400 Subject: A number of bug fixes in the manual --- doc/manual.tex | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) 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} \\ -- cgit v1.2.3 From 030173645dbd08281dc59e3673f7f379619d523f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 2 Jul 2015 12:42:49 -0400 Subject: Allow mouse and key events for --- lib/ur/basis.urs | 33 ++++++++++++++++++--------------- tests/bodyClick.ur | 6 ++++++ 2 files changed, 24 insertions(+), 15 deletions(-) create mode 100644 tests/bodyClick.ur diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 56c8d767..2defec9e 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] 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 + alert "You clicked the body."} + onkeyup={fn _ => alert "Key"}> +

Text

+ +
-- cgit v1.2.3 From 085eb5df98b7a95356a712c4eaaefc568cdfe296 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 2 Jul 2015 13:02:37 -0400 Subject: Add HTML 'align' attribute --- lib/ur/basis.urs | 4 ++-- tests/align.ur | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 tests/align.ur diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 2defec9e..19ff9642 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -851,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 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 +

Left

+

Right

+
-- cgit v1.2.3 From fabac72992d397942fd5712d49733424ccb9de56 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 3 Jul 2015 17:25:56 -0400 Subject: Fix a maddening bug in the comparator for Core constructors --- src/core_util.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_util.sml b/src/core_util.sml index 152ba7ac..d098039a 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 -- cgit v1.2.3 From 963a33d73b14f37cfda0dd8a85d2a02fddaeed6c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 4 Jul 2015 18:44:52 -0400 Subject: Stray character in a comment --- lib/ur/top.urs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 907b28b2..8273db0c 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -35,7 +35,7 @@ con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2 con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3 (* Convert a record of n Units into a type-level record where -o each field has the same value (which describes a uniformly + each field has the same value (which describes a uniformly typed record) *) con mapU = K ==> fn f :: K => map (fn _ :: Unit => f) -- cgit v1.2.3 From 538f884e80430c2a3180b8ed77af50f67f3b64ef Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 4 Jul 2015 19:24:26 -0400 Subject: Tag NULLs with their types in SQL, to help the DBMS do type inference --- src/monoize.sml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/monoize.sml b/src/monoize.sml index bac82f55..8934db2c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2214,6 +2214,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), @@ -2223,7 +2236,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), -- cgit v1.2.3 From 31044921b25e830707fb00ba57fd4ea6cf50c422 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 5 Jul 2015 16:11:24 -0400 Subject: Add a missed case in CoreUtil.Exp fold --- src/core_util.sml | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/core_util.sml b/src/core_util.sml index d098039a..9ca85c37 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -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, -- cgit v1.2.3 From f698960a72cc0c1669084530a749b33c295f371f Mon Sep 17 00:00:00 2001 From: Julian Squires Date: Mon, 13 Jul 2015 14:34:30 -0400 Subject: Allow returnBlob and redirect in static protocol Both of these functions end up returning RETURN_INDIRECTLY, which is assumed to be an error by static.c's main. Treat it as success instead. --- src/c/static.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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; -- cgit v1.2.3 From 8d606de7c6a5ddb5e57cb79eda0906e649df4a8e Mon Sep 17 00:00:00 2001 From: Julian Squires Date: Thu, 7 May 2015 16:12:06 -0400 Subject: Add onChange handler to radioOption --- lib/ur/basis.urs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 19ff9642..ec6ef599 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1011,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) -- cgit v1.2.3 From 5fb4f6c39c6ced6da3fd4740fa276bbba35e28d4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 29 Jul 2015 10:08:03 -0400 Subject: Add a simple 'make test' target --- Makefile.am | 16 +++++++++++++++- tests/crud1.html | 38 ++++++++++++++++++++++++++++++++++++++ tests/hello.html | 10 ++++++++++ 3 files changed, 63 insertions(+), 1 deletion(-) create mode 100644 tests/crud1.html create mode 100644 tests/hello.html diff --git a/Makefile.am b/Makefile.am index 11f9a132..79cd2e7d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -15,7 +15,7 @@ all-local: smlnj mlton SUBDIRS = src/c -.PHONY: smlnj mlton package reauto +.PHONY: smlnj mlton package reauto test smlnj: src/urweb.cm xml/entities.sml mlton: bin/urweb @@ -114,3 +114,17 @@ reauto: EXTRA_DIST = demo doc lib/js lib/ur xml \ src/coq src/*.sig src/*.sml src/*.mlb src/config.sml.in src/elisp src/*.cm src/sources src/*.grm src/*.lex \ CHANGELOG LICENSE urweb.ebuild include/urweb/*.h bin + +TESTDB = /tmp/urweb.db +TESTPID = /tmp/urweb.pid + +test: + urweb -dbms sqlite -db $(TESTDB) -demo /Demo demo + rm -f $(TESTDB) + sqlite3 $(TESTDB) < demo/demo.sql + demo/demo.exe & echo $$! > $(TESTPID) + sleep 1 + (curl -s 'http://localhost:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false) + (curl -s 'http://localhost:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false) + kill `cat $(TESTPID)` + echo Tests succeeded. diff --git a/tests/crud1.html b/tests/crud1.html new file mode 100644 index 00000000..7ed26d30 --- /dev/null +++ b/tests/crud1.html @@ -0,0 +1,38 @@ + + + +

Inserted with ID 1.

+ + + + + + + + + + + + + + + + + + + +
IDABCD
1123True +[Update] +[Delete] +
+


+ +
+
  • A:
  • +
  • B:
  • +
  • C:
  • +
  • D:
  • + +
    + + \ No newline at end of file diff --git a/tests/hello.html b/tests/hello.html new file mode 100644 index 00000000..9c249df0 --- /dev/null +++ b/tests/hello.html @@ -0,0 +1,10 @@ + + + + +Hello world! + + +

    Hello world!

    + + \ No newline at end of file -- cgit v1.2.3 From f30aebaed989fbb42859e303d5e31a2c9afeb9fd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Aug 2015 09:57:47 -0400 Subject: Change 'make test' to work before 'make install' --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 79cd2e7d..3c2e4e0d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -119,7 +119,7 @@ TESTDB = /tmp/urweb.db TESTPID = /tmp/urweb.pid test: - urweb -dbms sqlite -db $(TESTDB) -demo /Demo demo + bin/urweb -boot -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql demo/demo.exe & echo $$! > $(TESTPID) -- cgit v1.2.3 From 3b38c3e915e0ee658b6b4995432ee2fe3ff984f4 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Thu, 6 Aug 2015 10:15:53 -0400 Subject: Make OpenSSL usage thread-safe (closes #206) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Enable OpenSSL’s multithreading support by defining locking and thread-ID callbacks. Remove a lock obviated by this change. --- src/c/openssl.c | 40 ++++++++++++++++++++++++++++++++++++++++ src/c/urweb.c | 5 ----- 2 files changed, 40 insertions(+), 5 deletions(-) diff --git a/src/c/openssl.c b/src/c/openssl.c index 1d820a34..6d018707 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -1,5 +1,6 @@ #include "config.h" +#include #include #include #include @@ -7,12 +8,17 @@ #include #include #include +#include +#include #include #include #define PASSSIZE 4 +// OpenSSL locks array. See threads(3SSL). +static pthread_mutex_t *openssl_locks; + int uw_hash_blocksize = 32; static int password[PASSSIZE]; @@ -27,7 +33,41 @@ static void random_password() { } } +// OpenSSL callbacks +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_numeric(result, pthread_self()); +} +static void lock_or_unlock(const int mode, const int type, const char *file, + const int line) { + pthread_mutex_t *const lock = &openssl_locks[type]; + if (mode & CRYPTO_LOCK) { + if (pthread_mutex_lock(lock)) { + fprintf(stderr, "Can't take lock at %s:%d\n", file, line); + exit(1); + } + } else { + if (pthread_mutex_unlock(lock)) { + fprintf(stderr, "Can't release lock at %s:%d\n", file, line); + exit(1); + } + } +} + void uw_init_crypto() { + int i; + // Set up OpenSSL. + assert(openssl_locks == NULL); + openssl_locks = malloc(CRYPTO_num_locks() * sizeof(pthread_mutex_t)); + if (!openssl_locks) { + perror("malloc"); + exit(1); + } + for (i = 0; i < CRYPTO_num_locks(); ++i) { + pthread_mutex_init(&(openssl_locks[i]), NULL); + } + CRYPTO_THREADID_set_callback(thread_id); + CRYPTO_set_locking_callback(lock_or_unlock); + // Prepare signatures. if (uw_sig_file) { int fd; diff --git a/src/c/urweb.c b/src/c/urweb.c index 1e49dae0..6d3836f1 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -167,13 +167,8 @@ void *uw_init_client_data(); void uw_free_client_data(void *); void uw_copy_client_data(void *dst, void *src); -static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; - static uw_Basis_int my_rand() { - pthread_mutex_lock(&rand_mutex); int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); - pthread_mutex_unlock(&rand_mutex); - if (r) return abs(ret); else -- cgit v1.2.3 From 0c86ae16578d458d8b55a4546f16caba60b744d6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Aug 2015 12:51:09 -0400 Subject: Add '-noEmacs' for 'make test' --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 3c2e4e0d..ab11999e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -119,7 +119,7 @@ TESTDB = /tmp/urweb.db TESTPID = /tmp/urweb.pid test: - bin/urweb -boot -dbms sqlite -db $(TESTDB) -demo /Demo demo + bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql demo/demo.exe & echo $$! > $(TESTPID) -- cgit v1.2.3 From df2b273877a4d40baa37bdb45b40169d2d525fd3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Aug 2015 11:14:09 -0400 Subject: Fix termination bug in tutorial's isEven/isOdd --- doc/intro.ur | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/doc/intro.ur b/doc/intro.ur index 770b7b06..b08e2395 100644 --- a/doc/intro.ur +++ b/doc/intro.ur @@ -58,12 +58,15 @@ fun fact n = if n = 0 then 1 else n * fact (n - 1) fact 5 (* end *) -fun isEven n = n = 0 || isOdd (n - 1) -and isOdd n = n = 1 || isEven (n - 1) +fun isEven n = n = 0 || (n > 1 && isOdd (n - 1)) +and isOdd n = n = 1 || (n > 1 && isEven (n - 1)) (* begin eval *) isEven 32 (* end *) +(* begin eval *) +isEven 31 +(* end *) (* Of course we have anonymous functions, too. *) -- cgit v1.2.3 From ac2a4492e6e9447a1813e984910136b78978979c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Aug 2015 08:10:20 -0400 Subject: Add LIKE to the manual --- doc/manual.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index e140fac1..5c5e5cbb 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2314,7 +2314,7 @@ $$\begin{array}{rrcll} &&& (E) & \textrm{explicit precedence} \\ \textrm{Nullary operators} & n &::=& \mt{CURRENT\_TIMESTAMP} \\ \textrm{Unary operators} & u &::=& \mt{NOT} \\ - \textrm{Binary operators} & b &::=& \mt{AND} \mid \mt{OR} \mid = \mid \neq \mid < \mid \leq \mid > \mid \geq \\ + \textrm{Binary operators} & b &::=& \mt{AND} \mid \mt{OR} \mid = \mid \neq \mid < \mid \leq \mid > \mid \geq \mid \mt{LIKE} \\ \textrm{Aggregate functions} & a &::=& \mt{COUNT} \mid \mt{AVG} \mid \mt{SUM} \mid \mt{MIN} \mid \mt{MAX} \\ \textrm{Directions} & o &::=& \mt{ASC} \mid \mt{DESC} \mid \{e\} \\ \textrm{SQL integer} & N &::=& n \mid \{e\} \\ -- cgit v1.2.3 From fb6e6599b35df9cfa05786772868b1a3d2e58ac3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 19 Aug 2015 10:32:11 -0400 Subject: New release --- CHANGELOG | 11 +++++++++++ configure.ac | 4 ++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 838da410..02e9d754 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +======== +20150819 +======== + +- Allow mouse and key events for +- Add HTML 'align' attribute +- Add onChange handler to radioOption +- New literal [_LOC_] that is replaced with textual information on location in source file +- Add a simple 'make test' target +- Bug fixes and documentation improvements + ======== 20150520 ======== diff --git a/configure.ac b/configure.ac index f471eef7..b199cd29 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20150520]) -WORKING_VERSION=1 +AC_INIT([urweb], [20150819]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3