Fix historyHook memory leak

updateHistory leaks unfiltered windows from previous states as it is never
forced. The consumer of such data structure is not visible to ghc, so the
demand analysis has to fallback on pure laziness.

We fix this inserting evaluation points on the `historyHook` function. We do
this for two reasons, this is the only function calling `updateHistory`.
Plus we cannot do it clearly at the `updateHistory` function as we operate
inside a continuation on withWindowSet. In respect to the `put`, everything
would be a big thunk.

XMonad/Actions/GroupNavigation.hs

@@ -34,6 +34,7 @@ module XMonad.Actions.GroupNavigation ( -- * Usage
 
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Seq (using, seqFoldable, rseq)
 import Data.Map ((!))
 import qualified Data.Map as Map
 import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (<|), (><), (|>))
@@ -166,15 +167,20 @@ 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
+  db'@(HistoryDB cur del) <- updateHistory db
+  let del' = del `using` seqFoldable rseq
+      cur' = cur `using` seqFoldable rseq
+  cur' `seq` del' `seq` 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-contrib.cabal

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