ENH run xmonad and xmobar totally in rio

2022-12-31 21:03:58 -05:00
49 changed files with 1312 additions and 1909 deletions
--- a/bin/vbox-start.hs
+++ b/bin/vbox-start.hs
@ -1,3 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- | Start a VirtualBox instance with a sentinel wrapper process.
 --
 -- The only reason why this is needed is because I want to manage virtualboxes
@ -40,7 +43,7 @@ runAndWait [n] = do
      p <- vmPID i
      liftIO $ mapM_ waitUntilExit p
    err = logError "Could not get machine ID"
-runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
+runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"

 vmLaunch :: T.Text -> RIO SimpleApp ()
 vmLaunch i = do
--- a/bin/xmobar.hs
+++ b/bin/xmobar.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | Xmobar binary
 --
 -- Features:
@ -10,15 +12,16 @@
 module Main (main) where

 import Data.Internal.DBus
-import Data.Internal.XIO
-import GHC.Enum (enumFrom)
-import Options.Applicative
+import Data.Internal.Dependency
 import RIO hiding (hFlush)
-import RIO.FilePath
+import qualified RIO.ByteString.Lazy as BL
 import RIO.List
-import qualified RIO.NonEmpty as NE
+import RIO.Process
 import qualified RIO.Text as T
+import System.IO
+import UnliftIO.Environment
 import XMonad.Core hiding (config)
+import XMonad.Internal.Command.Desktop
 import XMonad.Internal.Command.Power
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -29,58 +32,32 @@ import Xmobar hiding
  ( iconOffset
  , run
  )
-import Xmobar.Plugins.ActiveConnection
 import Xmobar.Plugins.Bluetooth
 import Xmobar.Plugins.ClevoKeyboard
 import Xmobar.Plugins.Common
+import Xmobar.Plugins.Device
 import Xmobar.Plugins.IntelBacklight
 import Xmobar.Plugins.Screensaver
+import Xmobar.Plugins.VPN

 main :: IO ()
-main = parse >>= xio
+main = getArgs >>= parse

-parse :: IO XOpts
-parse = execParser opts
-  where
-    parseOpts = parseDeps <|> parseTest <|> pure XRun
-    opts =
-      info (parseOpts <**> helper) $
-        fullDesc <> header "xmobar: the best taskbar ever"
+parse :: [String] -> IO ()
+parse [] = run
+parse ["--deps"] = withCache printDeps
+parse ["--test"] = withCache $ withDBus_ evalConfig
+parse _ = usage

-data XOpts = XDeps | XTest | XRun
+run :: IO ()
+run = withCache $ withDBus_ $ \db -> do
+  c <- evalConfig db
+  -- this is needed to see any printed messages
+  liftIO $ do
+    hFlush stdout
+    xmobar c

-parseDeps :: Parser XOpts
-parseDeps =
-  flag'
-    XDeps
-    (long "deps" <> short 'd' <> help "print dependencies")
-
-parseTest :: Parser XOpts
-parseTest =
-  flag'
-    XTest
-    (long "test" <> short 't' <> help "test dependencies without running")
-
-xio :: XOpts -> IO ()
-xio o = case o of
-  XDeps -> hRunXIO False stderr printDeps
-  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
-  XRun -> runXIO "xmobar.log" run
-
-run :: XIO ()
-run = do
-  -- IDK why this is needed, I thought this was default
-  liftIO $ hSetBuffering stdout LineBuffering
-  -- this isn't totally necessary except for the fact that killing xmobar
-  -- will make it print something about catching SIGTERM, and without
-  -- linebuffering it usually only prints the first few characters (even then
-  -- it only prints 10-20% of the time)
-  liftIO $ hSetBuffering stderr LineBuffering
-  -- TODO do these dbus things really need to remain connected?
-  c <- withDBus Nothing Nothing evalConfig
-  liftIO $ xmobar c
-
-evalConfig :: DBusState -> XIO Config
+evalConfig :: DBusState -> FIO Config
 evalConfig db = do
  cs <- getAllCommands <$> rightPlugins db
  bf <- getTextFont
@ -88,14 +65,19 @@ evalConfig db = do
  d <- io $ cfgDir <$> getDirectories
  return $ config bf ifs ios cs d

-printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db ->
-  mapM_ logInfo $
-    fmap showFulfillment $
-      sort $
-        nub $
-          concatMap dumpFeature $
-            allFeatures db
+printDeps :: FIO ()
+printDeps = withDBus_ $ \db -> do
+  let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
+  io $ mapM_ (putStrLn . T.unpack) ps
+
+usage :: IO ()
+usage =
+  putStrLn $
+    intercalate
+      "\n"
+      [ "xmobar: run greatest taskbar"
+      , "xmobar --deps: print dependencies"
+      ]

 --------------------------------------------------------------------------------
 -- toplevel configuration
@ -118,7 +100,7 @@ iconFont =
  fontSometimes
    "XMobar Icon Font"
    "Symbols Nerd Font"
-    [Package Official "ttf-nerd-fonts-symbols"]
+    [Package Official "ttf-nerd-fonts-symbols-2048-em"]

 -- | Offsets for the icons in the bar (relative to the text offset)
 iconOffset :: BarFont -> Int
@ -164,7 +146,7 @@ config bf ifs ios br confDir =
    , pickBroadest = False
    , persistent = True
    , -- store the icons with the xmonad/xmobar stack project
-      iconRoot = confDir </> "assets" </> "icons"
+      iconRoot = confDir ++ "/icons"
    , commands = csRunnable <$> concatRegions br
    }

@ -187,7 +169,7 @@ getAllCommands right =
    , brRight = catMaybes right
    }

-rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
+rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
 rightPlugins db =
  mapM evalFeature $
    allFeatures db
@ -219,11 +201,11 @@ getWireless =
    xpfWireless
    [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]

-getEthernet :: Maybe NamedSysConnection -> BarFeature
-getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
+getEthernet :: Maybe SysClient -> BarFeature
+getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
  where
-    root useIcon tree' =
-      DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
+    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
+    tree = And1 (Only readEthernet) (Only_ devDep)

 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@ -235,12 +217,18 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
          io $
            fmap (Msg LevelError) <$> hasBattery

-getVPN :: Maybe NamedSysConnection -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
+getVPN :: Maybe SysClient -> BarFeature
+getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
  where
    root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
+    test =
+      DBusIO $
+        IOTest_
+          "Use nmcli to test if VPN is present"
+          networkManagerPkgs
+          vpnPresent

-getBt :: Maybe NamedSysConnection -> BarFeature
+getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd

 getAlsa :: BarFeature
@ -251,7 +239,7 @@ getAlsa =
  where
    root useIcon = IORoot_ (alsaCmd useIcon)

-getBl :: Maybe NamedSesConnection -> BarFeature
+getBl :: Maybe SesClient -> BarFeature
 getBl =
  xmobarDBus
    "Intel backlight indicator"
@ -259,7 +247,7 @@ getBl =
    intelBacklightSignalDep
    blCmd

-getCk :: Maybe NamedSesConnection -> BarFeature
+getCk :: Maybe SesClient -> BarFeature
 getCk =
  xmobarDBus
    "Clevo keyboard indicator"
@ -267,7 +255,7 @@ getCk =
    clevoKeyboardSignalDep
    ckCmd

-getSs :: Maybe NamedSesConnection -> BarFeature
+getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd

 getLock :: Always CmdSpec
@ -284,7 +272,7 @@ xmobarDBus
  -> XPQuery
  -> DBusDependency_ c
  -> (Fontifier -> CmdSpec)
-  -> Maybe (NamedConnection c)
+  -> Maybe c
  -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
  where
@ -298,16 +286,18 @@ iconIO_
  -> BarFeature
 iconIO_ = iconSometimes' And_ Only_

-- iconDBus
--   :: T.Text
--   -> XPQuery
--   -> (Fontifier -> DBusTree c p -> Root CmdSpec)
--   -> DBusTree c p
--   -> BarFeature
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
+iconDBus
+  :: SafeClient c
+  => T.Text
+  -> XPQuery
+  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
+  -> DBusTree c p
+  -> BarFeature
+iconDBus = iconSometimes' And1 $ Only_ . DBusIO

 iconDBus_
-  :: T.Text
+  :: SafeClient c
+  => T.Text
  -> XPQuery
  -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
  -> DBusTree_ c
@ -369,19 +359,13 @@ wirelessCmd iface =
        , "<icon=wifi_%%.xpm/>"
        ]

-ethernetCmd :: Fontifier -> CmdSpec
-ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
-
-vpnCmd :: Fontifier -> CmdSpec
-vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
-
-connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
-connCmd icon abbr contypes fontify =
+ethernetCmd :: Fontifier -> T.Text -> CmdSpec
+ethernetCmd fontify iface =
  CmdSpec
-    { csAlias = connAlias contypes
+    { csAlias = iface
    , csRunnable =
        Run $
-          ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
+          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
    }

 batteryCmd :: Fontifier -> CmdSpec
@ -417,13 +401,20 @@ batteryCmd fontify =
        , fontify' "\xf1e6" "AC"
        ]

+vpnCmd :: Fontifier -> CmdSpec
+vpnCmd fontify =
+  CmdSpec
+    { csAlias = vpnAlias
+    , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
+    }
+
 btCmd :: Fontifier -> CmdSpec
 btCmd fontify =
  CmdSpec
    { csAlias = btAlias
    , csRunnable =
        Run $
-          Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
+          Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
    }
  where
    fontify' i = fontify IconLarge i . T.append "BT"
@ -464,7 +455,7 @@ ckCmd :: Fontifier -> CmdSpec
 ckCmd fontify =
  CmdSpec
    { csAlias = ckAlias
-    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
+    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
    }

 ssCmd :: Fontifier -> CmdSpec
@ -500,8 +491,8 @@ lockCmd fontify =
              ]
    }
  where
-    numIcon = fontify' "\x0f03a6" "N"
-    capIcon = fontify' "\x0f0bf1" "C"
+    numIcon = fontify' "\xf8a5" "N"
+    capIcon = fontify' "\xf657" "C"
    fontify' = fontify IconXLarge
    disabledColor = xmobarFGColor XT.backdropFgColor

@ -512,13 +503,36 @@ dateCmd =
    , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
    }

+--------------------------------------------------------------------------------
+-- low-level testing functions
+
+vpnPresent :: FIO (Maybe Msg)
+vpnPresent = do
+  res <- proc "nmcli" args readProcess
+  return $ case res of
+    (ExitSuccess, out, _)
+      | "vpn" `elem` BL.split 10 out -> Nothing
+      | otherwise -> Just $ Msg LevelError "vpn not found"
+    (ExitFailure c, _, err) ->
+      Just $
+        Msg LevelError $
+          T.concat
+            [ "vpn search exited with code "
+            , T.pack $ show c
+            , ": "
+            , T.decodeUtf8With T.lenientDecode $
+                BL.toStrict err
+            ]
+  where
+    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
+
 --------------------------------------------------------------------------------
 -- text font
 --
 -- ASSUME there is only one text font for this entire configuration. This
 -- will correspond to the first font/offset parameters in the config record.

-getTextFont :: XIO T.Text
+getTextFont :: FIO T.Text
 getTextFont = do
  fb <- evalAlways textFont
  return $ fb textFontData
@ -526,7 +540,7 @@ getTextFont = do
 --------------------------------------------------------------------------------
 -- icon fonts

-getIconFonts :: XIO ([T.Text], [Int])
+getIconFonts :: FIO ([T.Text], [Int])
 getIconFonts = do
  fb <- evalSometimes iconFont
  return $ maybe ([], []) apply fb
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@ -1,16 +1,20 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 --  XMonad binary

 module Main (main) where

 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import Data.Monoid
 import Data.Text.IO (hPutStrLn)
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Extras
-import Options.Applicative hiding (action)
 import RIO
 import RIO.Directory
 import RIO.List
@ -21,7 +25,8 @@ import System.Process
  ( getPid
  , getProcessExitCode
  )
-import XMonad hiding (display)
+import UnliftIO.Environment
+import XMonad
 import XMonad.Actions.CopyWindow
 import XMonad.Actions.CycleWS
 import XMonad.Actions.PhysicalScreens
@ -45,7 +50,6 @@ import XMonad.Internal.DBus.Removable
 import XMonad.Internal.DBus.Screensaver
 import XMonad.Internal.Shell hiding (proc)
 import qualified XMonad.Internal.Theme as XT
-import XMonad.Layout.Decoration
 import XMonad.Layout.MultiToggle
 import XMonad.Layout.NoBorders
 import XMonad.Layout.NoFrillsDecoration
@ -61,37 +65,15 @@ import XMonad.Util.NamedActions
 import XMonad.Util.WorkspaceCompare

 main :: IO ()
-main = parse >>= xio
+main = getArgs >>= parse

-parse :: IO XOpts
-parse = execParser opts
-  where
-    parseOpts = parseDeps <|> parseTest <|> pure XRun
-    opts =
-      info (parseOpts <**> helper) $
-        fullDesc <> header "xmonad: the best window manager ever"
+parse :: [String] -> IO ()
+parse [] = run
+parse ["--deps"] = withCache printDeps
+-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
+parse _ = usage

-data XOpts = XDeps | XTest | XRun
-
-parseDeps :: Parser XOpts
-parseDeps =
-  flag'
-    XDeps
-    (long "deps" <> short 'd' <> help "print dependencies")
-
-parseTest :: Parser XOpts
-parseTest =
-  flag'
-    XTest
-    (long "test" <> short 't' <> help "test dependencies without running")
-
-xio :: XOpts -> IO ()
-xio o = case o of
-  XDeps -> hRunXIO False stderr printDeps
-  XTest -> undefined
-  XRun -> runXIO "xmonad.log" run
-
-run :: XIO ()
+run :: IO ()
 run = do
  -- These first two commands are only significant when xmonad is restarted.
  -- The 'launch' function below this will turn off buffering (so flushes are
@ -106,31 +88,31 @@ run = do
  -- signal handlers to carry over to the top.
  uninstallSignalHandlers
  hSetBuffering stdout LineBuffering
-  withDBusX_ $ \db -> do
-    let fs = features $ dbSysClient db
-    withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
+  withCache $ do
+    withDBusX_ $ \db -> do
+      let sys = dbSysClient db
+      let fs = features sys
+      startDBusInterfaces db fs
      withXmobar $ \xmobarP -> do
        withChildDaemons fs $ \ds -> do
-          let toClean = Cleanup ds (Just xmobarP) unexporters
-          void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
-          void $ async $ void $ executeSometimes $ fsPowerMon fs
+          let ts = ThreadState ds (Just xmobarP)
+          startRemovableMon db fs
+          startPowerMon fs
          dws <- startDynWorkspaces fs
-          runIO <- askRunInIO
-          let cleanup = runCleanup runIO toClean db
-          kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
+          kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
          sk <- evalAlways $ fsShowKeys fs
          ha <- evalAlways $ fsACPIHandler fs
          tt <- evalAlways $ fsTabbedTheme fs
          let conf =
                ewmh $
-                  addKeymap dws (liftIO . runIO . sk) kbs $
+                  addKeymap dws sk kbs $
                    docks $
                      def
                        { terminal = myTerm
                        , modMask = myModMask
                        , layoutHook = myLayouts tt
                        , manageHook = myManageHook dws
-                        , handleEventHook = myEventHook runIO ha
+                        , handleEventHook = myEventHook ha
                        , startupHook = myStartupHook
                        , workspaces = myWorkspaces
                        , logHook = myLoghook xmobarP
@ -139,21 +121,32 @@ run = do
                        , normalBorderColor = T.unpack XT.bordersColor
                        , focusedBorderColor = T.unpack XT.selectedBordersColor
                        }
-          runXMonad conf
+          io $ runXMonad conf
  where
+    startRemovableMon db fs =
+      void $
+        executeSometimes $
+          fsRemovableMon fs $
+            dbSysClient db
+    startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
    startDynWorkspaces fs = do
      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
-      void $ async $ runWorkspaceMon dws
+      void $ io $ async $ runWorkspaceMon dws
      return dws

-runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> XIO ()
+runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
 runXMonad conf = do
  dirs <- getCreateDirectories
-  liftIO $ launch conf dirs
+  launch conf dirs

-getCreateDirectories :: XIO Directories
+startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
+startDBusInterfaces db fs =
+  mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
+    fsDBusExporters fs
+
+getCreateDirectories :: IO Directories
 getCreateDirectories = do
-  ds <- liftIO getDirectories
+  ds <- getDirectories
  mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
  return ds
  where
@ -161,19 +154,19 @@ getCreateDirectories = do
      let d = f ds
      r <- tryIO $ createDirectoryIfMissing True d
      case r of
-        (Left e) -> logError $ display e
+        (Left e) -> print e
        _ -> return ()

 data FeatureSet = FeatureSet
-  { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
+  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
  , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
-  , fsDaemons :: [Sometimes (XIO (Process () () ()))]
+  , fsRemovableMon :: Maybe SysClient -> SometimesIO
+  , fsDaemons :: [Sometimes (FIO (Process () () ()))]
  , fsACPIHandler :: Always (String -> X ())
  , fsTabbedTheme :: Always Theme
  , fsDynWorkspaces :: [Sometimes DynWorkspace]
-  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
+  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
  }

 tabbedFeature :: Always Theme
@ -183,7 +176,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
    niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
    fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont

-features :: Maybe NamedSysConnection -> FeatureSet
+features :: Maybe SysClient -> FeatureSet
 features cl =
  FeatureSet
    { fsKeys = externalBindings
@ -197,12 +190,8 @@ features cl =
    , fsDaemons = [runNetAppDaemon cl, runAutolock]
    }

-withXmobar :: (Process Handle () () -> XIO a) -> XIO a
-withXmobar = bracket startXmobar stopXmobar
-
-startXmobar :: XIO (Process Handle () ())
+startXmobar :: FIO (Process Handle () ())
 startXmobar = do
-  logInfo "starting xmobar child process"
  p <- proc "xmobar" [] start
  io $ hSetBuffering (getStdin p) LineBuffering
  return p
@ -212,87 +201,66 @@ startXmobar = do
        . setStdin createPipe
        . setCreateGroup True

-stopXmobar
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Process Handle () ()
-  -> m ()
-stopXmobar p = do
-  logInfo "stopping xmobar child process"
-  io $ killNoWait p
+startChildDaemons :: FeatureSet -> FIO [Process () () ()]
+startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)

-withChildDaemons
-  :: FeatureSet
-  -> ([(Utf8Builder, Process () () ())] -> XIO a)
-  -> XIO a
-withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
-
-startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
-startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
+withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
+withChildDaemons fs = bracket (startChildDaemons fs) cleanup
  where
-    start s@(Sometimes sname _ _) = do
-      let sname_ = Utf8Builder $ encodeUtf8Builder sname
-      res <- executeSometimes s
-      case res of
-        Just p -> do
-          logInfo $ "starting child process: " <> sname_
-          return $ Just (sname_, p)
-        -- don't log anything here since presumably the feature itself will log
-        -- an error if it fails during execution
-        _ -> return Nothing
+    cleanup ps = do
+      logInfo "stopping child processes"
+      mapM_ (io . killNoWait) ps

-stopChildDaemons
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [(Utf8Builder, Process () () ())]
-  -> m ()
-stopChildDaemons = mapM_ stop
+withXmobar :: (Process Handle () () -> FIO a) -> FIO a
+withXmobar = bracket startXmobar cleanup
  where
-    stop (n, p) = do
-      logInfo $ "stopping child process: " <> n
-      liftIO $ killNoWait p
+    cleanup p = do
+      logInfo "stopping xmobar child process"
+      io $ killNoWait p

-printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db -> do
-  runIO <- askRunInIO
-  let mockCleanup = runCleanup runIO mockClean db
-  let bfs =
-        concatMap (fmap kbMaybeAction . kgBindings) $
-          externalBindings runIO mockCleanup db
-  let dbus =
-        fmap (\f -> f $ dbSesClient db) dbusExporters
-          :: [Sometimes (XIO (), XIO ())]
-  let others = [runRemovableMon $ dbSysClient db, runPowermon]
-  -- TODO might be better to use glog for this?
-  mapM_ logInfo $
+printDeps :: FIO ()
+printDeps = withDBus_ $ \db -> do
+  (i, f, d) <- allFeatures db
+  mapM_ (liftIO . putStrLn . T.unpack) $
    fmap showFulfillment $
      sort $
        nub $
          concat $
-            fmap dumpSometimes dbus
-              ++ fmap dumpSometimes others
-              ++ fmap dumpSometimes allDWs'
-              ++ fmap dumpFeature bfs
+            fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
+
+allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
+allFeatures db = do
+  let bfs =
+        concatMap (fmap kbMaybeAction . kgBindings) $
+          externalBindings ts db
+  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
+  let others = [runRemovableMon $ dbSysClient db, runPowermon]
+  return (dbus ++ others, Left runScreenLock : bfs, allDWs')
  where
-    mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
+    ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
+
+usage :: IO ()
+usage =
+  putStrLn $
+    intercalate
+      "\n"
+      [ "xmonad: run greatest window manager"
+      , "xmonad --deps: print dependencies"
+      ]

 --------------------------------------------------------------------------------
 -- Concurrency configuration

-data Cleanup = Cleanup
-  { clChildren :: [(Utf8Builder, Process () () ())]
-  , clXmobar :: Maybe (Process Handle () ())
-  , clDBusUnexporters :: [XIO ()]
+data ThreadState = ThreadState
+  { tsChildPIDs :: [Process () () ()]
+  , tsXmobar :: Maybe (Process Handle () ())
  }

-runCleanup
-  :: (XIO () -> IO ())
-  -> Cleanup
-  -> DBusState
-  -> X ()
-runCleanup runIO ts db = liftIO $ runIO $ do
-  mapM_ stopXmobar $ clXmobar ts
-  stopChildDaemons $ clChildren ts
-  sequence_ $ clDBusUnexporters ts
-  disconnectDBus db
+runCleanup :: ThreadState -> DBusState -> X ()
+runCleanup ts db = io $ do
+  mapM_ killNoWait $ tsXmobar ts
+  mapM_ killNoWait $ tsChildPIDs ts
+  disconnectDBusX db

 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@ -345,6 +313,9 @@ vmTag = "VM"
 xsaneTag :: String
 xsaneTag = "XSANE"

+f5Tag :: String
+f5Tag = "F5VPN"
+
 gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
  where
@ -417,11 +388,31 @@ xsaneDynamicWorkspace =
        }
    c = "Xsane"

+f5vpnDynamicWorkspace :: Sometimes DynWorkspace
+f5vpnDynamicWorkspace =
+  Sometimes
+    "F5 VPN workspace"
+    xpfF5VPN
+    [Subfeature (IORoot_ dw tree) "f5vpn"]
+  where
+    tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
+    dw =
+      DynWorkspace
+        { dwName = "F5Vpn"
+        , dwTag = f5Tag
+        , dwClass = c
+        , dwHook = [className =? c -?> appendShift f5Tag]
+        , dwKey = 'i'
+        , dwCmd = Just skip
+        }
+    c = "F5 VPN"
+
 allDWs' :: [Sometimes DynWorkspace]
 allDWs' =
  [ xsaneDynamicWorkspace
  , vmDynamicWorkspace
  , gimpDynamicWorkspace
+  , f5vpnDynamicWorkspace
  ]

 --------------------------------------------------------------------------------
@ -436,10 +427,6 @@ myLayouts tt =
      mkToggle (single HIDE) $
        tall ||| fulltab ||| full
  where
-    addTopBar
-      :: (Eq a)
-      => l a
-      -> ModifiedLayout (Decoration NoFrillsDecoration DefaultShrinker) l a
    addTopBar = noFrillsDeco shrinkText tt
    tall =
      renamed [Replace "Tall"] $
@ -622,30 +609,20 @@ manageApps dws =
 --------------------------------------------------------------------------------
 -- Eventhook configuration

-myEventHook
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (m () -> IO ())
-  -> (String -> X ())
-  -> Event
-  -> X All
-myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
+myEventHook :: (String -> X ()) -> Event -> X All
+myEventHook handler = xMsgEventHook handler <+> handleEventHook def

 -- | React to ClientMessage events from concurrent threads
-xMsgEventHook
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (m () -> IO ())
-  -> (String -> X ())
-  -> Event
-  -> X All
-xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
+xMsgEventHook :: (String -> X ()) -> Event -> X All
+xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
  | t == bITMAP = do
      let (xtype, tag) = splitXMsg d
      case xtype of
        Workspace -> removeDynamicWorkspace tag
        ACPI -> handler tag
-        Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
+        Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
      return (All True)
-xMsgEventHook _ _ _ = return (All True)
+xMsgEventHook _ _ = return (All True)

 --------------------------------------------------------------------------------
 -- Keymap configuration
@ -748,13 +725,13 @@ data KeyGroup a = KeyGroup
  , kgBindings :: [KeyBinding a]
  }

-evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
+evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
 evalExternal = mapM go
  where
    go k@KeyGroup {kgBindings = bs} =
      (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs

-evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
+evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
 evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
  (\f -> k {kbMaybeAction = f}) <$> evalFeature a

@ -769,52 +746,52 @@ filterExternal = fmap go
            ]
        }

-externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-externalBindings runIO cleanup db =
+externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
+externalBindings ts db =
  [ KeyGroup
      "Launchers"
-      [ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
-      , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
-      , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
-      , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
-      , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
-      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
-      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
-      , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
-      , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
-      , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
-      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
-      , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
-      , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
-      , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
+      [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
+      , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
+      , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
+      , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
+      , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
+      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
+      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
+      , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
+      , KeyBinding "M-C-e" "launch editor" $ Left runEditor
+      , KeyBinding "M-C-w" "launch browser" $ Left runBrowser
+      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
+      , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
+      , KeyBinding "M-C-q" "launch calc" $ Left runCalc
+      , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
      ]
  , KeyGroup
      "Actions"
      [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
-      , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
+      , KeyBinding "M-r" "run program" $ Left runCmdMenu
      , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
-      , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
-      , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
-      , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
-      , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
+      , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
+      , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
+      , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
+      , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
      -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
      ]
  , KeyGroup
      "Multimedia"
-      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
-      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
-      , KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
-      , KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
-      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
-      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
-      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
+      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
+      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
+      , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
+      , KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
+      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
+      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
+      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
      ]
  , KeyGroup
      "Dunst"
-      [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
-      , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
-      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
-      , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
+      [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
+      , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
+      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
+      , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
      ]
  , KeyGroup
      "System"
@ -832,25 +809,22 @@ externalBindings runIO cleanup db =
      , -- M-<F1> reserved for showing the keymap
        KeyBinding "M-<F2>" "restart xmonad" restartf
      , KeyBinding "M-<F3>" "recompile xmonad" recompilef
-      , KeyBinding "M-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
-      , KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
-      , KeyBinding "M-<F9>" "toggle network" $ Left $ toX runToggleNetworking
-      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
-      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
+      , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
+      , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
+      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
+      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
      , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
      ]
  ]
  where
    ses = dbSesClient db
    sys = dbSysClient db
-    brightessControls ctl getter = (toX . getter . ctl) ses
+    brightessControls ctl getter = (getter . ctl) ses
    ib = Left . brightessControls intelBacklightControls
    ck = Left . brightessControls clevoKeyboardControls
    ftrAlways n = Right . Always n . Always_ . FallbackAlone
-    restartf = ftrAlways "restart function" (cleanup >> runRestart)
+    restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
    recompilef = ftrAlways "recompile function" runRecompile
-    toX_ = liftIO . runIO
-    toX = fmap toX_

 type MaybeX = Maybe (X ())

--- a/assets/icons/wifi_0.xpm
+++ b/assets/icons/wifi_0.xpm
--- a/assets/icons/wifi_1.xpm
+++ b/assets/icons/wifi_1.xpm
--- a/assets/icons/wifi_2.xpm
+++ b/assets/icons/wifi_2.xpm
--- a/assets/icons/wifi_3.xpm
+++ b/assets/icons/wifi_3.xpm
--- a/assets/icons/wifi_4.xpm
+++ b/assets/icons/wifi_4.xpm
--- a/assets/icons/wifi_5.xpm
+++ b/assets/icons/wifi_5.xpm
--- a/assets/icons/wifi_6.xpm
+++ b/assets/icons/wifi_6.xpm
--- a/assets/icons/wifi_7.xpm
+++ b/assets/icons/wifi_7.xpm
--- a/assets/icons/wifi_8.xpm
+++ b/assets/icons/wifi_8.xpm
--- a/lib/Data/Internal/DBus.hs
+++ b/lib/Data/Internal/DBus.hs
@ -5,17 +5,7 @@ module Data.Internal.DBus
  ( SafeClient (..)
  , SysClient (..)
  , SesClient (..)
-  , NamedConnection (..)
-  , NamedSesConnection
-  , NamedSysConnection
-  , DBusEnv (..)
-  , DIO
-  , HasClient (..)
-  , releaseBusName
-  , withDIO
  , addMatchCallback
-  , addMatchCallbackSignal
-  , matchSignalFull
  , matchProperty
  , matchPropertyFull
  , matchPropertyChanged
@ -35,218 +25,93 @@ module Data.Internal.DBus
  , addInterfaceRemovedListener
  , fromSingletonVariant
  , bodyToMaybe
-  , exportPair
-  , displayBusName
-  , displayObjectPath
-  , displayMemberName
-  , displayInterfaceName
-  , displayWrapQuote
-  , busNameT
-  , interfaceNameT
-  , memberNameT
-  , objectPathT
  )
 where

 import DBus
 import DBus.Client
-import qualified Data.ByteString.Char8 as BC
 import RIO
-import RIO.List
 import qualified RIO.Map as M
 import qualified RIO.Text as T

 --------------------------------------------------------------------------------
 -- Type-safe client

-data NamedConnection c = NamedConnection
-  { ncClient :: !Client
-  , ncHumanName :: !(Maybe BusName)
-  --, ncUniqueName :: !BusName
-  , ncType :: !c
-  }
-
-type NamedSesConnection = NamedConnection SesClient
-
-type NamedSysConnection = NamedConnection SysClient
-
 class SafeClient c where
+  toClient :: c -> Client
+
  getDBusClient
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
-    -> m (Maybe (NamedConnection c))
+    => m (Maybe c)

-  disconnectDBusClient
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => NamedConnection c
-    -> m ()
-  disconnectDBusClient c = do
-    releaseBusName c
-    liftIO $ disconnect $ ncClient c
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
+  disconnectDBusClient = liftIO . disconnect . toClient

  withDBusClient
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
-    -> (NamedConnection c -> m a)
+    => (c -> m a)
    -> m (Maybe a)
-  withDBusClient n f =
-    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
+  withDBusClient f =
+    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f

  withDBusClient_
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
-    -> (NamedConnection c -> m ())
+    => (c -> m ())
    -> m ()
-  withDBusClient_ n = void . withDBusClient n
+  withDBusClient_ = void . withDBusClient

  fromDBusClient
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
-    -> (NamedConnection c -> a)
+    => (c -> a)
    -> m (Maybe a)
-  fromDBusClient n f = withDBusClient n (return . f)
+  fromDBusClient f = withDBusClient (return . f)

-data SysClient = SysClient
+newtype SysClient = SysClient Client

 instance SafeClient SysClient where
-  getDBusClient = connectToDBusWithName True SysClient
+  toClient (SysClient cl) = cl

-data SesClient = SesClient
+  getDBusClient = fmap SysClient <$> getSomeDBusClient True
+
+newtype SesClient = SesClient Client

 instance SafeClient SesClient where
-  -- TODO wet
-  getDBusClient = connectToDBusWithName False SesClient
+  toClient (SesClient cl) = cl

-connectToDBusWithName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Bool
-  -> c
-  -> Maybe BusName
-  -> m (Maybe (NamedConnection c))
-connectToDBusWithName sys t n = do
-  clRes <- getDBusClient' sys
-  case clRes of
-    Nothing -> do
-      logError "could not get client"
-      return Nothing
-    Just cl -> do
-      --helloRes <- liftIO $ callHello cl
-      --case helloRes of
-      --  Nothing -> do
-      --    logError "count not get unique name"
-      --    return Nothing
-      --  Just unique -> do
-          n' <- maybe (return Nothing) (`requestBusName` cl) n
-          return $
-            Just $
-              NamedConnection
-                { ncClient = cl
-                , ncHumanName = n'
-      --          , ncUniqueName = unique
-                , ncType = t
-                }
+  getDBusClient = fmap SesClient <$> getSomeDBusClient False

-releaseBusName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => NamedConnection c
-  -> m ()
-releaseBusName NamedConnection {ncClient, ncHumanName} = do
-  -- TODO this might error?
-  case ncHumanName of
-    Just n -> do
-      liftIO $ void $ releaseName ncClient n
-      logInfo $ "released bus name: " <> displayBusName n
-    Nothing -> return ()
-
-requestBusName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => BusName
-  -> Client
-  -> m (Maybe BusName)
-requestBusName n cl = do
-  res <- try $ liftIO $ requestName cl n []
-  case res of
-    Left e -> do
-      logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
-      return Nothing
-    Right r -> do
-      let msg
-            | r == NamePrimaryOwner = "registering name"
-            | r == NameAlreadyOwner = "this process already owns name"
-            | r == NameInQueue
-                || r == NameExists =
-                "another process owns name"
-            -- this should never happen
-            | otherwise = "unknown error when requesting name"
-      logInfo $ msg <> ": " <> displayBusName n
-      case r of
-        NamePrimaryOwner -> return $ Just n
-        _ -> return Nothing
-
-getDBusClient'
+getSomeDBusClient
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Bool
  -> m (Maybe Client)
-getDBusClient' sys = do
+getSomeDBusClient sys = do
  res <- try $ liftIO $ if sys then connectSystem else connectSession
  case res of
    Left e -> do
-      logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
      return Nothing
    Right c -> return $ Just c

--callHello :: Client -> IO (Maybe BusName)
--callHello cl = do
--  reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
--  case methodReturnBody reply of
--    [name] | Just nameStr <- fromVariant name -> do
--      busName <- parseBusName nameStr
--      return $ Just busName
--    _ -> return Nothing
--
-data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
-
-type DIO env c = RIO (DBusEnv env c)
-
-instance HasClient (DBusEnv SimpleApp) where
-  clientL = lens dClient (\x y -> x {dClient = y})
-
-instance HasLogFunc (DBusEnv SimpleApp c) where
-  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
-
-withDIO
-  :: (MonadUnliftIO m, MonadReader env m)
-  => NamedConnection c
-  -> DIO env c a
-  -> m a
-withDIO cl x = do
-  env <- ask
-  runRIO (DBusEnv cl env) x
-
-class HasClient env where
-  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
-
 --------------------------------------------------------------------------------
 -- Methods

 type MethodBody = Either T.Text [Variant]

-callMethod'
-  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
-  => MethodCall
-  -> m MethodBody
-callMethod' mc = do
-  cl <- ncClient <$> view clientL
-  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
+callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
+callMethod' cl =
+  liftIO
+    . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
+    . call (toClient cl)

 callMethod
-  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
-  => BusName
+  :: (MonadUnliftIO m, SafeClient c)
+  => c
+  -> BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m MethodBody
-callMethod bus path iface = callMethod' . methodCallBus bus path iface
+callMethod client bus path iface = callMethod' client . methodCallBus bus path iface

 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
 methodCallBus b p i m =
@ -260,22 +125,8 @@ methodCallBus b p i m =
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"

-callGetNameOwner
-  :: ( SafeClient c
-     , MonadUnliftIO m
-     , MonadReader (env c) m
-     , HasClient env
-     , HasLogFunc (env c)
-     )
-  => BusName
-  -> m (Maybe BusName)
-callGetNameOwner name = do
-  res <- callMethod' mc
-  case res of
-    Left err -> do
-      logError $ Utf8Builder $ encodeUtf8Builder err
-      return Nothing
-    Right body -> return $ fromSingletonVariant body
+callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
+callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
  where
    mc =
      (methodCallBus dbusName dbusPath dbusInterface mem)
@ -286,7 +137,6 @@ callGetNameOwner name = do
 --------------------------------------------------------------------------------
 -- Variant parsing

-- TODO log failures here?
 fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
 fromSingletonVariant = fromVariant <=< listToMaybe

@ -298,29 +148,14 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant

 type SignalCallback m = [Variant] -> m ()

-addMatchCallbackSignal
-  :: ( MonadReader (env c) m
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
-  => MatchRule
-  -> (Signal -> m ())
-  -> m SignalHandler
-addMatchCallbackSignal rule cb = do
-  cl <- ncClient <$> view clientL
-  withRunInIO $ \run -> addMatch cl rule $ run . cb
-
 addMatchCallback
-  :: ( MonadReader (env c) m
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
+  :: (MonadUnliftIO m, SafeClient c)
  => MatchRule
  -> SignalCallback m
+  -> c
  -> m SignalHandler
-addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
+addMatchCallback rule cb cl = withRunInIO $ \run -> do
+  addMatch (toClient cl) rule $ run . cb . signalBody

 matchSignal
  :: Maybe BusName
@ -337,35 +172,15 @@ matchSignal b p i m =
    }

 matchSignalFull
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
-  => BusName
+  :: (MonadUnliftIO m, SafeClient c)
+  => c
+  -> BusName
  -> Maybe ObjectPath
  -> Maybe InterfaceName
  -> Maybe MemberName
  -> m (Maybe MatchRule)
-matchSignalFull b p i m = do
-  res <- callGetNameOwner b
-  case res of
-    Just o -> return $ Just $ matchSignal (Just o) p i m
-    Nothing -> do
-      logError msg
-      return Nothing
-  where
-    bus_ = displayWrapQuote $ displayBusName b
-    iface_ = displayWrapQuote . displayInterfaceName <$> i
-    path_ = displayWrapQuote . displayObjectPath <$> p
-    mem_ = displayWrapQuote . displayMemberName <$> m
-    match =
-      intersperse ", " $
-        mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
-          zip ["interface", "path", "member"] [iface_, path_, mem_]
-    stem = "could not get match rule for bus " <> bus_
-    msg = if null match then stem else stem <> " where " <> mconcat match
+matchSignalFull client b p i m =
+  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b

 --------------------------------------------------------------------------------
 -- Properties
@ -377,42 +192,31 @@ propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"

 callPropertyGet
-  :: ( HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     )
+  :: (MonadUnliftIO m, SafeClient c)
  => BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
+  -> c
  -> m [Variant]
-callPropertyGet bus path iface property = do
-  cl <- ncClient <$> view clientL
-  res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
-  case res of
-    Left err -> do
-      logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
-      return []
-    Right v -> return [v]
+callPropertyGet bus path iface property cl =
+  liftIO $
+    fmap (either (const []) (: [])) $
+      getProperty (toClient cl) $
+        methodCallBus bus path iface property

 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
  matchSignal b p (Just propertyInterface) (Just propertySignal)

 matchPropertyFull
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
-  => BusName
+  :: (MonadUnliftIO m, SafeClient c)
+  => c
+  -> BusName
  -> Maybe ObjectPath
  -> m (Maybe MatchRule)
-matchPropertyFull b p =
-  matchSignalFull b p (Just propertyInterface) (Just propertySignal)
+matchPropertyFull cl b p =
+  matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)

 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)

@ -424,26 +228,26 @@ withSignalMatch _ NoMatch = return ()
 matchPropertyChanged
  :: IsVariant a
  => InterfaceName
-  -> MemberName
+  -> T.Text
  -> [Variant]
  -> SignalMatch a
-matchPropertyChanged iface property [sigIface, sigValues, _] =
-  let i = fromVariant sigIface :: Maybe T.Text
-      v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
-   in case (i, v) of
-        (Just i', Just v') ->
-          if i' == interfaceNameT iface
-            then
-              maybe NoMatch Match $
-                fromVariant =<< M.lookup (memberNameT property) v'
+matchPropertyChanged iface property [i, body, _] =
+  let i' = (fromVariant i :: Maybe T.Text)
+      b = toMap body
+   in case (i', b) of
+        (Just i'', Just b') ->
+          if i'' == T.pack (formatInterfaceName iface)
+            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
            else NoMatch
        _ -> Failure
+  where
+    toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
 matchPropertyChanged _ _ _ = Failure

 --------------------------------------------------------------------------------
 -- Object Manager

-type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
+type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))

 omInterface :: InterfaceName
 omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@ -458,132 +262,43 @@ omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"

 callGetManagedObjects
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
-  => BusName
+  :: (MonadUnliftIO m, SafeClient c)
+  => c
+  -> BusName
  -> ObjectPath
  -> m ObjectTree
-callGetManagedObjects bus path = do
-  res <- callMethod bus path omInterface getManagedObjects
-  case res of
-    Left err -> do
-      logError $ Utf8Builder $ encodeUtf8Builder err
-      return M.empty
-    Right v ->
-      return $
-        fmap (M.mapKeys interfaceName_) $
-          fromMaybe M.empty $
-            fromSingletonVariant v
+callGetManagedObjects cl bus path =
+  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
+    <$> callMethod cl bus path omInterface getManagedObjects

 addInterfaceChangedListener
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
+  :: (MonadUnliftIO m, SafeClient c)
  => BusName
  -> MemberName
  -> ObjectPath
  -> SignalCallback m
+  -> c
  -> m (Maybe SignalHandler)
-addInterfaceChangedListener bus prop path sc = do
-  res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
-  case res of
-    Nothing -> do
-      logError $
-        "could not add listener for property"
-          <> prop_
-          <> " at path "
-          <> path_
-          <> " on bus "
-          <> bus_
-      return Nothing
-    Just rule -> Just <$> addMatchCallback rule sc
-  where
-    bus_ = "'" <> displayBusName bus <> "'"
-    path_ = "'" <> displayObjectPath path <> "'"
-    prop_ = "'" <> displayMemberName prop <> "'"
+addInterfaceChangedListener bus prop path sc cl = do
+  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
+  forM rule $ \r -> addMatchCallback r sc cl

 addInterfaceAddedListener
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
+  :: (MonadUnliftIO m, SafeClient c)
  => BusName
  -> ObjectPath
  -> SignalCallback m
+  -> c
  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
  addInterfaceChangedListener bus omInterfacesAdded

 addInterfaceRemovedListener
-  :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
+  :: (MonadUnliftIO m, SafeClient c)
  => BusName
  -> ObjectPath
  -> SignalCallback m
+  -> c
  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
  addInterfaceChangedListener bus omInterfacesRemoved
-
--------------------------------------------------------------------------------
-- Interface export/unexport
-
-exportPair
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => ObjectPath
-  -> (Client -> m Interface)
-  -> NamedConnection c
-  -> (m (), m ())
-exportPair path toIface cl = (up, down)
-  where
-    cl_ = ncClient cl
-    up = do
-      logInfo $ "adding interface: " <> path_
-      i <- toIface cl_
-      liftIO $ export cl_ path i
-    down = do
-      logInfo $ "removing interface: " <> path_
-      liftIO $ unexport cl_ path
-    path_ = displayObjectPath path
-
--------------------------------------------------------------------------------
-- logging helpers
-
-busNameT :: BusName -> T.Text
-busNameT = T.pack . formatBusName
-
-objectPathT :: ObjectPath -> T.Text
-objectPathT = T.pack . formatObjectPath
-
-interfaceNameT :: InterfaceName -> T.Text
-interfaceNameT = T.pack . formatInterfaceName
-
-memberNameT :: MemberName -> T.Text
-memberNameT = T.pack . formatMemberName
-
-displayBusName :: BusName -> Utf8Builder
-displayBusName = displayBytesUtf8 . BC.pack . formatBusName
-
-displayObjectPath :: ObjectPath -> Utf8Builder
-displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
-
-displayMemberName :: MemberName -> Utf8Builder
-displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
-
-displayInterfaceName :: InterfaceName -> Utf8Builder
-displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
-
-displayWrapQuote :: Utf8Builder -> Utf8Builder
-displayWrapQuote x = "'" <> x <> "'"
--- a/lib/Data/Internal/Dependency.hs
+++ b/lib/Data/Internal/Dependency.hs
@ -1,7 +1,14 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- Functions for handling dependencies

-module Data.Internal.XIO
+module Data.Internal.Dependency
 -- feature types
  ( Feature
  , Always (..)
@ -19,7 +26,6 @@ module Data.Internal.XIO
  , SubfeatureRoot
  , Msg (..)
  -- configuration
-  , XEnv (..)
  , XParams (..)
  , XPFeatures (..)
  , XPQuery
@ -47,9 +53,8 @@ module Data.Internal.XIO
  , dumpSometimes
  , showFulfillment
  -- testing
-  , XIO
-  , runXIO
-  , hRunXIO
+  , FIO
+  , withCache
  , evalFeature
  , executeSometimes
  , executeAlways
@ -91,7 +96,6 @@ module Data.Internal.XIO
  , process
  -- misc
  , shellTest
-  , withLogFile
  )
 where

@ -100,7 +104,6 @@ import qualified DBus.Introspection as I
 import Data.Aeson hiding (Error, Result)
 import Data.Aeson.Key
 import Data.Internal.DBus
-import qualified Data.Text.IO as TI
 import Data.Yaml
 import GHC.IO.Exception (ioe_description)
 import RIO hiding (bracket, fromString)
@ -112,7 +115,7 @@ import qualified RIO.Text as T
 import System.Posix.Files
 import System.Process.Typed (nullStream)
 import UnliftIO.Environment
-import XMonad.Core (X, dataDir, getDirectories, io)
+import XMonad.Core (X, io)
 import XMonad.Internal.IO
 import XMonad.Internal.Shell hiding (proc, runProcess)
 import XMonad.Internal.Theme
@ -125,47 +128,30 @@ import XMonad.Internal.Theme

 -- | Run feature evaluation(s) with the cache
 -- Currently there is no easy way to not use this (oh well)
-runXIO :: FilePath -> XIO a -> IO a
-runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
-
-- TODO use dhall to encode config file and log here to control the loglevel
-withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a
-withLogFile logfile f = do
-  p <- (</> logfile) . dataDir <$> liftIO getDirectories
-  catchIO (withBinaryFile p AppendMode f) $ \e -> do
-    liftIO $ TI.putStrLn $ T.pack $ show e
-    liftIO $ TI.putStrLn "could not open log file, falling back to stderr"
-    f stderr
-
-hRunXIO :: Bool -> Handle -> XIO a -> IO a
-hRunXIO verbose h x = do
-  hSetBuffering h LineBuffering
-  logOpts <- logOptionsHandle_ verbose h
+withCache :: FIO a -> IO a
+withCache x = do
+  logOpts <- logOptionsHandle stderr False
  pc <- mkDefaultProcessContext
  withLogFunc logOpts $ \f -> do
    p <- getParams
-    let s = XEnv f pc p
+    let s = DepStage f pc p
    runRIO s x

-logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions
-logOptionsHandle_ v h =
-  setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False
-
 -- | Execute an Always immediately
-executeAlways :: Always (IO a) -> XIO a
+executeAlways :: Always (IO a) -> FIO a
 executeAlways = io <=< evalAlways

 -- | Execute a Sometimes immediately (or do nothing if failure)
-executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
+executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
 executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a

 -- | Possibly return the action of an Always/Sometimes
-evalFeature :: Feature a -> XIO (Maybe a)
+evalFeature :: Feature a -> FIO (Maybe a)
 evalFeature (Right a) = Just <$> evalAlways a
 evalFeature (Left s) = evalSometimes s

 -- | Possibly return the action of a Sometimes
-evalSometimes :: Sometimes a -> XIO (Maybe a)
+evalSometimes :: Sometimes a -> FIO (Maybe a)
 evalSometimes x = either goFail goPass =<< evalSometimesMsg x
  where
    goPass (a, ws) = putErrors ws >> return (Just a)
@ -173,13 +159,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
    putErrors = mapM_ logMsg

 -- | Return the action of an Always
-evalAlways :: Always a -> XIO a
+evalAlways :: Always a -> FIO a
 evalAlways a = do
  (x, ws) <- evalAlwaysMsg a
  mapM_ logMsg ws
  return x

-logMsg :: FMsg -> XIO ()
+logMsg :: FMsg -> FIO ()
 logMsg (FMsg fn n (Msg ll m)) = do
  p <- io getProgName
  f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@ -200,9 +186,8 @@ logMsg (FMsg fn n (Msg ll m)) = do
 --------------------------------------------------------------------------------
 -- Package status

-showFulfillment :: Fulfillment -> Utf8Builder
-showFulfillment (Package t n) =
-  displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
+showFulfillment :: Fulfillment -> T.Text
+showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]

 dumpFeature :: Feature a -> [Fulfillment]
 dumpFeature = either dumpSometimes dumpAlways
@ -224,7 +209,7 @@ type AlwaysIO = Always (IO ())

 type SometimesX = Sometimes (X ())

-type SometimesIO = Sometimes (XIO ())
+type SometimesIO = Sometimes (FIO ())

 type Feature a = Either (Sometimes a) (Always a)

@ -234,13 +219,12 @@ type Feature a = Either (Sometimes a) (Always a)
 -- | Feature that is guaranteed to work
 -- This is composed of sub-features that are tested in order, and if all fail
 -- the fallback is a monadic action (eg a plain haskell function)
-data Always a = Always T.Text (Always_ a) deriving (Functor)
+data Always a = Always T.Text (Always_ a)

 -- | Feature that is guaranteed to work (inner data)
 data Always_ a
  = Option (SubfeatureRoot a) (Always_ a)
  | Always_ (FallbackRoot a)
-  deriving (Functor)

 -- | Root of a fallback action for an always
 -- This may either be a lone action or a function that depends on the results
@ -249,23 +233,15 @@ data FallbackRoot a
  = FallbackAlone a
  | forall p. FallbackTree (p -> a) (FallbackStack p)

-instance Functor FallbackRoot where
-  fmap f (FallbackAlone a) = FallbackAlone (f a)
-  fmap f (FallbackTree g s) = FallbackTree (f . g) s
-
 -- | Always features that are used as a payload for a fallback action
 data FallbackStack p
  = FallbackBottom (Always p)
  | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)

-instance Functor FallbackStack where
-  fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
-  fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
-
 -- | Feature that might not be present
 -- This is like an Always except it doesn't fall back on a guaranteed monadic
 -- action
-data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
+data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)

 -- | Feature that might not be present (inner data)
 type Sometimes_ a = [SubfeatureRoot a]
@ -278,7 +254,6 @@ data Subfeature f = Subfeature
  { sfData :: f
  , sfName :: T.Text
  }
-  deriving (Functor)

 type SubfeatureRoot a = Subfeature (Root a)

@ -288,24 +263,8 @@ type SubfeatureRoot a = Subfeature (Root a)
 data Root a
  = forall p. IORoot (p -> a) (IOTree p)
  | IORoot_ a IOTree_
-  | forall c p.
-    SafeClient c =>
-    DBusRoot
-      (p -> NamedConnection c -> a)
-      (DBusTree c p)
-      (Maybe (NamedConnection c))
-  | forall c.
-    SafeClient c =>
-    DBusRoot_
-      (NamedConnection c -> a)
-      (DBusTree_ c)
-      (Maybe (NamedConnection c))
-
-instance Functor Root where
-  fmap f (IORoot a t) = IORoot (f . a) t
-  fmap f (IORoot_ a t) = IORoot_ (f a) t
-  fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
-  fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
+  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
+  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)

 -- | The dependency tree with rule to merge results when needed
 data Tree d d_ p
@ -330,7 +289,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
 -- | A dependency that only requires IO to evaluate (with payload)
 data IODependency p
  = -- an IO action that yields a payload
-    IORead T.Text [Fulfillment] (XIO (Result p))
+    IORead T.Text [Fulfillment] (FIO (Result p))
  | -- always yields a payload
    IOConst p
  | -- an always that yields a payload
@ -343,11 +302,12 @@ data DBusDependency_ c
  = Bus [Fulfillment] BusName
  | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
  | DBusIO IODependency_
+  deriving (Generic)

 -- | A dependency that only requires IO to evaluate (no payload)
 data IODependency_
  = IOSystem_ [Fulfillment] SystemDependency
-  | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
+  | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
  | forall a. IOSometimes_ (Sometimes a)

 -- | A system component to an IODependency
@ -357,23 +317,23 @@ data SystemDependency
  | AccessiblePath FilePath Bool Bool
  | Systemd UnitType T.Text
  | Process T.Text
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)

 -- | The type of a systemd service
-data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
+data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)

 -- | Wrapper type to describe and endpoint
 data DBusMember
  = Method_ MemberName
  | Signal_ MemberName
  | Property_ T.Text
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)

 -- | A means to fulfill a dependency
 -- For now this is just the name of an Arch Linux package (AUR or official)
 data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)

-data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
+data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)

 --------------------------------------------------------------------------------
 -- Tested dependency tree
@ -416,25 +376,19 @@ data PostFail = PostFail [Msg] | PostMissing Msg
 --------------------------------------------------------------------------------
 -- Configuration

-type XIO a = RIO XEnv a
+type FIO a = RIO DepStage a

-data XEnv = XEnv
-  { xLogFun :: !LogFunc
-  , xProcCxt :: !ProcessContext
-  , xParams :: !XParams
+data DepStage = DepStage
+  { dsLogFun :: !LogFunc
+  , dsProcCxt :: !ProcessContext
+  , dsParams :: !XParams
  }

-instance HasLogFunc XEnv where
-  logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
+instance HasLogFunc DepStage where
+  logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})

-instance HasLogFunc (DBusEnv XEnv c) where
-  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
-
-instance HasProcessContext XEnv where
-  processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})
-
-instance HasClient (DBusEnv XEnv) where
-  clientL = lens dClient (\x y -> x {dClient = y})
+instance HasProcessContext DepStage where
+  processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})

 data XParams = XParams
  { xpLogLevel :: LogLevel
@ -468,8 +422,7 @@ data XPFeatures = XPFeatures
  , xpfIntelBacklight :: Bool
  , xpfClevoBacklight :: Bool
  , xpfBattery :: Bool
-  , xpfEthPrefix :: Maybe Text
-  , xpfWifiPrefix :: Maybe Text
+  , xpfF5VPN :: Bool
  }

 instance FromJSON XPFeatures where
@ -496,9 +449,7 @@ instance FromJSON XPFeatures where
      <*> o
      .:+ "battery"
      <*> o
-      .:? "ethPrefix"
-      <*> o
-      .:? "wifiPrefix"
+      .:+ "f5vpn"

 defParams :: XParams
 defParams =
@ -521,8 +472,7 @@ defXPFeatures =
    , xpfIntelBacklight = False
    , xpfClevoBacklight = False
    , xpfBattery = False
-    , xpfEthPrefix = Nothing
-    , xpfWifiPrefix = Nothing
+    , xpfF5VPN = False
    }

 type XPQuery = XPFeatures -> Bool
@ -533,7 +483,7 @@ getParams = do
  maybe (return defParams) (liftIO . decodeYaml) p
  where
    decodeYaml p =
-      either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
+      either (\e -> print e >> return defParams) return
        =<< decodeFileEither p

 getParamFile :: MonadIO m => m (Maybe FilePath)
@ -557,9 +507,9 @@ infix 9 .:+
 --------------------------------------------------------------------------------
 -- Testing pipeline

-evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
+evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n u xs) = do
-  r <- asks (u . xpFeatures . xParams)
+  r <- asks (u . xpFeatures . dsParams)
  if not r
    then return $ Left [dis n]
    else do
@ -571,7 +521,7 @@ evalSometimesMsg (Sometimes n u xs) = do
  where
    dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")

-evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
+evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
  r <- testAlways x
  return $ case r of
@ -591,7 +541,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
  where
    f = fmap (FMsg fn (Just n))

-testAlways :: Always_ a -> XIO (PostAlways a)
+testAlways :: Always_ a -> FIO (PostAlways a)
 testAlways = go []
  where
    go failed (Option fd next) = do
@ -601,18 +551,18 @@ testAlways = go []
        (Right pass) -> return $ Primary pass failed next
    go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar

-evalFallbackRoot :: FallbackRoot a -> XIO a
+evalFallbackRoot :: FallbackRoot a -> FIO a
 evalFallbackRoot (FallbackAlone a) = return a
 evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s

-evalFallbackStack :: FallbackStack p -> XIO p
+evalFallbackStack :: FallbackStack p -> FIO p
 evalFallbackStack (FallbackBottom a) = evalAlways a
 evalFallbackStack (FallbackStack f a as) = do
  ps <- evalFallbackStack as
  p <- evalAlways a
  return $ f p ps

-testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
+testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
 testSometimes = go (PostSometimes Nothing [])
  where
    go ts [] = return ts
@ -622,13 +572,13 @@ testSometimes = go (PostSometimes Nothing [])
        (Left l) -> go (ts {psFailed = l : psFailed ts}) xs
        (Right pass) -> return $ ts {psSuccess = Just pass}

-testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
+testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
 testSubfeature sf@Subfeature {sfData = t} = do
  t' <- testRoot t
  -- monomorphism restriction :(
  return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'

-testRoot :: Root a -> XIO (Either PostFail (PostPass a))
+testRoot :: Root a -> FIO (Either PostFail (PostPass a))
 testRoot r = do
  case r of
    (IORoot a t) -> go a testIODep_ testIODep t
@ -642,7 +592,7 @@ testRoot r = do
            Msg LevelError "client not available"
  where
    -- rank N polymorphism is apparently undecidable...gross
-    go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
+    go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
      bimap PostFail (fmap a) <$> testTree f_ f t
    go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t

@ -655,13 +605,13 @@ type MResult p = Memoized (Result p)

 testTree
  :: forall d d_ p
-   . (d_ -> XIO MResult_)
-  -> (forall q. d q -> XIO (MResult q))
+   . (d_ -> FIO MResult_)
+  -> (forall q. d q -> FIO (MResult q))
  -> Tree d d_ p
-  -> XIO (Either [Msg] (PostPass p))
+  -> FIO (Either [Msg] (PostPass p))
 testTree test_ test = go
  where
-    go :: forall q. Tree d d_ q -> XIO (Result q)
+    go :: forall q. Tree d d_ q -> FIO (Result q)
    go (And12 f a b) = do
      ra <- go a
      liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -678,7 +628,7 @@ testTree test_ test = go
    and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
    liftRight = either (return . Left)

-testIODep :: IODependency p -> XIO (MResult p)
+testIODep :: IODependency p -> FIO (MResult p)
 testIODep d = memoizeMVar $ case d of
  IORead _ _ t -> t
  IOConst c -> return $ Right $ PostPass c []
@ -706,7 +656,7 @@ type Result_ = Either [Msg] [Msg]

 type MResult_ = Memoized Result_

-testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
+testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
 testTree_ test = go
  where
    go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -714,10 +664,10 @@ testTree_ test = go
    go (Only_ a) = runMemoized =<< test a
    test2nd ws = fmap ((Right . (ws ++)) =<<) . go

-testIODep_ :: IODependency_ -> XIO MResult_
+testIODep_ :: IODependency_ -> FIO MResult_
 testIODep_ d = memoizeMVar $ testIODepNoCache_ d

-testIODepNoCache_ :: IODependency_ -> XIO Result_
+testIODepNoCache_ :: IODependency_ -> FIO Result_
 testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
 testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
 testIODepNoCache_ (IOSometimes_ x) =
@ -812,7 +762,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
 fontTestName :: T.Text -> T.Text
 fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]

-- testFont :: T.Text -> XIO (Result FontBuilder)
+-- testFont :: T.Text -> FIO (Result FontBuilder)
 -- testFont = liftIO . testFont'

 testFont
@ -833,16 +783,16 @@ testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
 -- start with "en" and wireless interfaces always start with "wl"

 readEthernet :: IODependency T.Text
-readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
+readEthernet = readInterface "get ethernet interface" isEthernet

 readWireless :: IODependency T.Text
-readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
+readWireless = readInterface "get wireless interface" isWireless

-- isWireless :: T.Text -> Bool
-- isWireless = T.isPrefixOf "wl"
+isWireless :: T.Text -> Bool
+isWireless = T.isPrefixOf "wl"

-- isEthernet :: T.Text -> Bool
-- isEthernet = T.isPrefixOf "en"
+isEthernet :: T.Text -> Bool
+isEthernet = T.isPrefixOf "en"

 listInterfaces :: MonadUnliftIO m => m [T.Text]
 listInterfaces =
@ -854,12 +804,11 @@ sysfsNet = "/sys/class/net"

 -- ASSUME there are no (non-base) packages required to make these interfaces
 -- work (all at the kernel level)
-readInterface :: T.Text -> (XPFeatures -> Text) -> IODependency T.Text
+readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
 readInterface n f = IORead n [] go
  where
-    go = do
-      p <- asks (f . xpFeatures . xParams)
-      ns <- filter (T.isPrefixOf p) <$> listInterfaces
+    go = io $ do
+      ns <- filter f <$> listInterfaces
      case ns of
        [] -> return $ Left [Msg LevelError "no interfaces found"]
        (x : xs) -> do
@ -871,7 +820,7 @@ readInterface n f = IORead n [] go
 --------------------------------------------------------------------------------
 -- Misc testers

-socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
+socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
 socketExists n ful =
  IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'

@ -895,12 +844,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"

-testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
+testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d

-testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
-testDBusDepNoCache_ cl (Bus _ bus) = do
-  ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
+testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
+testDBusDepNoCache_ cl (Bus _ bus) = io $ do
+  ret <- callMethod cl queryBus queryPath queryIface queryMem
  return $ case ret of
    Left e -> Left [Msg LevelError e]
    Right b ->
@ -919,10 +868,8 @@ testDBusDepNoCache_ cl (Bus _ bus) = do
    queryMem = memberName_ "ListNames"
    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
    bodyGetNames _ = []
-testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
-  ret <-
-    withDIO cl $
-      callMethod busname objpath introspectInterface introspectMethod
+testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
+  ret <- callMethod cl busname objpath introspectInterface introspectMethod
  return $ case ret of
    Left e -> Left [Msg LevelError e]
    Right body -> procBody body
@ -978,6 +925,12 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
 -- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
 -- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}

+-- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
+-- ioRoot (IORoot a t) = IORoot (io . a) t
+-- ioRoot (IORoot_ a t) = IORoot_ (io a) t
+-- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
+-- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
+
 --------------------------------------------------------------------------------
 -- Feature constructors

@ -1029,17 +982,16 @@ sometimesExeArgs fn n ful sys path args =

 sometimesDBus
  :: SafeClient c
-  => Maybe (NamedConnection c)
+  => Maybe c
  -> T.Text
  -> T.Text
  -> Tree_ (DBusDependency_ c)
-  -> (NamedConnection c -> a)
+  -> (c -> a)
  -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c

-- TODO do I need to hardcode XEnv?
 sometimesEndpoint
-  :: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
+  :: (SafeClient c, MonadIO m)
  => T.Text
  -> T.Text
  -> [Fulfillment]
@ -1047,13 +999,13 @@ sometimesEndpoint
  -> ObjectPath
  -> InterfaceName
  -> MemberName
-  -> Maybe (NamedConnection c)
+  -> Maybe c
  -> Sometimes (m ())
 sometimesEndpoint fn name ful busname path iface mem cl =
  sometimesDBus cl fn name deps cmd
  where
    deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
-    cmd c = void $ withDIO c $ callMethod busname path iface mem
+    cmd c = io $ void $ callMethod c busname path iface mem

 --------------------------------------------------------------------------------
 -- Dependency Tree Constructors
--- a/lib/XMonad/Internal/Command/DMenu.hs
+++ b/lib/XMonad/Internal/Command/DMenu.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Dmenu (Rofi) Commands

@ -17,18 +19,15 @@ module XMonad.Internal.Command.DMenu
 where

 import DBus
-import qualified Data.ByteString.Char8 as BC
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import Graphics.X11.Types
-import RIO
-import qualified RIO.ByteString as B
 import RIO.Directory
  ( XdgDirectory (..)
  , getXdgDirectory
  )
 import qualified RIO.Text as T
-- import System.IO
+import System.IO
 import XMonad.Core hiding (spawn)
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
@ -75,7 +74,7 @@ clipboardPkgs = [Package AUR "rofi-greenclip"]
 --------------------------------------------------------------------------------
 -- Other internal functions

-spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
+spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
 spawnDmenuCmd n =
  sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd

@ -98,7 +97,7 @@ dmenuDep = sysExe dmenuPkgs myDmenuCmd
 -- Exported Commands

 -- TODO test that veracrypt and friends are installed
-runDevMenu :: MonadUnliftIO m => Sometimes (m ())
+runDevMenu :: SometimesX
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
  where
    t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
@ -111,7 +110,7 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
          ++ myDmenuMatchingArgs

 -- TODO test that bluetooth interface exists
-runBTMenu :: MonadUnliftIO m => Sometimes (m ())
+runBTMenu :: SometimesX
 runBTMenu =
  Sometimes
    "bluetooth selector"
@ -121,7 +120,7 @@ runBTMenu =
    cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
    tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth

-runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
+runVPNMenu :: SometimesX
 runVPNMenu =
  Sometimes
    "VPN selector"
@ -137,16 +136,16 @@ runVPNMenu =
          socketExists "expressVPN" [] $
            return "/var/lib/expressvpn/expressvpnd.socket"

-runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
+runCmdMenu :: SometimesX
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]

-runAppMenu :: MonadUnliftIO m => Sometimes (m ())
+runAppMenu :: SometimesX
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]

-runWinMenu :: MonadUnliftIO m => Sometimes (m ())
+runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]

-runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
+runNetMenu :: Maybe SysClient -> SometimesX
 runNetMenu cl =
  Sometimes
    "network control menu"
@ -162,7 +161,7 @@ runNetMenu cl =
          DBusIO $
            sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks

-runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
+runAutorandrMenu :: SometimesX
 runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
  where
    cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
@ -171,7 +170,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- Password manager

-runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runBwMenu :: Maybe SesClient -> SometimesX
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
  where
    cmd _ =
@ -184,7 +183,7 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
 --------------------------------------------------------------------------------
 -- Clipboard

-runClipMenu :: MonadUnliftIO m => Sometimes (m ())
+runClipMenu :: SometimesX
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
  where
    act = spawnCmd myDmenuCmd args
@ -207,9 +206,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
 --------------------------------------------------------------------------------
 -- Shortcut menu

-runShowKeys
-  :: (MonadReader env m, MonadUnliftIO m)
-  => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
+runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
 runShowKeys =
  Always "keyboard menu" $
    Option showKeysDMenu $
@ -222,23 +219,18 @@ runShowKeys =
        spawnNotify $
          defNoteError {body = Just $ Text "could not display keymap"}

-showKeysDMenu
-  :: (MonadReader env m, MonadUnliftIO m)
-  => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
+showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
 showKeysDMenu =
  Subfeature
    { sfName = "keyboard shortcut menu"
    , sfData = IORoot_ showKeys $ Only_ dmenuDep
    }

-showKeys
-  :: (MonadReader env m, MonadUnliftIO m)
-  => [((KeyMask, KeySym), NamedAction)]
-  -> m ()
+showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
 showKeys kbs = do
  h <- spawnPipe cmd
-  B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
-  hClose h
+  io $ hPutStr h $ unlines $ showKm kbs
+  io $ hClose h
  where
    cmd =
      fmtCmd myDmenuCmd $
--- a/lib/XMonad/Internal/Command/Desktop.hs
+++ b/lib/XMonad/Internal/Command/Desktop.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- General commands

@ -19,8 +21,7 @@ module XMonad.Internal.Command.Desktop
  , runVolumeUp
  , runVolumeMute
  , runToggleBluetooth
-  , runToggleNetworking
-  , runToggleWifi
+  , runToggleEthernet
  , runRestart
  , runRecompile
  , runAreaCapture
@ -40,7 +41,7 @@ where

 import DBus
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import RIO.Directory
 import RIO.FilePath
@ -59,13 +60,13 @@ import XMonad.Operations
 -- My Executables

 myTerm :: FilePath
-myTerm = "alacritty"
+myTerm = "urxvt"

 myCalc :: FilePath
 myCalc = "bc"

 myBrowser :: FilePath
-myBrowser = "firefox"
+myBrowser = "brave"

 myEditor :: FilePath
 myEditor = "emacsclient"
@ -93,7 +94,8 @@ myNotificationCtrl = "dunstctl"

 myTermPkgs :: [Fulfillment]
 myTermPkgs =
-  [ Package Official "alacritty"
+  [ Package Official "rxvt-unicode"
+  , Package Official "urxvt-perls"
  ]

 myEditorPkgs :: [Fulfillment]
@ -108,9 +110,6 @@ bluetoothPkgs = [Package Official "bluez-utils"]
 networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]

-nmcli :: IODependency_
-nmcli = sysExe networkManagerPkgs "nmcli"
-
 --------------------------------------------------------------------------------
 -- Misc constants

@ -120,10 +119,10 @@ volumeChangeSound = "smb_fireball.wav"
 --------------------------------------------------------------------------------
 -- Some nice apps

-runTerm :: MonadUnliftIO m => Sometimes (m ())
-runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
+runTerm :: SometimesX
+runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm

-runTMux :: MonadUnliftIO m => Sometimes (m ())
+runTMux :: SometimesX
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
  where
    deps =
@ -141,13 +140,13 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
      t <- getTemporaryDirectory
      return $ t </> "tmux-" ++ show u </> "default"

-runCalc :: MonadUnliftIO m => Sometimes (m ())
+runCalc :: SometimesX
 runCalc = sometimesIO_ "calculator" "bc" deps act
  where
    deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
    act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]

-runBrowser :: MonadUnliftIO m => Sometimes (m ())
+runBrowser :: SometimesX
 runBrowser =
  sometimesExe
    "web browser"
@ -156,7 +155,7 @@ runBrowser =
    False
    myBrowser

-runEditor :: MonadUnliftIO m => Sometimes (m ())
+runEditor :: SometimesX
 runEditor = sometimesIO_ "text editor" "emacs" tree cmd
  where
    cmd =
@ -167,7 +166,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
    -- before xmonad starts, so just check to see if the process has started
    tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer

-runFileManager :: MonadUnliftIO m => Sometimes (m ())
+runFileManager :: SometimesX
 runFileManager =
  sometimesExe
    "file browser"
@ -179,11 +178,7 @@ runFileManager =
 --------------------------------------------------------------------------------
 -- Multimedia Commands

-runMultimediaIfInstalled
-  :: MonadUnliftIO m
-  => T.Text
-  -> T.Text
-  -> Sometimes (m ())
+runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
 runMultimediaIfInstalled n cmd =
  sometimesExeArgs
    (T.append n " multimedia control")
@ -193,23 +188,23 @@ runMultimediaIfInstalled n cmd =
    myMultimediaCtl
    [cmd]

-runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
+runTogglePlay :: SometimesX
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"

-runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
+runPrevTrack :: SometimesX
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"

-runNextTrack :: MonadUnliftIO m => Sometimes (m ())
+runNextTrack :: SometimesX
 runNextTrack = runMultimediaIfInstalled "next track" "next"

-runStopPlay :: MonadUnliftIO m => Sometimes (m ())
+runStopPlay :: SometimesX
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"

 --------------------------------------------------------------------------------
 -- Volume Commands

 soundDir :: FilePath
-soundDir = "assets" </> "sound"
+soundDir = "sound"

 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
@ -218,13 +213,7 @@ playSound file = do
  -- paplay seems to have less latency than aplay
  spawnCmd "paplay" [T.pack p]

-featureSound
-  :: MonadUnliftIO m
-  => T.Text
-  -> FilePath
-  -> m ()
-  -> m ()
-  -> Sometimes (m ())
+featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
 featureSound n file pre post =
  sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
    pre >> playSound file >> post
@ -233,24 +222,19 @@ featureSound n file pre post =
    -- to play sound (duh) but libpulse is the package with the paplay binary
    tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"

-runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
+runVolumeDown :: SometimesX
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)

-runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
+runVolumeUp :: SometimesX
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)

-runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
+runVolumeMute :: SometimesX
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()

 --------------------------------------------------------------------------------
 -- Notification control

-runNotificationCmd
-  :: MonadUnliftIO m
-  => T.Text
-  -> T.Text
-  -> Maybe NamedSesConnection
-  -> Sometimes (m ())
+runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
 runNotificationCmd n arg cl =
  sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
  where
@ -261,37 +245,37 @@ runNotificationCmd n arg cl =
          Method_ $
            memberName_ "NotificationAction"

-runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationClose :: Maybe SesClient -> SometimesX
 runNotificationClose = runNotificationCmd "close notification" "close"

-runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationCloseAll :: Maybe SesClient -> SometimesX
 runNotificationCloseAll =
  runNotificationCmd "close all notifications" "close-all"

-runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationHistory :: Maybe SesClient -> SometimesX
 runNotificationHistory =
  runNotificationCmd "see notification history" "history-pop"

-runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationContext :: Maybe SesClient -> SometimesX
 runNotificationContext =
  runNotificationCmd "open notification context" "context"

 --------------------------------------------------------------------------------
 -- System commands

-- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
-runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
+-- this is required for some vpn's to work properly with network-manager
+runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
 runNetAppDaemon cl =
  Sometimes
    "network applet"
-    (\x -> xpfVPN x || xpfWireless x)
+    xpfVPN
    [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
  where
    tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
    app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
    cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)

-runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
+runToggleBluetooth :: Maybe SysClient -> SometimesX
 runToggleBluetooth cl =
  Sometimes
    "bluetooth toggle"
@ -308,35 +292,27 @@ runToggleBluetooth cl =
          #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}

-runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
-runToggleNetworking =
+runToggleEthernet :: SometimesX
+runToggleEthernet =
  Sometimes
-    "network toggle"
-    (\x -> xpfEthernet x || xpfWireless x)
+    "ethernet toggle"
+    xpfEthernet
    [Subfeature root "nmcli"]
  where
-    root = IORoot_ cmd $ Only_ nmcli
-    cmd =
+    root =
+      IORoot cmd $
+        And1 (Only readEthernet) $
+          Only_ $
+            sysExe networkManagerPkgs "nmcli"
+    -- TODO make this less noisy
+    cmd iface =
      S.spawn $
-        fmtCmd "nmcli" ["networking"]
-          #!| "grep -q enabled"
-          #!&& "a=off"
-          #!|| "a=on"
-          #!>> fmtCmd "nmcli" ["networking", "$a"]
-          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
-
-runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
-runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
-  where
-    root = IORoot_ cmd $ Only_ nmcli
-    cmd =
-      S.spawn $
-        fmtCmd "nmcli" ["radio", "wifi"]
-          #!| "grep -q enabled"
-          #!&& "a=off"
-          #!|| "a=on"
-          #!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
-          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
+        fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
+          #!| "grep -q disconnected"
+          #!&& "a=connect"
+          #!|| "a=disconnect"
+          #!>> fmtCmd "nmcli" ["device", "$a", iface]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}

 --------------------------------------------------------------------------------
 -- Configuration commands
@ -344,7 +320,6 @@ runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
 runRestart :: X ()
 runRestart = restart "xmonad" True

-- TODO use rio in here so I don't have to fill my xinit log with stack poop
 -- TODO only recompile the VM binary if we have virtualbox enabled
 runRecompile :: X ()
 runRecompile = do
@ -373,12 +348,7 @@ getCaptureDir = do
  where
    fallback = (</> ".local/share") <$> getHomeDirectory

-runFlameshot
-  :: MonadUnliftIO m
-  => T.Text
-  -> T.Text
-  -> Maybe NamedSesConnection
-  -> Sometimes (m ())
+runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
  where
    cmd _ = spawnCmd myCapture [mode]
@ -389,18 +359,18 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd

 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runAreaCapture :: Maybe SesClient -> SometimesX
 runAreaCapture = runFlameshot "screen area capture" "gui"

 -- myWindowCap = "screencap -w" --external script

-runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runDesktopCapture :: Maybe SesClient -> SometimesX
 runDesktopCapture = runFlameshot "fullscreen capture" "full"

-runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runScreenCapture :: Maybe SesClient -> SometimesX
 runScreenCapture = runFlameshot "screen capture" "screen"

-runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
+runCaptureBrowser :: SometimesX
 runCaptureBrowser = sometimesIO_
  "screen capture browser"
  "feh"
--- a/lib/XMonad/Internal/Command/Power.hs
+++ b/lib/XMonad/Internal/Command/Power.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Commands for controlling power

@ -24,7 +26,7 @@ module XMonad.Internal.Command.Power
  )
 where

-import Data.Internal.XIO
+import Data.Internal.Dependency
 import Graphics.X11.Types
 import RIO
 import RIO.Directory
@ -67,30 +69,29 @@ runScreenLock =
    False
    myScreenlock

-runPowerOff :: MonadUnliftIO m => m ()
+runPowerOff :: X ()
 runPowerOff = spawn "systemctl poweroff"

-runSuspend :: MonadUnliftIO m => m ()
+runSuspend :: X ()
 runSuspend = spawn "systemctl suspend"

-runHibernate :: MonadUnliftIO m => m ()
+runHibernate :: X ()
 runHibernate = spawn "systemctl hibernate"

-runReboot :: MonadUnliftIO m => m ()
+runReboot :: X ()
 runReboot = spawn "systemctl reboot"

 --------------------------------------------------------------------------------
 -- Autolock

-runAutolock :: Sometimes (XIO (P.Process () () ()))
+runAutolock :: Sometimes (FIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
  where
    tree =
      And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
        Only_ $
          IOSometimes_ runScreenLock
-    cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
-    args = ["--ignore-sleep", "--", "screenlock", "true"]
+    cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)

 --------------------------------------------------------------------------------
 -- Confirmation prompts
@ -105,7 +106,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
 confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x

 suspendPrompt :: XT.FontBuilder -> X ()
-suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
+suspendPrompt = confirmPrompt' "suspend?" runSuspend

 quitPrompt :: XT.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -179,20 +180,17 @@ data PowerMaybeAction
  | Reboot
  deriving (Eq)

-fromPMA :: PowerMaybeAction -> Int
-fromPMA a = case a of
-  Poweroff -> 0
-  Shutdown -> 1
-  Hibernate -> 2
-  Reboot -> 3
+instance Enum PowerMaybeAction where
+  toEnum 0 = Poweroff
+  toEnum 1 = Shutdown
+  toEnum 2 = Hibernate
+  toEnum 3 = Reboot
+  toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"

-toPMA :: Int -> Maybe PowerMaybeAction
-toPMA x = case x of
-  0 -> Just Poweroff
-  1 -> Just Shutdown
-  2 -> Just Hibernate
-  3 -> Just Reboot
-  _ -> Nothing
+  fromEnum Poweroff = 0
+  fromEnum Shutdown = 1
+  fromEnum Hibernate = 2
+  fromEnum Reboot = 3

 data PowerPrompt = PowerPrompt

@ -224,11 +222,9 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
            , (xK_Return, quit)
            , (xK_Escape, quit)
            ]
-    sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
-    executeMaybeAction a = case toPMA =<< readMaybe a of
-      Just Poweroff -> liftIO runPowerOff
-      Just Shutdown -> lock >> liftIO runSuspend
-      Just Hibernate -> lock >> liftIO runHibernate
-      Just Reboot -> liftIO runReboot
-      -- TODO log an error here since this should never happen
-      Nothing -> skip
+    sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
+    executeMaybeAction a = case toEnum $ read a of
+      Poweroff -> runPowerOff
+      Shutdown -> lock >> runSuspend
+      Hibernate -> lock >> runHibernate
+      Reboot -> runReboot
--- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs
+++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs
@ -1,3 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Concurrent module to handle events from acpid

@ -7,7 +10,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
  )
 where

-import Data.Internal.XIO
+import Data.Internal.Dependency
 import Network.Socket
 import Network.Socket.ByteString
 import RIO
@ -30,18 +33,15 @@ data ACPIEvent
  | LidClose
  deriving (Eq)

-fromACPIEvent :: ACPIEvent -> Int
-fromACPIEvent x = case x of
-  Power -> 0
-  Sleep -> 1
-  LidClose -> 2
+instance Enum ACPIEvent where
+  toEnum 0 = Power
+  toEnum 1 = Sleep
+  toEnum 2 = LidClose
+  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"

-toACPIEvent :: Int -> Maybe ACPIEvent
-toACPIEvent x = case x of
-  0 -> Just Power
-  1 -> Just Sleep
-  2 -> Just LidClose
-  _ -> Nothing
+  fromEnum Power = 0
+  fromEnum Sleep = 1
+  fromEnum LidClose = 2

 --------------------------------------------------------------------------------
 -- Internal functions
@ -64,7 +64,7 @@ parseLine line =

 -- | Send an ACPIEvent to the X server as a ClientMessage
 sendACPIEvent :: ACPIEvent -> IO ()
-sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
+sendACPIEvent = sendXMsg ACPI . show . fromEnum

 isDischarging :: IO (Maybe Bool)
 isDischarging = do
@ -91,14 +91,14 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
 -- Xmonad's event hook)
 handleACPI :: FontBuilder -> X () -> String -> X ()
 handleACPI fb lock tag = do
-  let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
+  let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
  forM_ acpiTag $ \case
    Power -> powerPrompt lock fb
    Sleep -> suspendPrompt fb
    LidClose -> do
      status <- io isDischarging
      -- only run suspend if battery exists and is discharging
-      forM_ status $ flip when $ liftIO runSuspend
+      forM_ status $ flip when runSuspend
      lock

 --------------------------------------------------------------------------------
--- a/lib/XMonad/Internal/Concurrent/ClientMessage.hs
+++ b/lib/XMonad/Internal/Concurrent/ClientMessage.hs
@ -28,7 +28,6 @@ import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Display
 import Graphics.X11.Xlib.Event
 import Graphics.X11.Xlib.Extras
-import RIO
 import XMonad.Internal.IO

 --------------------------------------------------------------------------------
@ -43,18 +42,14 @@ data XMsgType
  | Unknown
  deriving (Eq, Show)

-fromXMsgType :: XMsgType -> Int
-fromXMsgType x = case x of
-  ACPI -> 0
-  Workspace -> 1
-  Unknown -> 2
+instance Enum XMsgType where
+  toEnum 0 = ACPI
+  toEnum 1 = Workspace
+  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"

-toXMsgType :: Int -> Maybe XMsgType
-toXMsgType x = case x of
-  0 -> Just ACPI
-  1 -> Just Workspace
-  2 -> Just Unknown
-  _ -> Nothing
+  fromEnum ACPI = 0
+  fromEnum Workspace = 1
+  fromEnum Unknown = 2

 --------------------------------------------------------------------------------
 -- Exported API
@ -63,9 +58,9 @@ toXMsgType x = case x of
 -- type and payload
 splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
 splitXMsg [] = (Unknown, "")
-splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
+splitXMsg (x : xs) = (xtype, tag)
  where
-    xtype = toXMsgType $ fromIntegral x
+    xtype = toEnum $ fromIntegral x
    tag = chr . fromIntegral <$> takeWhile (/= 0) xs

 -- | Emit a ClientMessage event to the X server with the given type and payloud
@ -91,5 +86,5 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
    setClientMessageEvent' e root bITMAP 8 (x : t)
    sendEvent dpy root False substructureNotifyMask e
  where
-    x = fromIntegral $ fromXMsgType xtype
+    x = fromIntegral $ fromEnum xtype
    t = fmap (fromIntegral . fromEnum) tag
--- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
+++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
@ -34,8 +34,6 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
  )
 where

-import qualified Data.ByteString.Char8 as BC
-import Data.Internal.XIO
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Display
@ -90,49 +88,38 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String

-data WEnv = WEnv
-  { wDisplay :: !Display
-  , wDynWorkspaces :: ![DynWorkspace]
-  , wCurPIDs :: !(MVar (S.Set Pid))
-  , wXEnv :: !XEnv
+data WConf = WConf
+  { display :: Display
+  , dynWorkspaces :: [DynWorkspace]
+  , curPIDs :: MVar (S.Set Pid)
  }

-instance HasLogFunc WEnv where
-  logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
+type W a = RIO WConf ()

-type WIO a = RIO WEnv a
-
-runWorkspaceMon :: [DynWorkspace] -> XIO ()
+runWorkspaceMon :: [DynWorkspace] -> IO ()
 runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
-  root <- liftIO $ rootWindow dpy $ defaultScreen dpy
+  root <- rootWindow dpy $ defaultScreen dpy
  -- listen only for substructure change events (which includes MapNotify)
-  liftIO $ allocaSetWindowAttributes $ \a -> do
+  allocaSetWindowAttributes $ \a -> do
    set_event_mask a substructureNotifyMask
    changeWindowAttributes dpy root cWEventMask a
-  withRunInIO $ \runIO -> do
-    void $ allocaXEvent $ runIO . withEvents dpy
+  void $ allocaXEvent $ withEvents dpy
  where
-    wrapEnv dpy ps x =
-      WEnv
-        { wDisplay = dpy
-        , wDynWorkspaces = dws
-        , wCurPIDs = ps
-        , wXEnv = x
-        }
    withEvents dpy e = do
      ps <- newMVar S.empty
-      mapRIO (wrapEnv dpy ps) $ do
+      let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
+      runRIO c $
        forever $
          handleEvent =<< io (nextEvent dpy e >> getEvent e)

-handleEvent :: Event -> WIO ()
+handleEvent :: Event -> W ()

 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
 handleEvent MapNotifyEvent {ev_window = w} = do
-  dpy <- asks wDisplay
+  dpy <- asks display
  hint <- io $ getClassHint dpy w
-  dws <- asks wDynWorkspaces
+  dws <- asks dynWorkspaces
  let tag =
        M.lookup (resClass hint) $
          M.fromList $
@ -146,28 +133,21 @@ handleEvent MapNotifyEvent {ev_window = w} = do
      _ -> return ()
 handleEvent _ = return ()

-withUniquePid :: Pid -> String -> WIO ()
+withUniquePid :: Pid -> String -> W ()
 withUniquePid pid tag = do
-  ps <- asks wCurPIDs
+  ps <- asks curPIDs
  pids <- readMVar ps
-  unless (pid `elem` pids)
+  io
+    $ unless (pid `elem` pids)
    $ bracket_
      (modifyMVar_ ps (return . S.insert pid))
      (modifyMVar_ ps (return . S.delete pid))
-    $ do
-      logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
-      waitUntilExit pid
-      logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
-      liftIO $ sendXMsg Workspace tag
-  where
-    pid_ = "'" <> displayShow pid <> "'"
-    tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
+    $ waitUntilExit pid >> sendXMsg Workspace tag

 --------------------------------------------------------------------------------
 -- Launching apps
 -- When launching apps on dymamic workspaces, first check if they are running
 -- and launch if not, then switch to their workspace
-
 wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
 wsOccupied tag ws =
  elem tag $
--- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs
+++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs
@ -1,3 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- VirtualBox-specific functions

@ -8,7 +11,7 @@ module XMonad.Internal.Concurrent.VirtualBox
  )
 where

-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO hiding (try)
 import RIO.Directory
 import RIO.FilePath
@ -33,7 +36,7 @@ vmInstanceConfig vmName = do
 vmDirectory :: IO (Either String String)
 vmDirectory = do
  p <- vmConfig
-  s <- tryIO $ readFileUtf8 p
+  s <- tryIO $ readFile p
  return $ case s of
    (Left _) -> Left "could not read VirtualBox config file"
    (Right x) ->
--- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for Clevo Keyboard control

@ -13,7 +15,7 @@ where

 import DBus
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
@ -44,34 +46,34 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
 stateFile :: FilePath
 stateFile = backlightDir </> "state"

-stateChange :: MonadUnliftIO m => Bool -> m ()
+stateChange :: Bool -> IO ()
 stateChange = writeBool stateFile

-stateOn :: MonadUnliftIO m => m ()
+stateOn :: IO ()
 stateOn = stateChange True

-stateOff :: MonadUnliftIO m => m ()
+stateOff :: IO ()
 stateOff = stateChange False

 brightnessFile :: FilePath
 brightnessFile = backlightDir </> "brightness"

-getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+getBrightness :: RawBounds -> IO Brightness
 getBrightness bounds = readPercent bounds brightnessFile

-minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+minBrightness :: RawBounds -> IO Brightness
 minBrightness bounds = do
  b <- writePercentMin bounds brightnessFile
  stateOff
  return b

-maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+maxBrightness :: RawBounds -> IO Brightness
 maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile

-incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+incBrightness :: RawBounds -> IO Brightness
 incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds

-decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+decBrightness :: RawBounds -> IO Brightness
 decBrightness bounds = do
  b <- decPercent steps brightnessFile bounds
  when (b == 0) stateOff
@ -86,7 +88,7 @@ blPath = objectPath_ "/clevo_keyboard"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"

-clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
+clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
 clevoKeyboardConfig =
  BrightnessConfig
    { bcMin = minBrightness
@ -111,14 +113,9 @@ brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]

 clevoKeyboardSignalDep :: DBusDependency_ SesClient
-clevoKeyboardSignalDep =
-  -- TODO do I need to get rid of the IO here?
-  signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
+clevoKeyboardSignalDep = signalDep clevoKeyboardConfig

-exportClevoKeyboard
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> Sometimes (m (), m ())
+exportClevoKeyboard :: Maybe SesClient -> SometimesIO
 exportClevoKeyboard =
  brightnessExporter
    xpfClevoBacklight
@ -126,23 +123,15 @@ exportClevoKeyboard =
    [stateFileDep, brightnessFileDep]
    clevoKeyboardConfig

-clevoKeyboardControls
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> BrightnessControls m
+clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig

-callGetBrightnessCK
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
-  => m (Maybe Brightness)
+callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig

 matchSignalCK
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     )
+  :: MonadUnliftIO m
  => (Maybe Brightness -> m ())
+  -> SesClient
  -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig
--- a/lib/XMonad/Internal/DBus/Brightness/Common.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for DBus brightness controls

@ -16,9 +18,10 @@ import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import qualified RIO.Text as T
+import XMonad.Core (io)
 import XMonad.Internal.DBus.Common

 --------------------------------------------------------------------------------
@ -29,32 +32,31 @@ import XMonad.Internal.DBus.Common
 -- integer and emit a signal with the same brightness value. Additionally, there
 -- is one method to get the current brightness.

-data BrightnessConfig m a b = BrightnessConfig
-  { bcMin :: (a, a) -> m b
-  , bcMax :: (a, a) -> m b
-  , bcDec :: (a, a) -> m b
-  , bcInc :: (a, a) -> m b
-  , bcGet :: (a, a) -> m b
+data BrightnessConfig a b = BrightnessConfig
+  { bcMin :: (a, a) -> IO b
+  , bcMax :: (a, a) -> IO b
+  , bcDec :: (a, a) -> IO b
+  , bcInc :: (a, a) -> IO b
+  , bcGet :: (a, a) -> IO b
  , bcMinRaw :: a
-  , bcGetMax :: m a
+  , bcGetMax :: IO a
  , bcPath :: ObjectPath
  , bcInterface :: InterfaceName
  , bcName :: T.Text
  }

-data BrightnessControls m = BrightnessControls
-  { bctlMax :: Sometimes (m ())
-  , bctlMin :: Sometimes (m ())
-  , bctlInc :: Sometimes (m ())
-  , bctlDec :: Sometimes (m ())
+data BrightnessControls = BrightnessControls
+  { bctlMax :: SometimesX
+  , bctlMin :: SometimesX
+  , bctlInc :: SometimesX
+  , bctlDec :: SometimesX
  }

 brightnessControls
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => XPQuery
-  -> BrightnessConfig m a b
-  -> Maybe NamedSesConnection
-  -> BrightnessControls m
+  :: XPQuery
+  -> BrightnessConfig a b
+  -> Maybe SesClient
+  -> BrightnessControls
 brightnessControls q bc cl =
  BrightnessControls
    { bctlMax = cb "max brightness" memMax
@ -66,34 +68,26 @@ brightnessControls q bc cl =
    cb = callBacklight q cl bc

 callGetBrightness
-  :: ( HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     , SafeClient c
-     , Num n
-     )
-  => BrightnessConfig m a b
+  :: (MonadUnliftIO m, SafeClient c, Num n)
+  => BrightnessConfig a b
+  -> c
  -> m (Maybe n)
-callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
+callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
  either (const Nothing) bodyGetBrightness
-    <$> callMethod xmonadSesBusName p i memGet
+    <$> callMethod client xmonadBusName p i memGet

-signalDep :: BrightnessConfig m a b -> DBusDependency_ c
+signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
-  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
+  Endpoint [] xmonadBusName p i $ Signal_ memCur

 matchSignal
-  :: ( HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     , SafeClient c
-     , Num n
-     )
-  => BrightnessConfig m a b
+  :: (MonadUnliftIO m, SafeClient c, Num n)
+  => BrightnessConfig a b
  -> (Maybe n -> m ())
+  -> c
  -> m ()
 matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
-  void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
+  void . addMatchCallback brMatcher (cb . bodyGetBrightness)
  where
    -- TODO add busname to this
    brMatcher =
@ -107,46 +101,45 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
 -- Internal DBus Crap

 brightnessExporter
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+  :: RealFrac b
  => XPQuery
  -> [Fulfillment]
  -> [IODependency_]
-  -> BrightnessConfig m a b
-  -> Maybe NamedSesConnection
-  -> Sometimes (m (), m ())
+  -> BrightnessConfig a b
+  -> Maybe SesClient
+  -> SometimesIO
 brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
  Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
  where
-    root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
-    tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
+    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
+    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps

-exportBrightnessControlsInner
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
-  => BrightnessConfig m a b
-  -> NamedSesConnection
-  -> (m (), m ())
-exportBrightnessControlsInner bc = cmd
+exportBrightnessControls'
+  :: (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]
+      }
  where
-    cmd = exportPair (bcPath bc) $ \cl_ -> do
-      -- assume the max value will never change
-      bounds <- (bcMinRaw bc,) <$> bcGetMax bc
-      runIO <- askRunInIO
-      let autoMethod' m f = autoMethod m $ runIO $ do
-            val <- f bc bounds
-            emitBrightness bc cl_ val
-      funget <- toIO $ bcGet bc bounds
-      return $
-        defaultInterface
-          { interfaceName = bcInterface bc
-          , interfaceMethods =
-              [ autoMethod' memMax bcMax
-              , autoMethod' memMin bcMin
-              , autoMethod' memInc bcInc
-              , autoMethod' memDec bcDec
-              , autoMethod memGet (round <$> funget :: IO Int32)
-              ]
-          , interfaceSignals = [sig]
-          }
    sig =
      I.Signal
        { I.signalName = memCur
@ -160,7 +153,7 @@ exportBrightnessControlsInner bc = cmd

 emitBrightness
  :: (MonadUnliftIO m, RealFrac b)
-  => BrightnessConfig m a b
+  => BrightnessConfig a b
  -> Client
  -> b
  -> m ()
@ -170,18 +163,26 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
    sig = signal p i memCur

 callBacklight
-  :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
-  => XPQuery
-  -> Maybe NamedSesConnection
-  -> BrightnessConfig m a b
+  :: XPQuery
+  -> Maybe SesClient
+  -> BrightnessConfig a b
  -> T.Text
  -> MemberName
-  -> Sometimes (m ())
-callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
-  Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
-  where
-    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
-    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
+  -> SometimesX
+callBacklight
+  q
+  cl
+  BrightnessConfig
+    { bcPath = p
+    , bcInterface = i
+    , bcName = n
+    }
+  controlName
+  m =
+    Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
+    where
+      root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
+      cmd c = io $ void $ callMethod c xmonadBusName p i m

 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
--- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for Intel Backlight control

@ -13,7 +15,7 @@ where

 import DBus
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
@ -43,22 +45,22 @@ maxFile = backlightDir </> "max_brightness"
 curFile :: FilePath
 curFile = backlightDir </> "brightness"

-getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
+getMaxRawBrightness :: IO RawBrightness
 getMaxRawBrightness = readInt maxFile

-getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+getBrightness :: RawBounds -> IO Brightness
 getBrightness bounds = readPercent bounds curFile

-minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+minBrightness :: RawBounds -> IO Brightness
 minBrightness bounds = writePercentMin bounds curFile

-maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+maxBrightness :: RawBounds -> IO Brightness
 maxBrightness bounds = writePercentMax bounds curFile

-incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+incBrightness :: RawBounds -> IO Brightness
 incBrightness = incPercent steps curFile

-decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+decBrightness :: RawBounds -> IO Brightness
 decBrightness = decPercent steps curFile

 --------------------------------------------------------------------------------
@ -70,9 +72,7 @@ blPath = objectPath_ "/intelbacklight"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"

-intelBacklightConfig
-  :: MonadUnliftIO m
-  => BrightnessConfig m RawBrightness Brightness
+intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
 intelBacklightConfig =
  BrightnessConfig
    { bcMin = minBrightness
@ -97,14 +97,9 @@ maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []

 intelBacklightSignalDep :: DBusDependency_ SesClient
-intelBacklightSignalDep =
-  -- TODO do I need to get rid of the IO here?
-  signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
+intelBacklightSignalDep = signalDep intelBacklightConfig

-exportIntelBacklight
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> Sometimes (m (), m ())
+exportIntelBacklight :: Maybe SesClient -> SometimesIO
 exportIntelBacklight =
  brightnessExporter
    xpfIntelBacklight
@ -112,23 +107,15 @@ exportIntelBacklight =
    [curFileDep, maxFileDep]
    intelBacklightConfig

-intelBacklightControls
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> BrightnessControls m
+intelBacklightControls :: Maybe SesClient -> BrightnessControls
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig

-callGetBrightnessIB
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
-  => m (Maybe Brightness)
+callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig

 matchSignalIB
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     )
+  :: MonadUnliftIO m
  => (Maybe Brightness -> m ())
+  -> SesClient
  -> m ()
 matchSignalIB = matchSignal intelBacklightConfig
--- a/lib/XMonad/Internal/DBus/Common.hs
+++ b/lib/XMonad/Internal/DBus/Common.hs
@ -2,8 +2,7 @@
 -- High-level interface for managing XMonad's DBus

 module XMonad.Internal.DBus.Common
-  ( xmonadSesBusName
-  , xmonadSysBusName
+  ( xmonadBusName
  , btBus
  , notifyBus
  , notifyPath
@ -13,11 +12,8 @@ where

 import DBus

-xmonadSesBusName :: BusName
-xmonadSesBusName = busName_ "org.xmonad.session"
-
-xmonadSysBusName :: BusName
-xmonadSysBusName = busName_ "org.xmonad.system"
+xmonadBusName :: BusName
+xmonadBusName = busName_ "org.xmonad"

 btBus :: BusName
 btBus = busName_ "org.bluez"
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@ -1,17 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- High-level interface for managing XMonad's DBus

 module XMonad.Internal.DBus.Control
  ( Client
  , DBusState (..)
-  , withDBusInterfaces
-  , withDBusX
-  , withDBusX_
  , withDBus
  , withDBus_
+  , withDBusX
+  , withDBusX_
  , connectDBus
+  , connectDBusX
  , disconnectDBus
-  -- , disconnectDBusX
+  , disconnectDBusX
  , getDBusClient
  , withDBusClient
  , withDBusClient_
@ -23,7 +26,7 @@ where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -32,157 +35,90 @@ import XMonad.Internal.DBus.Screensaver

 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-  { dbSesClient :: Maybe NamedSesConnection
-  , dbSysClient :: Maybe NamedSysConnection
+  { dbSesClient :: Maybe SesClient
+  , dbSysClient :: Maybe SysClient
  }

 withDBusX_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m ()
-withDBusX_ = void . withDBusX
+withDBusX_ = void . withDBusX_

 withDBusX
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
-  -> m a
-withDBusX = withDBus (Just xmonadSesBusName) Nothing
+  -> m (Maybe a)
+withDBusX f = withDBus $ \db ->
+  -- TODO log error if this fails
+  forM (dbSesClient db) $ \ses ->
+    bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)

 withDBus_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
-  -> Maybe BusName
-  -> (DBusState -> m a)
+  => (DBusState -> m a)
  -> m ()
-withDBus_ sesname sysname = void . withDBus sesname sysname
+withDBus_ = void . withDBus

 withDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
-  -> Maybe BusName
-  -> (DBusState -> m a)
+  => (DBusState -> m a)
  -> m a
-withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
+withDBus = bracket connectDBus disconnectDBus

 -- | Connect to the DBus
 connectDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
-  -> Maybe BusName
-  -> m DBusState
-connectDBus sesname sysname = do
-  ses <- getDBusClient sesname
-  sys <- getDBusClient sysname
+  => m DBusState
+connectDBus = do
+  ses <- getDBusClient
+  sys <- getDBusClient
  return DBusState {dbSesClient = ses, dbSysClient = sys}

 -- | Disconnect from the DBus
-disconnectDBus
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => DBusState
-  -> m ()
+disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
  where
-    disc
-      :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
-      => (DBusState -> Maybe (NamedConnection c))
-      -> m ()
    disc f = maybe (return ()) disconnectDBusClient $ f db

-- -- | Connect to the DBus and request the XMonad name
-- connectDBusX
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => m DBusState
-- connectDBusX = do
--   db <- connectDBus
--   requestXMonadName2 db
--   return db
+-- | Connect to the DBus and request the XMonad name
+connectDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => m DBusState
+connectDBusX = do
+  db <- connectDBus
+  forM_ (dbSesClient db) requestXMonadName
+  return db

-- -- | Disconnect from DBus and release the XMonad name
-- disconnectDBusX
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => DBusState
--   -> m ()
-- disconnectDBusX db = do
--   forM_ (dbSesClient db) releaseBusName
--   forM_ (dbSysClient db) releaseBusName
--   disconnectDBus db
-
-- requestXMonadName2
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => DBusState
--   -> m ()
-- requestXMonadName2 db = do
--   forM_ (dbSesClient db) requestXMonadName
--   forM_ (dbSysClient db) requestXMonadName
-
-withDBusInterfaces
-  :: DBusState
-  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
-  -> ([XIO ()] -> XIO a)
-  -> XIO a
-withDBusInterfaces db interfaces = bracket up sequence
-  where
-    up = do
-      pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
-      mapM_ fst pairs
-      return $ snd <$> pairs
+-- | Disconnect from DBus and release the XMonad name
+disconnectDBusX
+  :: MonadUnliftIO m
+  => DBusState
+  -> m ()
+disconnectDBusX db = do
+  forM_ (dbSesClient db) releaseXMonadName
+  disconnectDBus db

 -- | All exporter features to be assigned to the DBus
-dbusExporters
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
+dbusExporters :: [Maybe SesClient -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

-- releaseXMonadName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => c
--   -> m ()
-- releaseXMonadName cl = do
--   -- TODO this might error?
--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
--   logInfo "released xmonad name"
+releaseXMonadName
+  :: MonadUnliftIO m
+  => SesClient
+  -> m ()
+releaseXMonadName ses = do
+  liftIO $ void $ releaseName (toClient ses) xmonadBusName

-- releaseBusName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => BusName
--   -> c
--   -> m ()
-- releaseBusName n cl = do
--   -- TODO this might error?
--   liftIO $ void $ releaseName (toClient cl) n
--   logInfo $ "released bus name: " <> displayBusName n
-
-- requestBusName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => BusName
--   -> c
--   -> m ()
-- requestBusName n cl = do
--   res <- try $ liftIO $ requestName (toClient cl) n []
--   case res of
--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
--     Right r -> do
--       let msg
--             | r == NamePrimaryOwner = "registering name"
--             | r == NameAlreadyOwner = "this process already owns name"
--             | r == NameInQueue
--                 || r == NameExists =
--                 "another process owns name"
--             -- this should never happen
--             | otherwise = "unknown error when requesting name"
--       logInfo $ msg <> ": " <> displayBusName n
-
-- requestXMonadName
--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => c
--   -> m ()
-- requestXMonadName cl = do
--   res <- liftIO $ requestName (toClient cl) xmonadBusName []
--   let msg
--         | res == NamePrimaryOwner = "registering name"
--         | res == NameAlreadyOwner = "this process already owns name"
--         | res == NameInQueue
--             || res == NameExists =
--             "another process owns name"
--         | otherwise = "unknown error when requesting name"
--   logInfo $ msg <> ": " <> displayBusName xmonadBusName
+requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
+requestXMonadName ses = do
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
+  -- TODO if the client is not released on shutdown the owner will be different
+  let msg
+        | res == NamePrimaryOwner = Nothing
+        | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
+        | res == NameInQueue
+            || res == NameExists =
+            Just $ "another process owns " ++ xn
+        | otherwise = Just $ "unknown error when requesting " ++ xn
+  liftIO $ forM_ msg putStrLn
+  where
+    xn = "'" ++ formatBusName xmonadBusName ++ "'"
--- a/lib/XMonad/Internal/DBus/Removable.hs
+++ b/lib/XMonad/Internal/DBus/Removable.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Module for monitoring removable drive events
 --
@ -9,7 +11,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import qualified RIO.Map as M
 import XMonad.Core (io)
@ -71,36 +73,25 @@ removedHasDrive [_, a] =
    (fromVariant a :: Maybe [String])
 removedHasDrive _ = False

-playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
+playSoundMaybe :: FilePath -> Bool -> IO ()
 playSoundMaybe p b = when b $ io $ playSound p

 -- NOTE: the udisks2 service should be already running for this module to work.
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices
-  :: ( HasClient (DBusEnv env)
-     , MonadReader env m
-     , MonadUnliftIO m
-     )
-  => NamedSysConnection
-  -> m ()
+listenDevices :: SysClient -> IO ()
 listenDevices cl = do
  addMatch' memAdded driveInsertedSound addedHasDrive
  addMatch' memRemoved driveRemovedSound removedHasDrive
  where
-    addMatch' m p f = do
-      let rule = ruleUdisks {matchMember = Just m}
-      void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
+    addMatch' m p f =
+      void $
+        addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
+          playSoundMaybe p . f . signalBody

-runRemovableMon
-  :: ( HasClient (DBusEnv env)
-     , MonadReader env m
-     , MonadUnliftIO m
-     )
-  => Maybe NamedSysConnection
-  -> Sometimes (m ())
+runRemovableMon :: Maybe SysClient -> SometimesIO
 runRemovableMon cl =
-  sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
+  sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
  where
    deps = toAnd_ addedDep removedDep
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/lib/XMonad/Internal/DBus/Screensaver.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for X11 screensave/DPMS control

@ -14,7 +16,7 @@ import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import Graphics.X11.XScreenSaver
 import RIO
 import XMonad.Internal.DBus.Common
@ -91,24 +93,24 @@ bodyGetCurrentState _ = Nothing
 --------------------------------------------------------------------------------
 -- Exported haskell API

-exportScreensaver
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> Sometimes (m (), m ())
+exportScreensaver :: Maybe SesClient -> SometimesIO
 exportScreensaver ses =
  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
  where
-    cmd = exportPair ssPath $ \cl_ -> do
-      liftIO $ withRunInIO $ \run ->
-        return $
-          defaultInterface
-            { interfaceName = interface
-            , interfaceMethods =
-                [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
-                , autoMethod memQuery (run query)
-                ]
-            , interfaceSignals = [sig]
-            }
+    cmd cl =
+      let cl' = toClient cl
+       in withRunInIO $ \run ->
+            export
+              cl'
+              ssPath
+              defaultInterface
+                { interfaceName = interface
+                , interfaceMethods =
+                    [ autoMethod memToggle $ run $ emitState cl' =<< toggle
+                    , autoMethod memQuery (run query)
+                    ]
+                , interfaceSignals = [sig]
+                }
    sig =
      I.Signal
        { I.signalName = memState
@ -119,42 +121,32 @@ exportScreensaver ses =
                }
            ]
        }
-    bus = Bus [] xmonadSesBusName
+    bus = Bus [] xmonadBusName
    ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable

-callToggle
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
-  -> Sometimes (m ())
+callToggle :: Maybe SesClient -> SometimesX
 callToggle =
  sometimesEndpoint
    "screensaver toggle"
    "dbus switch"
    []
-    xmonadSesBusName
+    xmonadBusName
    ssPath
    interface
    memToggle

-callQuery
-  :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
-  => m (Maybe SSState)
-callQuery = do
-  reply <- callMethod xmonadSesBusName ssPath interface memQuery
+callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
+callQuery ses = do
+  reply <- callMethod ses xmonadBusName ssPath interface memQuery
  return $ either (const Nothing) bodyGetCurrentState reply

-matchSignal
-  :: ( HasClient env
-     , MonadReader (env SesClient) m
-     , MonadUnliftIO m
-     )
-  => (Maybe SSState -> m ())
-  -> m ()
-matchSignal cb =
+matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
+matchSignal cb ses =
  void $
    addMatchCallback
      ruleCurrentState
      (cb . bodyGetCurrentState)
+      ses

 ssSignalDep :: DBusDependency_ SesClient
-ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState
+ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
--- a/lib/XMonad/Internal/IO.hs
+++ b/lib/XMonad/Internal/IO.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 --------------------------------------------------------------------------------
 -- Random IO-ish functions used throughtout xmonad
 --
@ -39,7 +41,7 @@ import System.Process
 -- read

 readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
-readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
+readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8

 readBool :: MonadIO m => FilePath -> m Bool
 readBool = fmap (== (1 :: Int)) . readInt
@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
 --------------------------------------------------------------------------------
 -- write

-writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
+writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
 writeInt f = writeFileUtf8 f . T.pack . show

 writeBool :: MonadIO m => FilePath -> Bool -> m ()
@ -60,7 +62,7 @@ writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
 -- value. Assume that the file being read has a min of 0 and an unchanging max
 -- given by a runtime argument, which is scaled linearly to the range 0-100
 -- (percent).
-rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
+rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
 rawToPercent (lower, upper) raw =
  100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)

@ -164,7 +166,7 @@ getPermissionsSafe f = do
 -- | Block until a PID has exited.
 -- Use this to control flow based on a process that was not explicitly started
 -- by the Haskell runtime itself, and thus has no data structures to query.
-waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
+waitUntilExit :: (MonadIO m) => Pid -> m ()
 waitUntilExit pid = do
  res <- doesDirectoryExist $ "/proc" </> show pid
  when res $ do
--- a/lib/XMonad/Internal/Notify.hs
+++ b/lib/XMonad/Internal/Notify.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Functions for formatting and sending notifications
 --
--- a/lib/XMonad/Internal/Shell.hs
+++ b/lib/XMonad/Internal/Shell.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- Functions for formatting and spawning shell commands

 module XMonad.Internal.Shell
@ -83,31 +85,8 @@ spawn :: MonadIO m => T.Text -> m ()
 spawn = X.spawn . T.unpack

 -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
-spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
-spawnPipe = liftIO . XR.spawnPipe . T.unpack
-
-- spawnPipeRW
--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
--   => T.Text
--   -> m Handle
-- spawnPipeRW x = do
--   (r, h) <- liftIO mkPipe
--   child r
--   liftIO $ closeFd r
--   return h
--   where
--     mkPipe = do
--       (r, w) <- createPipe
--       setFdOption w CloseOnExec True
--       h <- fdToHandle w
--       -- ASSUME we are using utf8 everywhere
--       hSetEncoding h utf8
--       hSetBuffering h LineBuffering
--       return (r, h)
--     child r = void $ withRunInIO $ \runIO -> do
--       X.xfork $ runIO $ do
--         void $ liftIO $ dupTo r stdInput
--         liftIO $ executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
+spawnPipe :: MonadIO m => T.Text -> m Handle
+spawnPipe = XR.spawnPipe . T.unpack

 -- | Run 'XMonad.Core.spawn' with a command and arguments
 spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
--- a/lib/XMonad/Internal/Theme.hs
+++ b/lib/XMonad/Internal/Theme.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Theme for XMonad and Xmobar

@ -31,7 +33,6 @@ where

 import Data.Colour
 import Data.Colour.SRGB
-import RIO
 import qualified RIO.Text as T
 import qualified XMonad.Layout.Decoration as D
 import qualified XMonad.Prompt as P
--- a/lib/Xmobar/Plugins/ActiveConnection.hs
+++ b/lib/Xmobar/Plugins/ActiveConnection.hs
@ -1,155 +0,0 @@
--------------------------------------------------------------------------------
-- NetworkManager Connection plugin
--
-- Show active connections of varying types.
--
-- This plugin exclusively monitors the */ActiveConnection/* paths in the
-- NetworkManager DBus path for state changes. It does not pin these to any
-- particular interface but instead looks at all connections equally and filters
-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
-- track well enough with either one or a collection of similar interfaces (ie
-- all ethernet or all wifi).
-
-module Xmobar.Plugins.ActiveConnection
-  ( ActiveConnection (..)
-  , devDep
-  , connAlias
-  )
-where
-
-import DBus
-import Data.Internal.DBus
-import Data.Internal.XIO
-import RIO
-import qualified RIO.Map as M
-import qualified RIO.NonEmpty as NE
-import qualified RIO.Text as T
-import XMonad.Internal.Command.Desktop
-import XMonad.Internal.DBus.Common
-import Xmobar
-import Xmobar.Plugins.Common
-
-newtype ActiveConnection
-  = ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors)
-  deriving (Read, Show)
-
-connAlias :: NE.NonEmpty T.Text -> T.Text
-connAlias = T.intercalate "_" . NE.toList
-
-instance Exec ActiveConnection where
-  alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
-  start (ActiveConnection (contypes, text, colors)) cb =
-    withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do
-      let dpy cb' = displayMaybe cb' formatter . Just =<< readState
-      i <- withDIO c $ initialState contypes
-      s <- newMVar i
-      let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
-      mapEnv c $ addListener mapEnv >> pluginDisplay
-    where
-      formatter names = return $ case names of
-        [] -> colorText colors False text
-        xs -> T.unwords [colorText colors True text, T.intercalate "|" xs]
-      addListener mapEnv = do
-        res <- matchSignalFull nmBus Nothing (Just nmActiveInterface) (Just stateChanged)
-        case res of
-          Nothing -> logError "could not start listener"
-          Just rule ->
-            -- Start a new connection and RIO process since the parent thread
-            -- will have died before these callbacks fire, therefore the logging
-            -- file descriptor will be closed. This makes a new one
-            -- TODO can I recycle the client?
-            void $
-              addMatchCallbackSignal rule $ \sig ->
-                withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
-                  mapEnv c' $
-                    testActiveType contypes sig
-
-nmBus :: BusName
-nmBus = "org.freedesktop.NetworkManager"
-
-nmPath :: ObjectPath
-nmPath = "/org/freedesktop/NetworkManager"
-
-nmInterface :: InterfaceName
-nmInterface = "org.freedesktop.NetworkManager"
-
-nmObjectTreePath :: ObjectPath
-nmObjectTreePath = "/org/freedesktop"
-
-nmActiveInterface :: InterfaceName
-nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
-
-stateChanged :: MemberName
-stateChanged = "StateChanged"
-
-- semi-random method to test to ensure that NetworkManager is up and on DBus
-devDep :: DBusDependency_ SysClient
-devDep =
-  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
-    Method_ "GetDeviceByIpIface"
-
-type EthIO = PluginIO EthState SysClient
-
-type EthState = M.Map ObjectPath T.Text
-
-getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
-getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop
-
-getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
-getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
-
-getConnectionType :: ObjectPath -> EthIO (Maybe T.Text)
-getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
-
-updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
-updateConnected contypes path = do
-  typeRes <- getConnectionType path
-  logMaybe "type" getId typeRes
-  where
-    path' = displayBytesUtf8 $ T.encodeUtf8 $ T.pack $ formatObjectPath path
-    logMaybe what = maybe (logError ("could not get " <> what <> " for " <> path'))
-    getId contype = do
-      when (contype `elem` contypes) $ do
-        idRes <- getConnectionId path
-        logMaybe "ID" insertId idRes
-    insertId i = do
-      s <- asks plugState
-      modifyMVar_ s $ return . M.insert path i
-
-updateDisconnected :: ObjectPath -> EthIO ()
-updateDisconnected path = do
-  s <- asks plugState
-  modifyMVar_ s $ return . M.delete path
-
-testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
-testActiveType contypes sig = do
-  case signalBody sig of
-    [state, _] -> case fromVariant state of
-      Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
-      Just 4 -> updateDisconnected path >> pluginDisplay
-      _ -> return ()
-    _ -> return ()
-  where
-    path = signalPath sig
-
-initialState
-  :: ( SafeClient c
-     , MonadUnliftIO m
-     , MonadReader (env c) m
-     , HasClient env
-     , HasLogFunc (env c)
-     )
-  => NE.NonEmpty T.Text
-  -> m EthState
-initialState contypes =
-  M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
-  where
-    go = getId <=< M.lookup nmActiveInterface
-    getId m =
-      fromVariant
-        =<< (\t -> if t `elem` contypes then M.lookup "Id" m else Nothing)
-        =<< fromVariant
-        =<< M.lookup "Type" m
-
-readState :: EthIO [T.Text]
-readState = M.elems <$> (readMVar =<< asks plugState)
--- a/lib/Xmobar/Plugins/BacklightCommon.hs
+++ b/lib/Xmobar/Plugins/BacklightCommon.hs
@ -1,10 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- Common backlight plugin bits
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
 module Xmobar.Plugins.BacklightCommon (startBacklight) where

-import DBus
 import Data.Internal.DBus
 import RIO
 import qualified RIO.Text as T
@ -12,17 +13,15 @@ import Xmobar.Plugins.Common

 startBacklight
  :: (MonadUnliftIO m, RealFrac a)
-  => Maybe BusName
-  -> Maybe FilePath
-  -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-  -> DIO SimpleApp SesClient (Maybe a)
+  => ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
+  -> (SesClient -> RIO SimpleApp (Maybe a))
  -> T.Text
  -> Callback
  -> m ()
-startBacklight n name matchSignal callGetBrightness icon cb = do
-  withDBusClientConnection cb n name $ \c -> withDIO c $ do
-    matchSignal dpy
-    dpy =<< callGetBrightness
+startBacklight matchSignal callGetBrightness icon cb = do
+  withDBusClientConnection cb $ \c -> do
+    matchSignal dpy c
+    dpy =<< callGetBrightness c
  where
    formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
    dpy = displayMaybe cb formatBrightness
--- a/lib/Xmobar/Plugins/Bluetooth.hs
+++ b/lib/Xmobar/Plugins/Bluetooth.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Bluetooth plugin
 --
@ -7,18 +9,28 @@
 -- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
 -- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
 --
-- Simple and somewhat crude way to do this is to have two monitors, one
-- watching the powered state of the adaptor and one listening for connection
-- changes. The former is easy since this is just one /org/bluez/hciX. For the
-- latter, each 'Connected' property is embedded in each individual device path
-- on `org.bluez.Device1', so just watch the entire bluez bus for property
-- changes and filter those that correspond to the aforementioned
-- interface/property. Track all this in a state which keeps the powered
-- property and a running list of connected devices.
+-- This plugin will reflect if the adapter is powered and if any device is
+-- connected to it. The rough outline for this procedure:
+-- 1) get the adapter from the object manager
+-- 2) get all devices associated with the adapter using the object interface
+-- 3) determine if the adapter is powered
+-- 4) determine if any devices are connected
+-- 5) format the icon; powered vs not powered controls the color and connected
+--    vs not connected controls the icon (connected bluetooth symbol has two
+--    dots flanking it)
+--
+-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
+-- querying the "Powered" property. Step 4 can be done using the
+-- "org.bluez.Device1" interface and the "Connected" property for each device
+-- path. Since these are properties, we can asynchronously read changes to them
+-- via the "PropertiesChanged" signal.
+--
+-- If any devices are added/removed, steps 2-4 will need to be redone and any
+-- listeners will need to be updated. (TODO not sure which signals to use in
+-- determining if a device is added)
 --
 -- TODO also not sure if I need to care about multiple adapters and/or the
-- adapter changing. For now it should just get the first adaptor and only pay
-- attention to devices associated with it.
+-- adapter changing.

 module Xmobar.Plugins.Bluetooth
  ( Bluetooth (..)
@ -30,12 +42,11 @@ where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.XIO
+import Data.Internal.Dependency
 import RIO
 import RIO.FilePath
 import RIO.List
 import qualified RIO.Map as M
-import qualified RIO.Set as S
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Common
 import Xmobar
@ -54,28 +65,31 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
  alias (Bluetooth _ _) = T.unpack btAlias
  start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
-      startAdapter icons colors cb
+    withDBusClientConnection cb $ startAdapter icons colors cb

 startAdapter
-  :: Icons
+  :: MonadUnliftIO m
+  => Icons
  -> Colors
  -> Callback
-  -> NamedSysConnection
-  -> RIO SimpleApp ()
+  -> SysClient
+  -> m ()
 startAdapter is cs cb cl = do
+  ot <- getBtObjectTree cl
  state <- newMVar emptyState
-  let dpy cb' = displayIcon cb' (iconFormatter is cs)
-  mapRIO (PluginEnv cl state dpy cb) $ do
-    ot <- getBtObjectTree
-    case findAdaptor ot of
-      Nothing -> logError "could not find bluetooth adapter"
-      Just adaptor -> do
-        initAdapterState adaptor
-        initDevicesState adaptor ot
-        startAdaptorListener adaptor
-        startConnectedListener adaptor
-        pluginDisplay
+  let dpy = displayIcon cb (iconFormatter is cs) state
+  forM_ (findAdapter ot) $ \adapter -> do
+    -- set up adapter
+    initAdapter state adapter cl
+    -- TODO this step could fail; at least warn the user...
+    void $ addAdaptorListener state dpy adapter cl
+    -- set up devices on the adapter (and listeners for adding/removing devices)
+    let devices = findDevices adapter ot
+    addDeviceAddedListener state dpy adapter cl
+    addDeviceRemovedListener state dpy adapter cl
+    forM_ devices $ \d -> addAndInitDevice state dpy d cl
+    -- after setting things up, show the icon based on the initialized state
+    dpy

 --------------------------------------------------------------------------------
 -- Icon Display
@ -87,9 +101,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)

 type Icons = (T.Text, T.Text)

-displayIcon :: Callback -> IconFormatter -> BTIO ()
+displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
 displayIcon callback formatter =
-  liftIO . callback . T.unpack . uncurry formatter =<< readState
+  liftIO . callback . T.unpack . uncurry formatter <=< readState

 -- TODO maybe I want this to fail when any of the device statuses are Nothing
 iconFormatter :: Icons -> Colors -> IconFormatter
@ -100,52 +114,47 @@ iconFormatter (iconConn, iconDisc) cs powered connected =

 --------------------------------------------------------------------------------
 -- Connection State
+--
+-- The signal handlers all run on separate threads, yet the icon depends on
+-- the state reflected by all these signals. The best (only?) way to do this is
+-- is to track the shared state of the bluetooth adaptor and its devices using
+-- an MVar.

-type BTIO = PluginIO BtState SysClient
+data BTDevice = BTDevice
+  { btDevConnected :: Maybe Bool
+  , btDevSigHandler :: SignalHandler
+  }
+
+type ConnectedDevices = M.Map ObjectPath BTDevice

 data BtState = BtState
-  { btDevices :: S.Set ObjectPath
+  { btDevices :: ConnectedDevices
  , btPowered :: Maybe Bool
  }

+type MutableBtState = MVar BtState
+
 emptyState :: BtState
 emptyState =
  BtState
-    { btDevices = S.empty
+    { btDevices = M.empty
    , btPowered = Nothing
    }

-readState :: BTIO (Maybe Bool, Bool)
-readState = do
-  p <- readPowered
-  c <- readDevices
-  return (p, not $ null c)
-
-modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
-modifyState f = do
-  m <- asks plugState
-  modifyMVar m f
-
-beforeDisplay :: BTIO () -> BTIO ()
-beforeDisplay f = f >> pluginDisplay
+readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
+readState state = do
+  p <- readPowered state
+  c <- readDevices state
+  return (p, anyDevicesConnected c)

 --------------------------------------------------------------------------------
 -- Object manager

-findAdaptor :: ObjectTree -> Maybe ObjectPath
-findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+findAdapter :: ObjectTree -> Maybe ObjectPath
+findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys

-- | Search the object tree for devices which are in a connected state.
-- Return the object path for said devices.
-findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
-findConnectedDevices adaptor =
-  filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
-  where
-    isConnectedDev m = Just True == lookupState m
-    lookupState =
-      fromVariant
-        <=< M.lookup (memberNameT devConnected)
-        <=< M.lookup devInterface
+findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
+findDevices adapter = filter (adaptorHasDevice adapter) . M.keys

 adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
 adaptorHasDevice adaptor device = case splitPathNoRoot device of
@ -155,120 +164,190 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
 splitPathNoRoot :: ObjectPath -> [FilePath]
 splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath

-getBtObjectTree
-  :: ( HasClient env
-     , SafeClient c
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => m ObjectTree
-getBtObjectTree = callGetManagedObjects btBus btOMPath
+getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
+getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath

 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"

+addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
+addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
+
+addDeviceAddedListener
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addDeviceAddedListener state dpy adapter client =
+  addBtOMListener addDevice client
+  where
+    addDevice = pathCallback adapter dpy $ \d ->
+      addAndInitDevice state dpy d client
+
+addDeviceRemovedListener
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addDeviceRemovedListener state dpy adapter sys =
+  addBtOMListener remDevice sys
+  where
+    remDevice = pathCallback adapter dpy $ \d -> do
+      old <- removeDevice state d
+      forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
+
+pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
+pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
+  when (adaptorHasDevice adapter d) $ f d >> dpy
+pathCallback _ _ _ _ = return ()
+
 --------------------------------------------------------------------------------
 -- Adapter

-- | Get powered state of adaptor and log the result
-initAdapterState :: ObjectPath -> BTIO ()
-initAdapterState adapter = do
-  reply <- callGetPowered adapter
-  putPowered $ fromSingletonVariant reply
+initAdapter
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+initAdapter state adapter client = do
+  reply <- callGetPowered adapter client
+  putPowered state $ fromSingletonVariant reply

 matchBTProperty
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => ObjectPath
+  :: (MonadUnliftIO m)
+  => SysClient
+  -> ObjectPath
  -> m (Maybe MatchRule)
-matchBTProperty p = matchPropertyFull btBus (Just p)
+matchBTProperty sys p = matchPropertyFull sys btBus (Just p)

-- | Start a listener that monitors changes to the powered state of an adaptor
-startAdaptorListener :: ObjectPath -> BTIO ()
-startAdaptorListener adaptor = do
-  res <- matchBTProperty adaptor
-  case res of
-    Just rule -> void $ addMatchCallback rule callback
-    Nothing -> do
-      logError $
-        "could not add listener for prop "
-          <> displayMemberName adaptorPowered
-          <> " on path "
-          <> displayObjectPath adaptor
+addAdaptorListener
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m (Maybe SignalHandler)
+addAdaptorListener state dpy adaptor sys = do
+  rule <- matchBTProperty sys adaptor
+  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
  where
-    callback sig =
-      withNestedDBusClientConnection Nothing Nothing $
-        withSignalMatch procMatch $
-          matchPropertyChanged adaptorInterface adaptorPowered sig
-    procMatch = beforeDisplay . putPowered
+    procMatch = withSignalMatch $ \b -> putPowered state b >> dpy

-callGetPowered
-  :: ( HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , SafeClient c
-     , MonadUnliftIO m
-     )
-  => ObjectPath
-  -> m [Variant]
+callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 callGetPowered adapter =
-  callPropertyGet btBus adapter adaptorInterface adaptorPowered
+  callPropertyGet btBus adapter adapterInterface $
+    memberName_ $
+      T.unpack adaptorPowered

-putPowered :: Maybe Bool -> BTIO ()
-putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
+matchPowered :: [Variant] -> SignalMatch Bool
+matchPowered = matchPropertyChanged adapterInterface adaptorPowered

-readPowered :: BTIO (Maybe Bool)
-readPowered = fmap btPowered $ readMVar =<< asks plugState
+putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
+putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})

-adaptorInterface :: InterfaceName
-adaptorInterface = interfaceName_ "org.bluez.Adapter1"
+readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
+readPowered = fmap btPowered . readMVar

-adaptorPowered :: MemberName
+adapterInterface :: InterfaceName
+adapterInterface = interfaceName_ "org.bluez.Adapter1"
+
+adaptorPowered :: T.Text
 adaptorPowered = "Powered"

 --------------------------------------------------------------------------------
 -- Devices

-initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
-initDevicesState adaptor ot = do
-  let devices = findConnectedDevices adaptor ot
-  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
+addAndInitDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addAndInitDevice state dpy device client = do
+  sh <- addDeviceListener state dpy device client
+  -- TODO add some intelligent error messages here
+  forM_ sh $ \s -> initDevice state s device client

-startConnectedListener :: ObjectPath -> BTIO ()
-startConnectedListener adaptor = do
-  reply <- matchPropertyFull btBus Nothing
-  case reply of
-    Just rule -> do
-      void $ addMatchCallbackSignal rule callback
-      logInfo $ "Started listening for device connections on " <> adaptor_
-    Nothing -> logError "Could not listen for connection changes"
+initDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> SignalHandler
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+initDevice state sh device sys = do
+  reply <- callGetConnected device sys
+  void $
+    insertDevice state device $
+      BTDevice
+        { btDevConnected = fromVariant =<< listToMaybe reply
+        , btDevSigHandler = sh
+        }
+
+addDeviceListener
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m (Maybe SignalHandler)
+addDeviceListener state dpy device sys = do
+  rule <- matchBTProperty sys device
+  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
  where
-    adaptor_ = displayWrapQuote $ displayObjectPath adaptor
-    callback sig =
-      withNestedDBusClientConnection Nothing Nothing $ do
-        let devpath = signalPath sig
-        when (adaptorHasDevice adaptor devpath) $
-          withSignalMatch (update devpath) $
-            matchConnected $
-              signalBody sig
-    matchConnected = matchPropertyChanged devInterface devConnected
-    update _ Nothing = return ()
-    update devpath (Just x) = do
-      let f = if x then S.insert else S.delete
-      beforeDisplay $
-        modifyState $
-          \s -> return (s {btDevices = f devpath $ btDevices s}, ())
+    procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy

-readDevices :: BTIO (S.Set ObjectPath)
-readDevices = fmap btDevices $ readMVar =<< asks plugState
+matchConnected :: [Variant] -> SignalMatch Bool
+matchConnected = matchPropertyChanged devInterface devConnected
+
+callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
+callGetConnected p =
+  callPropertyGet btBus p devInterface $
+    memberName_ (T.unpack devConnected)
+
+insertDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> BTDevice
+  -> m Bool
+insertDevice m device dev = modifyMVar m $ \s -> do
+  let new = M.insert device dev $ btDevices s
+  return (s {btDevices = new}, anyDevicesConnected new)
+
+updateDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> Maybe Bool
+  -> m Bool
+updateDevice m device status = modifyMVar m $ \s -> do
+  let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
+  return (s {btDevices = new}, anyDevicesConnected new)
+
+anyDevicesConnected :: ConnectedDevices -> Bool
+anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
+
+removeDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> m (Maybe BTDevice)
+removeDevice m device = modifyMVar m $ \s -> do
+  let devs = btDevices s
+  return (s {btDevices = M.delete device devs}, M.lookup device devs)
+
+readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
+readDevices = fmap btDevices . readMVar

 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"

-devConnected :: MemberName
+devConnected :: T.Text
 devConnected = "Connected"
--- a/lib/Xmobar/Plugins/ClevoKeyboard.hs
+++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Clevo Keyboard plugin
 --
@ -10,7 +12,6 @@ module Xmobar.Plugins.ClevoKeyboard
  )
 where

-import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import Xmobar
@ -24,9 +25,4 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
  alias (ClevoKeyboard _) = T.unpack ckAlias
  start (ClevoKeyboard icon) =
-    startBacklight
-      (Just "org.xmobar.clevo")
-      (Just "clevo_kbd.log")
-      matchSignalCK
-      callGetBrightnessCK
-      icon
+    startBacklight matchSignalCK callGetBrightnessCK icon
--- a/lib/Xmobar/Plugins/Common.hs
+++ b/lib/Xmobar/Plugins/Common.hs
@ -1,52 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Xmobar.Plugins.Common
  ( colorText
  , startListener
  , procSignalMatch
  , na
  , fromSingletonVariant
-  , withNestedDBusClientConnection
  , withDBusClientConnection
  , Callback
  , Colors (..)
  , displayMaybe
  , displayMaybe'
  , xmobarFGColor
-  , PluginEnv (..)
-  , PluginIO
-  , pluginDisplay
  )
 where

 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
 import XMonad.Hooks.DynamicLog (xmobarColor)

-data PluginEnv s c = PluginEnv
-  { plugClient :: !(NamedConnection c)
-  , plugState :: !(MVar s)
-  , plugDisplay :: !(Callback -> PluginIO s c ())
-  , plugCallback :: !Callback
-  , plugEnv :: !SimpleApp
-  }
-
-pluginDisplay :: PluginIO s c ()
-pluginDisplay = do
-  cb <- asks plugCallback
-  dpy <- asks plugDisplay
-  dpy cb
-
-type PluginIO s c = RIO (PluginEnv s c)
-
-instance HasClient (PluginEnv s) where
-  clientL = lens plugClient (\x y -> x {plugClient = y})
-
-instance HasLogFunc (PluginEnv s c) where
-  logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
-
 -- use string here since all the callbacks in xmobar use strings :(
 type Callback = String -> IO ()

@ -57,22 +32,18 @@ data Colors = Colors
  deriving (Eq, Show, Read)

 startListener
-  :: ( HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     , SafeClient c
-     , IsVariant a
-     )
+  :: (MonadUnliftIO m, SafeClient c, IsVariant a)
  => MatchRule
-  -> m [Variant]
+  -> (c -> m [Variant])
  -> ([Variant] -> SignalMatch a)
  -> (a -> m T.Text)
  -> Callback
+  -> c
  -> m ()
-startListener rule getProp fromSignal toColor cb = do
-  reply <- getProp
+startListener rule getProp fromSignal toColor cb client = do
+  reply <- getProp client
  displayMaybe cb toColor $ fromSingletonVariant reply
-  void $ addMatchCallback rule (procMatch . fromSignal)
+  void $ addMatchCallback rule (procMatch . fromSignal) client
  where
    procMatch = procSignalMatch cb toColor

@ -99,42 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
  :: (MonadUnliftIO m, SafeClient c)
  => Callback
-  -> Maybe BusName
-  -> Maybe FilePath
-  -> (NamedConnection c -> RIO SimpleApp ())
+  -> (c -> RIO SimpleApp ())
  -> m ()
-withDBusClientConnection cb n logfile f =
-  maybe (run stderr) (`withLogFile` run) logfile
-  where
-    run h = do
-      logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
-      withLogFunc logOpts $ \lf -> do
-        env <- mkSimpleApp lf Nothing
-        runRIO env $ displayMaybe' cb f =<< getDBusClient n
-
-- | Run a plugin action with a new DBus client and logfile path. This is
-- necessary for DBus callbacks which run in separate threads, which will
-- usually fire when the parent thread already exited and killed off its DBus
-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
-- this function will open and new logfile and client connection and close both
-- on completion. 'withDBusClientConnection' will only close the log file but
-- keep the client connection active upon termination; this client will only be
-- killed when the entire process is killed. This distinction is important
-- because callbacks only need ephemeral connections, while listeners (started
-- with 'withDBusClientConnection') need long-lasting connections.
-withNestedDBusClientConnection
-  :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
-  => Maybe BusName
-  -> Maybe FilePath
-  -> PluginIO s c ()
-  -> m ()
-withNestedDBusClientConnection n logfile f = do
-  dpy <- asks plugDisplay
-  s <- asks plugState
-  cb <- asks plugCallback
-  let run h = do
-        logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
-        withLogFunc logOpts $ \lf -> do
-          env <- mkSimpleApp lf Nothing
-          runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
-  maybe (run stderr) (`withLogFile` run) logfile
+withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient
--- a/lib/Xmobar/Plugins/Device.hs
+++ b/lib/Xmobar/Plugins/Device.hs
@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+--------------------------------------------------------------------------------
+-- Device plugin
+--
+-- Display different text depending on whether or not the interface has
+-- connectivity
+
+module Xmobar.Plugins.Device
+  ( Device (..)
+  , devDep
+  )
+where
+
+import DBus
+import Data.Internal.DBus
+import Data.Internal.Dependency
+import RIO
+import qualified RIO.Text as T
+import XMonad.Internal.Command.Desktop
+import XMonad.Internal.DBus.Common
+import Xmobar
+import Xmobar.Plugins.Common
+
+newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
+
+nmPath :: ObjectPath
+nmPath = objectPath_ "/org/freedesktop/NetworkManager"
+
+nmInterface :: InterfaceName
+nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
+
+nmDeviceInterface :: InterfaceName
+nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
+
+getByIP :: MemberName
+getByIP = memberName_ "GetDeviceByIpIface"
+
+devSignal :: T.Text
+devSignal = "Ip4Connectivity"
+
+devDep :: DBusDependency_ SysClient
+devDep =
+  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
+    Method_ getByIP
+
+getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
+getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
+  where
+    mc =
+      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
+        { methodCallBody = [toVariant iface]
+        }
+
+getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
+getDeviceConnected path =
+  callPropertyGet networkManagerBus path nmDeviceInterface $
+    memberName_ $
+      T.unpack devSignal
+
+matchStatus :: [Variant] -> SignalMatch Word32
+matchStatus = matchPropertyChanged nmDeviceInterface devSignal
+
+instance Exec Device where
+  alias (Device (iface, _, _)) = T.unpack iface
+  start (Device (iface, text, colors)) cb = do
+    withDBusClientConnection cb $ \sys -> do
+      path <- getDevice sys iface
+      displayMaybe' cb (listener sys) path
+    where
+      listener sys path = do
+        rule <- matchPropertyFull sys networkManagerBus (Just path)
+        -- TODO warn the user here rather than silently drop the listener
+        forM_ rule $ \r ->
+          startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
+      chooseColor' = return . (\s -> colorText colors s text) . (> 1)
--- a/lib/Xmobar/Plugins/IntelBacklight.hs
+++ b/lib/Xmobar/Plugins/IntelBacklight.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Intel backlight plugin
 --
@ -10,7 +12,6 @@ module Xmobar.Plugins.IntelBacklight
  )
 where

-import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import Xmobar
@ -24,9 +25,4 @@ blAlias = "intelbacklight"
 instance Exec IntelBacklight where
  alias (IntelBacklight _) = T.unpack blAlias
  start (IntelBacklight icon) =
-    startBacklight
-      (Just "org.xmobar.intelbacklight")
-      (Just "intel_backlight.log")
-      matchSignalIB
-      callGetBrightnessIB
-      icon
+    startBacklight matchSignalIB callGetBrightnessIB icon
--- a/lib/Xmobar/Plugins/Screensaver.hs
+++ b/lib/Xmobar/Plugins/Screensaver.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Screensaver plugin
 --
@ -10,8 +12,6 @@ module Xmobar.Plugins.Screensaver
  )
 where

-import Data.Internal.DBus
-import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Screensaver
 import Xmobar
@ -24,13 +24,9 @@ ssAlias = "screensaver"

 instance Exec Screensaver where
  alias (Screensaver _) = T.unpack ssAlias
-  start (Screensaver (text, colors)) cb =
-    withDBusClientConnection
-      cb
-      (Just "org.xmobar.screensaver")
-      (Just "screensaver.log")
-      $ \cl -> withDIO cl $ do
-        matchSignal dpy
-        dpy =<< callQuery
+  start (Screensaver (text, colors)) cb = do
+    withDBusClientConnection cb $ \sys -> do
+      matchSignal display sys
+      display =<< callQuery sys
    where
-      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
+      display = displayMaybe cb $ return . (\s -> colorText colors s text)
--- a/lib/Xmobar/Plugins/VPN.hs
+++ b/lib/Xmobar/Plugins/VPN.hs
@ -0,0 +1,133 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+--------------------------------------------------------------------------------
+-- VPN plugin
+--
+-- Use the networkmanager to detect when a VPN interface is added or removed.
+-- Specifically, monitor the object tree to detect paths with the interface
+-- "org.freedesktop.NetworkManager.Device.Tun".
+
+module Xmobar.Plugins.VPN
+  ( VPN (..)
+  , vpnAlias
+  , vpnDep
+  )
+where
+
+import DBus
+import Data.Internal.DBus
+import Data.Internal.Dependency
+import RIO
+import qualified RIO.Map as M
+import qualified RIO.Set as S
+import qualified RIO.Text as T
+import XMonad.Internal.Command.Desktop
+import XMonad.Internal.DBus.Common
+import Xmobar
+import Xmobar.Plugins.Common
+
+newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
+
+instance Exec VPN where
+  alias (VPN _) = T.unpack vpnAlias
+  start (VPN (text, colors)) cb =
+    withDBusClientConnection cb $ \c -> do
+      state <- initState c
+      let dpy = displayMaybe cb iconFormatter . Just =<< readState state
+      let signalCallback' f = f state dpy
+      vpnAddedListener (signalCallback' addedCallback) c
+      vpnRemovedListener (signalCallback' removedCallback) c
+      dpy
+    where
+      iconFormatter b = return $ colorText colors b text
+
+--------------------------------------------------------------------------------
+-- VPN State
+--
+-- Maintain a set of paths which are the currently active VPNs. Most of the time
+-- this will be a null or singleton set, but this setup could handle the edge
+-- case of multiple VPNs being active at once without puking.
+
+type VPNState = S.Set ObjectPath
+
+type MutableVPNState = MVar VPNState
+
+initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
+initState client = do
+  ot <- getVPNObjectTree client
+  newMVar $ findTunnels ot
+
+readState :: MonadUnliftIO m => MutableVPNState -> m Bool
+readState = fmap (not . null) . readMVar
+
+updateState
+  :: MonadUnliftIO m
+  => (ObjectPath -> VPNState -> VPNState)
+  -> MutableVPNState
+  -> ObjectPath
+  -> m ()
+updateState f state op = modifyMVar_ state $ return . f op
+
+--------------------------------------------------------------------------------
+-- Tunnel Device Detection
+
+getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
+getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
+
+findTunnels :: ObjectTree -> VPNState
+findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
+
+vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
+vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
+
+vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
+vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
+
+addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+addedCallback state dpy [device, added] = update >> dpy
+  where
+    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
+    is = M.keys $ fromMaybe M.empty added'
+    update = updateDevice S.insert state device is
+addedCallback _ _ _ = return ()
+
+removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+removedCallback state dpy [device, interfaces] = update >> dpy
+  where
+    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
+    update = updateDevice S.delete state device is
+removedCallback _ _ _ = return ()
+
+updateDevice
+  :: MonadUnliftIO m
+  => (ObjectPath -> VPNState -> VPNState)
+  -> MutableVPNState
+  -> Variant
+  -> [T.Text]
+  -> m ()
+updateDevice f state device interfaces =
+  when (vpnDeviceTun `elem` interfaces) $
+    forM_ d $
+      updateState f state
+  where
+    d = fromVariant device :: Maybe ObjectPath
+
+--------------------------------------------------------------------------------
+-- DBus Interface
+
+vpnBus :: BusName
+vpnBus = busName_ "org.freedesktop.NetworkManager"
+
+vpnPath :: ObjectPath
+vpnPath = objectPath_ "/org/freedesktop"
+
+vpnDeviceTun :: T.Text
+vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
+
+vpnAlias :: T.Text
+vpnAlias = "vpn"
+
+vpnDep :: DBusDependency_ SysClient
+vpnDep =
+  Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
+    Method_ getManagedObjects
--- a/package.yaml
+++ b/package.yaml
@ -9,47 +9,9 @@ extra-source-files:
 - README.md
 - fourmolu.yaml
 - make_pkgs
- runtime_pkgs
- assets/icons/*
- assets/sound/*
+- icons/*
 - scripts/*
-
-default-extensions:
-  - OverloadedStrings
-  - FlexibleContexts
-  - FlexibleInstances
-  - InstanceSigs
-  - MultiParamTypeClasses
-  - EmptyCase
-  - LambdaCase
-  - MultiWayIf
-  - NamedFieldPuns
-  - TupleSections
-  - DeriveFoldable
-  - DeriveFunctor
-  - DeriveGeneric
-  - DeriveLift
-  - DeriveTraversable
-  - DerivingStrategies
-  - DeriveDataTypeable
-  - EmptyDataDecls
-  - PartialTypeSignatures
-  - GeneralizedNewtypeDeriving
-  - StandaloneDeriving
-  - BangPatterns
-  - TypeOperators
-  - ScopedTypeVariables
-  - TypeApplications
-  - ConstraintKinds
-  - RankNTypes
-  - GADTs
-  - DefaultSignatures
-  - NoImplicitPrelude
-  - FunctionalDependencies
-  - DataKinds
-  - TypeFamilies
-  - BinaryLiterals
-  - ViewPatterns
+- sound/*

 dependencies:
  - rio >= 0.1.21.0
@ -73,21 +35,14 @@ dependencies:
  - typed-process >= 0.2.8.0
  - network >= 3.1.2.7
  - unliftio >= 0.2.21.0
-  - optparse-applicative >= 0.16.1.0
-
-ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2

 library:
  source-dirs: lib/
+  ghc-options:
+    - -Wall
+    - -Werror
+    - -Wpartial-fields
+    - -O2

 executables:
  xmobar: &bin
@ -97,15 +52,21 @@ executables:
     - xmonad-config
    ghc-options:
      - -threaded
+      - -Wall
+      - -Werror
+      - -Wpartial-fields
+      - -O2
  xmonad: 
    <<: *bin
    main:                xmonad.hs
    ghc-options:
      - -threaded
+      - -Wall
+      - -Werror
+      - -Wpartial-fields
+      - -O2
      # this is needed to avoid writing super complex layout types
      - -fno-warn-missing-signatures
  vbox-start:
    <<: *bin
    main:                vbox-start.hs
-    ghc-options:
-      - -threaded
--- a/scripts/runtime_pkgs
+++ b/scripts/runtime_pkgs
--- a/scripts/screencap
+++ b/scripts/screencap
@ -1,22 +0,0 @@
-#! /bin/bash
-
-## capture a screenshot using scrot
-
-SS_DIR="$XDG_CACHE_HOME/screenshots"
-
-while getopts ":sw" opt; do
-	case ${opt} in
-		s)
-			scrot "$SS_DIR/desktop/%Y-%m-%d-%H:%M:%S_desktop.png"
-			notify-send "Screen captured"
-			;;
-		w)
-			scrot -u "$SS_DIR/window/%Y-%m-%d-%H:%M:%S-\$wx\$h.png"
-			notify-send "Window captured"
-			;;
-		\?)
-			echo "invalid option, read the code"
-			;;
-	esac
-done
-
--- a/scripts/screenlock
+++ b/scripts/screenlock
@ -1,61 +0,0 @@
-#! /bin/bash
-
-## lock the screen using i3lock (and maybe suspend)
-
-## usage: screenlock [SUSPEND]
-
-# WORKAROUND make the date show up in the right place on 2+ monitor setups
-# I want it to only show up on the primary screen, so use xrandr to get the
-# dimensions and position of the primary monitor and calculate the date position
-# from that
-geometry=$(xrandr | sed -n 's/^.*primary \([0-9]*\)x[0-9]*+\([0-9]\)*+[0-9]* .*/\1 \2/p')
-width=$(echo "$geometry" | cut -f1 -d" ")
-xpos=$(echo "$geometry" | cut -f2 -d" ")
-xoffset=$(("$xpos" + "$width" / 2))
-datepos="$xoffset:600"
-
-# lock and fork so we can suspend with the screen locked
-i3lock --color=000000 \
-       --pass-media-keys \
-       --nofork \
-       --ignore-empty-password \
-       --screen=0 \
-       --indicator \
-       --inside-color=00000055 \
-       --insidever-color=00000055 \
-       --insidewrong-color=00000055 \
-       --ring-color=555555ff \
-       --ringwrong-color=ff3333ff \
-       --ringver-color=99ceffff \
-       --keyhl-color=99ceffff \
-       --bshl-color=9523ffff \
-       --line-color=00000000 \
-       --separator-color=00000000 \
-       --clock \
-       --verif-color=99ceffff \
-       --wrong-color=ff8282ff \
-       --time-color=ffffffff \
-       --time-size=72 \
-       --time-str="%H:%M" \
-       --date-color=ffffffff \
-       --date-size=42 \
-       --date-str="%b %d, %Y" \
-       --date-align 0 \
-       --date-pos="$datepos" \
-       --wrong-size=72 \
-       --verif-size=72 \
-       --radius=300 \
-       --ring-width=25 &
-
-# suspend if we want, and if this machine is currently using a battery
-batpath=/sys/class/power_supply/BAT0/status
-
-if [ -f "$batpath" ] && \
-       [ "$(cat $batpath)" == "Discharging" ] && \
-       [ "$1" == "true" ]; then
-    systemctl suspend
-fi
-
-# block until the screen is unlocked (since xss-lock expects the locker to exit
-# only when unlocked)
-wait
--- a/assets/sound/smb_fireball.wav
+++ b/assets/sound/smb_fireball.wav
--- a/assets/sound/smb_pipe.wav
+++ b/assets/sound/smb_pipe.wav
--- a/assets/sound/smb_powerup.wav
+++ b/assets/sound/smb_powerup.wav
--- a/stack.yaml
+++ b/stack.yaml
@ -17,8 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-19.33
-#resolver: nightly-2022-03-03
+#resolver: lts-17.4
+resolver: nightly-2022-03-03

 # User packages to be built.
 # Various formats can be used as shown in the example below.