From e0a186dd1897c0b691674daeb6df5e76b8b55c2f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sun, 1 Jan 2023 13:07:10 -0500
Subject: [PATCH] ENH clean up interfaces

---
 bin/xmonad.hs                           | 55 ++++++++++++-------------
 lib/XMonad/Internal/DBus/Control.hs     |  4 +-
 lib/XMonad/Internal/DBus/Screensaver.hs |  9 +++-
 3 files changed, 36 insertions(+), 32 deletions(-)

diff --git a/bin/xmonad.hs b/bin/xmonad.hs
index 834222c..f7747db 100644
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@@ -114,15 +114,15 @@ run = do
   hSetBuffering stdout LineBuffering
   withDBusX_ $ \db -> do
     let fs = features $ dbSysClient db
-    withDBusInterfaces db (fsDBusExporters fs) $ \_ -> do
+    withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
       withXmobar $ \xmobarP -> do
         withChildDaemons fs $ \ds -> do
-          let ts = ThreadState ds (Just xmobarP)
+          let toClean = Cleanup ds (Just xmobarP) unexporters
           void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
           void $ async $ void $ executeSometimes $ fsPowerMon fs
           dws <- startDynWorkspaces fs
           runIO <- askRunInIO
-          let cleanup = runCleanup runIO ts db
+          let cleanup = runCleanup runIO toClean db
           kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
           sk <- evalAlways $ fsShowKeys fs
           ha <- evalAlways $ fsACPIHandler fs
@@ -241,49 +241,46 @@ stopChildDaemons ps = do
 
 printDeps :: FIO ()
 printDeps = withDBus_ $ \db -> do
-  (u, i, f, d) <- allFeatures db
+  runIO <- askRunInIO
+  let mockCleanup = runCleanup runIO mockClean db
+  let bfs =
+        concatMap (fmap kbMaybeAction . kgBindings) $
+          externalBindings mockCleanup db
+  let dbus =
+        fmap (\f -> f $ dbSesClient db) dbusExporters
+          :: [Sometimes (FIO (), FIO ())]
+  let others = [runRemovableMon $ dbSysClient db, runPowermon]
   -- TODO might be better to use glog for this?
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
         nub $
           concat $
-            fmap dumpSometimes u
-              ++ fmap dumpFeature f
-              ++ fmap dumpSometimes i
-              ++ fmap dumpSometimes d
-
-allFeatures
-  :: DBusState
-  -> FIO ([Sometimes (IO (), IO ())], [SometimesIO], [FeatureX], [Sometimes DynWorkspace])
-allFeatures db = withRunInIO $ \runIO -> do
-  let cleanup = runCleanup runIO ts db
-  let bfs =
-        concatMap (fmap kbMaybeAction . kgBindings) $
-          externalBindings cleanup db
-  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
-  let others = [runRemovableMon $ dbSysClient db, runPowermon]
-  return (dbus, others, Left runScreenLock : bfs, allDWs')
+            fmap dumpSometimes dbus
+              ++ fmap dumpSometimes others
+              ++ fmap dumpSometimes allDWs'
+              ++ fmap dumpFeature bfs
   where
-    ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
+    mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
 
 --------------------------------------------------------------------------------
 -- Concurrency configuration
 
-data ThreadState = ThreadState
-  { tsChildPIDs :: [Process () () ()]
-  , tsXmobar :: Maybe (Process Handle () ())
+data Cleanup = Cleanup
+  { clChildren :: [Process () () ()]
+  , clXmobar :: Maybe (Process Handle () ())
+  , clDBusUnexporters :: [FIO ()]
   }
 
 runCleanup
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (m () -> IO ())
-  -> ThreadState
+  :: (FIO () -> IO ())
+  -> Cleanup
   -> DBusState
   -> X ()
 runCleanup runIO ts db = liftIO $ runIO $ do
-  mapM_ stopXmobar $ tsXmobar ts
-  stopChildDaemons $ tsChildPIDs ts
+  mapM_ stopXmobar $ clXmobar ts
+  stopChildDaemons $ clChildren ts
+  sequence_ $ clDBusUnexporters ts
   disconnectDBusX db
 
 -- | Kill a process (group) after xmonad has already started
diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs
index ea45fa9..584a618 100644
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@@ -113,7 +113,9 @@ withDBusInterfaces db interfaces = bracket up sequence
       return $ snd <$> pairs
 
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: MonadUnliftIO m => [Maybe SesClient -> Sometimes (m (), m ())]
+dbusExporters
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 releaseXMonadName
diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs
index cfd20ce..4cc6c4a 100644
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/lib/XMonad/Internal/DBus/Screensaver.hs
@@ -93,7 +93,10 @@ bodyGetCurrentState _ = Nothing
 --------------------------------------------------------------------------------
 -- Exported haskell API
 
-exportScreensaver :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ())
+exportScreensaver
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe SesClient
+  -> Sometimes (m (), m ())
 exportScreensaver ses =
   sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl)
   where
@@ -111,7 +114,9 @@ exportScreensaver ses =
                     ]
                 , interfaceSignals = [sig]
                 }
-    down cl = liftIO $ unexport (toClient cl) ssPath
+    down cl = do
+      logInfo "removing screensaver interface"
+      liftIO $ unexport (toClient cl) ssPath
     sig =
       I.Signal
         { I.signalName = memState