diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Common.hs | 54 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 46 | ||||
| -rw-r--r-- | Assistant/Threads/Committer.hs | 1 |
3 files changed, 53 insertions, 48 deletions
diff --git a/Assistant/Common.hs b/Assistant/Common.hs index 30c73de43..fcb6d65c8 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -10,7 +10,12 @@ module Assistant.Common ( ThreadName, NamedThread(..), runNamedThread, - debug + debug, + addAlert, + removeAlert, + alertWhile, + alertWhile', + alertDuring, ) where import Common.Annex as X @@ -20,6 +25,7 @@ import Assistant.DaemonStatus import System.Log.Logger import qualified Control.Exception as E +import qualified Data.Map as M type ThreadName = String data NamedThread = NamedThread ThreadName (Assistant ()) @@ -44,3 +50,49 @@ runNamedThread (NamedThread name a) = do -- TODO click to restart void $ addAlert (daemonStatusHandle d) $ warningAlert name msg + +{- Returns the alert's identifier, which can be used to remove it. -} +addAlert :: DaemonStatusHandle -> Alert -> IO AlertId +addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go + where + go s = (s { lastAlertId = i, alertMap = m }, i) + where + i = nextAlertId $ lastAlertId s + m = mergeAlert i alert (alertMap s) + +removeAlert :: DaemonStatusHandle -> AlertId -> IO () +removeAlert dstatus i = updateAlert dstatus i (const Nothing) + +updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO () +updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m + +updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO () +updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go + where + go s = s { alertMap = a (alertMap s) } + +{- Displays an alert while performing an activity that returns True on + - success. + - + - The alert is left visible afterwards, as filler. + - Old filler is pruned, to prevent the map growing too large. -} +alertWhile :: DaemonStatusHandle -> Alert -> IO Bool -> IO Bool +alertWhile dstatus alert a = alertWhile' dstatus alert $ do + r <- a + return (r, r) + +{- Like alertWhile, but allows the activity to return a value too. -} +alertWhile' :: DaemonStatusHandle -> Alert -> IO (Bool, a) -> IO a +alertWhile' dstatus alert a = do + let alert' = alert { alertClass = Activity } + i <- addAlert dstatus alert' + (ok, r) <- a + updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert' + return r + +{- Displays an alert while performing an activity, then removes it. -} +alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a +alertDuring dstatus alert a = do + let alert' = alert { alertClass = Activity } + i <- addAlert dstatus alert' + removeAlert dstatus i `after` a diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 08cdbaf55..49586754c 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -223,49 +223,3 @@ notifyTransfer dstatus = sendNotification notifyAlert :: DaemonStatusHandle -> IO () notifyAlert dstatus = sendNotification =<< alertNotifier <$> atomically (readTMVar dstatus) - -{- Returns the alert's identifier, which can be used to remove it. -} -addAlert :: DaemonStatusHandle -> Alert -> IO AlertId -addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go - where - go s = (s { lastAlertId = i, alertMap = m }, i) - where - i = nextAlertId $ lastAlertId s - m = mergeAlert i alert (alertMap s) - -removeAlert :: DaemonStatusHandle -> AlertId -> IO () -removeAlert dstatus i = updateAlert dstatus i (const Nothing) - -updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO () -updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m - -updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO () -updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go - where - go s = s { alertMap = a (alertMap s) } - -{- Displays an alert while performing an activity that returns True on - - success. - - - - The alert is left visible afterwards, as filler. - - Old filler is pruned, to prevent the map growing too large. -} -alertWhile :: DaemonStatusHandle -> Alert -> IO Bool -> IO Bool -alertWhile dstatus alert a = alertWhile' dstatus alert $ do - r <- a - return (r, r) - -{- Like alertWhile, but allows the activity to return a value too. -} -alertWhile' :: DaemonStatusHandle -> Alert -> IO (Bool, a) -> IO a -alertWhile' dstatus alert a = do - let alert' = alert { alertClass = Activity } - i <- addAlert dstatus alert' - (ok, r) <- a - updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert' - return r - -{- Displays an alert while performing an activity, then removes it. -} -alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a -alertDuring dstatus alert a = do - let alert' = alert { alertClass = Activity } - i <- addAlert dstatus alert' - removeAlert dstatus i `after` a diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 2ab693f05..7bcdaa836 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -15,7 +15,6 @@ import Assistant.Commits import Assistant.Alert import Assistant.Threads.Watcher import Assistant.TransferQueue -import Assistant.DaemonStatus import Logs.Transfer import qualified Annex.Queue import qualified Git.Command |