diff options
author | 2015-04-04 15:01:00 -0400 | |
---|---|---|
committer | 2015-04-04 15:01:00 -0400 | |
commit | b855580614852c7558fb2aad387609d15c4b0c6b (patch) | |
tree | 9f523cdb70e17cfa3d8bdb6a5d51364557572869 /Messages.hs | |
parent | 7cd9433dab89e1e007cef783d8b18e5eeac987f1 (diff) | |
parent | 8815f95d1ad0413ca35e6873f4b7b272bac629db (diff) |
Merge branch 'concurrentprogress'
Diffstat (limited to 'Messages.hs')
-rw-r--r-- | Messages.hs | 93 |
1 files changed, 26 insertions, 67 deletions
diff --git a/Messages.hs b/Messages.hs index a8816218c..0e83a7243 100644 --- a/Messages.hs +++ b/Messages.hs @@ -10,9 +10,6 @@ module Messages ( showStart', showNote, showAction, - showProgressDots, - metered, - meteredBytes, showSideAction, doSideAction, doQuietSideAction, @@ -33,28 +30,26 @@ module Messages ( showRaw, setupConsole, enableDebugOutput, - disableDebugOutput + disableDebugOutput, + commandProgressDisabled, ) where import Text.JSON -import Data.Progress.Meter -import Data.Progress.Tracker -import Data.Quantity import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple -import Common hiding (handle) +import Common import Types import Types.Messages +import Messages.Internal import qualified Messages.JSON as JSON import Types.Key import qualified Annex -import Utility.Metered showStart :: String -> FilePath -> Annex () -showStart command file = handle (JSON.start command $ Just file) $ +showStart command file = handleMessage (JSON.start command $ Just file) $ flushed $ putStr $ command ++ " " ++ file ++ " " showStart' :: String -> Key -> Maybe FilePath -> Annex () @@ -62,42 +57,12 @@ showStart' command key afile = showStart command $ fromMaybe (key2file key) afile showNote :: String -> Annex () -showNote s = handle (JSON.note s) $ +showNote s = handleMessage (JSON.note s) $ flushed $ putStr $ "(" ++ s ++ ") " showAction :: String -> Annex () showAction s = showNote $ s ++ "..." -{- Progress dots. -} -showProgressDots :: Annex () -showProgressDots = 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. -} -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) - showSideAction :: String -> Annex () showSideAction m = Annex.getState Annex.output >>= go where @@ -108,7 +73,7 @@ showSideAction m = Annex.getState Annex.output >>= go Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () | otherwise = p - p = handle q $ putStrLn $ "(" ++ m ++ "...)" + p = handleMessage q $ putStrLn $ "(" ++ m ++ "...)" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" @@ -130,12 +95,13 @@ doSideAction' b a = do where set o = Annex.changeState $ \s -> s { Annex.output = o } +{- Make way for subsequent output of a command. -} showOutput :: Annex () -showOutput = handle q $ - putStr "\n" +showOutput = unlessM commandProgressDisabled $ + handleMessage q $ putStr "\n" showLongNote :: String -> Annex () -showLongNote s = handle (JSON.note s) $ +showLongNote s = handleMessage (JSON.note s) $ putStrLn $ '\n' : indent s showEndOk :: Annex () @@ -145,7 +111,7 @@ showEndFail :: Annex () showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult ok = handle (JSON.end ok) $ putStrLn msg +showEndResult ok = handleMessage (JSON.end ok) $ putStrLn msg where msg | ok = "ok" @@ -159,7 +125,7 @@ warning = warning' . indent warning' :: String -> Annex () warning' w = do - handle q $ putStr "\n" + handleMessage q $ putStr "\n" liftIO $ do hFlush stdout hPutStrLn stderr w @@ -175,7 +141,7 @@ indent = intercalate "\n" . map (\l -> " " ++ l) . lines {- Shows a JSON fragment only when in json mode. -} maybeShowJSON :: JSON a => [(String, a)] -> Annex () -maybeShowJSON v = handle (JSON.add v) q +maybeShowJSON v = handleMessage (JSON.add v) q {- Shows a complete JSON value, only when in json mode. -} showFullJSON :: JSON a => [(String, a)] -> Annex Bool @@ -190,16 +156,16 @@ showFullJSON v = withOutputType $ liftIO . go - This is only needed when showStart and showEndOk is not used. -} showCustom :: String -> Annex Bool -> Annex () showCustom command a = do - handle (JSON.start command Nothing) q + handleMessage (JSON.start command Nothing) q r <- a - handle (JSON.end r) q + handleMessage (JSON.end r) q showHeader :: String -> Annex () -showHeader h = handle q $ +showHeader h = handleMessage q $ flushed $ putStr $ h ++ ": " showRaw :: String -> Annex () -showRaw s = handle q $ putStrLn s +showRaw s = handleMessage q $ putStrLn s setupConsole :: IO () setupConsole = do @@ -219,18 +185,11 @@ enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG disableDebugOutput :: IO () disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE -handle :: IO () -> IO () -> Annex () -handle json normal = withOutputType go - where - go NormalOutput = liftIO normal - go QuietOutput = 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 +{- Should commands that normally output progress messages have that + - output disabled? -} +commandProgressDisabled :: Annex Bool +commandProgressDisabled = withOutputType $ \t -> return $ case t of + QuietOutput -> True + ProgressOutput -> True + JSONOutput -> True + NormalOutput -> False |