aboutsummaryrefslogtreecommitdiff
path: root/Assistant/DaemonStatus.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-01-05 21:30:48 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-01-05 21:30:48 -0400
commit4cf6d95c1a9d10cb59669eaceafce4c7a3155eb6 (patch)
tree2ed9440dd31cb4cb925e9010bd54694b8c776519 /Assistant/DaemonStatus.hs
parent5d305f1337e88ae7a07f54adc06c4a9d1d39f872 (diff)
assistant: Fixed several minor memory leaks that manifested when adding a large number of files.
Diffstat (limited to 'Assistant/DaemonStatus.hs')
-rw-r--r--Assistant/DaemonStatus.hs19
1 files changed, 12 insertions, 7 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 7268bbbfb..ed73c210a 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE BangPatterns #-}
+
module Assistant.DaemonStatus where
import Assistant.Common
@@ -23,7 +25,7 @@ import System.Posix.Types
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
import qualified Data.Text as T
getDaemonStatus :: Assistant DaemonStatus
@@ -37,7 +39,7 @@ modifyDaemonStatus a = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ do
(s, b) <- atomically $ do
- r@(s, _) <- a <$> takeTMVar dstatus
+ r@(!s, _) <- a <$> takeTMVar dstatus
putTMVar dstatus s
return r
sendNotification $ changeNotifier s
@@ -153,7 +155,8 @@ tenMinutes = 10 * 60
adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
adjustTransfersSTM dstatus a = do
s <- takeTMVar dstatus
- putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
+ let !v = a (currentTransfers s)
+ putTMVar dstatus $ s { currentTransfers = v }
{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
@@ -168,7 +171,7 @@ alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
- or if already present, updates it while preserving the old transferTid,
- transferPaused, and bytesComplete values, which are not written to disk. -}
updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
-updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
+updateTransferInfo t info = updateTransferInfo' $ M.insertWith merge t info
where
merge new old = new
{ transferTid = maybe (transferTid new) Just (transferTid old)
@@ -213,8 +216,8 @@ addAlert alert = do
where
add s = (s { lastAlertId = i, alertMap = m }, i)
where
- i = nextAlertId $ lastAlertId s
- m = mergeAlert i alert (alertMap s)
+ !i = nextAlertId $ lastAlertId s
+ !m = mergeAlert i alert (alertMap s)
removeAlert :: AlertId -> Assistant ()
removeAlert i = updateAlert i (const Nothing)
@@ -225,7 +228,9 @@ updateAlert i a = updateAlertMap $ \m -> M.update a i m
updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
where
- update s = s { alertMap = a (alertMap s) }
+ update s =
+ let !m = a (alertMap s)
+ in s { alertMap = a (alertMap s) }
{- Displays an alert while performing an activity that returns True on
- success.