working hGetLineUntilExitOrEOF

The problem with the old version seemed to be that hWaitForInput blocks
rather than timing out when being run concurrently with hGetLine on the
same handle.

This passes the bench test, and also works when run concurrently on
different handles.

Utility/Process.hs

@@ -250,58 +250,57 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
  - buffered to the handle before exiting.
  -}
 hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
-hGetLineUntilExitOrEOF ph h = do
+hGetLineUntilExitOrEOF ph h = go []
-	w <- async waiter
-	r <- reader
-	cancel w
-	return r
   where
-	reader = hIsEOF h >>= \case
+	go buf = do
-		True -> return Nothing
+		ready <- waitforinputorerror smalldelay
-		False -> Just <$> hGetLine h
+		if ready
+			then getloop buf go
+			else getProcessExitCode ph >>= \case
+				-- Process still running, wait longer.
+				Nothing -> go buf
+				-- Process is done. It's possible
+				-- that it output something and exited
+				-- since the prior hWaitForInput,
+				-- so check one more time for any buffered
+				-- output.
+				Just _ -> finalcheck buf
 
-	waiter = do
+	finalcheck buf = do
-		smalldelay
+		ready <- hWaitForInput h 0
-		print "hGetLineUntilExitOrEOF waitForProcess"
+		if ready
-		hFlush stdout
+			then getloop buf finalcheck
-		_ <- waitForProcess ph
+			-- No remaining buffered input, though the handle
-		print "hGetLineUntilExitOrEOF process done"
+			-- may not be EOF if something else is keeping it
-		hFlush stdout
+			-- open. Treated the same as EOF.
-		waitbufferempty
+			else eofwithnolineend buf
-		print "hGetLineUntilExitOrEOF buffer empty"
-		hFlush stdout
-		-- Reached the end of the processes output.
-		hClose h
 
-	waitbufferempty = isanythingbuffered >>= \case
+	-- On exception, proceed as if there was input;
-		True -> do
+	-- EOF and any encoding issues are dealt with
-			print "something still buffered.."
+	-- when reading from the handle.
-			-- Waiting for the reader to consume
+	waitforinputorerror t = hWaitForInput h t
-			-- buffered output after the process has
+		`catchNonAsync` const (pure True)
-			-- exited.
-			threadDelay 10000 -- 1/100th second
-			waitbufferempty
-		False ->  return ()
 
-	isanythingbuffered = do
+	getchar = catchIOErrorType EOF 
-		print "hWaitForInput call start"
+		(const (pure Nothing)) 
-		-- waitForInput is documented to throw an encoding
+		(Just <$> hGetChar h)
-		-- error in some cases, if the Handle has buffered on it
-		-- something that cannot be decoded. If it does,
-		-- that does imply there's still something buffered though.
-		r <- hWaitForInput h 100
-		{-
-		catchNonAsync
-			-- waitForInput can throw an EOF error
-			(catchIOErrorType EOF
-				(const (print "EOF exception" >> return False))
-				(hWaitForInput h 1))
-			(const (print "encoding exception" >> return True))
-		-}
-		print "hWaitForInput call done"
-		return r
 
-	-- A small delay avoids starting the work of waitForProcess
+	getloop buf cont =
-	-- unncessarily in the common case where hGetLine gets a buffered
+		getchar >>= \case
-	-- line immediately.
+			Just c
-	smalldelay = threadDelay 10000 -- 1/100th second
+				| c == '\n' -> return (Just (reverse buf))
+				| otherwise -> cont (c:buf)
+			Nothing -> eofwithnolineend buf
+
+	eofwithnolineend buf = return $
+		if null buf 
+			then Nothing -- no line read
+			else Just (reverse buf)
+
+	-- Tenth of a second delay. If the process exits with the FD being
+	-- held open, will wait up to twice this long before returning.
+	-- This delay could be made smaller. However, that is an unusual
+	-- case, and making it too small would cause lots of wakeups while
+	-- waiting for output. Bearing in mind that this could be run on
+	-- many processes at the same time.
+	smalldelay = 100 -- milliseconds