diff options
author | Adam Chlipala <adam@chlipala.net> | 2017-08-11 19:38:43 -0400 |
---|---|---|
committer | Adam Chlipala <adam@chlipala.net> | 2017-08-11 19:38:43 -0400 |
commit | 4b7939d2fef1d8ef02ff761ade62cc220ab248cf (patch) | |
tree | e9a3811f6a763bd81522fff4a8d3c4631c4a34e7 | |
parent | 9fdb50d8ecc7782ae73472b9d943a24a304d0191 (diff) | |
parent | f814fd699dc707e810c996062370ee787863d926 (diff) |
Merge branch 'master' of ssh://hnf.impredicative.com:/home/adamc/git-root/urweb
-rw-r--r-- | CHANGELOG | 12 | ||||
-rw-r--r-- | Makefile.am | 4 | ||||
-rw-r--r-- | configure.ac | 4 | ||||
-rw-r--r-- | doc/manual.tex | 5 | ||||
-rw-r--r-- | src/c/http.c | 2 | ||||
-rw-r--r-- | src/c/static.c | 1 | ||||
-rw-r--r-- | src/compiler.sig | 1 | ||||
-rw-r--r-- | src/compiler.sml | 15 | ||||
-rw-r--r-- | src/demo.sml | 7 | ||||
-rw-r--r-- | src/elaborate.sml | 69 | ||||
-rw-r--r-- | src/settings.sig | 1 | ||||
-rw-r--r-- | src/settings.sml | 12 | ||||
-rw-r--r-- | src/source.sml | 2 | ||||
-rw-r--r-- | src/source_print.sml | 10 | ||||
-rw-r--r-- | src/urweb.grm | 44 | ||||
-rw-r--r-- | tests/topLevelPattern.ur | 5 |
16 files changed, 158 insertions, 36 deletions
@@ -1,4 +1,16 @@ ======== +20170720 +======== + +- New .urp directive: 'jsModule' +- New compiler command-line option: '-js' +- New HTML attribute for <button>: 'disabled' +- Allow inexhaustive patterns for lefthand sides of top-level 'val' declarations +- New standard-library functions: 'List.appi' and 'Option.app' +- Support for Emacs bg-build mode +- Bug fixes and improvements to error messages + +======== 20170105 ======== diff --git a/Makefile.am b/Makefile.am index 33bf4e7c..f0392de0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -123,7 +123,7 @@ test: bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo rm -f $(TESTDB) sqlite3 $(TESTDB) < demo/demo.sql - demo/demo.exe -a 127.0.0.1 & echo $$! > $(TESTPID) + demo/demo.exe -q -a 127.0.0.1 & 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) @@ -133,7 +133,7 @@ test: echo "Running IPv6 tests."; \ rm -f $(TESTDB); \ sqlite3 $(TESTDB) < demo/demo.sql; \ - demo/demo.exe -A ::1 & echo $$! > $(TESTPID); \ + demo/demo.exe -q -A ::1 & echo $$! > $(TESTPID); \ sleep 1; \ (curl -g -6 -s 'http://[::1]:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false); \ (curl -g -6 -s 'http://[::1]: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); \ diff --git a/configure.ac b/configure.ac index 5d0cd40f..5786c582 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20170105]) -WORKING_VERSION=1 +AC_INIT([urweb], [20170720]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it diff --git a/doc/manual.tex b/doc/manual.tex index f6d67f07..eaf7aab5 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -155,6 +155,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules. \item \texttt{jsFile FILENAME} asks to serve the contents of a file as JavaScript. All such content is concatenated into a single file, included via a \texttt{<script>} tag on every page that needs client-side scripting. \item \texttt{jsFunc Module.ident=name} gives the JavaScript name of an FFI value. +\item \texttt{jsModule Module} helps make \texttt{jsFunc} directives less verbose, by setting a module name to prefix in front of \texttt{name} arguments (so running e.g. \texttt{jsFunc MyFfi.foo=bar} actually sets up \texttt{Mod.bar} as the JavaScript name for that function, if \texttt{jsModule Mod} was run beforehand). \item \texttt{library FILENAME} parses \texttt{FILENAME.urp} and merges its contents with the rest of the current file's contents. If \texttt{FILENAME.urp} doesn't exist, the compiler also tries \texttt{FILENAME/lib.urp}. \item \texttt{limit class num} sets a resource usage limit for generated applications. The limit \texttt{class} will be set to the non-negative integer \texttt{num}. The classes are: \begin{itemize} @@ -554,7 +555,7 @@ $$\begin{array}{rrcll} &&& \_ & \textrm{wildcard} \\ &&& (e) & \textrm{explicit precedence} \\ \\ - \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ + \textrm{Local declarations} & ed &::=& \cd{val} \; p = e & \textrm{non-recursive value} \\ &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually recursive values} \\ \end{array}$$ @@ -565,7 +566,7 @@ $$\begin{array}{rrcll} \textrm{Declarations} & d &::=& \mt{con} \; x :: \kappa = c & \textrm{constructor synonym} \\ &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ &&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\ - &&& \mt{val} \; x : \tau = e & \textrm{value} \\ + &&& \mt{val} \; p = e & \textrm{value} \\ &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually recursive values} \\ &&& \mt{structure} \; X : S = M & \textrm{module definition} \\ &&& \mt{signature} \; X = S & \textrm{signature definition} \\ diff --git a/src/c/http.c b/src/c/http.c index b39520cc..21ad809f 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -359,7 +359,7 @@ int main(int argc, char *argv[]) { my_addr.sa.sa_family = AF_INET; my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP - while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:m:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option\n"); diff --git a/src/c/static.c b/src/c/static.c index 7f63d393..d70881e2 100644 --- a/src/c/static.c +++ b/src/c/static.c @@ -38,6 +38,7 @@ int main(int argc, char *argv[]) { fk = uw_begin(ctx, argv[1]); if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { + uw_commit(ctx); uw_print(ctx, 1); puts(""); return 0; diff --git a/src/compiler.sig b/src/compiler.sig index a4b3e562..952c7070 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -48,6 +48,7 @@ signature COMPILER = sig benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, diff --git a/src/compiler.sml b/src/compiler.sml index 3e08fcc6..c13de304 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -52,6 +52,7 @@ type job = { benignEffectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, + jsModule : string option, jsFuncs : (Settings.ffi * string) list, rewrites : Settings.rewrite list, filterUrl : Settings.rule list, @@ -273,7 +274,7 @@ val parseUr = { fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, - clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) = + clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let open Print.PD open Print @@ -312,6 +313,9 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, p_ffi "BenignEffectful" benignEffectful, p_ffi "ClientOnly" clientOnly, p_ffi "ServerOnly" serverOnly, + case jsModule of + NONE => string "No JavaScript FFI module" + | SOME m => string ("JavaScript FFI module: " ^ m), p_list_sep (box []) (fn ((m, s), s') => box [string "JsFunc", space, string m, string ".", string s, space, string "=", space, string s', newline]) jsFuncs, @@ -368,6 +372,7 @@ fun institutionalizeJob (job : job) = Settings.setBenignEffectful (#benignEffectful job); Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); + Settings.setJsModule (#jsModule job); Settings.setJsFuncs (#jsFuncs job); Settings.setRewriteRules (#rewrites job); Settings.setUrlRules (#filterUrl job); @@ -445,6 +450,7 @@ fun parseUrp' accLibs fname = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = [{pkind = Settings.Any, kind = Settings.Prefix, @@ -579,6 +585,7 @@ fun parseUrp' accLibs fname = val benignEffectful = ref [] val clientOnly = ref [] val serverOnly = ref [] + val jsModule = ref NONE val jsFuncs = ref [] val rewrites = ref [] val url = ref [] @@ -616,6 +623,7 @@ fun parseUrp' accLibs fname = benignEffectful = rev (!benignEffectful), clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), + jsModule = !jsModule, jsFuncs = rev (!jsFuncs), rewrites = rev (!rewrites), filterUrl = rev (!url), @@ -674,6 +682,7 @@ fun parseUrp' accLibs fname = benignEffectful = #benignEffectful old @ #benignEffectful new, clientOnly = #clientOnly old @ #clientOnly new, serverOnly = #serverOnly old @ #serverOnly new, + jsModule = #jsModule old, jsFuncs = #jsFuncs old @ #jsFuncs new, rewrites = #rewrites old @ #rewrites new, filterUrl = #filterUrl old @ #filterUrl new, @@ -809,6 +818,10 @@ fun parseUrp' accLibs fname = | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful | "clientOnly" => clientOnly := ffiS () :: !clientOnly | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsModule" => + (case !jsModule of + NONE => jsModule := SOME arg + | SOME _ => ()) | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs | "rewrite" => let diff --git a/src/demo.sml b/src/demo.sml index 47d22395..62b9037a 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -111,6 +111,7 @@ fun make' {prefix, dirname, guided} = benignEffectful = [], clientOnly = [], serverOnly = [], + jsModule = NONE, jsFuncs = [], rewrites = #rewrites combined @ #rewrites urp, filterUrl = #filterUrl combined @ #filterUrl urp, @@ -280,7 +281,7 @@ fun make' {prefix, dirname, guided} = val (urpData, out) = startUrp urp in finished (); - + SOME (readUrp (urpData, out)) end @@ -399,7 +400,7 @@ fun make' {prefix, dirname, guided} = case #kind rule of Settings.Exact => () | Settings.Prefix => TextIO.output (outf, "*"); - TextIO.output (outf, "\n"))) + TextIO.output (outf, "\n"))) in Option.app (fn db => (TextIO.output (outf, "database "); TextIO.output (outf, db); diff --git a/src/elaborate.sml b/src/elaborate.sml index 6965adfd..4a04d4bf 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2489,6 +2489,15 @@ fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) +fun patVarsOf (p : L.pat) = + case #1 p of + L.PVar x => [x] + | L.PPrim _ => [] + | L.PCon (_, _, NONE) => [] + | L.PCon (_, _, SOME p) => patVarsOf p + | L.PRecord (xps, _) => ListUtil.mapConcat (fn (_, p) => patVarsOf p) xps + | L.PAnnot (p', _) => patVarsOf p' + fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of NONE => (strError env (UnboundStr (loc, str)); @@ -3807,7 +3816,8 @@ and wildifyStr env (str, sgn) = foldl (fn ((d, _), nd) => case d of L.DCon (x, _, _) => ndelCon (nd, x) - | L.DVal (x, _, _) => ndelVal (nd, x) + | L.DVal (p, _) => + foldl (fn (x, nd) => ndelVal (nd, x)) nd (patVarsOf p) | L.DOpen _ => nempty | L.DStr (x, _, _, (L.StrConst ds', _), _) => (case SM.find (nmods nd, x) of @@ -3855,7 +3865,7 @@ and wildifyStr env (str, sgn) = | xs => let val ewild = (L.EWild, #2 str) - val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs + val ds'' = map (fn x => (L.DVal ((L.PVar x, #2 str), ewild), #2 str)) xs in ds'' @ ds' end @@ -4022,22 +4032,55 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([], (env, denv, []))) end) - | L.DVal (x, co, e) => + | L.DVal (p, e) => let - val (c', _, gs1) = case co of - NONE => (cunif env (loc, ktype), ktype, []) - | SOME c => elabCon (env, denv) c + val ((p', pt), (env', bound)) = elabPat (p, (env, SS.empty)) - val (e', et, gs2) = elabExp (env, denv) e + val (e', et, gs1) = elabExp (env, denv) e - val () = checkCon env e' et c' + val c' = normClassConstraint env et - val c' = normClassConstraint env c' - val (env', n) = E.pushENamed env x c' + fun singleVar (p : L.pat) = + case #1 p of + L.PVar x => SOME x + | L.PAnnot (p', _) => singleVar p' + | _ => NONE in - (*prefaces "DVal" [("x", Print.PD.string x), - ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs)) + unifyCons env loc et pt; + + (case exhaustive (env, et, [p'], loc) of + NONE => () + | SOME p => if !mayDelay then + delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives + else + expError env (Inexhaustive (loc, p))); + + case singleVar p of + SOME x => + let + val (env', n) = E.pushENamed env x et + in + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, gs1 @ gs)) + end + | NONE => + let + val (env', n) = E.pushENamed env "$tmp" et + val vars = SS.listItems bound + val (decls, env') = + ListUtil.foldlMap (fn (x, env') => + let + val e = (L.ECase ((L.EVar ([], "$tmp", L.Infer), loc), + [(p, (L.EVar ([], x, L.Infer), loc))]), loc) + val (e', t, _) = elabExp (env', denv) e + val (env', n) = E.pushENamed env' x t + in + ((L'.DVal (x, n, t, e'), loc), + env') + end) env' vars + in + ((L'.DVal ("$tmp", n, c', e'), loc) :: decls, + (env', denv, gs1 @ gs)) + end end | L.DValRec vis => let diff --git a/src/settings.sig b/src/settings.sig index 0ae81b13..256a12b5 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -96,6 +96,7 @@ signature SETTINGS = sig val isServerOnly : ffi -> bool (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) + val setJsModule : string option -> unit val setJsFuncs : (ffi * string) list -> unit val addJsFunc : ffi * string -> unit val jsFunc : ffi -> string option diff --git a/src/settings.sml b/src/settings.sml index 9fdc2232..a3263c06 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -346,7 +346,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("asin", "asin"), ("acos", "acos"), ("atan", "atan"), - ("atan2", "atan2"), + ("atan2", "atan2"), ("abs", "abs"), ("now", "now"), @@ -395,9 +395,15 @@ val jsFuncsBase = basisM [("alert", "alert"), ("htmlifySpecialChar", "htmlifySpecialChar"), ("chr", "chr")] val jsFuncs = ref jsFuncsBase -fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls +val jsModule = ref (NONE : string option) +fun setJsModule m = jsModule := m +fun jsFuncName f = + case !jsModule of + SOME m => m ^ "." ^ f + | NONE => f +fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) -fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v) fun allJsFuncs () = M.listItemsi (!jsFuncs) datatype pattern_kind = Exact | Prefix diff --git a/src/source.sml b/src/source.sml index 9971ca93..2d8c1ed3 100644 --- a/src/source.sml +++ b/src/source.sml @@ -157,7 +157,7 @@ datatype decl' = DCon of string * kind option * con | DDatatype of (string * string list * (string * con option) list) list | DDatatypeImp of string * string list * string - | DVal of string * con option * exp + | DVal of pat * exp | DValRec of (string * con option * exp) list | DSgn of string * sgn | DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *) diff --git a/src/source_print.sml b/src/source_print.sml index 7b657422..e18a82f9 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -560,9 +560,13 @@ fun p_decl ((d, _) : decl) = string "datatype", space, p_list_sep (string ".") string (ms @ [x'])] - | DVal vi => box [string "val", - space, - p_vali vi] + | DVal (p, e) => box [string "val", + space, + p_pat p, + space, + string "=", + space, + p_exp e] | DValRec vis => box [string "val", space, string "rec", diff --git a/src/urweb.grm b/src/urweb.grm index db5473a6..afebff0a 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -490,7 +490,7 @@ fun patternOut (e : exp) = | earga of exp * con -> exp * con | eargs of exp * con -> exp * con | eargl of exp * con -> exp * con - | eargl2 of exp * con -> exp * con + | eargl2 of bool * (exp * con -> exp * con) | branch of pat * exp | branchs of (pat * exp) list @@ -622,7 +622,41 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let (case dargs of [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] | _ => raise Fail "Arguments specified for imported datatype") - | VAL vali ([(DVal vali, s (VALleft, valiright))]) + | VAL pat eargl2 copt EQ eexp (let + fun justVar (p : pat) = + case #1 p of + PVar x => SOME x + | PAnnot (p', _) => justVar p' + | _ => NONE + + val loc = s (VALleft, eexpright) + in + case justVar pat of + SOME x => + let + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + val (e, t) = #2 eargl2 (eexp, t) + val pat = + case #1 t of + CWild _ => pat + | _ => (PAnnot (pat, t), loc) + in + [(DVal (pat, e), loc)] + end + | NONE => + let + val pat = + case copt of + SOME t => (PAnnot (pat, t), loc) + | _ => pat + in + (if #1 eargl2 then + ErrorMsg.errorAt loc "Additional arguments not allowed after pattern" + else + ()); + [(DVal (pat, eexp), loc)] + end + end) | VAL REC valis ([(DValRec valis, s (VALleft, valisright))]) | FUN valis ([(DValRec valis, s (FUNleft, valisright))]) @@ -695,7 +729,7 @@ vali : SYMBOL eargl2 copt EQ eexp (let val loc = s (SYMBOLleft, eexpright) val t = Option.getOpt (copt, (CWild (KType, loc), loc)) - val (e, t) = eargl2 (eexp, t) + val (e, t) = #2 eargl2 (eexp, t) in (SYMBOL, SOME t, e) end) @@ -1279,8 +1313,8 @@ eargs : earg (earg) eargl : eargp eargp (eargp1 o eargp2) | eargp eargl (eargp o eargl) -eargl2 : (fn x => x) - | eargp eargl2 (eargp o eargl2) +eargl2 : (false, fn x => x) + | eargp eargl2 (true, eargp o #2 eargl2) earg : patS (fn (e, t) => let diff --git a/tests/topLevelPattern.ur b/tests/topLevelPattern.ur new file mode 100644 index 00000000..e272c30c --- /dev/null +++ b/tests/topLevelPattern.ur @@ -0,0 +1,5 @@ +val (x, y) = (1, 2) + +fun main () : transaction page = return <xml> + {[x]} + {[y]} = {[x + y]} +</xml> |