From 4b2f27492da41c685518fc1ca60e3d1395fce805 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Oct 2015 10:50:59 -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 ee76f9ee..451fee29 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20151018]) -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 1039ca399237c1db17b072655084e71a61727d00 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Oct 2015 14:38:20 -0400 Subject: Grandfathered into release: make urweb-mode keep working in Emacs 23 --- configure.ac | 2 +- src/elisp/urweb-mode.el | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 451fee29..ee76f9ee 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20151018]) -WORKING_VERSION=1 +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index db08e1e0..bc71a052 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -377,7 +377,11 @@ See doc for the variable `urweb-mode-info'." (add-to-list 'auto-mode-alist '("\\.urs?\\'" . urweb-mode)) ;;;###autoload -(define-derived-mode urweb-mode prog-mode "Ur/Web" +(defalias 'urweb-mode-derived-from + (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode)) + +;;;###autoload +(define-derived-mode urweb-mode urweb-mode-derived-from "Ur/Web" "\\Major mode for editing Ur/Web code. This mode runs `urweb-mode-hook' just before exiting. \\{urweb-mode-map}" -- cgit v1.2.3 From 0ecdb977493fdb88f0fd8d219448e22f55cf3ddd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Oct 2015 14:46:50 -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 ee76f9ee..451fee29 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20151018]) -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 f85797e259e4aa8f06cac98034fb0a20334b9374 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Oct 2015 16:03:56 -0400 Subject: Allow duplicate 'file' directives if paths normalize to same value --- src/settings.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/settings.sml b/src/settings.sml index 10a4af48..bea26103 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -880,7 +880,7 @@ fun addFile {Uri, LoadFromFilename} = in case SM.find (!files, Uri) of SOME (path', _) => - if path' = path then + if OS.Path.mkCanonical path' = OS.Path.mkCanonical path then () else ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")") -- cgit v1.2.3 From 09d7f40a1030d01dd478e0c81769b6d96a1d1208 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 24 Oct 2015 17:23:07 -0400 Subject: More Elaborate work to avoid instantiating unification variables with out-of-scope regular variables --- src/elaborate.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index ca4e124c..1885345d 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -783,7 +783,8 @@ val sum = case c of - (L'.CRecord (_, xcs), _) => {fields = xcs, unifs = [], others = []} + (L'.CRecord (_, xcs), _) => {fields = map (fn (x, c) => (hnormCon env x, hnormCon env c)) xcs, + unifs = [], others = []} | (L'.CConcat (c1, c2), _) => let val s1 = recordSummary env c1 -- cgit v1.2.3 From 88e068e1815a30e7b4b1e7e7dc99cf171ab51c59 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 31 Oct 2015 11:49:30 -0400 Subject: Monad.mapR3 --- lib/ur/monad.ur | 9 +++++++++ lib/ur/monad.urs | 6 ++++++ 2 files changed, 15 insertions(+) diff --git a/lib/ur/monad.ur b/lib/ur/monad.ur index ab7742fe..8bff0133 100644 --- a/lib/ur/monad.ur +++ b/lib/ur/monad.ur @@ -81,6 +81,15 @@ fun mapR2 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type] [tr :: K - return (acc ++ {nm = v'})) {} +fun mapR3 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: K -> Type] + (f : nm :: Name -> t :: K -> tf1 t -> tf2 t -> tf3 t -> m (tr t)) = + @@foldR3 [m] _ [tf1] [tf2] [tf3] [fn r => $(map tr r)] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] (v1 : tf1 t) (v2 : tf2 t) (v3 : tf3 t) + (acc : $(map tr rest)) => + v' <- f [nm] [t] v1 v2 v3; + return (acc ++ {nm = v'})) + {} + fun foldMapR [K] [m] (_ : monad m) [tf :: K -> Type] [tf' :: K -> Type] [tr :: {K} -> Type] (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => diff --git a/lib/ur/monad.urs b/lib/ur/monad.urs index ce823f4a..8ca8d0a3 100644 --- a/lib/ur/monad.urs +++ b/lib/ur/monad.urs @@ -58,6 +58,12 @@ val mapR2 : K --> m ::: (Type -> Type) -> monad m -> (nm :: Name -> t :: K -> tf1 t -> tf2 t -> m (tr t)) -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> m ($(map tr r)) +val mapR3 : K --> m ::: (Type -> Type) -> monad m + -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) + -> tr :: (K -> Type) + -> (nm :: Name -> t :: K -> tf1 t -> tf2 t -> tf3 t -> m (tr t)) + -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> m ($(map tr r)) + val foldMapR : K --> m ::: (Type -> Type) -> monad m -> tf :: (K -> Type) -> tf' :: (K -> Type) -- cgit v1.2.3 From b3ca8155f59546e5e36277de08f1eeed1d541598 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 31 Oct 2015 19:21:05 -0400 Subject: Remove spurious failure about reopening database connection --- src/c/urweb.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index d656ae03..1ef6600c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -806,9 +806,6 @@ static void uw_try_reconnecting(uw_context ctx) { ctx->db = NULL; } ctx->app->db_init(ctx); - - if (!ctx->db) - uw_error(ctx, FATAL, "Error reopening database connection"); } void uw_try_reconnecting_and_restarting(uw_context ctx) { -- cgit v1.2.3 From 6fead9bd93c982e05fbb5f13e3c866b3acf3ba08 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Nov 2015 11:55:01 -0500 Subject: Basis.fromMilliseconds --- include/urweb/urweb_cpp.h | 1 + lib/js/urweb.js | 4 ++++ lib/ur/basis.urs | 1 + src/c/urweb.c | 5 +++++ src/settings.sml | 1 + 5 files changed, 12 insertions(+) diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index a371d8e8..5aa6ec69 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -273,6 +273,7 @@ uw_Basis_int uw_Basis_diffInSeconds(struct uw_context *, uw_Basis_time, uw_Basis uw_Basis_int uw_Basis_toSeconds(struct uw_context *, uw_Basis_time); uw_Basis_int uw_Basis_diffInMilliseconds(struct uw_context *, uw_Basis_time, uw_Basis_time); uw_Basis_int uw_Basis_toMilliseconds(struct uw_context *, uw_Basis_time); +uw_Basis_time uw_Basis_fromMilliseconds(struct uw_context *, uw_Basis_int); uw_Basis_time uw_Basis_fromDatetime(struct uw_context *, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int, uw_Basis_int); uw_Basis_int uw_Basis_datetimeYear(struct uw_context *, uw_Basis_time); uw_Basis_int uw_Basis_datetimeMonth(struct uw_context *, uw_Basis_time); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 335cb525..ac4e4c9e 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -149,6 +149,10 @@ function toMilliseconds(tm) { return Math.round(tm / 1000); } +function fromMilliseconds(tm) { + return tm * 1000; +} + function addSeconds(tm, n) { return tm + n * 1000000; } diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index ec6ef599..e4eaa0a9 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -163,6 +163,7 @@ val toSeconds : time -> int val diffInSeconds : time -> time -> int (* Earlier time first *) val toMilliseconds : time -> int +val fromMilliseconds : int -> time val diffInMilliseconds : time -> time -> int val timef : string -> time -> string (* Uses strftime() format string *) val readUtc : string -> option time diff --git a/src/c/urweb.c b/src/c/urweb.c index 1ef6600c..169152dc 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4060,6 +4060,11 @@ uw_Basis_int uw_Basis_toMilliseconds(uw_context ctx, uw_Basis_time tm) { return tm.seconds * 1000 + tm.microseconds / 1000; } +uw_Basis_time uw_Basis_fromMilliseconds(uw_context ctx, uw_Basis_int n) { + uw_Basis_time tm = {n / 1000, n % 1000 * 1000}; + return tm; +} + uw_Basis_int uw_Basis_diffInMilliseconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) { return uw_Basis_toMilliseconds(ctx, tm2) - uw_Basis_toMilliseconds(ctx, tm1); } diff --git a/src/settings.sml b/src/settings.sml index bea26103..0140ddc0 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -342,6 +342,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("addSeconds", "addSeconds"), ("diffInSeconds", "diffInSeconds"), ("toMilliseconds", "toMilliseconds"), + ("fromMilliseconds", "fromMilliseconds"), ("diffInMilliseconds", "diffInMilliseconds"), ("fromDatetime", "fromDatetime"), -- cgit v1.2.3 From 808afe59b97b345f05d16d1a99bbd24c466c8cbf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Nov 2015 12:23:44 -0500 Subject: Better client-side error messages for RPC failures --- lib/js/urweb.js | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index ac4e4c9e..45ed6be8 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -472,8 +472,11 @@ function onConnectFail(f) { connectHandlers = cons(flift(f), connectHandlers); } -function conn() { - runHandlers("Connect", connectHandlers, null); +function conn(msg) { + var rx = /(.*)((.|\n|\r)*)<\/body>(.*)/g; + var arr = rx.exec(msg); + msg = (arr && arr.length >= 3) ? arr[2] : msg; + runHandlers("RPC failure", connectHandlers, msg); } var serverHandlers = null; @@ -1595,7 +1598,7 @@ function rc(prefix, uri, parse, k, needsSig, isN) { } } else { if (isN == null) - conn(); + conn(xhr.responseText); else k(null); } -- cgit v1.2.3 From b16e75da8b5937914fb17852cd03127934bac08c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Nov 2015 14:17:09 -0500 Subject: JavaScript versions of a few more functions --- lib/js/urweb.js | 8 ++++++++ src/settings.sml | 5 ++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 45ed6be8..6cf8a3f3 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1475,6 +1475,14 @@ function strcmp(str1, str2) { return ((str1 == str2) ? 0 : ((str1 > str2) ? 1 : -1)); } +function chr(n) { + return String.fromCharCode(n); +} + +function htmlifySpecialChar(ch) { + return "&#" + ch.charCodeAt(0) + ";"; +} + // Remote calls diff --git a/src/settings.sml b/src/settings.sml index 0140ddc0..b021b587 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -376,7 +376,10 @@ val jsFuncsBase = basisM [("alert", "alert"), ("atom", "atom"), ("css_url", "css_url"), ("property", "property"), - ("giveFocus", "giveFocus")] + ("giveFocus", "giveFocus"), + + ("htmlifySpecialChar", "htmlifySpecialChar"), + ("chr", "chr")] val jsFuncs = ref jsFuncsBase fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) -- cgit v1.2.3 From 3772d0b752c4201c6ae1d00562ea0e80e46608ee Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Nov 2015 16:33:14 -0500 Subject: After a tricky debugging session, limit visibility of type-class instances from anonymous modules --- src/elab.sml | 8 +++++++- src/elab_env.sml | 14 +++++++------- src/elab_print.sml | 14 +++++++------- src/elab_util.sml | 8 ++++---- src/elaborate.sml | 46 +++++++++++++++++++++++++++++----------------- src/explify.sml | 2 +- 6 files changed, 55 insertions(+), 37 deletions(-) diff --git a/src/elab.sml b/src/elab.sml index 249531f1..209d3307 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -138,13 +138,19 @@ and edecl' = withtype exp = exp' located and edecl = edecl' located +(* We have to be careful about crawling automatically generated signatures recursively, + * importing all type-class instances that we find. + * The reason is that selfification will add signatures of anonymous structures, + * and it's counterintuitive for instances to escape anonymous structures! *) +datatype import_mode = Import | Skip + datatype sgn_item' = SgiConAbs of string * int * kind | SgiCon of string * int * kind * con | SgiDatatype of (string * int * string list * (string * int * con option) list) list | SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list | SgiVal of string * int * con - | SgiStr of string * int * sgn + | SgiStr of import_mode * string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con | SgiClassAbs of string * int * kind diff --git a/src/elab_env.sml b/src/elab_env.sml index 9fbe7bd7..9c9cd14f 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -990,7 +990,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiDatatypeImp (x, n, _, _, _, _, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiVal _ => (sgns, strs, cons) | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) - | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) + | SgiStr (_, x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) | SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) @@ -1143,13 +1143,13 @@ and hnormSgn env (all as (sgn, loc)) = else traverse (ms, sgi :: pre, rest) - | (sgi as (SgiStr (x', n, sgn'), loc)) :: rest => + | (sgi as (SgiStr (im, x', n, sgn'), loc)) :: rest => (case ms of [] => traverse (ms, sgi :: pre, rest) | x :: ms' => if x = x' then List.revAppend (pre, - (SgiStr (x', n, + (SgiStr (im, x', n, rewrite (sgn', ms')), loc) :: rest) else traverse (ms, sgi :: pre, rest)) @@ -1186,7 +1186,7 @@ fun enrichClasses env classes (m1, ms) sgn = fun default () = (classes, newClasses, sgiSeek (#1 sgi, fmap), env) in case #1 sgi of - SgiStr (x, _, sgn) => + SgiStr (Import, x, _, sgn) => let val str = manifest (m1, ms, #2 sgi) val sgn' = sgnSubSgn (str, fmap) sgn @@ -1360,7 +1360,7 @@ fun sgiBinds env (sgi, loc) = env xncs end | SgiVal (x, n, t) => pushENamedAs env x n t - | SgiStr (x, n, sgn) => pushStrNamedAs env x n sgn + | SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env @@ -1374,7 +1374,7 @@ fun sgnSubCon x = fun projectStr env {sgn, str, field} = case #1 (hnormSgn env sgn) of SgnConst sgis => - (case sgnSeek (fn SgiStr (x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of + (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of NONE => NONE | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) | SgnError => SOME (SgnError, ErrorMsg.dummySpan) @@ -1544,7 +1544,7 @@ fun sgnSeekConstraints (str, sgis) = | SgiDatatypeImp (x, n, _, _, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) - | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) + | SgiStr (_, x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) | SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) in diff --git a/src/elab_print.sml b/src/elab_print.sml index 957d4646..5a41883f 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -611,13 +611,13 @@ fun p_sgn_item env (sgiAll as (sgi, _)) = string ":", space, p_con env c] - | SgiStr (x, n, sgn) => box [string "structure", - space, - p_named x n, - space, - string ":", - space, - p_sgn env sgn] + | SgiStr (_, x, n, sgn) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] | SgiSgn (x, n, sgn) => box [string "signature", space, p_named x n, diff --git a/src/elab_util.sml b/src/elab_util.sml index fef55852..acc696dd 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -688,10 +688,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c, fn c' => (SgiVal (x, n, c'), loc)) - | SgiStr (x, n, s) => + | SgiStr (im, x, n, s) => S.map2 (sg ctx s, fn s' => - (SgiStr (x, n, s'), loc)) + (SgiStr (im, x, n, s'), loc)) | SgiSgn (x, n, s) => S.map2 (sg ctx s, fn s' => @@ -738,7 +738,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = bind (ctx, NamedC (x, n, (KType, loc), SOME (CModProj (m1, ms, s), loc))) | SgiVal _ => ctx - | SgiStr (x, n, sgn) => + | SgiStr (_, x, n, sgn) => bind (ctx, Str (x, n, sgn)) | SgiSgn (x, n, sgn) => bind (ctx, Sgn (x, n, sgn)) @@ -1270,7 +1270,7 @@ and maxNameSgi (sgi, _) = foldl (fn ((_, n', _), m) => Int.max (n', m)) (Int.max (n1, n2)) ns | SgiVal (_, n, _) => n - | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiStr (_, _, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 | SgiClassAbs (_, n, _) => n diff --git a/src/elaborate.sml b/src/elaborate.sml index 1885345d..c3e81b65 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2481,7 +2481,7 @@ fun dopenConstraints (loc, env, denv) {str, strs} = L'.SgnConst sgis => foldl (fn (sgi, cs) => case #1 sgi of - L'.SgiStr (x, _, _) => + L'.SgiStr (L'.Import, x, _, _) => (case E.projectStr env {sgn = sgn, str = st, field = x} of NONE => raise Fail "Elaborate: projectStr in collect" | SOME sgn' => @@ -2494,6 +2494,18 @@ fun dopenConstraints (loc, env, denv) {str, strs} = D.assert env denv (c1, c2)) denv (collect true (st, sgn)) end +fun tcdump env = + Print.preface("Instances", p_list_sep Print.PD.newline + (fn (cl, ls) => + box [p_con env cl, + box [Print.PD.string "{", + p_list (fn (t, e) => + box [p_exp env e, + Print.PD.string " : ", + p_con env t]) ls, + Print.PD.string "}"]]) + (E.listClasses env)) + fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ((*Print.preface ("elabSgi", SourcePrint.p_sgn_item (sgi, loc));*) case sgi of @@ -2695,7 +2707,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (env', n) = E.pushStrNamed env x sgn' val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} in - ([(L'.SgiStr (x, n, sgn'), loc)], (env', denv', gs' @ gs)) + ([(L'.SgiStr (L'.Import, x, n, sgn'), loc)], (env', denv', gs' @ gs)) end | L.SgiSgn (x, sgn) => @@ -2814,7 +2826,7 @@ and elabSgn (env, denv) (sgn, loc) = else (); (cons, vals, SS.add (sgns, x), strs)) - | L'.SgiStr (x, _, _) => + | L'.SgiStr (_, x, _, _) => (if SS.member (strs, x) then sgnError env (DuplicateStr (loc, x)) else @@ -2865,7 +2877,7 @@ and elabSgn (env, denv) (sgn, loc) = (unifyKinds env k ck handle KUnify x => sgnError env (WhereWrongKind x); true) - | (L'.SgiStr (x', _, sgn''), _) => + | (L'.SgiStr (_, x', _, sgn''), _) => (case ms of [] => false | m :: ms' => @@ -2914,8 +2926,8 @@ and selfify env {str, strs, sgn} = map (fn (x, n, xs, xncs) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts | (L'.SgiClassAbs (x, n, k), loc) => [(L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] - | (L'.SgiStr (x, n, sgn), loc) => - [(L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] + | (L'.SgiStr (im, x, n, sgn), loc) => + [(L'.SgiStr (im, x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] | x => [x], E.sgiBinds env sgi)) env sgis)), #2 sgn) | L'.SgnFun _ => sgn @@ -2987,7 +2999,7 @@ and dopen env {str, strs, sgn} = [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] else [] - | L'.SgiStr (x, n, sgn) => + | L'.SgiStr (_, x, n, sgn) => if isVisible x then [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] else @@ -3033,8 +3045,8 @@ and sgiOfDecl (d, loc) = | L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)] | L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis | L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)] - | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (x, n, sgn), loc)] - | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] + | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] + | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] | L'.DTable (tn, x, n, c, _, pc, _, cc) => @@ -3344,10 +3356,10 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = NONE | _ => NONE) - | L'.SgiStr (x, n2, sgn2) => + | L'.SgiStr (_, x, n2, sgn2) => seek (fn (env, sgi1All as (sgi1, loc)) => case sgi1 of - L'.SgiStr (x', n1, sgn1) => + L'.SgiStr (_, x', n1, sgn1) => if x = x' then let (* Don't forget to save & restore the @@ -3749,7 +3761,7 @@ and wildifyStr env (str, sgn) = else nd end - | L'.SgiStr (x, _, s) => + | L'.SgiStr (_, x, _, s) => (case #1 (hnormSgn env' s) of L'.SgnConst sgis' => naddMod (nd, x, (env', buildNeeded env' sgis')) | _ => nd) @@ -4496,7 +4508,7 @@ and elabStr (env, denv) (str, loc) = ((L'.SgiSgn (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end - | L'.SgiStr (x, n, sgn) => + | L'.SgiStr (im, x, n, sgn) => let val (strs, x) = if SS.member (strs, x) then @@ -4504,7 +4516,7 @@ and elabStr (env, denv) (str, loc) = else (SS.add (strs, x), x) in - ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiStr (im, x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) | L'.SgiClassAbs (x, n, k) => @@ -4610,7 +4622,7 @@ and elabStr (env, denv) (str, loc) = * question-mark identifiers generated previously by this * very code fragment. *) fun mungeName m = - if List.exists (fn (L'.SgiStr (x, _, _), _) => x = m + if List.exists (fn (L'.SgiStr (_, x, _, _), _) => x = m | _ => false) sgis then mungeName ("?" ^ m) else @@ -4619,7 +4631,7 @@ and elabStr (env, denv) (str, loc) = val m = mungeName m in ((L'.StrApp (str1', str2'), loc), - (L'.SgnConst ((L'.SgiStr (m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), + (L'.SgnConst ((L'.SgiStr (L'.Skip, m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), gs1 @ gs2) end | _ => raise Fail "Unable to hnormSgn in functor application") @@ -5001,7 +5013,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = (); (*Print.preface("File", ElabPrint.p_file env file);*) - + (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan) diff --git a/src/explify.sml b/src/explify.sml index fd0f3277..f38151d2 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -150,7 +150,7 @@ fun explifySgi (sgi, loc) = SOME (L'.SgiDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) => (x, n, Option.map explifyCon co)) xncs), loc) | L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc) - | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) + | L.SgiStr (_, x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE | L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc) -- cgit v1.2.3 From 736665b9b6975af4dbb3f68cec31fb75d77915f2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Nov 2015 17:02:16 -0500 Subject: Change behavior of SQL equality to do the intuitive thing for nullable types --- lib/ur/basis.urs | 3 +++ src/monoize.sml | 39 +++++++++++++++++++++++++++++++-------- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index e4eaa0a9..a4872c32 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -554,6 +554,9 @@ val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t val sql_mod : sql_binary int int int val sql_eq : t ::: Type -> sql_binary t t bool +(* Note that the semantics of this operator on nullable types are different than for standard SQL! + * Instead, we do it the sane way, where [NULL = NULL]. *) + val sql_ne : t ::: Type -> sql_binary t t bool val sql_lt : t ::: Type -> sql_binary t t bool val sql_le : t ::: Type -> sql_binary t t bool diff --git a/src/monoize.sml b/src/monoize.sml index 8934db2c..dd2c41c5 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2592,22 +2592,45 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), _), _), - _), _), + arg1), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) + + val default = strcat [str "(", + (L'.ERel 1, loc), + str " ", + (L'.ERel 2, loc), + str " ", + (L'.ERel 0, loc), + str ")"] + + val body = case #1 arg1 of + L.CApp ((L.CFfi ("Basis", "option"), _), _) => + (L'.ECase ((L'.ERel 2, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), + strcat [str "((", + (L'.ERel 1, loc), + str " ", + (L'.ERel 2, loc), + str " ", + (L'.ERel 0, loc), + str ") OR ((", + (L'.ERel 1, loc), + str ") IS NULL AND (", + (L'.ERel 0, loc), + str ") IS NULL))"]), + ((L'.PWild, loc), + default)], + {disc = s, + result = s}), loc) + | _ => default in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat [str "(", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ")"]), loc)), loc)), loc), + body), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_and") => (str "AND", fm) -- cgit v1.2.3 From deb89707754afa4caab231ca3b98764e6d695a3b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 22 Nov 2015 10:03:35 -0500 Subject: Make daemon mode support sharing of libraries across projects --- src/compiler.sml | 6 +----- src/elaborate.sml | 2 ++ src/main.mlton.sml | 35 ++++++++++++++++++++--------------- src/settings.sig | 4 ++++ src/settings.sml | 49 ++++++++++++++++++++++++++++++++++++++++++++----- 5 files changed, 71 insertions(+), 25 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 8f6d1fad..99f2ff31 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -413,11 +413,7 @@ fun inputCommentableLine inf = val lastUrp = ref "" fun parseUrp' accLibs fname = - (if !lastUrp = fname then - () - else - ModDb.reset (); - lastUrp := fname; + (lastUrp := fname; if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) andalso Posix.FileSys.access (fname ^ ".ur", []) then let diff --git a/src/elaborate.sml b/src/elaborate.sml index c3e81b65..7671f597 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -5019,5 +5019,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan) :: ds' @ file end + handle e => (ModDb.revert (); + raise e) end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfc18e59..7197babf 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -279,19 +279,25 @@ val () = case CommandLine.arguments () of in case cmd of "" => - let - val success = (oneRun (rev args)) - handle ex => (print "unhandled exception:\n"; - print (General.exnMessage ex ^ "\n"); - OS.Process.failure) - in - TextIO.flushOut TextIO.stdOut; - TextIO.flushOut TextIO.stdErr; - send (sock, if OS.Process.isSuccess success then - "\001" - else - "\002") - end + (case args of + ["stop", "daemon"] => + (((Socket.close listen; + OS.FileSys.remove socket) handle OS.SysErr _ => ()); + OS.Process.exit OS.Process.success) + | _ => + let + val success = (oneRun (rev args)) + handle ex => (print "unhandled exception:\n"; + print (General.exnMessage ex ^ "\n"); + OS.Process.failure) + in + TextIO.flushOut TextIO.stdOut; + TextIO.flushOut TextIO.stdErr; + send (sock, if OS.Process.isSuccess success then + "\001" + else + "\002") + end) | _ => loop' (rest, cmd :: args) end end handle OS.SysErr _ => () @@ -315,6 +321,7 @@ val () = case CommandLine.arguments () of Posix.IO.close oldStdout; Posix.IO.close oldStderr; + Settings.reset (); MLton.GC.pack (); loop () end @@ -324,8 +331,6 @@ val () = case CommandLine.arguments () of Socket.listen (listen, 1); loop () end) - | ["daemon", "stop"] => - (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success) | args => let val sock = UnixSock.Strm.socket () diff --git a/src/settings.sig b/src/settings.sig index 9b32e502..d918f0c5 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -27,6 +27,10 @@ signature SETTINGS = sig + (* Call this when compiling a new project, e.g. with the Ur/Web daemon or from the SML/NJ REPL. + * Some settings stay, but most are reset, especially files cached for the app to serve. *) + val reset : unit -> unit + (* XXX these should be unit -> string too *) val configBin : string ref val configLib : string ref diff --git a/src/settings.sml b/src/settings.sml index b021b587..8300d621 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -726,11 +726,6 @@ val minHeap = ref 0 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap" fun getMinHeap () = !minHeap -structure SS = BinarySetFn(struct - type ord_key = string - val compare = String.compare - end) - val alwaysInline = ref SS.empty fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s) fun checkAlwaysInline s = SS.member (!alwaysInline, s) @@ -908,4 +903,48 @@ fun addFile {Uri, LoadFromFilename} = fun listFiles () = map #2 (SM.listItems (!files)) +fun reset () = + (urlPrefixFull := "/"; + urlPrefix := "/"; + urlPrePrefix := ""; + timeout := 0; + headers := []; + scripts := []; + clientToServer := clientToServerBase; + effectful := effectfulBase; + benign := benignBase; + client := clientBase; + server := serverBase; + jsFuncs := jsFuncsBase; + rewrites := []; + url := []; + mime := []; + request := []; + response := []; + env := []; + debug := false; + dbstring := NONE; + exe := NONE; + sql := NONE; + coreInline := 5; + monoInline := 5; + staticLinking := false; + deadlines := false; + sigFile := NONE; + safeGet := SS.empty; + onError := NONE; + limitsList := []; + minHeap := 0; + alwaysInline := SS.empty; + neverInline := SS.empty; + noXsrfProtection := SS.empty; + timeFormat := "%c"; + mangle := true; + html5 := false; + less := false; + noMimeFile := false; + mimeTypes := NONE; + files := SM.empty; + filePath := ".") + end -- cgit v1.2.3 From 638e838a81e1ccc6594fda1920df441eb21577ae Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 22 Nov 2015 10:09:16 -0500 Subject: New release --- CHANGELOG | 9 +++++++++ configure.ac | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 1e87b778..e3e69f57 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +20151122 +======== + +- Daemon mode now supports shared caching of libraries across projects. +- Change behavior of SQL equality to do the intuitive thing for nullable types. +- Basis.fromMilliseconds +- Bug fixes and improvements to type inference and error messages + ======== 20151018 ======== diff --git a/configure.ac b/configure.ac index 451fee29..6a2b328e 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20151018]) -WORKING_VERSION=1 +AC_INIT([urweb], [20151122]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3