summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Benjamin Barenblat <bbaren@mit.edu>2015-11-22 10:39:36 -0500
committerGravatar Benjamin Barenblat <bbaren@mit.edu>2015-11-22 10:39:36 -0500
commitbf037ce78c2c76a34ecca0fb8bafa5d5be38968a (patch)
tree3e91b0d0e8e0fb704c7df444283b6c8c63351f95
parent7d861ea0debf944cb8e3e38d73a8c0197de574b3 (diff)
parent638e838a81e1ccc6594fda1920df441eb21577ae (diff)
Merge branch 'upstream' into dfsg_clean20151122+dfsg
Diffstat
-rw-r--r--CHANGELOG9
-rw-r--r--configure.ac2
-rw-r--r--include/urweb/urweb_cpp.h1
-rw-r--r--lib/js/urweb.js21
-rw-r--r--lib/ur/basis.urs4
-rw-r--r--lib/ur/monad.ur9
-rw-r--r--lib/ur/monad.urs6
-rw-r--r--src/c/urweb.c8
-rw-r--r--src/compiler.sml6
-rw-r--r--src/elab.sml8
-rw-r--r--src/elab_env.sml14
-rw-r--r--src/elab_print.sml14
-rw-r--r--src/elab_util.sml8
-rw-r--r--src/elaborate.sml51
-rw-r--r--src/elisp/urweb-mode.el6
-rw-r--r--src/explify.sml2
-rw-r--r--src/main.mlton.sml35
-rw-r--r--src/monoize.sml39
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml57
20 files changed, 223 insertions, 81 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 1e87b778..e3e69f57 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,13 @@
========
+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 ee76f9ee..6a2b328e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-AC_INIT([urweb], [20151018])
+AC_INIT([urweb], [20151122])
WORKING_VERSION=0
AC_USE_SYSTEM_EXTENSIONS
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..6cf8a3f3 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;
}
@@ -468,8 +472,11 @@ function onConnectFail(f) {
connectHandlers = cons(flift(f), connectHandlers);
}
-function conn() {
- runHandlers("Connect", connectHandlers, null);
+function conn(msg) {
+ var rx = /(.*)<body>((.|\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;
@@ -1468,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
@@ -1591,7 +1606,7 @@ function rc(prefix, uri, parse, k, needsSig, isN) {
}
} else {
if (isN == null)
- conn();
+ conn(xhr.responseText);
else
k(null);
}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ec6ef599..a4872c32 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
@@ -553,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/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)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index d656ae03..169152dc 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) {
@@ -4063,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/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/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 ca4e124c..7671f597 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
@@ -2480,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' =>
@@ -2493,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
@@ -2694,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) =>
@@ -2813,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
@@ -2864,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' =>
@@ -2913,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
@@ -2986,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
@@ -3032,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) =>
@@ -3343,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
@@ -3748,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)
@@ -4495,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
@@ -4503,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) =>
@@ -4609,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
@@ -4618,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")
@@ -5000,11 +5013,13 @@ 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)
:: ds' @ file
end
+ handle e => (ModDb.revert ();
+ raise e)
end
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"
"\\<urweb-mode-map>Major mode for editing Ur/Web code.
This mode runs `urweb-mode-hook' just before exiting.
\\{urweb-mode-map}"
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)
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/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)
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 10a4af48..8300d621 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"),
@@ -375,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)
@@ -722,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)
@@ -880,7 +879,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 ^ ")")
@@ -904,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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 17:18:44 +0000