summaryrefslogtreecommitdiff
path: root/Messages.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-03-04 03:17:03 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-03-04 03:17:25 -0400
commit9856c24a5996f2d493c559cd9ea6b27b8127694a (patch)
treede50fea60e3e0eeb0cb8303cbf25bb2a0415034b /Messages.hs
parent8fc533643d0acd5cddbdfede1a438a84c57329ba (diff)
Add progress bar display to the directory special remote.
So far I've only written progress bars for sending files, not yet receiving. No longer uses external cp at all. ByteString IO is fast enough.
Diffstat (limited to 'Messages.hs')
-rw-r--r--Messages.hs25
1 files changed, 25 insertions, 0 deletions
diff --git a/Messages.hs b/Messages.hs
index 1b51cf23e..e8bbfed13 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -10,6 +10,8 @@ module Messages (
showNote,
showAction,
showProgress,
+ metered,
+ MeterUpdate,
showSideAction,
showOutput,
showLongNote,
@@ -29,9 +31,13 @@ module Messages (
) where
import Text.JSON
+import Data.Progress.Meter
+import Data.Progress.Tracker
+import Data.Quantity
import Common
import Types
+import Types.Key
import qualified Annex
import qualified Messages.JSON as JSON
@@ -46,10 +52,29 @@ showNote s = handle (JSON.note s) $
showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."
+{- Progress dots. -}
showProgress :: Annex ()
showProgress = handle q $
flushed $ putStr "."
+{- Shows a progress meter while performing a transfer of a key.
+ - The action is passed a callback to use to update the meter. -}
+type MeterUpdate = Integer -> IO ()
+metered :: Key -> (MeterUpdate -> Annex a) -> Annex a
+metered key a = Annex.getState Annex.output >>= go (keySize key)
+ where
+ go (Just size) Annex.NormalOutput = do
+ progress <- liftIO $ newProgress "" size
+ meter <- liftIO $ newMeter progress "B" 20 (renderNums binaryOpts 1)
+ showOutput
+ liftIO $ displayMeter stdout meter
+ r <- a $ \n -> liftIO $ do
+ incrP progress n
+ displayMeter stdout meter
+ liftIO $ clearMeter stdout meter
+ return r
+ go _ _ = a (const $ return ())
+
showSideAction :: String -> Annex ()
showSideAction s = handle q $
putStrLn $ "(" ++ s ++ "...)"