From 70bc30acb1e320ef516dfb243904b3ad3a7d2158 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 12 Jun 2019 13:33:15 -0400 Subject: [PATCH] get rid of implicitMessages state Oh joyous day, this is probably git-annex's oldest implementation wart, source of much unncessary bother. Now that we have a StartMessage, showEndResult' can look at it to know if it needs to display an end message or not. This is also going to be faster, because it avoids an uncessary state lookup for each file processed. --- CmdLine.hs | 4 +--- CmdLine/Action.hs | 47 ++++++++++++++++++++++++++++------------------- Messages.hs | 18 +++++++----------- Types/Messages.hs | 2 -- 4 files changed, 36 insertions(+), 35 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index dc885956d6..ede1f0d0d6 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -122,10 +122,8 @@ findCmd fuzzyok argv cmds prepRunCommand :: Command -> GlobalSetter -> Annex () prepRunCommand cmd globalconfig = do - when (cmdnomessages cmd) $ do + when (cmdnomessages cmd) $ Annex.setOutput QuietOutput - Annex.changeState $ \s -> s - { Annex.output = (Annex.output s) { implicitMessages = False } } getParsed globalconfig whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 8530c188cb..625e8c1cd6 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -101,22 +101,21 @@ commandAction start = Annex.getState Annex.concurrency >>= \case mkjob workerst startmsg perform = inOwnConsoleRegion (Annex.output workerst) $ - void $ accountCommandAction $ + void $ accountCommandAction startmsg $ performconcurrent startmsg perform - -- Like callCommandAction, but the start stage has already run, - -- and the worker thread's stage is changed before starting the - -- cleanup action. + -- Like performCommandAction' but the worker thread's stage + -- is changed before starting the cleanup action. performconcurrent startmsg perform = do showStartMessage startmsg perform >>= \case Just cleanup -> do changeStageTo CleanupStage r <- cleanup - implicitMessage (showEndResult r) + showEndMessage startmsg r return r Nothing -> do - implicitMessage (showEndResult False) + showEndMessage startmsg False return False -- | Wait until there's an idle worker in the pool, remove it from the @@ -206,17 +205,23 @@ changeStageTo newstage = do {- Like commandAction, but without the concurrency. -} includeCommandAction :: CommandStart -> CommandCleanup -includeCommandAction = accountCommandAction . callCommandAction +includeCommandAction start = + start >>= \case + Nothing -> return True + Just (startmsg, perform) -> do + showStartMessage startmsg + accountCommandAction startmsg $ + performCommandAction' startmsg perform -accountCommandAction :: CommandCleanup -> CommandCleanup -accountCommandAction a = tryNonAsync a >>= \case +accountCommandAction :: StartMessage -> CommandCleanup -> CommandCleanup +accountCommandAction startmsg cleanup = tryNonAsync cleanup >>= \case Right True -> return True Right False -> incerr Left err -> case fromException err of Just exitcode -> liftIO $ exitWith exitcode Nothing -> do toplevelWarning True (show err) - implicitMessage showEndFail + showEndMessage startmsg False incerr where incerr = do @@ -232,19 +237,23 @@ callCommandAction = fromMaybe True <$$> callCommandAction' {- Like callCommandAction, but returns Nothing when the command did not - perform any action. -} callCommandAction' :: CommandStart -> Annex (Maybe Bool) -callCommandAction' a = callCommandActionQuiet a >>= \case - Nothing -> return Nothing - Just r -> implicitMessage (showEndResult r) >> return (Just r) - -callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool) -callCommandActionQuiet start = +callCommandAction' start = start >>= \case Nothing -> return Nothing Just (startmsg, perform) -> do showStartMessage startmsg - perform >>= \case - Nothing -> return (Just False) - Just cleanup -> Just <$> cleanup + Just <$> performCommandAction' startmsg perform + +performCommandAction' :: StartMessage -> CommandPerform -> CommandCleanup +performCommandAction' startmsg perform = + perform >>= \case + Nothing -> do + showEndMessage startmsg False + return False + Just cleanup -> do + r <- cleanup + showEndMessage startmsg r + return r {- Do concurrent output when that has been requested. -} allowConcurrentOutput :: Annex a -> Annex a diff --git a/Messages.hs b/Messages.hs index 94766048c9..1c58327ec8 100644 --- a/Messages.hs +++ b/Messages.hs @@ -9,6 +9,7 @@ module Messages ( showStart, showStart', showStartMessage, + showEndMessage, StartMessage(..), ActionItem(..), mkActionItem, @@ -43,7 +44,6 @@ module Messages ( debugEnabled, commandProgressDisabled, outputMessage, - implicitMessage, withMessageState, prompt, ) where @@ -97,13 +97,15 @@ showStartMessage (StartUsualMessages command ai) = do outputType <$> Annex.getState Annex.output >>= \case QuietOutput -> Annex.setOutput NormalOutput _ -> noop - Annex.changeState $ \s -> s - { Annex.output = (Annex.output s) { implicitMessages = True } } showStartMessage (StartMessage command ai) showStartMessage (CustomOutput _) = do Annex.setOutput QuietOutput - Annex.changeState $ \s -> s - { Annex.output = (Annex.output s) { implicitMessages = False } } + +-- Only show end result if the StartMessage is one that gets displayed. +showEndMessage :: StartMessage -> Bool -> Annex () +showEndMessage (StartMessage _ _) = showEndResult +showEndMessage (StartUsualMessages _ _) = showEndResult +showEndMessage (CustomOutput _) = const noop showNote :: String -> Annex () showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " @@ -275,12 +277,6 @@ commandProgressDisabled = withMessageState $ \s -> return $ JSONOutput _ -> True NormalOutput -> concurrentOutputEnabled s -{- Use to show a message that is displayed implicitly, and so might be - - disabled when running a certian command that needs more control over its - - output. -} -implicitMessage :: Annex () -> Annex () -implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output) - {- Prevents any concurrent console access while running an action, so - that the action is the only thing using the console, and can eg prompt - the user. diff --git a/Types/Messages.hs b/Types/Messages.hs index 0658c2405a..f4319d9cfb 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -35,7 +35,6 @@ data MessageState = MessageState { outputType :: OutputType , concurrentOutputEnabled :: Bool , sideActionBlock :: SideActionBlock - , implicitMessages :: Bool , consoleRegion :: Maybe ConsoleRegion , consoleRegionErrFlag :: Bool , jsonBuffer :: Maybe Aeson.Object @@ -49,7 +48,6 @@ newMessageState = do { outputType = NormalOutput , concurrentOutputEnabled = False , sideActionBlock = NoBlock - , implicitMessages = True , consoleRegion = Nothing , consoleRegionErrFlag = False , jsonBuffer = Nothing