Merge pull request #653 from RubenAstudillo/feature/no-leak-history-hook

Fix memory leaks in `historyHook` and `workspaceHistoryHook`

XMonad/Actions/GroupNavigation.hs

@@ -1,3 +1,4 @@
+{-# language DeriveGeneric, DeriveAnyClass #-}
 ----------------------------------------------------------------------
 -- |
 -- Module      : XMonad.Actions.GroupNavigation
@@ -34,12 +35,14 @@ module XMonad.Actions.GroupNavigation ( -- * Usage
 
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.DeepSeq
 import Data.Map ((!))
 import qualified Data.Map as Map
 import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (<|), (><), (|>))
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
 import Graphics.X11.Types
+import GHC.Generics
 import Prelude hiding (concatMap, drop, elem, filter, null, reverse)
 import XMonad.Core
 import XMonad.ManageHook
@@ -156,7 +159,7 @@ orderedWorkspaceList ss wsids = rotateTo isCurWS wspcs'
 -- The state extension that holds the history information
 data HistoryDB = HistoryDB (Maybe Window) -- currently focused window
                            (Seq Window)   -- previously focused windows
-               deriving (Read, Show)
+               deriving (Read, Show, Generic, NFData)
 
 instance ExtensionClass HistoryDB where
 
@@ -166,15 +169,17 @@ instance ExtensionClass HistoryDB where
 -- | Action that needs to be executed as a logHook to maintain the
 -- focus history of all windows as the WindowSet changes.
 historyHook :: X ()
-historyHook = XS.get >>= updateHistory >>= XS.put
+historyHook = do
+  db' <- XS.get >>= updateHistory
+  db' `deepseq` XS.put db'
 
 -- Updates the history in response to a WindowSet change
 updateHistory :: HistoryDB -> X HistoryDB
-updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss -> do
+updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss ->
   let newcur   = SS.peek ss
       wins     = Set.fromList $ SS.allWindows ss
       newhist  = Seq.filter (`Set.member` wins) (ins oldcur oldhist)
-  return $ HistoryDB newcur (del newcur newhist)
+  in pure $ HistoryDB newcur (del newcur newhist)
   where
     ins x xs = maybe xs (<| xs) x
     del x xs = maybe xs (\x' -> Seq.filter (/= x') xs) x

XMonad/Hooks/WorkspaceHistory.hs

@@ -28,9 +28,9 @@ module XMonad.Hooks.WorkspaceHistory (
   , workspaceHistoryModify
   ) where
 
-import           Control.Applicative
-import           Prelude
-
+import Control.Applicative
+import Control.DeepSeq
+import Prelude
 import XMonad
 import XMonad.StackSet hiding (delete, filter, new)
 import XMonad.Prelude (delete, find, foldl', groupBy, nub, sortBy)
@@ -65,6 +65,13 @@ newtype WorkspaceHistory = WorkspaceHistory
                                          -- reverse-chronological order.
   } deriving (Read, Show)
 
+-- @ScreenId@ is not an instance of NFData, but is a newtype on @Int@. @seq@
+-- is enough for forcing it. This requires us to provide an instance.
+instance NFData WorkspaceHistory where
+  rnf (WorkspaceHistory hist) =
+    let go = liftRnf2 rwhnf rwhnf
+    in liftRnf go hist
+
 instance ExtensionClass WorkspaceHistory where
     initialValue = WorkspaceHistory []
     extensionType = PersistentExtension
@@ -72,13 +79,15 @@ instance ExtensionClass WorkspaceHistory where
 -- | A 'logHook' that keeps track of the order in which workspaces have
 -- been viewed.
 workspaceHistoryHook :: X ()
-workspaceHistoryHook = gets windowset >>= (XS.modify . updateLastActiveOnEachScreen)
+workspaceHistoryHook = workspaceHistoryHookExclude []
 
 -- | Like 'workspaceHistoryHook', but with the ability to exclude
 -- certain workspaces.
 workspaceHistoryHookExclude :: [WorkspaceId] -> X ()
-workspaceHistoryHookExclude ws =
-  gets windowset >>= XS.modify . updateLastActiveOnEachScreenExclude ws
+workspaceHistoryHookExclude ws = do
+  s <- gets windowset
+  let update' = force . updateLastActiveOnEachScreenExclude ws s
+  XS.modify' update'
 
 workspaceHistoryWithScreen :: X [(ScreenId, WorkspaceId)]
 workspaceHistoryWithScreen = XS.gets history

XMonad/Util/ExtensibleState.hs

@@ -20,6 +20,7 @@ module XMonad.Util.ExtensibleState (
                               -- $usage
                               put
                               , modify
+                              , modify'
                               , remove
                               , get
                               , gets
@@ -90,6 +91,11 @@ modifyStateExts f = State.modify $ \st -> st { extensibleState = f (extensibleSt
 modify :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
 modify f = put . f =<< get
 
+-- | Like @modify@ but the result value is applied strictly in respect to
+-- the monadic environment.
+modify' :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
+modify' f = (put $!) . f =<< get
+
 -- | Add a value to the extensible state field. A previously stored value with the same
 -- type will be overwritten. (More precisely: A value whose string representation of its type
 -- is equal to the new one's)

xmonad-contrib.cabal

@@ -61,7 +61,8 @@ library
                    unix,
                    X11 >= 1.10 && < 1.11,
                    xmonad >= 0.16.99999 && < 0.18,
-                   utf8-string
+                   utf8-string,
+                   deepseq
     default-language: Haskell2010
 
     cpp-options:   -DXMONAD_CONTRIB_VERSION_MAJOR=0
@@ -448,6 +449,7 @@ test-suite tests
                , process
                , unix
                , utf8-string
+               , deepseq
                , xmonad >= 0.16.9999 && < 0.18
   cpp-options: -DTESTING
   ghc-options: -Wall -Wno-unused-do-bind