concurrent-output, first pass

Output without -Jn should be unchanged from before. With -Jn,
concurrent-output is used for messages, but regions are not used yet, so
it's a mess.

3 files changed, 80 insertions, 27 deletions

diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs
new file mode 100644
index 000000000..3b7b28d28
--- /dev/null
+++ b/Messages/Concurrent.hs
@@ -0,0 +1,33 @@
+{- git-annex concurrent output
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Messages.Concurrent where
+
+import Common.Annex
+import Messages.Internal
+import Types.Messages
+
+#ifdef WITH_CONCURRENTOUTPUT
+import qualified System.Console.Concurrent as Console
+#endif
+
+{- Enable concurrent output when that has been requested.
+ -
+ - This should only be run once per git-annex lifetime, with
+ - everything that might generate messages run inside it.
+ -}
+withConcurrentOutput :: Annex a -> Annex a
+#ifdef WITH_CONCURRENTOUTPUT
+withConcurrentOutput a = withOutputType go
+  where
+	go (ConcurrentOutput _) = Console.withConcurrentOutput a
+	go _ = a
+#else
+withConcurrentOutput = id
+#endif
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 2495f4fd3..1501c072a 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Messages.Internal where
 
 import Common
@@ -12,14 +14,38 @@ import Types
 import Types.Messages
 import qualified Annex
 
-handleMessage :: IO () -> IO () -> Annex ()
-handleMessage json normal = withOutputType go
+#ifdef WITH_CONCURRENTOUTPUT
+import System.Console.Concurrent
+#endif
+
+outputMessage :: IO () -> String -> Annex ()
+outputMessage json s = withOutputType go
   where
-	go NormalOutput = liftIO normal
+	go NormalOutput = liftIO $
+		flushed $ putStr s
 	go QuietOutput = q
-	go (ParallelOutput _) = q
+	go (ConcurrentOutput _) = liftIO $
+#ifdef WITH_CONCURRENTOUTPUT
+		outputConcurrent s
+#else
+		q
+#endif
 	go JSONOutput = liftIO $ flushed json
 
+outputError :: String -> Annex ()
+outputError s = withOutputType go
+  where
+	go (ConcurrentOutput _) = liftIO $
+#ifdef WITH_CONCURRENTOUTPUT
+		errorConcurrent s
+#else
+		q
+#endif
+	go _ = liftIO $ do
+		hFlush stdout
+		hPutStr stderr s
+		hFlush stderr
+
 q :: Monad m => m ()
 q = noop
 
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index 25e2e03ae..a20ba098e 100644
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -17,15 +17,14 @@ import Types
 import Types.Messages
 import Types.Key
 
-#ifdef WITH_ASCIIPROGRESS
-import System.Console.AsciiProgress
-import qualified System.Console.Terminal.Size as Terminal
+#ifdef WITH_CONCURRENTOUTPUT
+import System.Console.Concurrent
+import System.Console.Regions
 import Control.Concurrent
-#else
+#endif
 import Data.Progress.Meter
 import Data.Progress.Tracker
 import Data.Quantity
-#endif
 
 {- Shows a progress meter while performing a transfer of a key.
  - The action is passed a callback to use to update the meter. -}
@@ -36,7 +35,7 @@ metered combinemeterupdate key af a = case keySize key of
   where
 	go _ QuietOutput = nometer
 	go _ JSONOutput = nometer
-#ifdef WITH_ASCIIPROGRESS
+#if 0
 	go size _ = do
 		showOutput
 		liftIO $ putStrLn ""
@@ -65,8 +64,8 @@ metered combinemeterupdate key af a = case keySize key of
 
 		return r
 #else
-	-- Old progress bar code, not suitable for parallel output.
-	go _ (ParallelOutput _) = do
+	-- Old progress bar code, not suitable for concurrent output.
+	go _ (ConcurrentOutput _) = do
 		r <- nometer
 		liftIO $ putStrLn $ fromMaybe (key2file key) af
 		return r
@@ -79,7 +78,7 @@ metered combinemeterupdate key af a = case keySize key of
 		return r
 #endif
 
-#ifdef WITH_ASCIIPROGRESS
+#if 0
 	pupdate pg n = do
 		let i = fromBytesProcessed n
 		sofar <- stCompleted <$> getProgressStats pg
@@ -95,24 +94,17 @@ metered combinemeterupdate key af a = case keySize key of
 
 	nometer = a (const noop)
 
-#ifdef WITH_ASCIIPROGRESS
-	truncatepretty n s
-		| length s > n = take (n-2) s ++ ".."
-		| otherwise = s
-#endif
-
-{- Use when the progress meter is only desired for parallel
- - mode; as when a command's own progress output is preferred. -}
-parallelMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
-parallelMetered combinemeterupdate key af a = withOutputType go
+{- Use when the progress meter is only desired for concurrent
+ - output; as when a command's own progress output is preferred. -}
+concurrentMetered :: Maybe MeterUpdate -> Key -> AssociatedFile -> (MeterUpdate -> Annex a) -> Annex a
+concurrentMetered combinemeterupdate key af a = withOutputType go
   where
-	go (ParallelOutput _) = metered combinemeterupdate key af a
+	go (ConcurrentOutput _) = metered combinemeterupdate key af a
 	go _ = a (fromMaybe (const noop) combinemeterupdate)
 
 {- Progress dots. -}
 showProgressDots :: Annex ()
-showProgressDots = handleMessage q $
-	flushed $ putStr "."
+showProgressDots = outputMessage q "."
 
 {- Runs a command, that may output progress to either stdout or
  - stderr, as well as other messages.
@@ -149,5 +141,7 @@ mkStderrRelayer = do
 mkStderrEmitter :: Annex (String -> IO ())
 mkStderrEmitter = withOutputType go
   where
-	go (ParallelOutput _) = return $ \s -> hPutStrLn stderr ("E: " ++ s)
+#ifdef WITH_CONCURRENTOUTPUT
+	go (ConcurrentOutput _) = return errorConcurrent
+#endif
 	go _ = return (hPutStrLn stderr)