Mercurial > urweb
changeset 1733:ab24a7cb2a64
'urweb daemon start' and 'urweb daemon stop'
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 29 Apr 2012 16:23:03 -0400 |
| parents | 4a03aa3251cb |
| children | d2b3fada532e |
| files | Makefile.am Makefile.in doc/manual.tex src/compiler.sml src/elaborate.sig src/elaborate.sml src/main.mlton.sml src/mod_db.sml src/source.sml tests/dep.urp tests/dep1.ur tests/dep2.ur tests/dep3.ur tests/dep4.ur |
| diffstat | 14 files changed, 298 insertions(+), 148 deletions(-) [+] |
line wrap: on
line diff
--- a/Makefile.am Sun Apr 29 13:17:31 2012 -0400 +++ b/Makefile.am Sun Apr 29 16:23:03 2012 -0400 @@ -75,7 +75,7 @@ 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)/
--- a/Makefile.in Sun Apr 29 13:17:31 2012 -0400 +++ b/Makefile.in Sun Apr 29 16:23:03 2012 -0400 @@ -822,7 +822,7 @@ 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)/
--- a/doc/manual.tex Sun Apr 29 13:17:31 2012 -0400 +++ b/doc/manual.tex Sun Apr 29 16:23:03 2012 -0400 @@ -211,6 +211,18 @@ \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.
--- a/src/compiler.sml Sun Apr 29 13:17:31 2012 -0400 +++ b/src/compiler.sml Sun Apr 29 16:23:03 2012 -0400 @@ -917,7 +917,7 @@ 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 @@ 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) =>
--- a/src/elaborate.sig Sun Apr 29 13:17:31 2012 -0400 +++ b/src/elaborate.sig Sun Apr 29 16:23:03 2012 -0400 @@ -41,4 +41,6 @@ (* Run all phases of type inference, even if an error is detected by an * early phase. *) + val incremental : bool ref + end
--- a/src/elaborate.sml Sun Apr 29 13:17:31 2012 -0400 +++ b/src/elaborate.sml Sun Apr 29 16:23:03 2012 -0400 @@ -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 @@ ([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 @@ 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 @@ 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 @@ 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)
--- a/src/main.mlton.sml Sun Apr 29 13:17:31 2012 -0400 +++ b/src/main.mlton.sml Sun Apr 29 16:23:03 2012 -0400 @@ -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 socket = ".urweb_daemon" -val () = Compiler.beforeC := MLton.GC.pack +(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) -fun printVersion () = (print (Config.versionString ^ "\n"); - OS.Process.exit OS.Process.success) -fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); - OS.Process.exit OS.Process.success) +exception Code of OS.Process.status -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) +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 () = doArgs (CommandLine.arguments ()) + val () = (Compiler.debug := false; + Elaborate.dumpTypes := false; + Elaborate.unifyMore := false; + Compiler.dumpSource := false; + Compiler.doIflow := false; + Demo.noEmacs := false; + Settings.setDebug false) -val job = - case !sources of - [file] => file - | _ => printVersion () + val () = Compiler.beforeC := MLton.GC.pack -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 + 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)
--- a/src/mod_db.sml Sun Apr 29 13:17:31 2012 -0400 +++ b/src/mod_db.sml Sun Apr 29 16:23:03 2012 -0400 @@ -131,7 +131,7 @@ SOME (#Decl r) else NONE) - | Source.DFfiStr (x, _, tm) => + | Source.DFfiStr (x, _, SOME tm) => (case SM.find (!byName, x) of NONE => NONE | SOME r =>
--- a/src/source.sml Sun Apr 29 13:17:31 2012 -0400 +++ b/src/source.sml Sun Apr 29 16:23:03 2012 -0400 @@ -155,7 +155,7 @@ | 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dep.urp Sun Apr 29 16:23:03 2012 -0400 @@ -0,0 +1,4 @@ +dep1 +dep2 +dep3 +dep4
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dep1.ur Sun Apr 29 16:23:03 2012 -0400 @@ -0,0 +1,1 @@ +val x = "Hello world"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dep2.ur Sun Apr 29 16:23:03 2012 -0400 @@ -0,0 +1,1 @@ +val y = Dep1.x