# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1336236335 14400
# Node ID 6fcce0592178759dfe1b2e2e6a91c4862a68eff3
# Parent  1e940643a5f01757139c85e1352290f03498f119
Send daemon output to calling process

diff -r 1e940643a5f0 -r 6fcce0592178 src/elaborate.sig
--- a/src/elaborate.sig	Fri May 04 10:38:22 2012 -0400
+++ b/src/elaborate.sig	Sat May 05 12:45:35 2012 -0400
@@ -42,5 +42,6 @@
      * early phase. *)
 
     val incremental : bool ref
+    val verbose : bool ref
 
 end
diff -r 1e940643a5f0 -r 6fcce0592178 src/elaborate.sml
--- a/src/elaborate.sml	Fri May 04 10:38:22 2012 -0400
+++ b/src/elaborate.sml	Sat May 05 12:45:35 2012 -0400
@@ -41,6 +41,7 @@
  val dumpTypes = ref false
  val unifyMore = ref false
  val incremental = ref false
+ val verbose = ref false
 
  structure IS = IntBinarySet
  structure IM = IntBinaryMap
@@ -3931,6 +3932,7 @@
                 (case ModDb.lookup dAll of
                      SOME d =>
                      let
+                         val () = if !verbose then TextIO.print ("REUSE: " ^ x ^ "\n") else ()
                          val env' = E.declBinds env d
                          val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
                      in
@@ -3938,6 +3940,8 @@
                      end
                    | NONE =>
                      let
+                         val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else ()
+
                          val () = if x = "Basis" then
                                       raise Fail "Not allowed to redefine structure 'Basis'"
                                   else
@@ -4680,7 +4684,7 @@
                                                   val c = normClassKey env c
                                               in
                                                   case resolveClass env c of
-                                                      SOME _ => raise Fail "Type class resolution succeeded unexpectedly"
+                                                      SOME _ => ()
                                                     | NONE => expError env (Unresolvable (loc, c))
                                               end)
                                           gs)
diff -r 1e940643a5f0 -r 6fcce0592178 src/main.mlton.sml
--- a/src/main.mlton.sml	Fri May 04 10:38:22 2012 -0400
+++ b/src/main.mlton.sml	Sat May 05 12:45:35 2012 -0400
@@ -41,6 +41,7 @@
         val css = ref false
 
         val () = (Compiler.debug := false;
+                  Elaborate.verbose := false;
                   Elaborate.dumpTypes := false;
                   Elaborate.unifyMore := false;
                   Compiler.dumpSource := false;
@@ -91,6 +92,7 @@
                  doArgs rest)
               | "-verbose" :: rest =>
                 (Compiler.debug := true;
+                 Elaborate.verbose := true;
                  doArgs rest)
               | "-timing" :: rest =>
                 (timing := true;
@@ -243,19 +245,43 @@
                                               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")
+                                                  "" =>
+                                                  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 _ => ()
+
+                              fun redirect old =
+                                  Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
+                                                 new = old}
+
+                              val oldStdout = Posix.IO.dup Posix.FileSys.stdout
+                              val oldStderr = Posix.IO.dup Posix.FileSys.stderr
                           in
+                              (* Redirect the daemon's output to the socket. *)
+                              redirect Posix.FileSys.stdout;
+                              redirect Posix.FileSys.stderr;
+                              
                               loop' ("", []);
                               Socket.close sock;
+
+                              Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
+                              Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
+                              Posix.IO.close oldStdout;
+                              Posix.IO.close oldStderr;
+
                               MLton.GC.pack ();
                               loop ()
                           end
@@ -272,15 +298,26 @@
 
                  fun wait () =
                      let
-                         val v = Socket.recvVec (sock, 1)
+                         val v = Socket.recvVec (sock, 1024)
                      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"
+                             let
+                                 val s = Vector.map (chr o Word8.toInt) v
+                                 val last = Vector.sub (v, Vector.length v - 1)
+                                 val (rc, s) = if last = Word8.fromInt 1 then
+                                                   (SOME OS.Process.success, String.substring (s, 0, size s - 1))
+                                               else if last = Word8.fromInt 2 then
+                                                   (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
+                                               else
+                                                   (NONE, s)
+                             in
+                                 print s;
+                                 case rc of
+                                     NONE => wait ()
+                                   | SOME rc => rc
+                             end
                      end handle OS.SysErr _ => OS.Process.failure
              in
                  if Socket.connectNB (sock, UnixSock.toAddr socket)