WIP on making --quiet silence progress, and infra for concurrent progress bars

2 files changed, 107 insertions, 0 deletions

diff --git a/Messages/Internal.hs b/Messages/Internal.hs
new file mode 100644
index 000000000..1dd856b5e
--- /dev/null
+++ b/Messages/Internal.hs
@@ -0,0 +1,30 @@
+{- git-annex output messages
+ -
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Messages.Internal where
+
+import Common
+import Types
+import Types.Messages
+import qualified Annex
+
+handleMessage :: IO () -> IO () -> Annex ()
+handleMessage json normal = withOutputType go
+  where
+	go NormalOutput = liftIO normal
+	go QuietOutput = q
+	go ProgressOutput = q
+	go JSONOutput = liftIO $ flushed json
+
+q :: Monad m => m ()
+q = noop
+
+flushed :: IO () -> IO ()
+flushed a = a >> hFlush stdout
+
+withOutputType :: (OutputType -> Annex a) -> Annex a
+withOutputType a = outputType <$> Annex.getState Annex.output >>= a
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
new file mode 100644
index 000000000..60ab8271a
--- /dev/null
+++ b/Messages/Progress.hs
@@ -0,0 +1,77 @@
+module Messages.Progress where
+
+import Common
+import Messages
+import Messages.Internal
+import Utility.Metered
+import Types
+import Types.Messages
+import Types.Key
+
+import Data.Progress.Meter
+import Data.Progress.Tracker
+import Data.Quantity
+
+{- Shows a progress meter while performing a transfer of a key.
+ - The action is passed a callback to use to update the meter. -}
+metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
+metered combinemeterupdate key a = go (keySize key)
+  where
+	go (Just size) = meteredBytes combinemeterupdate size a
+	go _ = a (const noop)
+
+{- Shows a progress meter while performing an action on a given number
+ - of bytes. -}
+meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
+meteredBytes combinemeterupdate size a = withOutputType go
+  where
+	go NormalOutput = do
+		progress <- liftIO $ newProgress "" size
+		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
+		showOutput
+		r <- a $ \n -> liftIO $ do
+			setP progress $ fromBytesProcessed n
+			displayMeter stdout meter
+			maybe noop (\m -> m n) combinemeterupdate
+		liftIO $ clearMeter stdout meter
+		return r
+	go _ = a (const noop)
+
+{- Progress dots. -}
+showProgressDots :: Annex ()
+showProgressDots = handleMessage q $
+	flushed $ putStr "."
+
+{- Runs a command, the output of which is some sort of progress display.
+ -
+ - Normally, this is displayed to the user.
+ -
+ - In QuietOutput mode, both the stdout and stderr are discarded,
+ - unless the command fails, in which case stderr will be displayed.
+ -}
+progressOutput :: FilePath -> [CommandParam] -> Annex Bool
+progressOutput cmd ps = undefined
+
+mkProgressHandler :: MeterUpdate -> Annex ProgressHandler
+mkProgressHandler meter = ProgressHandler
+	<$> quietmode
+	<*> (stderrhandler <$> mkStderrEmitter)
+	<*> pure meter
+  where
+	quietmode = withOutputType $ \t -> return $ case t of
+		ProgressOutput -> True
+		_ -> False
+	stderrhandler emitter h = do
+		void $ emitter =<< hGetLine stderr
+		stderrhandler emitter h
+
+{- Generates an IO action that can be used to emit stderr.
+ -
+ - When a progress meter is displayed, this takes care to avoid
+ - messing it up with interleaved stderr from a command.
+ -}
+mkStderrEmitter :: Annex (String -> IO ())
+mkStderrEmitter = withOutputType go
+  where
+	go ProgressOutput = return $ \s -> hPutStrLn stderr ("E: " ++ s)
+	go _ = return (hPutStrLn stderr)