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(+) (limited to 'lib') 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 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(+) (limited to 'lib') 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(-) (limited to 'lib') 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(-) (limited to 'lib') 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 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(-) (limited to 'lib') 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