ENH use exporter/unexporter pairs

2023-01-01 12:43:54 -05:00 · 2023-01-01 12:43:54 -05:00 · 43345f8ce0
parent 4afaf9af10
commit 43345f8ce0
6 changed files with 89 additions and 73 deletions
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@ -114,38 +114,39 @@ run = do
  hSetBuffering stdout LineBuffering
  withDBusX_ $ \db -> do
    let fs = features $ dbSysClient db
-    startDBusInterfaces db fs
-    withXmobar $ \xmobarP -> do
-      withChildDaemons fs $ \ds -> do
-        let ts = ThreadState ds (Just xmobarP)
-        void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
-        void $ async $ void $ executeSometimes $ fsPowerMon fs
-        dws <- startDynWorkspaces fs
-        runIO <- askRunInIO
-        let cleanup = runCleanup runIO ts db
-        kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
-        sk <- evalAlways $ fsShowKeys fs
-        ha <- evalAlways $ fsACPIHandler fs
-        tt <- evalAlways $ fsTabbedTheme fs
-        let conf =
-              ewmh $
-                addKeymap dws sk kbs $
-                  docks $
-                    def
-                      { terminal = myTerm
-                      , modMask = myModMask
-                      , layoutHook = myLayouts tt
-                      , manageHook = myManageHook dws
-                      , handleEventHook = myEventHook runIO ha
-                      , startupHook = myStartupHook
-                      , workspaces = myWorkspaces
-                      , logHook = myLoghook xmobarP
-                      , clickJustFocuses = False
-                      , focusFollowsMouse = False
-                      , normalBorderColor = T.unpack XT.bordersColor
-                      , focusedBorderColor = T.unpack XT.selectedBordersColor
-                      }
-        io $ runXMonad conf
+    -- startDBusInterfaces db fs
+    withDBusInterfaces db $ \_ -> do
+      withXmobar $ \xmobarP -> do
+        withChildDaemons fs $ \ds -> do
+          let ts = ThreadState ds (Just xmobarP)
+          void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
+          void $ async $ void $ executeSometimes $ fsPowerMon fs
+          dws <- startDynWorkspaces fs
+          runIO <- askRunInIO
+          let cleanup = runCleanup runIO ts db
+          kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
+          sk <- evalAlways $ fsShowKeys fs
+          ha <- evalAlways $ fsACPIHandler fs
+          tt <- evalAlways $ fsTabbedTheme fs
+          let conf =
+                ewmh $
+                  addKeymap dws sk kbs $
+                    docks $
+                      def
+                        { terminal = myTerm
+                        , modMask = myModMask
+                        , layoutHook = myLayouts tt
+                        , manageHook = myManageHook dws
+                        , handleEventHook = myEventHook runIO ha
+                        , startupHook = myStartupHook
+                        , workspaces = myWorkspaces
+                        , logHook = myLoghook xmobarP
+                        , clickJustFocuses = False
+                        , focusFollowsMouse = False
+                        , normalBorderColor = T.unpack XT.bordersColor
+                        , focusedBorderColor = T.unpack XT.selectedBordersColor
+                        }
+          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 db fs =
-  mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
-    fsDBusExporters fs
+-- startDBusInterfaces :: DBusState -> [Maybe SesClient -> SometimesIO] -> FIO ()
+-- startDBusInterfaces db = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)

 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}

--- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
+++ b/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
--- a/lib/XMonad/Internal/DBus/Brightness/Common.hs
+++ b/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 ()
-exportBrightnessControls' bc cl = io $ 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]
-      }
+  -> (m (), m ())
+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)
+      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
--- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
+++ b/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
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/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
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/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