ENH use exporter/unexporter pairs

bin/xmonad.hs

@@ -114,38 +114,39 @@ run = do
   hSetBuffering stdout LineBuffering
   withDBusX_ $ \db -> do
     let fs = features $ dbSysClient db
-    startDBusInterfaces db fs
+    -- startDBusInterfaces db fs
-    withXmobar $ \xmobarP -> do
+    withDBusInterfaces db $ \_ -> do
-      withChildDaemons fs $ \ds -> do
+      withXmobar $ \xmobarP -> do
-        let ts = ThreadState ds (Just xmobarP)
+        withChildDaemons fs $ \ds -> do
-        void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
+          let ts = ThreadState ds (Just xmobarP)
-        void $ async $ void $ executeSometimes $ fsPowerMon fs
+          void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
-        dws <- startDynWorkspaces fs
+          void $ async $ void $ executeSometimes $ fsPowerMon fs
-        runIO <- askRunInIO
+          dws <- startDynWorkspaces fs
-        let cleanup = runCleanup runIO ts db
+          runIO <- askRunInIO
-        kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
+          let cleanup = runCleanup runIO ts db
-        sk <- evalAlways $ fsShowKeys fs
+          kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
-        ha <- evalAlways $ fsACPIHandler fs
+          sk <- evalAlways $ fsShowKeys fs
-        tt <- evalAlways $ fsTabbedTheme fs
+          ha <- evalAlways $ fsACPIHandler fs
-        let conf =
+          tt <- evalAlways $ fsTabbedTheme fs
-              ewmh $
+          let conf =
-                addKeymap dws sk kbs $
+                ewmh $
-                  docks $
+                  addKeymap dws sk kbs $
-                    def
+                    docks $
-                      { terminal = myTerm
+                      def
-                      , modMask = myModMask
+                        { terminal = myTerm
-                      , layoutHook = myLayouts tt
+                        , modMask = myModMask
-                      , manageHook = myManageHook dws
+                        , layoutHook = myLayouts tt
-                      , handleEventHook = myEventHook runIO ha
+                        , manageHook = myManageHook dws
-                      , startupHook = myStartupHook
+                        , handleEventHook = myEventHook runIO ha
-                      , workspaces = myWorkspaces
+                        , startupHook = myStartupHook
-                      , logHook = myLoghook xmobarP
+                        , workspaces = myWorkspaces
-                      , clickJustFocuses = False
+                        , logHook = myLoghook xmobarP
-                      , focusFollowsMouse = False
+                        , clickJustFocuses = False
-                      , normalBorderColor = T.unpack XT.bordersColor
+                        , focusFollowsMouse = False
-                      , focusedBorderColor = T.unpack XT.selectedBordersColor
+                        , normalBorderColor = T.unpack XT.bordersColor
-                      }
+                        , focusedBorderColor = T.unpack XT.selectedBordersColor
-        io $ runXMonad conf
+                        }
+          io $ runXMonad conf
   where
     startDynWorkspaces fs = do
       dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
@@ -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,45 +101,47 @@ 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)
-  let ses = toClient cl
-  maxval <- bcGetMax bc -- assume the max value will never change
-  let bounds = (bcMinRaw bc, maxval)
-  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
-  let funget = bcGet bc
-  export
-    ses
-    (bcPath bc)
-    defaultInterface
-      { interfaceName = bcInterface bc
-      , interfaceMethods =
-          [ autoMethod' memMax bcMax
-          , autoMethod' memMin bcMin
-          , autoMethod' memInc bcInc
-          , autoMethod' memDec bcDec
-          , autoMethod memGet (round <$> funget bounds :: IO Int32)
-          ]
-      , interfaceSignals = [sig]
-      }
   where
+    up = liftIO $ do
+      let ses = toClient cl
+      maxval <- bcGetMax bc -- assume the max value will never change
+      let bounds = (bcMinRaw bc, maxval)
+      let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
+      let funget = bcGet bc
+      export
+        ses
+        (bcPath bc)
+        defaultInterface
+          { interfaceName = bcInterface bc
+          , interfaceMethods =
+              [ autoMethod' memMax bcMax
+              , autoMethod' memMin bcMin
+              , autoMethod' memInc bcInc
+              , autoMethod' memDec bcDec
+              , autoMethod memGet (round <$> funget bounds :: IO Int32)
+              ]
+          , interfaceSignals = [sig]
+          }
+    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