'urweb daemon start' and 'urweb daemon stop'

14 files changed, 304 insertions, 154 deletions

diff --git a/Makefile.am b/Makefile.am
index 42e5d4d7..98d1ca11 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -75,7 +75,7 @@ endif
 
 install-exec-local-main:
 	mkdir -p $(DESTDIR)$(BIN)
-	cp bin/urweb $(DESTDIR)$(BIN)/
+	install bin/urweb $(DESTDIR)$(BIN)/
 	mkdir -p $(DESTDIR)$(LIB_UR)
 	cp lib/ur/*.urs $(DESTDIR)$(LIB_UR)/
 	cp lib/ur/*.ur $(DESTDIR)$(LIB_UR)/
diff --git a/Makefile.in b/Makefile.in
index 332db7f5..fe487127 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -822,7 +822,7 @@ install-exec-emacs:
 
 install-exec-local-main:
 	mkdir -p $(DESTDIR)$(BIN)
-	cp bin/urweb $(DESTDIR)$(BIN)/
+	install bin/urweb $(DESTDIR)$(BIN)/
 	mkdir -p $(DESTDIR)$(LIB_UR)
 	cp lib/ur/*.urs $(DESTDIR)$(LIB_UR)/
 	cp lib/ur/*.ur $(DESTDIR)$(LIB_UR)/
diff --git a/doc/manual.tex b/doc/manual.tex
index 8b44e078..41e07a52 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -211,6 +211,18 @@ urweb -css P
 \end{verbatim}
 The first output line is a list of categories of CSS properties that would be worth setting on the document body.  The remaining lines are space-separated pairs of CSS class names and categories of properties that would be worth setting for that class.  The category codes are divided into two varieties.  Codes that reveal properties of a tag or its (recursive) children are \cd{B} for block-level elements, \cd{C} for table captions, \cd{D} for table cells, \cd{L} for lists, and \cd{T} for tables.  Codes that reveal properties of the precise tag that uses a class are \cd{b} for block-level elements, \cd{t} for tables, \cd{d} for table cells, \cd{-} for table rows, \cd{H} for the possibility to set a height, \cd{N} for non-replaced inline-level elements, \cd{R} for replaced inline elements, and \cd{W} for the possibility to set a width.
 
+Ur/Web type inference can take a significant amount of time, so it can be helpful to cache type-inferred versions of source files.  This mode can be activated by running
+\begin{verbatim}
+urweb daemon start
+\end{verbatim}
+Further \cd{urweb} invocations in the same working directory will send requests to a background daemon process that reuses type inference results whenever possible, tracking source file dependencies and modification times.  To stop the background daemon, run
+\begin{verbatim}
+urweb daemon stop
+\end{verbatim}
+Communication happens via a UNIX domain socket in file \cd{.urweb\_daemon} in the working directory.
+
+\medskip
+
 Some other command-line parameters are accepted:
 \begin{itemize}
 \item \texttt{-db <DBSTRING>}: Set database connection information, using the format expected by Postgres's \texttt{PQconnectdb()}, which is \texttt{name1=value1 ... nameN=valueN}.  The same format is also parsed and used to discover connection parameters for MySQL and SQLite.  The only significant settings for MySQL are \texttt{host}, \texttt{hostaddr}, \texttt{port}, \texttt{dbname}, \texttt{user}, and \texttt{password}.  The only significant setting for SQLite is \texttt{dbname}, which is interpreted as the filesystem path to the database.  Additionally, when using SQLite, a database string may be just a file path.
diff --git a/src/compiler.sml b/src/compiler.sml
index c30c2a04..575d95c7 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -917,7 +917,7 @@ val parse = {
                           val sgn = (Source.SgnConst (#func parseUrs urs), loc)
                       in
                           checkErrors ();
-                          (Source.DFfiStr (mname, sgn, OS.FileSys.modTime urs), loc)
+                          (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc)
                       end
 
                   val defed = ref SS.empty
@@ -944,7 +944,8 @@ val parse = {
                                      last = ErrorMsg.dummyPos}
 
                           val ds = #func parseUr ur
-                          val d = (Source.DStr (mname, sgnO, SOME (OS.FileSys.modTime ur), (Source.StrConst ds, loc)), loc)
+                          val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (OS.FileSys.modTime ur) else NONE,
+                                                (Source.StrConst ds, loc)), loc)
 
                           val fname = OS.Path.mkCanonical fname
                           val d = case List.find (fn (root, name) =>
diff --git a/src/elaborate.sig b/src/elaborate.sig
index db325340..18e6c3b4 100644
--- a/src/elaborate.sig
+++ b/src/elaborate.sig
@@ -41,4 +41,6 @@ signature ELABORATE = sig
     (* Run all phases of type inference, even if an error is detected by an
      * early phase. *)
 
+    val incremental : bool ref
+
 end
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c712ee2a..852ba2b2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -40,6 +40,7 @@
 
  val dumpTypes = ref false
  val unifyMore = ref false
+ val incremental = ref false
 
  structure IS = IntBinarySet
  structure IM = IntBinaryMap
@@ -3977,7 +3978,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                          ([dNew], (env', denv', gs' @ gs))
                      end)
 
-              | L.DFfiStr (x, sgn, tm) =>
+              | L.DFfiStr (x, sgn, tmo) =>
                 (case ModDb.lookup dAll of
                      SOME d =>
                      let
@@ -3994,7 +3995,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
 
                          val dNew = (L'.DFfiStr (x, n, sgn'), loc)
                      in
-                         ModDb.insert (dNew, tm);
+                         Option.map (fn tm => ModDb.insert (dNew, tm)) tmo;
                          ([dNew], (env', denv, enD gs' @ gs))
                      end)
 
@@ -4461,9 +4462,9 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
         val () = delayedUnifs := []
         val () = delayedExhaustives := []
 
-        val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), basis_tm), ErrorMsg.dummySpan)
+        val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan)
         val (basis_n, env', sgn) =
-            case ModDb.lookup d of
+            case (if !incremental then ModDb.lookup d else NONE) of
                 NONE =>
                 let
                     val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan)
@@ -4503,7 +4504,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
                          SOME (if Time.< (top_tm, basis_tm) then basis_tm else top_tm),
                          (L.StrConst topStr, ErrorMsg.dummySpan)), ErrorMsg.dummySpan)
         val (top_n, env', topSgn, topStr) =
-            case ModDb.lookup d of
+            case (if !incremental then ModDb.lookup d else NONE) of
                 NONE =>
                 let
                     val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 00cb40b0..9c18f727 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -25,147 +25,271 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *)
 
-val timing = ref false
-val tc = ref false
-val sources = ref ([] : string list)
-val demo = ref (NONE : (string * bool) option)
-val tutorial = ref false
-val css = ref false
-
-val () = Compiler.beforeC := MLton.GC.pack
-
-fun printVersion () = (print (Config.versionString ^ "\n");
-		       OS.Process.exit OS.Process.success)
-fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
-			      OS.Process.exit OS.Process.success)
-
-fun doArgs args =
-    case args of
-        [] => ()
-      | "-version" :: rest => 
-	printVersion ()
-      | "-numeric-version" :: rest =>
-	printNumericVersion ()
-      | "-css" :: rest =>
-        (css := true;
-         doArgs rest)
-      | "-demo" :: prefix :: rest =>
-        (demo := SOME (prefix, false);
-         doArgs rest)
-      | "-guided-demo" :: prefix :: rest =>
-        (demo := SOME (prefix, true);
-         doArgs rest)
-      | "-tutorial" :: rest =>
-        (tutorial := true;
-         doArgs rest)
-      | "-protocol" :: name :: rest =>
-        (Settings.setProtocol name;
-         doArgs rest)
-      | "-prefix" :: prefix :: rest =>
-        (Settings.setUrlPrefix prefix;
-         doArgs rest)
-      | "-db" :: s :: rest =>
-        (Settings.setDbstring (SOME s);
-         doArgs rest)
-      | "-dbms" :: name :: rest =>
-        (Settings.setDbms name;
-         doArgs rest)
-      | "-debug" :: rest =>
-        (Settings.setDebug true;
-         doArgs rest)
-      | "-verbose" :: rest =>
-        (Compiler.debug := true;
-         doArgs rest)
-      | "-timing" :: rest =>
-        (timing := true;
-         doArgs rest)
-      | "-tc" :: rest =>
-        (tc := true;
-         doArgs rest)
-      | "-dumpTypes" :: rest =>
-        (Elaborate.dumpTypes := true;
-         doArgs rest)
-      | "-unifyMore" :: rest =>
-        (Elaborate.unifyMore := true;
-         doArgs rest)
-      | "-dumpSource" :: rest =>
-        (Compiler.dumpSource := true;
-         doArgs rest)
-      | "-output" :: s :: rest =>
-        (Settings.setExe (SOME s);
-         doArgs rest)
-      | "-sql" :: s :: rest =>
-        (Settings.setSql (SOME s);
-         doArgs rest)
-      | "-static" :: rest =>
-        (Settings.setStaticLinking true;
-         doArgs rest)
-      | "-path" :: name :: path :: rest =>
-        (Compiler.addPath (name, path);
-         doArgs rest)
-      | "-root" :: name :: root :: rest =>
-        (Compiler.addModuleRoot (root, name);
-         doArgs rest)
-      | "-sigfile" :: name :: rest =>
-        (Settings.setSigFile (SOME name);
-         doArgs rest)
-      | "-iflow" :: rest =>
-        (Compiler.doIflow := true;
-         doArgs rest)
-      | "-moduleOf" :: fname :: _ =>
-        (print (Compiler.moduleOf fname ^ "\n");
-         OS.Process.exit OS.Process.success)
-      | "-noEmacs" :: rest =>
-        (Demo.noEmacs := true;
-         doArgs rest)
-      | "-limit" :: class :: num :: rest =>
-        (case Int.fromString num of
-             NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
-           | SOME n =>
-             if n < 0 then
-                 raise Fail ("Invalid limit number '" ^ num ^ "'")
-             else
-                 Settings.addLimit (class, n);
-         doArgs rest)
-      | arg :: rest =>
-        (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
-             raise Fail ("Unknown flag " ^ arg)
-         else
-             sources := arg :: !sources;
-         doArgs rest)
-
-val () = doArgs (CommandLine.arguments ())
-
-val job =
-    case !sources of
-        [file] => file
-      | _ => printVersion ()
-
-val () =
-    case (!css, !demo, !tutorial) of
-        (true, _, _) =>
-        (case Compiler.run Compiler.toCss job of
-             NONE => OS.Process.exit OS.Process.failure
-           | SOME {Overall = ov, Classes = cl} =>
-             (app (print o Css.inheritableToString) ov;
-              print "\n";
-              app (fn (x, (ins, ots)) =>
-                      (print x;
-                       print " ";
-                       app (print o Css.inheritableToString) ins;
-                       app (print o Css.othersToString) ots;
-                       print "\n")) cl))
-      | (_, SOME (prefix, guided), _) =>
-        Demo.make {prefix = prefix, dirname = job, guided = guided}
-      | (_, _, true) => Tutorial.make job
-      | _ =>
-        if !tc then
-            (Compiler.check Compiler.toElaborate job;
-             if ErrorMsg.anyErrors () then
-                 OS.Process.exit OS.Process.failure
-             else
-                 ())
-        else if !timing then
-            Compiler.time Compiler.toCjrize job
+val socket = ".urweb_daemon"
+
+(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
+
+exception Code of OS.Process.status
+
+fun oneRun args =
+    let
+        val timing = ref false
+        val tc = ref false
+        val sources = ref ([] : string list)
+        val demo = ref (NONE : (string * bool) option)
+        val tutorial = ref false
+        val css = ref false
+
+        val () = (Compiler.debug := false;
+                  Elaborate.dumpTypes := false;
+                  Elaborate.unifyMore := false;
+                  Compiler.dumpSource := false;
+                  Compiler.doIflow := false;
+                  Demo.noEmacs := false;
+                  Settings.setDebug false)
+
+        val () = Compiler.beforeC := MLton.GC.pack
+
+        fun printVersion () = (print (Config.versionString ^ "\n");
+		               raise Code OS.Process.success)
+        fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
+			              raise Code OS.Process.success)
+
+        fun doArgs args =
+            case args of
+                [] => ()
+              | "-version" :: rest => 
+	        printVersion ()
+              | "-numeric-version" :: rest =>
+	        printNumericVersion ()
+              | "-css" :: rest =>
+                (css := true;
+                 doArgs rest)
+              | "-demo" :: prefix :: rest =>
+                (demo := SOME (prefix, false);
+                 doArgs rest)
+              | "-guided-demo" :: prefix :: rest =>
+                (demo := SOME (prefix, true);
+                 doArgs rest)
+              | "-tutorial" :: rest =>
+                (tutorial := true;
+                 doArgs rest)
+              | "-protocol" :: name :: rest =>
+                (Settings.setProtocol name;
+                 doArgs rest)
+              | "-prefix" :: prefix :: rest =>
+                (Settings.setUrlPrefix prefix;
+                 doArgs rest)
+              | "-db" :: s :: rest =>
+                (Settings.setDbstring (SOME s);
+                 doArgs rest)
+              | "-dbms" :: name :: rest =>
+                (Settings.setDbms name;
+                 doArgs rest)
+              | "-debug" :: rest =>
+                (Settings.setDebug true;
+                 doArgs rest)
+              | "-verbose" :: rest =>
+                (Compiler.debug := true;
+                 doArgs rest)
+              | "-timing" :: rest =>
+                (timing := true;
+                 doArgs rest)
+              | "-tc" :: rest =>
+                (tc := true;
+                 doArgs rest)
+              | "-dumpTypes" :: rest =>
+                (Elaborate.dumpTypes := true;
+                 doArgs rest)
+              | "-unifyMore" :: rest =>
+                (Elaborate.unifyMore := true;
+                 doArgs rest)
+              | "-dumpSource" :: rest =>
+                (Compiler.dumpSource := true;
+                 doArgs rest)
+              | "-output" :: s :: rest =>
+                (Settings.setExe (SOME s);
+                 doArgs rest)
+              | "-sql" :: s :: rest =>
+                (Settings.setSql (SOME s);
+                 doArgs rest)
+              | "-static" :: rest =>
+                (Settings.setStaticLinking true;
+                 doArgs rest)
+              | "-path" :: name :: path :: rest =>
+                (Compiler.addPath (name, path);
+                 doArgs rest)
+              | "-root" :: name :: root :: rest =>
+                (Compiler.addModuleRoot (root, name);
+                 doArgs rest)
+              | "-sigfile" :: name :: rest =>
+                (Settings.setSigFile (SOME name);
+                 doArgs rest)
+              | "-iflow" :: rest =>
+                (Compiler.doIflow := true;
+                 doArgs rest)
+              | "-moduleOf" :: fname :: _ =>
+                (print (Compiler.moduleOf fname ^ "\n");
+                 raise Code OS.Process.success)
+              | "-noEmacs" :: rest =>
+                (Demo.noEmacs := true;
+                 doArgs rest)
+              | "-limit" :: class :: num :: rest =>
+                (case Int.fromString num of
+                     NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
+                   | SOME n =>
+                     if n < 0 then
+                         raise Fail ("Invalid limit number '" ^ num ^ "'")
+                     else
+                         Settings.addLimit (class, n);
+                 doArgs rest)
+              | arg :: rest =>
+                (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
+                     raise Fail ("Unknown flag " ^ arg)
+                 else
+                     sources := arg :: !sources;
+                 doArgs rest)
+
+        val () = case args of
+                     ["daemon", "stop"] => OS.Process.exit OS.Process.success
+                   | _ => ()
+
+        val () = doArgs args
+
+        val job =
+            case !sources of
+                [file] => file
+              | _ => printVersion ()
+    in
+        case (!css, !demo, !tutorial) of
+            (true, _, _) =>
+            (case Compiler.run Compiler.toCss job of
+                 NONE => OS.Process.failure
+               | SOME {Overall = ov, Classes = cl} =>
+                 (app (print o Css.inheritableToString) ov;
+                  print "\n";
+                  app (fn (x, (ins, ots)) =>
+                          (print x;
+                           print " ";
+                           app (print o Css.inheritableToString) ins;
+                           app (print o Css.othersToString) ots;
+                           print "\n")) cl;
+                  OS.Process.success))
+          | (_, SOME (prefix, guided), _) =>
+            if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
+                OS.Process.success
+            else
+                OS.Process.failure
+          | (_, _, true) => (Tutorial.make job;
+                             OS.Process.success)
+          | _ =>
+            if !tc then
+                (Compiler.check Compiler.toElaborate job;
+                 if ErrorMsg.anyErrors () then
+                     OS.Process.failure
+                 else
+                     OS.Process.success)
+            else if !timing then
+                (Compiler.time Compiler.toCjrize job;
+                 OS.Process.success)
+            else
+                (if Compiler.compile job then
+                     OS.Process.success
+                 else
+                     OS.Process.failure)
+    end handle Code n => n
+
+fun send (sock, s) =
+    let
+        val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
+    in
+        if n >= size s then
+            ()
         else
-            Compiler.compiler job
+            send (sock, String.extract (s, n, NONE))
+    end
+
+val () = case CommandLine.arguments () of
+             ["daemon", "start"] =>
+             (case Posix.Process.fork () of
+                  SOME _ => ()
+                | NONE =>
+                  let
+                      val () = Elaborate.incremental := true
+                      val listen = UnixSock.Strm.socket ()
+
+                      fun loop () =
+                          let
+                              val (sock, _) = Socket.accept listen
+
+                              fun loop' (buf, args) =
+                                  let
+                                      val s = if CharVector.exists (fn ch => ch = #"\n") buf then
+                                                  ""
+                                              else
+                                                  Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
+                                      val s = buf ^ s
+                                      val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
+                                  in
+                                      if Substring.isEmpty after then
+                                          loop' (s, args)
+                                      else
+                                          let
+                                              val cmd = Substring.string befor
+                                              val rest = Substring.string (Substring.slice (after, 1, NONE))
+                                          in
+                                              case cmd of
+                                                  "" => send (sock, if OS.Process.isSuccess ((oneRun (rev args))
+                                                                                             handle ex => (print "unhandled exception:\n";
+                                                                                                           print (General.exnMessage ex ^ "\n");
+                                                                                                           OS.Process.failure)) then
+                                                                        "0"
+                                                                    else
+                                                                        "1")
+                                                | _ => loop' (rest, cmd :: args)
+                                          end
+                                  end handle OS.SysErr _ => ()
+                          in
+                              loop' ("", []);
+                              Socket.close sock;
+                              MLton.GC.pack ();
+                              loop ()
+                          end
+                  in
+                      OS.Process.atExit (fn () => OS.FileSys.remove socket);
+                      Socket.bind (listen, UnixSock.toAddr socket);
+                      Socket.listen (listen, 1);
+                      loop ()
+                  end)
+
+           | args =>
+             let
+                 val sock = UnixSock.Strm.socket ()
+
+                 fun wait () =
+                     let
+                         val v = Socket.recvVec (sock, 1)
+                     in
+                         if Vector.length v = 0 then
+                             OS.Process.failure
+                         else
+                             case chr (Word8.toInt (Vector.sub (v, 0))) of
+                                 #"0" => OS.Process.success
+                               | #"1" => OS.Process.failure
+                               | _ => raise Fail "Weird return code from daemon"
+                     end handle OS.SysErr _ => OS.Process.failure
+             in
+                 if Socket.connectNB (sock, UnixSock.toAddr socket)
+                    orelse not (List.null (#wrs (Socket.select {rds = [],
+                                                                wrs = [Socket.sockDesc sock],
+                                                                exs = [],
+                                                                timeout = SOME (Time.fromSeconds 1)}))) then
+                     (app (fn arg => send (sock, arg ^ "\n")) args;
+                      send (sock, "\n");
+                      OS.Process.exit (wait ()))
+                 else
+                     (OS.FileSys.remove socket;
+                      raise OS.SysErr ("", NONE))
+             end handle OS.SysErr _ => case args of
+                                           ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ())
+                                         | _ => OS.Process.exit (oneRun args)
diff --git a/src/mod_db.sml b/src/mod_db.sml
index ba9bcc3a..22c11183 100644
--- a/src/mod_db.sml
+++ b/src/mod_db.sml
@@ -131,7 +131,7 @@ fun lookup (d : Source.decl) =
                  SOME (#Decl r)
              else
                  NONE)
-      | Source.DFfiStr (x, _, tm) =>
+      | Source.DFfiStr (x, _, SOME tm) =>
         (case SM.find (!byName, x) of
              NONE => NONE
            | SOME r =>
diff --git a/src/source.sml b/src/source.sml
index ce29904d..8b126628 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -155,7 +155,7 @@ datatype decl' =
        | DValRec of (string * con option * exp) list
        | DSgn of string * sgn
        | DStr of string * sgn option * Time.time option * str
-       | DFfiStr of string * sgn * Time.time
+       | DFfiStr of string * sgn * Time.time option
        | DOpen of string * string list
        | DConstraint of con * con
        | DOpenConstraints of string * string list
diff --git a/tests/dep.urp b/tests/dep.urp
new file mode 100644
index 00000000..074f1b07
--- /dev/null
+++ b/tests/dep.urp
@@ -0,0 +1,4 @@
+dep1
+dep2
+dep3
+dep4
diff --git a/tests/dep1.ur b/tests/dep1.ur
new file mode 100644
index 00000000..dd90c563
--- /dev/null
+++ b/tests/dep1.ur
@@ -0,0 +1 @@
+val x = "Hello world"
diff --git a/tests/dep2.ur b/tests/dep2.ur
new file mode 100644
index 00000000..62cf3215
--- /dev/null
+++ b/tests/dep2.ur
@@ -0,0 +1 @@
+val y = Dep1.x
diff --git a/tests/dep3.ur b/tests/dep3.ur
new file mode 100644
index 00000000..fab407ec
--- /dev/null
+++ b/tests/dep3.ur
@@ -0,0 +1 @@
+val y = Dep1.x ^ "?!"
diff --git a/tests/dep4.ur b/tests/dep4.ur
new file mode 100644
index 00000000..7985829c
--- /dev/null
+++ b/tests/dep4.ur
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+  {[Dep2.y]}!
+</body></xml>