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

1 files changed, 30 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