ENH use rio for dyn workspace monitor

bin/xmonad.hs

@@ -32,7 +32,6 @@ import           System.Process
     ( getPid
     , getProcessExitCode
     )
-import           System.Process.Typed                           (nullStream)
 
 import           XMonad
 import           XMonad.Actions.CopyWindow

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
 --------------------------------------------------------------------------------
 -- | Automatically Manage Dynamic Workspaces
 -- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
@@ -39,10 +37,16 @@ import           Data.List                                (deleteBy, find)
 import qualified Data.Map                                 as M
 import           Data.Maybe
 
-import           Control.Concurrent
+-- import           Control.Concurrent
 import           Control.Monad
 import           Control.Monad.Reader
 
+import           RIO                                      hiding
+    ( Display
+    , display
+    )
+import qualified RIO.Set                                  as S
+
 import           Graphics.X11.Types
 
 import           Graphics.X11.Xlib.Atom
@@ -91,68 +95,62 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String
 
-type WatchedPIDs = MVar [Pid]
-
 data WConf = WConf
     { display       :: Display
     , dynWorkspaces :: [DynWorkspace]
+    , curPIDs       :: MVar (S.Set Pid)
     }
 
-newtype W a = W (ReaderT WConf IO a)
-  deriving (Functor, Monad, MonadIO, MonadReader WConf)
+type W a = RIO WConf ()
 
-instance Applicative W where
-  pure = return
-  (<*>) = ap
-
-runW :: WConf -> W a -> IO a
-runW c (W a) = runReaderT a c
+withDisplay :: (Display -> IO a) -> IO a
+withDisplay = bracket (openDisplay "") closeDisplay
 
 runWorkspaceMon :: [DynWorkspace] -> IO ()
-runWorkspaceMon dws = do
-  dpy <- openDisplay ""
+runWorkspaceMon dws = withDisplay $ \dpy -> do
   root <- rootWindow dpy $ defaultScreen dpy
-  curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
   -- listen only for substructure change events (which includes MapNotify)
   allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
-  let c = WConf { display = dpy, dynWorkspaces = dws }
-  _ <- allocaXEvent $ \e ->
-    runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
-  return ()
+  void $ allocaXEvent $ withEvents dpy
+  where
+    withEvents dpy e = do
+      ps <- newMVar S.empty
+      let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps }
+      runRIO c
+        $ forever
+        $ handleEvent =<< io (nextEvent dpy e >> getEvent e)
 
-handle :: WatchedPIDs -> Event -> W ()
+handleEvent :: Event -> W ()
 
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
-handle curPIDs MapNotifyEvent { ev_window = w } = do
+handleEvent MapNotifyEvent { ev_window = w } = do
   dpy <- asks display
   hint <- io $ getClassHint dpy w
   dws <- asks dynWorkspaces
-  let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
-  let tag = M.lookup (resClass hint) m
-  io $ forM_ tag $ \t -> do
-    a <- internAtom dpy "_NET_WM_PID" False
-    pid <- getWindowProperty32 dpy a w
+  let tag = M.lookup (resClass hint)
+            $ M.fromList
+            $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
+  forM_ tag $ \t -> do
+    a <- io $ internAtom dpy "_NET_WM_PID" False
+    pid <- io $ getWindowProperty32 dpy a w
     case pid of
       -- ASSUMPTION windows will only have one PID at one time
-      Just [p] -> let p' = fromIntegral p
-        in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
+      Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
       _        -> return ()
 
-handle _ _ = return ()
+handleEvent _ = return ()
 
-waitAndKill :: String -> Pid -> IO ()
-waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
-
-withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
-withUniquePid curPIDs pid f = do
-  pids <- readMVar curPIDs
-  unless (pid `elem` pids) $ do
-    modifyMVar_ curPIDs (return . (pid:))
-    f
-    modifyMVar_ curPIDs (return . filter (/=pid))
+withUniquePid :: Pid -> String -> W ()
+withUniquePid pid tag = do
+  ps <- asks curPIDs
+  pids <- readMVar ps
+  io $ unless (pid `elem` pids) $ bracket_
+    (modifyMVar_ ps (return . S.insert pid))
+    (modifyMVar_ ps (return . S.delete pid))
+    $ waitUntilExit pid >> sendXMsg Workspace tag
 
 --------------------------------------------------------------------------------
 -- | Launching apps