ENH use exporter/unexporter pairs

bin/xmonad.hs

@@ -114,7 +114,8 @@ run = do
   hSetBuffering stdout LineBuffering
   withDBusX_ $ \db -> do
     let fs = features $ dbSysClient db
-    startDBusInterfaces db fs
+    -- startDBusInterfaces db fs
+    withDBusInterfaces db $ \_ -> do
       withXmobar $ \xmobarP -> do
         withChildDaemons fs $ \ds -> do
           let ts = ThreadState ds (Just xmobarP)
@@ -157,10 +158,8 @@ runXMonad conf = do
   dirs <- getCreateDirectories
   launch conf dirs
 
-startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
+-- startDBusInterfaces :: DBusState -> [Maybe SesClient -> SometimesIO] -> FIO ()
-startDBusInterfaces db fs =
+-- startDBusInterfaces db = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
-  mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
-    fsDBusExporters fs
 
 getCreateDirectories :: IO Directories
 getCreateDirectories = do
@@ -177,7 +176,7 @@ getCreateDirectories = do
 
 data FeatureSet = FeatureSet
   { fsKeys :: X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
+  , fsDBusExporters :: [Maybe SesClient -> Sometimes (IO (), IO ())]
   , fsPowerMon :: SometimesIO
   , fsRemovableMon :: Maybe SysClient -> SometimesIO
   , fsDaemons :: [Sometimes (FIO (Process () () ()))]
@@ -246,16 +245,21 @@ stopChildDaemons ps = do
 
 printDeps :: FIO ()
 printDeps = withDBus_ $ \db -> do
-  (i, f, d) <- allFeatures db
+  (u, i, f, d) <- allFeatures db
   -- TODO might be better to use glog for this?
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
         nub $
           concat $
-            fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
+            fmap dumpSometimes u
+              ++ fmap dumpFeature f
+              ++ fmap dumpSometimes i
+              ++ fmap dumpSometimes d
 
-allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
+allFeatures
+  :: DBusState
+  -> FIO ([Sometimes (IO (), IO ())], [SometimesIO], [FeatureX], [Sometimes DynWorkspace])
 allFeatures db = withRunInIO $ \runIO -> do
   let cleanup = runCleanup runIO ts db
   let bfs =
@@ -263,7 +267,7 @@ allFeatures db = withRunInIO $ \runIO -> do
           externalBindings cleanup db
   let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
   let others = [runRemovableMon $ dbSysClient db, runPowermon]
-  return (dbus ++ others, Left runScreenLock : bfs, allDWs')
+  return (dbus, others, Left runScreenLock : bfs, allDWs')
   where
     ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
 

lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs

@@ -115,7 +115,7 @@ brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 clevoKeyboardSignalDep :: DBusDependency_ SesClient
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
 
-exportClevoKeyboard :: Maybe SesClient -> SometimesIO
+exportClevoKeyboard :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
     xpfClevoBacklight

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -101,25 +101,27 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
 -- Internal DBus Crap
 
 brightnessExporter
-  :: RealFrac b
+  :: (MonadUnliftIO m, RealFrac b)
   => XPQuery
   -> [Fulfillment]
   -> [IODependency_]
   -> BrightnessConfig a b
   -> Maybe SesClient
-  -> SometimesIO
+  -> Sometimes (m (), m ())
 brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
   Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
   where
-    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
+    root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
     tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
-exportBrightnessControls'
+exportBrightnessControlsInner
   :: (MonadUnliftIO m, RealFrac b)
   => BrightnessConfig a b
   -> SesClient
-  -> m ()
+  -> (m (), m ())
-exportBrightnessControls' bc cl = io $ do
+exportBrightnessControlsInner bc cl = (up, down)
+  where
+    up = liftIO $ do
       let ses = toClient cl
       maxval <- bcGetMax bc -- assume the max value will never change
       let bounds = (bcMinRaw bc, maxval)
@@ -139,7 +141,7 @@ exportBrightnessControls' bc cl = io $ do
               ]
           , interfaceSignals = [sig]
           }
-  where
+    down = liftIO $ unexport (toClient cl) (bcPath bc)
     sig =
       I.Signal
         { I.signalName = memCur

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

@@ -99,7 +99,7 @@ maxFileDep = pathR maxFile []
 intelBacklightSignalDep :: DBusDependency_ SesClient
 intelBacklightSignalDep = signalDep intelBacklightConfig
 
-exportIntelBacklight :: Maybe SesClient -> SometimesIO
+exportIntelBacklight :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
     xpfIntelBacklight

lib/XMonad/Internal/DBus/Control.hs

@@ -7,6 +7,7 @@
 module XMonad.Internal.DBus.Control
   ( Client
   , DBusState (..)
+  , withDBusInterfaces
   , withDBusX
   , withDBusX_
   , withDBus
@@ -99,8 +100,16 @@ disconnectDBusX db = do
   forM_ (dbSesClient db) releaseXMonadName
   disconnectDBus db
 
+withDBusInterfaces :: DBusState -> ([FIO ()] -> FIO a) -> FIO a
+withDBusInterfaces db = bracket up sequence
+  where
+    up = do
+      pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) dbusExporters
+      mapM_ fst pairs
+      return $ snd <$> pairs
+
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: [Maybe SesClient -> SometimesIO]
+dbusExporters :: MonadUnliftIO m => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 releaseXMonadName

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -93,13 +93,13 @@ bodyGetCurrentState _ = Nothing
 --------------------------------------------------------------------------------
 -- Exported haskell API
 
-exportScreensaver :: Maybe SesClient -> SometimesIO
+exportScreensaver :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ())
 exportScreensaver ses =
-  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
+  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl)
   where
-    cmd cl =
+    up cl =
       let cl' = toClient cl
-       in withRunInIO $ \run ->
+       in liftIO $ withRunInIO $ \run ->
             export
               cl'
               ssPath
@@ -111,6 +111,7 @@ exportScreensaver ses =
                     ]
                 , interfaceSignals = [sig]
                 }
+    down cl = liftIO $ unexport (toClient cl) ssPath
     sig =
       I.Signal
         { I.signalName = memState