Merge branch 'fix_rio_run'

2023-01-04 13:55:31 -05:00 · 2023-01-04 13:55:31 -05:00 · 3cc7e02416
parent af5877a402 24f0f034f0
commit 3cc7e02416
35 changed files with 3881 additions and 3051 deletions
--- a/.stylish-haskell.yaml
+++ b/.stylish-haskell.yaml
@ -1,357 +0,0 @@
 # stylish-haskell configuration file
 # ==================================
 # The stylish-haskell tool is mainly configured by specifying steps. These steps
 # are a list, so they have an order, and one specific step may appear more than
 # once (if needed). Each file is processed by these steps in the given order.
 steps:
  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
  # by default.
  # - unicode_syntax:
  #     # In order to make this work, we also need to insert the UnicodeSyntax
  #     # language pragma. If this flag is set to true, we insert it when it's
  #     # not already present. You may want to disable it if you configure
  #     # language extensions using some other method than pragmas. Default:
  #     # true.
  #     add_language_pragma: true
  # Format module header
  #
  # Currently, this option is not configurable and will format all exports and
  # module declarations to minimize diffs
  #
  # - module_header:
  #     # How many spaces use for indentation in the module header.
  #     indent: 4
  #
  #     # Should export lists be sorted?  Sorting is only performed within the
  #     # export section, as delineated by Haddock comments.
  #     sort: true
  #
  #     # See `separate_lists` for the `imports` step.
  #     separate_lists: true
  # Format record definitions. This is disabled by default.
  #
  # You can control the layout of record fields. The only rules that can't be configured
  # are these:
  #
  # - "|" is always aligned with "="
  # - "," in fields is always aligned with "{"
  # - "}" is likewise always aligned with "{"
  #
  # - records:
  #     # How to format equals sign between type constructor and data constructor.
  #     # Possible values:
  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
  #     equals: "indent 2"
  #
  #     # How to format first field of each record constructor.
  #     # Possible values:
  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
  #     first_field: "indent 2"
  #
  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
  #     field_comment: 2
  #
  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
  #     deriving: 2
  #
  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
  #     # Possible values:
  #     # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
  #     # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
  #     via: "indent 2"
  #
  #     # Sort typeclass names in the "deriving" list alphabetically.
  #     sort_deriving: true
  #
  #     # Wheter or not to break enums onto several lines
  #     #
  #     # Default: false
  #     break_enums: false
  #
  #     # Whether or not to break single constructor data types before `=` sign
  #     #
  #     # Default: true
  #     break_single_constructors: true
  #
  #     # Whether or not to curry constraints on function.
  #     #
  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
  #     #
  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
  #     #
  #     # Default: false
  #     curried_context: false
  # Align the right hand side of some elements.  This is quite conservative
  # and only applies to statements where each element occupies a single
  # line.
  # Possible values:
  # - always - Always align statements.
  # - adjacent - Align statements that are on adjacent lines in groups.
  # - never - Never align statements.
  # All default to always.
  - simple_align:
      cases: always
      top_level_patterns: always
      records: always
      multi_way_if: always
  # Import cleanup
  - imports:
      # There are different ways we can align names and lists.
      #
      # - global: Align the import names and import list throughout the entire
      #   file.
      #
      # - file: Like global, but don't add padding when there are no qualified
      #   imports in the file.
      #
      # - group: Only align the imports per group (a group is formed by adjacent
      #   import lines).
      #
      # - none: Do not perform any alignment.
      #
      # Default: global.
      align: global
      # The following options affect only import list alignment.
      #
      # List align has following options:
      #
      # - after_alias: Import list is aligned with end of import including
      #   'as' and 'hiding' keywords.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                          init, last, length)
      #
      # - with_alias: Import list is aligned with start of alias or hiding.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                 init, last, length)
      #
      # - with_module_name: Import list is aligned `list_padding` spaces after
      #   the module name.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #                          init, last, length)
      #
      #   This is mainly intended for use with `pad_module_names: false`.
      #
      #   > import qualified Data.List as List (concat, foldl, foldr, head,
      #                          init, last, length, scanl, scanr, take, drop,
      #                          sort, nub)
      #
      # - new_line: Import list starts always on new line.
      #
      #   > import qualified Data.List      as List
      #   >     (concat, foldl, foldr, head, init, last, length)
      #
      # - repeat: Repeat the module name to align the import list.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head)
      #   > import qualified Data.List      as List (init, last, length)
      #
      # Default: after_alias
      list_align: after_alias
      # Right-pad the module names to align imports in a group:
      #
      # - true: a little more readable
      #
      #   > import qualified Data.List       as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #
      # - false: diff-safe
      #
      #   > import qualified Data.List as List (concat, foldl, foldr, init,
      #   >                                     last, length)
      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
      #   >                                           init, last, length)
      #
      # Default: true
      pad_module_names: true
      # Long list align style takes effect when import is too long. This is
      # determined by 'columns' setting.
      #
      # - inline: This option will put as much specs on same line as possible.
      #
      # - new_line: Import list will start on new line.
      #
      # - new_line_multiline: Import list will start on new line when it's
      #   short enough to fit to single line. Otherwise it'll be multiline.
      #
      # - multiline: One line per import list entry.
      #   Type with constructor list acts like single import.
      #
      #   > import qualified Data.Map as M
      #   >     ( empty
      #   >     , singleton
      #   >     , ...
      #   >     , delete
      #   >     )
      #
      # Default: inline
      long_list_align: multiline
      # Align empty list (importing instances)
      #
      # Empty list align has following options
      #
      # - inherit: inherit list_align setting
      #
      # - right_after: () is right after the module name:
      #
      #   > import Vector.Instances ()
      #
      # Default: inherit
      empty_list_align: inherit
      # List padding determines indentation of import list on lines after import.
      # This option affects 'long_list_align'.
      #
      # - <integer>: constant value
      #
      # - module_name: align under start of module name.
      #   Useful for 'file' and 'group' align settings.
      #
      # Default: 4
      list_padding: 4
      # Separate lists option affects formatting of import list for type
      # or class. The only difference is single space between type and list
      # of constructors, selectors and class functions.
      #
      # - true: There is single space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
      #
      # - false: There is no space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
      #
      # Default: true
      separate_lists: true
      # Space surround option affects formatting of import lists on a single
      # line. The only difference is single space after the initial
      # parenthesis and a single space before the terminal parenthesis.
      #
      # - true: There is single space associated with the enclosing
      #   parenthesis.
      #
      #   > import Data.Foo ( foo )
      #
      # - false: There is no space associated with the enclosing parenthesis
      #
      #   > import Data.Foo (foo)
      #
      # Default: false
      space_surround: false
      # Enabling this argument will use the new GHC lib parse to format imports.
      #
      # This currently assumes a few things, it will assume that you want post
      # qualified imports. It is also not as feature complete as the old
      # imports formatting.
      #
      # It does not remove redundant lines or merge lines. As such, the full
      # feature scope is still pending.
      #
      # It _is_ however, a fine alternative if you are using features that are
      # not parseable by haskell src extensions and you're comfortable with the
      # presets.
      #
      # Default: false
      ghc_lib_parser: false
  # Language pragmas
  - language_pragmas:
      # We can generate different styles of language pragma lists.
      #
      # - vertical: Vertical-spaced language pragmas, one per line.
      #
      # - compact: A more compact style.
      #
      # - compact_line: Similar to compact, but wrap each line with
      #   `{-#LANGUAGE #-}'.
      #
      # Default: vertical.
      style: vertical
      # Align affects alignment of closing pragma brackets.
      #
      # - true: Brackets are aligned in same column.
      #
      # - false: Brackets are not aligned together. There is only one space
      #   between actual import and closing bracket.
      #
      # Default: true
      align: true
      # stylish-haskell can detect redundancy of some language pragmas. If this
      # is set to true, it will remove those redundant pragmas. Default: true.
      remove_redundant: true
      # Language prefix to be used for pragma declaration, this allows you to
      # use other options non case-sensitive like "language" or "Language".
      # If a non correct String is provided, it will default to: LANGUAGE.
      language_prefix: LANGUAGE
  # Replace tabs by spaces. This is disabled by default.
  # - tabs:
  #     # Number of spaces to use for each tab. Default: 8, as specified by the
  #     # Haskell report.
  #     spaces: 8
  # Remove trailing whitespace
  - trailing_whitespace: {}
  # Squash multiple spaces between the left and right hand sides of some
  # elements into single spaces. Basically, this undoes the effect of
  # simple_align but is a bit less conservative.
  # - squash: {}
 # A common setting is the number of columns (parts of) code will be wrapped
 # to. Different steps take this into account.
 #
 # Set this to null to disable all line wrapping.
 #
 # Default: 80.
 columns: 80
 # By default, line endings are converted according to the OS. You can override
 # preferred format here.
 #
 # - native: Native newline format. CRLF on Windows, LF on other OSes.
 #
 # - lf: Convert to LF ("\n").
 #
 # - crlf: Convert to CRLF ("\r\n").
 #
 # Default: native.
 newline: native
 # Sometimes, language extensions are specified in a cabal file or from the
 # command line instead of using language pragmas in the file. stylish-haskell
 # needs to be aware of these, so it can parse the file correctly.
 #
 # No language extensions are enabled by default.
 # language_extensions:
  # - TemplateHaskell
  # - QuasiQuotes
 # Attempt to find the cabal file in ancestors of the current directory, and
 # parse options (currently only language extensions) from that.
 #
 # Default: true
 cabal: true
--- a/bin/vbox-start.hs
+++ b/bin/vbox-start.hs
@ -1,7 +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
@ -15,21 +14,17 @@
 -- until its PID exits. By monitoring this wrapper, the dynamic workspace only
 -- has one process to track and will maintain the workspace throughout the
 -- lifetime of the VM.
 module Main (main) where
 import qualified Data.ByteString.Lazy.UTF8 as BU
 import RIO
 import RIO.Process
 import qualified RIO.Text as T
-
+import System.Process (Pid)
 import Text.XML.Light
-
+import UnliftIO.Environment
 import           System.Environment
 import XMonad.Internal.Concurrent.VirtualBox
-import           XMonad.Internal.Process               (waitUntilExit)
+import XMonad.Internal.IO
 main :: IO ()
 main = do
@ -46,20 +41,21 @@ runAndWait [n] = do
    runID i = do
      vmLaunch i
      p <- vmPID i
-      liftIO $ waitUntilExit p
+      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
  rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
  case rc of
    ExitSuccess -> return ()
-    _           -> logError $ "Failed to start VM: "
+    _ ->
      logError $
        "Failed to start VM: "
          <> displayBytesUtf8 (encodeUtf8 i)
-vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
+vmPID :: T.Text -> RIO SimpleApp (Maybe Pid)
 vmPID vid = do
  (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
  return $ case rc of
@ -73,7 +69,8 @@ vmMachineID iPath = do
    Right contents -> return $ findMachineID contents
    Left e -> logError (displayShow e) >> return Nothing
  where
-    findMachineID c = T.stripSuffix "}"
+    findMachineID c =
      T.stripSuffix "}"
        =<< T.stripPrefix "{"
        =<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
        =<< (\e -> findChild (qual e "Machine") e)
--- a/bin/xmobar.hs
+++ b/bin/xmobar.hs
@ -1,8 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 --------------------------------------------------------------------------------
 -- | Xmobar binary
 --
 -- Features:
@ -12,29 +9,16 @@ module Main (main) where
 -- * Some custom plugins (imported below)
 -- * Theme integration with xmonad (shared module imported below)
 -- * A custom Locks plugin from my own forked repo
-
+module Main (main) where
 import           Control.Monad
 import Data.Internal.DBus
-import           Data.Internal.Dependency
+import Data.Internal.XIO
-import           Data.List
+import Options.Applicative
 import           Data.Maybe
 import RIO hiding (hFlush)
 import qualified RIO.ByteString.Lazy as BL
 import RIO.List
 import RIO.Process
 import qualified RIO.Text as T
 import           System.Environment
 import           System.IO
 import           System.IO.Error
 import           Xmobar.Plugins.Bluetooth
 import           Xmobar.Plugins.ClevoKeyboard
 import           Xmobar.Plugins.Device
 import           Xmobar.Plugins.IntelBacklight
 import           Xmobar.Plugins.Screensaver
 import           Xmobar.Plugins.VPN
 import           System.Posix.Signals
 import XMonad.Core hiding (config)
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.Command.Power
@ -42,37 +26,64 @@ import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Control
 import XMonad.Internal.DBus.Screensaver (ssSignalDep)
 import           XMonad.Internal.Process                        hiding (CmdSpec)
 import qualified XMonad.Internal.Theme as XT
 import Xmobar hiding
  ( iconOffset
  , run
  )
 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 = getArgs >>= parse
+main = parse >>= xio
-parse :: [String] -> IO ()
+parse :: IO XOpts
-parse []         = run
+parse = execParser opts
-parse ["--deps"] = withCache printDeps
+  where
-parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
+    parseOpts = parseDeps <|> parseTest <|> pure XRun
-parse _          = usage
+    opts =
      info (parseOpts <**> helper) $
        fullDesc <> header "xmobar: the best taskbar ever"
-run :: IO ()
+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 -> hRunXIO False stderr $ withDBus_ evalConfig
  XRun -> runXIO "xmobar.log" run
 run :: XIO ()
 run = do
-  db <- connectDBus
+  -- IDK why this is needed, I thought this was default
-  c <- withCache $ evalConfig db
+  liftIO $ hSetBuffering stdout LineBuffering
-  disconnectDBus db
+  -- this isn't totally necessary except for the fact that killing xmobar
-  -- this is needed to prevent waitForProcess error when forking in plugins (eg
+  -- will make it print something about catching SIGTERM, and without
-  -- alsacmd)
+  -- linebuffering it usually only prints the first few characters (even then
-  _ <- installHandler sigCHLD Default Nothing
+  -- it only prints 10-20% of the time)
-  -- this is needed to see any printed messages
+  liftIO $ hSetBuffering stderr LineBuffering
-  hFlush stdout
+  withDBus_ $ \db -> do
-  xmobar c
+    c <- evalConfig db
    liftIO $ xmobar c
-evalConfig :: DBusState -> FIO Config
+evalConfig :: DBusState -> XIO Config
 evalConfig db = do
  cs <- getAllCommands <$> rightPlugins db
  bf <- getTextFont
@ -80,21 +91,17 @@ evalConfig db = do
  d <- io $ cfgDir <$> getDirectories
  return $ config bf ifs ios cs d
-printDeps :: FIO ()
+printDeps :: XIO ()
-printDeps = do
+printDeps = withDBus_ $ \db ->
-  db <- io connectDBus
+  mapM_ logInfo $
-  let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
+    fmap showFulfillment $
-  io $ mapM_ (putStrLn . T.unpack) ps
+      sort $
-  io $ disconnectDBus db
+        nub $
-
+          concatMap dumpFeature $
-usage :: IO ()
+            allFeatures db
 usage = putStrLn $ intercalate "\n"
  [ "xmobar: run greatest taskbar"
  , "xmobar --deps: print dependencies"
  ]
 --------------------------------------------------------------------------------
-- | toplevel configuration
+-- toplevel configuration
 -- | The text font family
 textFont :: Always XT.FontBuilder
@ -110,7 +117,10 @@ textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
 -- | The icon font family
 iconFont :: Sometimes XT.FontBuilder
-iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
+iconFont =
  fontSometimes
    "XMobar Icon Font"
    "Symbols Nerd Font"
    [Package Official "ttf-nerd-fonts-symbols-2048-em"]
 -- | Offsets for the icons in the bar (relative to the text offset)
@ -136,7 +146,8 @@ iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
 -- only one) text font, and all other fonts are icon fonts. If this assumption
 -- changes the code will need to change significantly
 config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
-config bf ifs ios br confDir = defaultConfig
+config bf ifs ios br confDir =
  defaultConfig
    { font = T.unpack bf
    , additionalFonts = fmap T.unpack ifs
    , textOffset = textFontOffset
@ -146,32 +157,31 @@ config bf ifs ios br confDir = defaultConfig
    , position = BottomSize C 100 24
    , border = NoBorder
    , borderColor = T.unpack XT.bordersColor
    , sepChar = T.unpack pSep
    , alignSep = [lSep, rSep]
    , template = T.unpack $ fmtRegions br
    , lowerOnStart = False
    , hideOnStart = False
    , allDesktops = True
    , overrideRedirect = True
    , pickBroadest = False
    , persistent = True
-  -- store the icons with the xmonad/xmobar stack project
+    , -- store the icons with the xmonad/xmobar stack project
-  , iconRoot = confDir ++ "/icons"
+      iconRoot = confDir ++ "/icons"
    , commands = csRunnable <$> concatRegions br
    }
 --------------------------------------------------------------------------------
-- | plugin features
+--  plugin features
 --
 -- some commands depend on the presence of interfaces that can only be
 -- determined at runtime; define these checks here
 getAllCommands :: [Maybe CmdSpec] -> BarRegions
-getAllCommands right = BarRegions
+getAllCommands right =
-  { brLeft = [ CmdSpec
+  BarRegions
    { brLeft =
        [ CmdSpec
            { csAlias = "UnsafeStdinReader"
            , csRunnable = Run UnsafeStdinReader
            }
@ -180,8 +190,10 @@ getAllCommands right = BarRegions
    , brRight = catMaybes right
    }
-rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
+rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
-rightPlugins db = mapM evalFeature $ allFeatures db
+rightPlugins db =
  mapM evalFeature $
    allFeatures db
      ++ [always' "date indicator" dateCmd]
  where
    always' n = Right . Always n . Always_ . FallbackAlone
@ -204,7 +216,10 @@ type BarFeature = Sometimes CmdSpec
 -- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
-getWireless = Sometimes "wireless status indicator" xpfWireless
+getWireless =
  Sometimes
    "wireless status indicator"
    xpfWireless
    [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 getEthernet :: Maybe SysClient -> BarFeature
@ -217,32 +232,49 @@ getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
  where
    root useIcon = IORoot_ (batteryCmd useIcon)
-    tree = Only_ $ IOTest_ "Test if battery is present" []
+    tree =
-      $ fmap (Msg LevelError) <$> hasBattery
+      Only_ $
        IOTest_ "Test if battery is present" [] $
          io $
            fmap (Msg LevelError) <$> hasBattery
 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"
+    test =
-      networkManagerPkgs vpnPresent
+      DBusIO $
        IOTest_
          "Use nmcli to test if VPN is present"
          networkManagerPkgs
          vpnPresent
 getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 getAlsa :: BarFeature
-getAlsa = iconIO_ "volume level indicator" (const True) root
+getAlsa =
-  $ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
+  iconIO_ "volume level indicator" (const True) root $
    Only_ $
      sysExe [Package Official "alsa-utils"] "alsactl"
  where
    root useIcon = IORoot_ (alsaCmd useIcon)
 getBl :: Maybe SesClient -> BarFeature
-getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
+getBl =
-  intelBacklightSignalDep blCmd
+  xmobarDBus
    "Intel backlight indicator"
    xpfIntelBacklight
    intelBacklightSignalDep
    blCmd
 getCk :: Maybe SesClient -> BarFeature
-getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
+getCk =
-  clevoKeyboardSignalDep ckCmd
+  xmobarDBus
    "Clevo keyboard indicator"
    xpfClevoBacklight
    clevoKeyboardSignalDep
    ckCmd
 getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
@ -253,29 +285,58 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
    root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
 --------------------------------------------------------------------------------
-- | bar feature constructors
+-- bar feature constructors
-xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
+xmobarDBus
-  -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
+  :: SafeClient c
  => T.Text
  -> XPQuery
  -> DBusDependency_ c
  -> (Fontifier -> CmdSpec)
  -> Maybe c
  -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
  where
    root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
-iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
+iconIO_
-  -> IOTree_ -> BarFeature
+  :: T.Text
  -> XPQuery
  -> (Fontifier -> IOTree_ -> Root CmdSpec)
  -> IOTree_
  -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
-iconDBus :: SafeClient c => T.Text -> XPQuery
+iconDBus
-  -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
+  :: SafeClient c
  => T.Text
  -> XPQuery
  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
  -> DBusTree c p
  -> BarFeature
 iconDBus = iconSometimes' And1 $ Only_ . DBusIO
-iconDBus_ :: SafeClient c => T.Text -> XPQuery
+iconDBus_
-  -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
+  :: SafeClient c
  => T.Text
  -> XPQuery
  -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
  -> DBusTree_ c
  -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
-iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
+iconSometimes'
-  -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
+  :: (t -> t_ -> t)
-iconSometimes' c d n q r t = Sometimes n q
+  -> (IODependency_ -> t_)
  -> T.Text
  -> XPQuery
  -> (Fontifier -> t -> Root CmdSpec)
  -> t
  -> BarFeature
 iconSometimes' c d n q r t =
  Sometimes
    n
    q
    [ Subfeature icon "icon indicator"
    , Subfeature text "text indicator"
    ]
@ -284,125 +345,170 @@ iconSometimes' c d n q r t = Sometimes n q
    text = r fontifyAlt t
 --------------------------------------------------------------------------------
-- | command specifications
+-- command specifications
 data BarRegions = BarRegions
  { brLeft :: [CmdSpec]
  , brCenter :: [CmdSpec]
  , brRight :: [CmdSpec]
-  } deriving Show
+  }
  deriving (Show)
 data CmdSpec = CmdSpec
  { csAlias :: T.Text
  , csRunnable :: Runnable
-  } deriving Show
+  }
  deriving (Show)
 concatRegions :: BarRegions -> [CmdSpec]
 concatRegions (BarRegions l c r) = l ++ c ++ r
 wirelessCmd :: T.Text -> CmdSpec
-wirelessCmd iface = CmdSpec
+wirelessCmd iface =
  CmdSpec
    { csAlias = T.append iface "wi"
    , csRunnable = Run $ Wireless (T.unpack iface) args 5
    }
  where
-    args = fmap T.unpack
+    args =
-      [ "-t", "<qualityipat><essid>"
+      fmap
        T.unpack
        [ "-t"
        , "<qualityipat><essid>"
        , "--"
-      , "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
+        , "--quality-icon-pattern"
        , "<icon=wifi_%%.xpm/>"
        ]
 ethernetCmd :: Fontifier -> T.Text -> CmdSpec
-ethernetCmd fontify iface = CmdSpec
+ethernetCmd fontify iface =
  CmdSpec
    { csAlias = iface
-  , csRunnable = Run
+    , csRunnable =
-    $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
+        Run $
          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
    }
 batteryCmd :: Fontifier -> CmdSpec
-batteryCmd fontify = CmdSpec
+batteryCmd fontify =
  CmdSpec
    { csAlias = "battery"
    , csRunnable = Run $ Battery args 50
    }
  where
    fontify' = fontify IconSmall
-    args = fmap T.unpack
+    args =
-      [ "--template", "<acstatus><left>"
+      fmap
-      , "--Low", "10"
+        T.unpack
-      , "--High", "80"
+        [ "--template"
-      , "--low", "red"
+        , "<acstatus><left>"
-      , "--normal", XT.fgColor
+        , "--Low"
-      , "--high", XT.fgColor
+        , "10"
        , "--High"
        , "80"
        , "--low"
        , "red"
        , "--normal"
        , XT.fgColor
        , "--high"
        , XT.fgColor
        , "--"
        , "-P"
-      , "-o" , fontify' "\xf0e7" "BAT"
+        , "-o"
-      , "-O" , fontify' "\xf1e6" "AC"
+        , fontify' "\xf0e7" "BAT"
-      , "-i" , fontify' "\xf1e6" "AC"
+        , "-O"
        , fontify' "\xf1e6" "AC"
        , "-i"
        , fontify' "\xf1e6" "AC"
        ]
 vpnCmd :: Fontifier -> CmdSpec
-vpnCmd fontify = CmdSpec
+vpnCmd fontify =
  CmdSpec
    { csAlias = vpnAlias
    , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
    }
 btCmd :: Fontifier -> CmdSpec
-btCmd fontify = CmdSpec
+btCmd fontify =
  CmdSpec
    { csAlias = btAlias
-  , csRunnable = Run
+    , csRunnable =
-    $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
+        Run $
          Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
    }
  where
    fontify' i = fontify IconLarge i . T.append "BT"
 alsaCmd :: Fontifier -> CmdSpec
-alsaCmd fontify = CmdSpec
+alsaCmd fontify =
  CmdSpec
    { csAlias = "alsa:default:Master"
-  , csRunnable = Run
+    , csRunnable =
-    $ Alsa "default" "Master"
+        Run $
-    $ fmap T.unpack
+          Alsa "default" "Master" $
-    [ "-t", "<status><volume>%"
+            fmap
              T.unpack
              [ "-t"
              , "<status><volume>%"
              , "--"
-    , "-O", fontify' "\xf028" "+"
+              , "-O"
-    , "-o", T.append (fontify' "\xf026" "-") " "
+              , fontify' "\xf028" "+"
-    , "-c", XT.fgColor
+              , "-o"
-    , "-C", XT.fgColor
+              , T.append (fontify' "\xf026" "-") " "
              , "-c"
              , XT.fgColor
              , "-C"
              , XT.fgColor
              ]
    }
  where
    fontify' i = fontify IconSmall i . T.append "VOL"
 blCmd :: Fontifier -> CmdSpec
-blCmd fontify = CmdSpec
+blCmd fontify =
  CmdSpec
    { csAlias = blAlias
    , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
    }
 ckCmd :: Fontifier -> CmdSpec
-ckCmd fontify = CmdSpec
+ckCmd fontify =
  CmdSpec
    { csAlias = ckAlias
    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
    }
 ssCmd :: Fontifier -> CmdSpec
-ssCmd fontify = CmdSpec
+ssCmd fontify =
  CmdSpec
    { csAlias = ssAlias
    , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
    }
 lockCmd :: Fontifier -> CmdSpec
-lockCmd fontify = CmdSpec
+lockCmd fontify =
  CmdSpec
    { csAlias = "locks"
-  , csRunnable = Run
+    , csRunnable =
-    $ Locks
+        Run $
-    $ fmap T.unpack
+          Locks $
-    [ "-N", numIcon
+            fmap
-    , "-n", disabledColor numIcon
+              T.unpack
-    , "-C", capIcon
+              [ "-N"
-    , "-c", disabledColor capIcon
+              , numIcon
-    , "-s", ""
+              , "-n"
-    , "-S", ""
+              , disabledColor numIcon
-    , "-d", " "
+              , "-C"
              , capIcon
              , "-c"
              , disabledColor capIcon
              , "-s"
              , ""
              , "-S"
              , ""
              , "-d"
              , " "
              ]
    }
  where
@ -412,51 +518,61 @@ lockCmd fontify = CmdSpec
    disabledColor = xmobarFGColor XT.backdropFgColor
 dateCmd :: CmdSpec
-dateCmd = CmdSpec
+dateCmd =
  CmdSpec
    { csAlias = "date"
    , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
    }
 --------------------------------------------------------------------------------
-- | low-level testing functions
+-- low-level testing functions
-vpnPresent :: IO (Maybe Msg)
+vpnPresent :: XIO (Maybe Msg)
-vpnPresent =
+vpnPresent = do
-  go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
+  res <- proc "nmcli" args readProcess
-  where
+  return $ case res of
-    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
+    (ExitSuccess, out, _)
-    go (Right (ExitSuccess, out, _))   = if "vpn" `elem` T.lines out then Nothing
+      | "vpn" `elem` BL.split 10 out -> Nothing
-                                         else Just $ Msg LevelError "vpn not found"
+      | otherwise -> Just $ Msg LevelError "vpn not found"
-    go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
+    (ExitFailure c, _, err) ->
-                                         $ T.concat ["vpn search exited with code "
+      Just $
        Msg LevelError $
          T.concat
            [ "vpn search exited with code "
            , T.pack $ show c
            , ": "
-                                                    , err]
+            , T.decodeUtf8With T.lenientDecode $
-    go (Left e)                        = Just $ Msg LevelError $ T.pack $ show e
+                BL.toStrict err
            ]
  where
    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
 --------------------------------------------------------------------------------
-- | text font
+-- 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 :: FIO T.Text
+getTextFont :: XIO T.Text
 getTextFont = do
  fb <- evalAlways textFont
  return $ fb textFontData
 --------------------------------------------------------------------------------
-- | icon fonts
+-- icon fonts
-getIconFonts :: FIO ([T.Text], [Int])
+getIconFonts :: XIO ([T.Text], [Int])
 getIconFonts = do
  fb <- evalSometimes iconFont
  return $ maybe ([], []) apply fb
  where
-    apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
+    apply fb =
      unzip $
        (\i -> (iconString fb i, iconOffset i + textFontOffset))
          <$> iconFonts
-data BarFont = IconSmall
+data BarFont
  = IconSmall
  | IconMedium
  | IconLarge
  | IconXLarge
@ -484,7 +600,7 @@ fontifyIcon :: Fontifier
 fontifyIcon f i _ = fontifyText f i
 --------------------------------------------------------------------------------
-- | various formatting things
+-- various formatting things
 colors :: Colors
 colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
@ -507,5 +623,6 @@ fmtSpecs = T.intercalate sep . fmap go
    go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
 fmtRegions :: BarRegions -> T.Text
-fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $
+fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
  T.concat
    [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@ -1,36 +1,32 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 --------------------------------------------------------------------------------
-- | XMonad binary
+--  XMonad binary
 module Main (main) where
 import           Control.Monad
 import Data.Internal.DBus
-import           Data.Internal.Dependency
+import Data.Internal.XIO
 import           Data.List
 import           Data.Maybe
 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                                            (async)
+import RIO
 import RIO.Directory
 import RIO.List
 import RIO.Process
 import qualified RIO.Text as T
-
+import System.Posix.Signals
 import           System.Directory
 import           System.Environment
 import           System.IO                                      hiding
    ( hPutStrLn
    )
 import           System.IO.Error
 import System.Process
-
+  ( getPid
  , getProcessExitCode
  )
 import XMonad
 import XMonad.Actions.CopyWindow
 import XMonad.Actions.CycleWS
@ -53,8 +49,7 @@ import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Control
 import XMonad.Internal.DBus.Removable
 import XMonad.Internal.DBus.Screensaver
-import           XMonad.Internal.Process
+import XMonad.Internal.Shell hiding (proc)
 import           XMonad.Internal.Shell
 import qualified XMonad.Internal.Theme as XT
 import XMonad.Layout.MultiToggle
 import XMonad.Layout.NoBorders
@ -71,23 +66,95 @@ import           XMonad.Util.NamedActions
 import XMonad.Util.WorkspaceCompare
 main :: IO ()
-main = getArgs >>= parse
+main = parse >>= xio
-parse :: [String] -> IO ()
+parse :: IO XOpts
-parse []         = run
+parse = execParser opts
-parse ["--deps"] = withCache printDeps
+  where
-parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
+    parseOpts = parseDeps <|> parseTest <|> pure XRun
-parse _          = usage
+    opts =
      info (parseOpts <**> helper) $
        fullDesc <> header "xmonad: the best window manager ever"
 data XOpts = XDeps | XTest | XRun
-run :: IO ()
+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 = do
-  db <- connectDBusX
+  -- These first two commands are only significant when xmonad is restarted.
-  conf <- withCache $ evalConf db
+  -- The 'launch' function below this will turn off buffering (so flushes are
-  ds <- getCreateDirectories
+  -- required to see stdout) and will also install xmonad's silly signal
-  -- IDK why this is necessary; nothing prior to this will print if missing
+  -- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN).
-  hFlush stdout
+  -- Ignoring sigCHLD is particularly bad since most of my setup entails
-  launch conf ds
+  -- spawning processes and waiting for their exit code, which totally breaks
  -- when sigCHLD is ignored (since children are killed immediately without
  -- the parent invoking 'wait'). Since the 'launch' function is called last
  -- here, everything before should be fine except for the case where xmonad
  -- is restarted, which uses 'exec' and thus should cause the buffering and
  -- 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
      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
          dws <- startDynWorkspaces fs
          runIO <- askRunInIO
          let cleanup = runCleanup runIO toClean db
          kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
          sk <- evalAlways $ fsShowKeys fs
          ha <- evalAlways $ fsACPIHandler fs
          tt <- evalAlways $ fsTabbedTheme fs
          let conf =
                ewmh $
                  addKeymap dws (liftIO . runIO . sk) kbs $
                    docks $
                      def
                        { terminal = myTerm
                        , modMask = myModMask
                        , layoutHook = myLayouts tt
                        , manageHook = myManageHook dws
                        , handleEventHook = myEventHook runIO ha
                        , startupHook = myStartupHook
                        , workspaces = myWorkspaces
                        , logHook = myLoghook xmobarP
                        , clickJustFocuses = False
                        , focusFollowsMouse = False
                        , normalBorderColor = T.unpack XT.bordersColor
                        , focusedBorderColor = T.unpack XT.selectedBordersColor
                        }
          io $ runXMonad conf
  where
    startDynWorkspaces fs = do
      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
      void $ async $ runWorkspaceMon dws
      return dws
 runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
 runXMonad conf = do
  dirs <- getCreateDirectories
  launch conf dirs
 getCreateDirectories :: IO Directories
 getCreateDirectories = do
@ -97,21 +164,21 @@ getCreateDirectories = do
  where
    createIfMissing ds f = do
      let d = f ds
-      r <- tryIOError $ createDirectoryIfMissing True d
+      r <- tryIO $ createDirectoryIfMissing True d
      case r of
        (Left e) -> print e
        _ -> return ()
 data FeatureSet = FeatureSet
-  { fsKeys          :: ThreadState -> DBusState -> [KeyGroup FeatureX]
+  { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
+  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
  , fsPowerMon :: SometimesIO
  , fsRemovableMon :: Maybe SysClient -> SometimesIO
-  , fsDaemons       :: [Sometimes (IO ProcessHandle)]
+  , fsDaemons :: [Sometimes (XIO (Process () () ()))]
  , fsACPIHandler :: Always (String -> X ())
  , fsTabbedTheme :: Always Theme
  , fsDynWorkspaces :: [Sometimes DynWorkspace]
-  , fsShowKeys      :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
+  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
  }
 tabbedFeature :: Always Theme
@ -122,7 +189,8 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
    fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
 features :: Maybe SysClient -> FeatureSet
-features cl = FeatureSet
+features cl =
  FeatureSet
    { fsKeys = externalBindings
    , fsDBusExporters = dbusExporters
    , fsPowerMon = runPowermon
@ -134,104 +202,141 @@ features cl = FeatureSet
    , fsDaemons = [runNetAppDaemon cl, runAutolock]
    }
-evalConf db@DBusState { dbSysClient = cl } = do
+withXmobar :: (Process Handle () () -> XIO a) -> XIO a
-  -- start DBus interfaces first since many features after this test these
+withXmobar = bracket startXmobar stopXmobar
-  -- interfaces as dependencies
+
-  let fs = features cl
+startXmobar :: XIO (Process Handle () ())
-  startDBusInterfaces fs
+startXmobar = do
-  (xmobarHandle, ts) <- startChildDaemons fs
+  logInfo "starting xmobar child process"
-  startRemovableMon fs
+  p <- proc "xmobar" [] start
-  startPowerMon fs
+  io $ hSetBuffering (getStdin p) LineBuffering
-  dws <- startDynWorkspaces fs
+  return p
  tt <- evalAlways $ fsTabbedTheme fs
  -- fb <- evalAlways $ fsFontBuilder features
  kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
  sk <- evalAlways $ fsShowKeys fs
  ha <- evalAlways $ fsACPIHandler fs
  return $ ewmh
    $ addKeymap dws sk kbs
    $ docks
    $ def { terminal = myTerm
          , modMask = myModMask
          , layoutHook = myLayouts tt
          , manageHook = myManageHook dws
          , handleEventHook = myEventHook ha
          , startupHook = myStartupHook
          , workspaces = myWorkspaces
          , logHook = myLoghook xmobarHandle
          , clickJustFocuses = False
          , focusFollowsMouse = False
          , normalBorderColor = T.unpack XT.bordersColor
          , focusedBorderColor = T.unpack XT.selectedBordersColor
          }
  where
-    forkIO_ = void . async
+    start =
-    startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
+      startProcess
-      $ fsDBusExporters fs
+        . setStdin createPipe
-    startChildDaemons fs = do
+        . setCreateGroup True
      (h, p) <- io $ spawnPipe "xmobar"
      ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
      return (h, ThreadState (p:ps) [h])
    startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
                        $ dbSysClient db
    startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
    startDynWorkspaces fs = do
      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
      io $ forkIO_ $ runWorkspaceMon dws
      return dws
-printDeps :: FIO ()
+stopXmobar
-printDeps = do
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  db <- io connectDBus
+  => Process Handle () ()
-  (i, f, d) <- allFeatures db
+  -> m ()
-  io $ mapM_ (putStrLn . T.unpack)
+stopXmobar p = do
-    $ fmap showFulfillment
+  logInfo "stopping xmobar child process"
-    $ sort
+  io $ killNoWait p
    $ nub
    $ concat
    $ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
  io $ disconnectDBus db
-allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
+withChildDaemons
-allFeatures db = do
+  :: FeatureSet
-  let bfs = concatMap (fmap kbMaybeAction . kgBindings)
+  -> ([(Utf8Builder, Process () () ())] -> XIO a)
-            $ externalBindings ts db
+  -> XIO a
-  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
+withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
 startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
 startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
  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
 stopChildDaemons
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => [(Utf8Builder, Process () () ())]
  -> m ()
 stopChildDaemons = mapM_ stop
  where
    stop (n, p) = do
      logInfo $ "stopping child process: " <> n
      liftIO $ killNoWait p
 printDeps :: XIO ()
 printDeps = withDBus_ $ \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]
-  return (dbus ++ others, Left runScreenLock:bfs, allDWs')
+  -- TODO might be better to use glog for this?
  mapM_ logInfo $
    fmap showFulfillment $
      sort $
        nub $
          concat $
            fmap dumpSometimes dbus
              ++ fmap dumpSometimes others
              ++ fmap dumpSometimes allDWs'
              ++ fmap dumpFeature bfs
  where
-    ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
+    mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
 usage :: IO ()
 usage = putStrLn $ intercalate "\n"
  [ "xmonad: run greatest window manager"
  , "xmonad --deps: print dependencies"
  ]
 --------------------------------------------------------------------------------
-- | Concurrency configuration
+-- Concurrency configuration
-data ThreadState = ThreadState
+data Cleanup = Cleanup
-    { tsChildPIDs    :: [ProcessHandle]
+  { clChildren :: [(Utf8Builder, Process () () ())]
-    , tsChildHandles :: [Handle]
+  , clXmobar :: Maybe (Process Handle () ())
  , clDBusUnexporters :: [XIO ()]
  }
-- TODO shouldn't this be run by a signal handler?
+runCleanup
-runCleanup :: ThreadState -> DBusState -> X ()
+  :: (XIO () -> IO ())
-runCleanup ts db = io $ do
+  -> Cleanup
-  mapM_ killHandle $ tsChildPIDs ts
+  -> DBusState
  -> X ()
 runCleanup runIO ts db = liftIO $ runIO $ do
  mapM_ stopXmobar $ clXmobar ts
  stopChildDaemons $ clChildren ts
  sequence_ $ clDBusUnexporters ts
  disconnectDBusX db
 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
 -- sets the handler for sigCHLD to Ignore which breaks 'waitForProcess' (which
 -- in turn will break 'stopProcess') and b) because I want to kill off entire
 -- process groups since they may spawn child processes themselves. NOTE:
 -- for reasons unknown I cannot just turn off/on the signal handlers here.
 killNoWait :: Process a () () -> IO ()
 killNoWait p = do
  -- this strategy is outlined/sanctioned in RIO.Process under
  -- 'unsafeProcessHandle':
  --
  -- get the handle (unsafely, since it breaks the semantics of RIO)
  let ph = unsafeProcessHandle p
  -- check if the process has already exited (if so, do nothing since trying
  -- to kill it will open wormholes
  ec <- getProcessExitCode ph
  unless (isJust ec) $ do
    -- send SIGTERM to the entire group (NOTE: 'System.Process.terminateProcess'
    -- does not actually do this despite what the docs say)
    i <- getPid ph
    forM_ i $ signalProcessGroup sigTERM
    -- actually call 'stopProcess' which will clean up associated data and
    -- then try to wait for the exit, which will fail because we are assuming
    -- this function is called when the handler for SIGCHLD is Ignore. Ignore
    -- the failure and move on with life.
    handleIO (\_ -> return ()) $ stopProcess p
 --------------------------------------------------------------------------------
-- | Startuphook configuration
+-- Startuphook configuration
 -- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
 myStartupHook :: X ()
-myStartupHook = setDefaultCursor xC_left_ptr
+myStartupHook =
  setDefaultCursor xC_left_ptr
    <+> startupHook def
 --------------------------------------------------------------------------------
-- | Workspace configuration
+-- Workspace configuration
 myWorkspaces :: [WorkspaceId]
 myWorkspaces = map show [1 .. 10 :: Int]
@ -252,7 +357,8 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
  where
    tree = Only_ $ sysExe [Package Official "gimp"] exe
-    dw = DynWorkspace
+    dw =
      DynWorkspace
        { dwName = "Gimp"
        , dwTag = gimpTag
        , dwClass = c
@ -266,21 +372,32 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
        , dwCmd = Just $ spawnCmd exe []
        }
    exe = "gimp-2.10"
-    matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
+    matchGimpRole role =
-      <&&> className =? c
+      isPrefixOf role
        <$> stringProperty "WM_WINDOW_ROLE"
        <&&> className
        =? c
    c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
 -- TODO don't hardcode the VM name/title/shortcut
 vmDynamicWorkspace :: Sometimes DynWorkspace
-vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
+vmDynamicWorkspace =
  Sometimes
    "virtualbox workspace"
    xpfVirtualBox
    [Subfeature root "windows 8 VM"]
  where
-    root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
+    root =
-      $ IOTest_ name [] $ vmExists vm
+      IORoot_ dw $
        toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
          IOTest_ name [] $
            io $
              vmExists vm
    name = T.unwords ["test if", vm, "exists"]
    c = "VirtualBoxVM"
    vm = "win8raw"
-    dw = DynWorkspace
+    dw =
      DynWorkspace
        { dwName = "Windows VirtualBox"
        , dwTag = vmTag
        , dwClass = c
@ -290,11 +407,15 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
        }
 xsaneDynamicWorkspace :: Sometimes DynWorkspace
-xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
+xsaneDynamicWorkspace =
  Sometimes
    "scanner workspace"
    xpfXSANE
    [Subfeature (IORoot_ dw tree) "xsane"]
  where
    tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
-    dw = DynWorkspace
+    dw =
      DynWorkspace
        { dwName = "XSane"
        , dwTag = xsaneTag
        , dwClass = c
@ -305,11 +426,15 @@ xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
    c = "Xsane"
 f5vpnDynamicWorkspace :: Sometimes DynWorkspace
-f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
+f5vpnDynamicWorkspace =
  Sometimes
    "F5 VPN workspace"
    xpfF5VPN
    [Subfeature (IORoot_ dw tree) "f5vpn"]
  where
    tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
-    dw = DynWorkspace
+    dw =
      DynWorkspace
        { dwName = "F5Vpn"
        , dwTag = f5Tag
        , dwClass = c
@ -320,42 +445,48 @@ f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
    c = "F5 VPN"
 allDWs' :: [Sometimes DynWorkspace]
-allDWs' = [xsaneDynamicWorkspace
+allDWs' =
  [ xsaneDynamicWorkspace
  , vmDynamicWorkspace
  , gimpDynamicWorkspace
  , f5vpnDynamicWorkspace
  ]
 --------------------------------------------------------------------------------
-- | Layout configuration
+-- Layout configuration
 -- NOTE this will have all available layouts, even those that may be for
 -- features that failed. Trying to dynamically take out a layout seems to
 -- make a new type :/
-myLayouts tt = onWorkspace vmTag vmLayout
+myLayouts tt =
-  $ onWorkspace gimpTag gimpLayout
+  onWorkspace vmTag vmLayout $
-  $ mkToggle (single HIDE)
+    onWorkspace gimpTag gimpLayout $
-  $ tall ||| fulltab ||| full
+      mkToggle (single HIDE) $
        tall ||| fulltab ||| full
  where
    addTopBar = noFrillsDeco shrinkText tt
-    tall = renamed [Replace "Tall"]
+    tall =
-      $ avoidStruts
+      renamed [Replace "Tall"] $
-      $ addTopBar
+        avoidStruts $
-      $ noBorders
+          addTopBar $
-      $ Tall 1 0.03 0.5
+            noBorders $
-    fulltab = renamed [Replace "Tabbed"]
+              Tall 1 0.03 0.5
-      $ avoidStruts
+    fulltab =
-      $ noBorders
+      renamed [Replace "Tabbed"] $
-      $ tabbedAlways shrinkText tt
+        avoidStruts $
-    full = renamed [Replace "Full"]
+          noBorders $
-      $ noBorders Full
+            tabbedAlways shrinkText tt
    full =
      renamed [Replace "Full"] $
        noBorders Full
    vmLayout = noBorders Full
    -- TODO use a tabbed layout for multiple master windows
-    gimpLayout = renamed [Replace "Gimp Layout"]
+    gimpLayout =
-      $ avoidStruts
+      renamed [Replace "Gimp Layout"] $
-      $ noBorders
+        avoidStruts $
-      $ addTopBar
+          noBorders $
-      $ Tall 1 0.025 0.8
+            addTopBar $
              Tall 1 0.025 0.8
 -- | Make a new empty layout and add a message to show/hide it. This is useful
 -- for quickly showing conky.
@ -377,10 +508,9 @@ runHide :: X ()
 runHide = sendMessage $ Toggle HIDE
 --------------------------------------------------------------------------------
-- | Loghook configuration
+-- Loghook configuration
 --
-myLoghook :: Handle -> X ()
+myLoghook :: Process Handle () () -> X ()
 myLoghook h = do
  logXinerama h
  logViewports
@ -396,7 +526,7 @@ myLoghook h = do
 -- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
 -- bother...(if that were necessary it would go in the startup hook)
 newtype DesktopViewports = DesktopViewports [Int]
-    deriving Eq
+  deriving (Eq)
 instance ExtensionClass DesktopViewports where
  initialValue = DesktopViewports []
@ -409,8 +539,9 @@ logViewports = withWindowSet $ \s -> do
  whenChanged (DesktopViewports desktopViewports) $
    setDesktopViewports desktopViewports
  where
-    wsToViewports s w = let cur = W.current s in
+    wsToViewports s w =
-      if W.tag w == currentTag cur then currentPos cur else [0, 0]
+      let cur = W.current s
       in if W.tag w == currentTag cur then currentPos cur else [0, 0]
    currentTag = W.tag . W.workspace
    currentPos = rectXY . screenRect . W.screenDetail
    rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
@ -436,20 +567,22 @@ whenChanged v action = do
 -- currently visible and the order reflects the physical location of each
 -- screen. The "<>" is the workspace that currently has focus. N is the number
 -- of windows on the current workspace.
-
+logXinerama :: Process Handle () () -> X ()
-logXinerama :: Handle -> X ()
+logXinerama p = withWindowSet $ \ws ->
-logXinerama h = withWindowSet $ \ws -> io
+  io $
-  $ hPutStrLn h
+    hPutStrLn (getStdin p) $
-  $ T.unwords
+      T.unwords $
-  $ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
+        filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
  where
-    onScreen ws = xmobarColor_ hilightFgColor hilightBgColor
+    onScreen ws =
-      $ (T.pack . pad . T.unpack)
+      xmobarColor_ hilightFgColor hilightBgColor $
-      $ T.unwords
+        (T.pack . pad . T.unpack) $
-      $ map (fmtTags ws . W.tag . W.workspace)
+          T.unwords $
-      $ sortBy compareXCoord
+            map (fmtTags ws . W.tag . W.workspace) $
-      $ W.current ws : W.visible ws
+              sortBy compareXCoord $
-    offScreen = xmobarColor_ XT.backdropFgColor ""
+                W.current ws : W.visible ws
    offScreen =
      xmobarColor_ XT.backdropFgColor ""
        . T.unwords
        . fmap (T.pack . W.tag)
        . filter (isJust . W.stack)
@ -457,7 +590,8 @@ logXinerama h = withWindowSet $ \ws -> io
        . W.hidden
    sep = xmobarColor_ XT.backdropFgColor "" ":"
    layout = T.pack . description . W.layout . W.workspace . W.current
-    nWindows = (\x -> T.concat ["(", x, ")"])
+    nWindows =
      (\x -> T.concat ["(", x, ")"])
        . T.pack
        . show
        . length
@ -467,76 +601,97 @@ logXinerama h = withWindowSet $ \ws -> io
        . W.current
    hilightBgColor = "#A6D3FF"
    hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
-    fmtTags ws t = let t_ = T.pack t in
+    fmtTags ws t =
-      if t == W.currentTag ws
+      let t_ = T.pack t
       in if t == W.currentTag ws
            then xmobarColor_ XT.fgColor hilightBgColor t_
            else t_
    xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
 compareXCoord
  :: W.Screen i1 l1 a1 ScreenId ScreenDetail
-     -> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
+  -> W.Screen i2 l2 a2 ScreenId ScreenDetail
  -> Ordering
 compareXCoord s0 s1 = compare (go s0) (go s1)
  where
    go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
 --------------------------------------------------------------------------------
-- | Managehook configuration
+-- Managehook configuration
 myManageHook :: [DynWorkspace] -> ManageHook
 myManageHook dws = manageApps dws <+> manageHook def
 manageApps :: [DynWorkspace] -> ManageHook
-manageApps dws = composeOne $ concatMap dwHook dws ++
+manageApps dws =
-  [ isDialog -?> doCenterFloat
+  composeOne $
-  -- the seafile applet
+    concatMap dwHook dws
-  , className =? "Seafile Client" -?> doFloat
+      ++ [ isDialog -?> doCenterFloat
-  -- gnucash
+         , -- the seafile applet
-  , (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
+           className =? "Seafile Client" -?> doFloat
-  -- plots and graphics
+         , -- gnucash
-  , className =? "R_x11" -?> doFloat
+           (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
         , -- plots and graphics
           className =? "R_x11" -?> doFloat
         , className =? "Matplotlib" -?> doFloat
         , className =? "mpv" -?> doFloat
-  -- the floating windows created by the brave browser
+         , -- the floating windows created by the brave browser
-  , stringProperty "WM_NAME" =? "Brave" -?> doFloat
+           stringProperty "WM_NAME" =? "Brave" -?> doFloat
-  -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
+         , -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
           --    <&&> className =? "Brave-browser") -?> doFloat
           -- the dialog windows created by the zotero addon in Google Docs
-  , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
+           (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
         ]
 --------------------------------------------------------------------------------
-- | Eventhook configuration
+-- Eventhook configuration
-myEventHook :: (String -> X ()) -> Event -> X All
+myEventHook
-myEventHook handler = xMsgEventHook handler <+> handleEventHook def
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (m () -> IO ())
  -> (String -> X ())
  -> Event
  -> X All
 myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
 -- | React to ClientMessage events from concurrent threads
-xMsgEventHook :: (String -> X ()) -> Event -> X All
+xMsgEventHook
-xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
+  :: (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}
  | t == bITMAP = do
      let (xtype, tag) = splitXMsg d
      case xtype of
        Workspace -> removeDynamicWorkspace tag
        ACPI -> handler tag
-      Unknown   -> io $ putStrLn "WARNING: unknown concurrent message"
+        Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
      return (All True)
-xMsgEventHook _ _ = return (All True)
+xMsgEventHook _ _ _ = return (All True)
 --------------------------------------------------------------------------------
-- | Keymap configuration
+-- Keymap configuration
 myModMask :: KeyMask
 myModMask = mod4Mask
-addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
+addKeymap
-  -> [KeyGroup (X ())] -> XConfig l -> XConfig l
+  :: [DynWorkspace]
-addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
+  -> ([((KeyMask, KeySym), NamedAction)] -> X ())
  -> [KeyGroup (X ())]
  -> XConfig l
  -> XConfig l
 addKeymap dws showKeys external =
  addDescrKeys'
    ((myModMask, xK_F1), showKeys)
    (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
 internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
 internalBindings dws c =
-  [ KeyGroup "Window Layouts"
+  [ KeyGroup
      "Window Layouts"
      [ KeyBinding "M-j" "focus down" $ windows W.focusDown
      , KeyBinding "M-k" "focus up" $ windows W.focusUp
      , KeyBinding "M-m" "focus master" $ windows W.focusMaster
@ -553,32 +708,36 @@ internalBindings dws c =
      , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
      , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
      ]
-
+  , KeyGroup
-  , KeyGroup "Workspaces"
+      "Workspaces"
      -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
      -- valid keysyms)
-    ([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces
+      ( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <-
      , (mods, msg, f) <-
                                                                        [ ("M-", "switch to workspace ", windows . W.view)
                                                                        , ("M-S-", "move client to workspace ", windows . W.shift)
-        , ("M-C-", "follow client to workspace ", \n' -> do
+                                                                        ,
                                                                          ( "M-C-"
                                                                          , "follow client to workspace "
                                                                          , \n' -> do
                                                                              windows $ W.shift n'
-              windows $ W.view n')
+                                                                              windows $ W.view n'
                                                                          )
                                                                        ]
-     ] ++
+        ]
-     [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
+          ++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
             , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
-     ])
+             ]
-
+      )
-  , KeyGroup "Dynamic Workspaces"
+  , KeyGroup
      "Dynamic Workspaces"
      [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
-    |  DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws,
+      | DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws
-       let cmd = case a of
+      , let cmd = case a of
              Just a' -> spawnOrSwitch t a'
              Nothing -> windows $ W.view t
      ]
-
+  , KeyGroup
-  , KeyGroup "Screens"
+      "Screens"
      [ KeyBinding "M-l" "move up screen" nextScr
      , KeyBinding "M-h" "move down screen" prevScr
      , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
@ -597,8 +756,9 @@ internalBindings dws c =
 mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
 mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
-  (subtitle h:) $ mkNamedKeymap c
+  (subtitle h :) $
-  $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
+    mkNamedKeymap c $
      (\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
        <$> b
 data KeyBinding a = KeyBinding
@ -612,13 +772,13 @@ data KeyGroup a = KeyGroup
  , kgBindings :: [KeyBinding a]
  }
-evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
+evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
 evalExternal = mapM go
  where
    go k@KeyGroup {kgBindings = bs} =
      (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
-evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
+evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
 evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
  (\f -> k {kbMaybeAction = f}) <$> evalFeature a
@ -626,59 +786,62 @@ filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
 filterExternal = fmap go
  where
    go k@KeyGroup {kgBindings = bs} =
-      k { kgBindings = [ kb { kbMaybeAction = x }
+      k
        { kgBindings =
            [ kb {kbMaybeAction = x}
            | kb@KeyBinding {kbMaybeAction = Just x} <- bs
            ]
        }
-externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
+externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-externalBindings ts db =
+externalBindings runIO cleanup db =
-  [ KeyGroup "Launchers"
+  [ KeyGroup
-    [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
+      "Launchers"
-    , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
+      [ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
-    , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
+      , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
-    , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
+      , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
-    , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
+      , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
-    , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
+      , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
-    , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
+      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
-    , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
+      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
-    , KeyBinding "M-C-e" "launch editor" $ Left runEditor
+      , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
-    , KeyBinding "M-C-w" "launch browser" $ Left runBrowser
+      , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
-    , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
+      , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
-    , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
+      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
-    , KeyBinding "M-C-q" "launch calc" $ Left runCalc
+      , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
-    , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
+      , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
      , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
      ]
-
+  , KeyGroup
-  , KeyGroup "Actions"
+      "Actions"
      [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
-    , KeyBinding "M-r" "run program" $ Left runCmdMenu
+      , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
      , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
-    , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
+      , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
-    , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
+      , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
-    , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
+      , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
-    , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
+      , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
      -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
      ]
-
+  , KeyGroup
-  , KeyGroup "Multimedia"
+      "Multimedia"
-    [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
+      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
-    , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
+      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
-    , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
+      , KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
-    , KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
+      , KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
-    , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
+      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
-    , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
+      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
-    , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
+      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
      ]
-
+  , KeyGroup
-  , KeyGroup "Dunst"
+      "Dunst"
-    [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
+      [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
-    , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
+      , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
-    , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
+      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
-    , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
+      , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
      ]
-
+  , KeyGroup
-  , KeyGroup "System"
+      "System"
      [ KeyBinding "M-." "backlight up" $ ib bctlInc
      , KeyBinding "M-," "backlight down" $ ib bctlDec
      , KeyBinding "M-M1-," "backlight min" $ ib bctlMin
@ -690,25 +853,27 @@ externalBindings ts db =
      , KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
      , KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
      , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-    -- M-<F1> reserved for showing the keymap
+      , -- M-<F1> reserved for showing the keymap
-    , KeyBinding "M-<F2>" "restart xmonad" restartf
+        KeyBinding "M-<F2>" "restart xmonad" restartf
      , KeyBinding "M-<F3>" "recompile xmonad" recompilef
-    , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
+      , KeyBinding "M-<F8>" "select autorandr profile" $ Left $ toX runAutorandrMenu
-    , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
+      , KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
-    , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
+      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
-    , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
+      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
      , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
      ]
  ]
  where
    ses = dbSesClient db
    sys = dbSysClient db
-    brightessControls ctl getter = (ioSometimes . getter . ctl) ses
+    brightessControls ctl getter = (toX . getter . ctl) ses
    ib = Left . brightessControls intelBacklightControls
    ck = Left . brightessControls clevoKeyboardControls
    ftrAlways n = Right . Always n . Always_ . FallbackAlone
-    restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
+    restartf = ftrAlways "restart function" (cleanup >> runRestart)
    recompilef = ftrAlways "recompile function" runRecompile
    toX_ = liftIO . runIO
    toX = fmap toX_
 type MaybeX = Maybe (X ())
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@ -0,0 +1,14 @@
 indentation: 2
 function-arrows: leading
 comma-style: leading
 import-export-style: leading
 indent-wheres: true
 record-brace-space: true
 newlines-between-decls: 1
 haddock-style: single-line
 haddock-style-module:
 let-style: inline
 in-style: right-align
 respectful: false
 fixities: []
 unicode: never
--- a/lib/Data/Internal/DBus.hs
+++ b/lib/Data/Internal/DBus.hs
@ -1,10 +1,18 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Common internal DBus functions
+-- Common internal DBus functions
 module Data.Internal.DBus
  ( SafeClient (..)
  , SysClient (..)
  , SesClient (..)
  , DBusEnv (..)
  , DIO
  , HasClient (..)
  , withDIO
  , addMatchCallback
  , matchProperty
  , matchPropertyFull
@ -25,43 +33,53 @@ module Data.Internal.DBus
  , addInterfaceRemovedListener
  , fromSingletonVariant
  , bodyToMaybe
-  ) where
+  , exportPair
-
+  , displayBusName
-import           Control.Exception
+  , displayObjectPath
-import           Control.Monad
+  , displayMemberName
-
+  , displayInterfaceName
-import           Data.Bifunctor
+  , displayWrapQuote
-import qualified Data.Map.Strict   as M
+  )
-import           Data.Maybe
+where
 import qualified RIO.Text          as T
 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
+-- Type-safe client
 class SafeClient c where
  toClient :: c -> Client
-  getDBusClient :: IO (Maybe c)
+  getDBusClient
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
    => m (Maybe c)
-  disconnectDBusClient :: c -> IO ()
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
-  disconnectDBusClient = disconnect . toClient
+  disconnectDBusClient = liftIO . disconnect . toClient
-  withDBusClient :: (c -> IO a) -> IO (Maybe a)
+  withDBusClient
-  withDBusClient f = do
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    client <- getDBusClient
+    => (c -> m a)
-    forM client $ \c -> do
+    -> m (Maybe a)
-      r <- f c
+  withDBusClient f =
-      disconnect (toClient c)
+    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
      return r
-  withDBusClient_ :: (c -> IO ()) -> IO ()
+  withDBusClient_
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
    => (c -> m ())
    -> m ()
  withDBusClient_ = void . withDBusClient
-  fromDBusClient :: (c -> a) -> IO (Maybe a)
+  fromDBusClient
    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
    => (c -> a)
    -> m (Maybe a)
  fromDBusClient f = withDBusClient (return . f)
 newtype SysClient = SysClient Client
@ -78,46 +96,101 @@ instance SafeClient SesClient where
  getDBusClient = fmap SesClient <$> getDBusClient' False
-getDBusClient' :: Bool -> IO (Maybe Client)
+getDBusClient'
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Bool
  -> m (Maybe Client)
 getDBusClient' sys = do
-  res <- try $ if sys then connectSystem else connectSession
+  res <- try $ liftIO $ if sys then connectSystem else connectSession
  case res of
-    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> do
      logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
      return Nothing
    Right c -> return $ Just c
 data DBusEnv env c = DBusEnv {dClient :: !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 SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
 withDIO
  :: (MonadUnliftIO m, MonadReader env m, SafeClient c)
  => 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) c
 --------------------------------------------------------------------------------
-- | Methods
+-- Methods
 type MethodBody = Either T.Text [Variant]
-callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
+callMethod'
-callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
-  . call (toClient cl)
+  => MethodCall
  -> m MethodBody
 callMethod' mc = do
  cl <- toClient <$> view clientL
  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
-callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
+callMethod
-  -> MemberName -> IO MethodBody
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
-callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
+  => BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m MethodBody
 callMethod bus path iface = callMethod' . methodCallBus bus path iface
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
-methodCallBus b p i m = (methodCall p i m)
+methodCallBus b p i m =
-    { methodCallDestination = Just b }
+  (methodCall p i m)
    { methodCallDestination = Just b
    }
 --------------------------------------------------------------------------------
-- | Bus names
+-- Bus names
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
-callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
+callGetNameOwner
-callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
+  :: ( 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
  where
-    mc = (methodCallBus dbusName dbusPath dbusInterface mem)
+    mc =
-      { methodCallBody = [toVariant name] }
+      (methodCallBus dbusName dbusPath dbusInterface mem)
        { methodCallBody = [toVariant name]
        }
    mem = memberName_ "GetNameOwner"
 --------------------------------------------------------------------------------
-- | Variant parsing
+-- Variant parsing
 -- TODO log failures here?
 fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
 fromSingletonVariant = fromVariant <=< listToMaybe
@ -125,30 +198,72 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
 bodyToMaybe = either (const Nothing) fromSingletonVariant
 --------------------------------------------------------------------------------
-- | Signals
+-- Signals
-type SignalCallback = [Variant] -> IO ()
+type SignalCallback m = [Variant] -> m ()
-addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
+addMatchCallback
-  -> IO SignalHandler
+  :: ( MonadReader (env c) m
-addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
+     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => MatchRule
  -> SignalCallback m
  -> m SignalHandler
 addMatchCallback rule cb = do
  cl <- toClient <$> view clientL
  withRunInIO $ \run -> do
    addMatch cl rule $ run . cb . signalBody
-matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
+matchSignal
-  -> Maybe MemberName -> MatchRule
+  :: Maybe BusName
-matchSignal b p i m = matchAny
+  -> Maybe ObjectPath
  -> Maybe InterfaceName
  -> Maybe MemberName
  -> MatchRule
 matchSignal b p i m =
  matchAny
    { matchPath = p
    , matchSender = b
    , matchInterface = i
    , matchMember = m
    }
-matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
+matchSignalFull
-  -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
+  :: ( MonadReader (env c) m
-matchSignalFull client b p i m =
+     , HasLogFunc (env c)
-  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
+     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => 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
 --------------------------------------------------------------------------------
-- | Properties
+-- Properties
 propertyInterface :: InterfaceName
 propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
@ -156,35 +271,64 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
-callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
+callPropertyGet
-  -> MemberName -> c -> IO [Variant]
+  :: ( HasClient env
-callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
+     , MonadReader (env c) m
-  $ getProperty (toClient cl) $ methodCallBus bus path iface property
+     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     )
  => BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m [Variant]
 callPropertyGet bus path iface property = do
  cl <- toClient <$> 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]
 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
  matchSignal b p (Just propertyInterface) (Just propertySignal)
-matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
+matchPropertyFull
-  -> IO (Maybe MatchRule)
+  :: ( MonadReader (env c) m
-matchPropertyFull cl b p =
+     , HasLogFunc (env c)
-  matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
+     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> Maybe ObjectPath
  -> m (Maybe MatchRule)
 matchPropertyFull b p =
  matchSignalFull b p (Just propertyInterface) (Just propertySignal)
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
-withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
+withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
 withSignalMatch f (Match x) = f (Just x)
 withSignalMatch f Failure = f Nothing
 withSignalMatch _ NoMatch = return ()
-matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
+matchPropertyChanged
  :: IsVariant a
  => InterfaceName
  -> T.Text
  -> [Variant]
  -> SignalMatch a
 matchPropertyChanged iface property [i, body, _] =
  let i' = (fromVariant i :: Maybe T.Text)
-      b = toMap body in
+      b = toMap body
-    case (i', b) of
+   in case (i', b) of
-      (Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
+        (Just i'', Just b') ->
-        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
+          if i'' == T.pack (formatInterfaceName iface)
            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
            else NoMatch
        _ -> Failure
  where
@ -192,7 +336,7 @@ matchPropertyChanged iface property [i, body, _] =
 matchPropertyChanged _ _ _ = Failure
 --------------------------------------------------------------------------------
-- | Object Manager
+-- Object Manager
 type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
@ -208,24 +352,117 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
 omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
-callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
+callGetManagedObjects
-  -> IO ObjectTree
+  :: ( MonadReader (env c) m
-callGetManagedObjects cl bus path =
+     , HasLogFunc (env c)
-  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
+     , MonadUnliftIO m
-  <$> callMethod cl bus path omInterface getManagedObjects
+     , SafeClient c
     , HasClient env
     )
  => 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 $ fromMaybe M.empty $ fromSingletonVariant v
-addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
+addInterfaceChangedListener
-  -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: ( MonadReader (env c) m
-addInterfaceChangedListener bus prop path sc cl = do
+     , HasLogFunc (env c)
-  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
+     , MonadUnliftIO m
-  forM rule $ \r -> addMatchCallback r sc cl
+     , SafeClient c
     , HasClient env
     )
  => BusName
  -> MemberName
  -> ObjectPath
  -> SignalCallback m
  -> 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 <> "'"
-addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
+addInterfaceAddedListener
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: ( MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> ObjectPath
  -> SignalCallback m
  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
  addInterfaceChangedListener bus omInterfacesAdded
-addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
+addInterfaceRemovedListener
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: ( MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     , SafeClient c
     , HasClient env
     )
  => BusName
  -> ObjectPath
  -> SignalCallback m
  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
  addInterfaceChangedListener bus omInterfacesRemoved
 --------------------------------------------------------------------------------
 -- Interface export/unexport
 exportPair
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
  => ObjectPath
  -> (Client -> m Interface)
  -> c
  -> (m (), m ())
 exportPair path toIface cl = (up, down)
  where
    cl_ = toClient 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
 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
--- a/lib/XMonad/Internal/Command/DMenu.hs
+++ b/lib/XMonad/Internal/Command/DMenu.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Dmenu (Rofi) Commands
+-- Dmenu (Rofi) Commands
 module XMonad.Internal.Command.DMenu
  ( runCmdMenu
@ -15,35 +15,31 @@ module XMonad.Internal.Command.DMenu
  , runBTMenu
  , runShowKeys
  , runAutorandrMenu
-  ) where
+  )
-
+where
 import           Control.Monad.Reader
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
-
+import qualified Data.ByteString.Char8 as BC
 import Data.Internal.DBus
 import Data.Internal.XIO
 import Graphics.X11.Types
-
+import RIO
-import qualified RIO.Text                        as T
+import qualified RIO.ByteString as B
-
+import RIO.Directory
 import           System.Directory
  ( XdgDirectory (..)
  , getXdgDirectory
  )
-import           System.IO
+import qualified RIO.Text as T
-
+-- import System.IO
 import XMonad.Core hiding (spawn)
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
 import XMonad.Internal.Notify
 import           XMonad.Internal.Process
 import XMonad.Internal.Shell
 import XMonad.Util.NamedActions
 --------------------------------------------------------------------------------
-- | DMenu executables
+-- DMenu executables
 myDmenuCmd :: FilePath
 myDmenuCmd = "rofi"
@ -70,7 +66,7 @@ myClipboardManager :: FilePath
 myClipboardManager = "greenclip"
 --------------------------------------------------------------------------------
-- | Packages
+-- Packages
 dmenuPkgs :: [Fulfillment]
 dmenuPkgs = [Package Official "rofi"]
@ -79,9 +75,9 @@ clipboardPkgs :: [Fulfillment]
 clipboardPkgs = [Package AUR "rofi-greenclip"]
 --------------------------------------------------------------------------------
-- | Other internal functions
+-- Other internal functions
-spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
+spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
 spawnDmenuCmd n =
  sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
@ -101,111 +97,153 @@ dmenuDep :: IODependency_
 dmenuDep = sysExe dmenuPkgs myDmenuCmd
 --------------------------------------------------------------------------------
-- | Exported Commands
+-- Exported Commands
 -- TODO test that veracrypt and friends are installed
-runDevMenu :: SometimesX
+runDevMenu :: MonadUnliftIO m => Sometimes (m ())
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
  where
    t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
    x = do
      c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
-      spawnCmd myDmenuDevices
+      spawnCmd myDmenuDevices $
-        $ ["-c", T.pack c]
+        ["-c", T.pack c]
-        ++ "--" : themeArgs "#999933"
+          ++ "--"
          : themeArgs "#999933"
          ++ myDmenuMatchingArgs
 -- TODO test that bluetooth interface exists
-runBTMenu :: SometimesX
+runBTMenu :: MonadUnliftIO m => Sometimes (m ())
-runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
+runBTMenu =
  Sometimes
    "bluetooth selector"
    xpfBluetooth
    [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
  where
    cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
    tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
-runVPNMenu :: SometimesX
+runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
-runVPNMenu = Sometimes "VPN selector" xpfVPN
+runVPNMenu =
  Sometimes
    "VPN selector"
    xpfVPN
    [Subfeature (IORoot_ cmd tree) "rofi VPN"]
  where
-    cmd = spawnCmd myDmenuVPN
+    cmd =
-      $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
+      spawnCmd myDmenuVPN $
-    tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
+        ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
-      $ socketExists "expressVPN" []
+    tree =
-      $ return "/var/lib/expressvpn/expressvpnd.socket"
+      dmenuTree $
        toAnd_ (localExe [] myDmenuVPN) $
          socketExists "expressVPN" [] $
            return "/var/lib/expressvpn/expressvpnd.socket"
-runCmdMenu :: SometimesX
+runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
-runAppMenu :: SometimesX
+runAppMenu :: MonadUnliftIO m => Sometimes (m ())
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
-runWinMenu :: SometimesX
+runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
-runNetMenu :: Maybe SysClient -> SometimesX
+runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
-runNetMenu cl = Sometimes "network control menu" enabled
+runNetMenu cl =
  Sometimes
    "network control menu"
    enabled
    [Subfeature root "network control menu"]
  where
    enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
    root = DBusRoot_ cmd tree cl
    cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
-    tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
+    tree =
-      $ toAnd_ (DBusIO dmenuDep) $ DBusIO
+      And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
-      $ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
+        toAnd_ (DBusIO dmenuDep) $
          DBusIO $
            sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
-runAutorandrMenu :: SometimesX
+runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
 runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
  where
    cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
    tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
 --------------------------------------------------------------------------------
-- | Password manager
+-- Password manager
-runBwMenu :: Maybe SesClient -> SometimesX
+runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
  where
-    cmd _ = spawnCmd myDmenuPasswords
+    cmd _ =
-      $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
+      spawnCmd myDmenuPasswords $
-    tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
+        ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-      $ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
+    tree =
      And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
        toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
 --------------------------------------------------------------------------------
-- | Clipboard
+-- Clipboard
-runClipMenu :: SometimesX
+runClipMenu :: MonadUnliftIO m => Sometimes (m ())
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
  where
    act = spawnCmd myDmenuCmd args
-    tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
+    tree =
      listToAnds
        dmenuDep
        [ sysExe clipboardPkgs myClipboardManager
        , process [] $ T.pack myClipboardManager
        ]
-    args = [ "-modi", "\"clipboard:greenclip print\""
+    args =
-           , "-show", "clipboard"
+      [ "-modi"
-           , "-run-command", "'{cmd}'"
+      , "\"clipboard:greenclip print\""
-           ] ++ themeArgs "#00c44e"
+      , "-show"
      , "clipboard"
      , "-run-command"
      , "'{cmd}'"
      ]
        ++ themeArgs "#00c44e"
 --------------------------------------------------------------------------------
-- | Shortcut menu
+-- Shortcut menu
-runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
+runShowKeys
-runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  $ FallbackAlone fallback
+  => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
 runShowKeys =
  Always "keyboard menu" $
    Option showKeysDMenu $
      Always_ $
        FallbackAlone fallback
  where
    -- TODO this should technically depend on dunst
-    fallback = const $ spawnNotify
+    fallback =
-      $ defNoteError { body = Just $ Text "could not display keymap" }
+      const $
        spawnNotify $
          defNoteError {body = Just $ Text "could not display keymap"}
-showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
+showKeysDMenu
-showKeysDMenu = Subfeature
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
 showKeysDMenu =
  Subfeature
    { sfName = "keyboard shortcut menu"
    , sfData = IORoot_ showKeys $ Only_ dmenuDep
    }
-showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
+showKeys
-showKeys kbs = io $ do
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-      (h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe }
+  => [((KeyMask, KeySym), NamedAction)]
-      forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
+  -> m ()
 showKeys kbs = do
  h <- spawnPipe cmd
  B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
  hClose h
  where
-    cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
+    cmd =
-      ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
+      fmtCmd myDmenuCmd $
        ["-dmenu", "-p", "commands"]
          ++ themeArgs "#7f66ff"
          ++ myDmenuMatchingArgs
--- a/lib/XMonad/Internal/Command/Desktop.hs
+++ b/lib/XMonad/Internal/Command/Desktop.hs
@ -1,12 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | General commands
+-- General commands
 module XMonad.Internal.Command.Desktop
  ( myTerm
  , playSound
  -- commands
  , runTerm
  , runTMux
@ -33,40 +32,32 @@ module XMonad.Internal.Command.Desktop
  , runNotificationCloseAll
  , runNotificationHistory
  , runNotificationContext
  -- daemons
  , runNetAppDaemon
  -- packages
  , networkManagerPkgs
-  ) where
+  )
-
+where
 import           Control.Monad               (void)
 import           Control.Monad.IO.Class
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import RIO.Directory
 import RIO.FilePath
 import qualified RIO.Process as P
 import qualified RIO.Text as T
 import           System.Directory
 import           System.Environment
 import System.Posix.User
-
+import UnliftIO.Environment
 import           XMonad                      (asks)
 import XMonad.Actions.Volume
 import XMonad.Core hiding (spawn)
 import XMonad.Internal.DBus.Common
 import XMonad.Internal.Notify
-import           XMonad.Internal.Process
+import XMonad.Internal.Shell as S
 import           XMonad.Internal.Shell
 import XMonad.Operations
 --------------------------------------------------------------------------------
-- | My Executables
+-- My Executables
 myTerm :: FilePath
 myTerm = "urxvt"
@ -99,10 +90,11 @@ myNotificationCtrl :: FilePath
 myNotificationCtrl = "dunstctl"
 --------------------------------------------------------------------------------
-- | Packages
+-- Packages
 myTermPkgs :: [Fulfillment]
-myTermPkgs = [ Package Official "rxvt-unicode"
+myTermPkgs =
  [ Package Official "rxvt-unicode"
  , Package Official "urxvt-perls"
  ]
@ -119,78 +111,101 @@ networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]
 --------------------------------------------------------------------------------
-- | Misc constants
+-- Misc constants
 volumeChangeSound :: FilePath
 volumeChangeSound = "smb_fireball.wav"
 --------------------------------------------------------------------------------
-- | Some nice apps
+-- Some nice apps
-runTerm :: SometimesX
+runTerm :: MonadUnliftIO m => Sometimes (m ())
 runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
-runTMux :: SometimesX
+runTMux :: MonadUnliftIO m => Sometimes (m ())
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
  where
-    deps = listToAnds (socketExists "tmux" [] socketName)
+    deps =
-      $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
+      listToAnds (socketExists "tmux" [] socketName) $
-    act = spawn
+        fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
-      $ T.unpack
+    act =
-      $ fmtCmd "tmux" ["has-session"]
+      S.spawn $
        fmtCmd "tmux" ["has-session"]
          #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
          #!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
    c = "exec tmux attach-session -d"
    msg = "could not connect to tmux session"
    socketName = do
-      u <- getEffectiveUserID
+      u <- liftIO getEffectiveUserID
      t <- getTemporaryDirectory
      return $ t </> "tmux-" ++ show u </> "default"
-runCalc :: SometimesX
+runCalc :: MonadUnliftIO m => Sometimes (m ())
 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 :: SometimesX
+runBrowser :: MonadUnliftIO m => Sometimes (m ())
-runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
+runBrowser =
-  False myBrowser
+  sometimesExe
    "web browser"
    "brave"
    [Package AUR "brave-bin"]
    False
    myBrowser
-runEditor :: SometimesX
+runEditor :: MonadUnliftIO m => Sometimes (m ())
 runEditor = sometimesIO_ "text editor" "emacs" tree cmd
  where
-    cmd = spawnCmd myEditor
+    cmd =
      spawnCmd
        myEditor
        ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
    -- NOTE 1: we could test if the emacs socket exists, but it won't come up
    -- before xmonad starts, so just check to see if the process has started
    tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
-runFileManager :: SometimesX
+runFileManager :: MonadUnliftIO m => Sometimes (m ())
-runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
+runFileManager =
-  True "pcmanfm"
+  sometimesExe
    "file browser"
    "pcmanfm"
    [Package Official "pcmanfm"]
    True
    "pcmanfm"
 --------------------------------------------------------------------------------
-- | Multimedia Commands
+-- Multimedia Commands
-runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
+runMultimediaIfInstalled
-runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
+  :: MonadUnliftIO m
-  "playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
+  => T.Text
  -> T.Text
  -> Sometimes (m ())
 runMultimediaIfInstalled n cmd =
  sometimesExeArgs
    (T.append n " multimedia control")
    "playerctl"
    [Package Official "playerctl"]
    True
    myMultimediaCtl
    [cmd]
-runTogglePlay :: SometimesX
+runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
-runPrevTrack :: SometimesX
+runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
-runNextTrack :: SometimesX
+runNextTrack :: MonadUnliftIO m => Sometimes (m ())
 runNextTrack = runMultimediaIfInstalled "next track" "next"
-runStopPlay :: SometimesX
+runStopPlay :: MonadUnliftIO m => Sometimes (m ())
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 --------------------------------------------------------------------------------
-- | Volume Commands
+-- Volume Commands
 soundDir :: FilePath
 soundDir = "sound"
@ -202,111 +217,140 @@ playSound file = do
  -- paplay seems to have less latency than aplay
  spawnCmd "paplay" [T.pack p]
-featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
+featureSound
  :: MonadUnliftIO m
  => T.Text
  -> FilePath
  -> m ()
  -> m ()
  -> Sometimes (m ())
 featureSound n file pre post =
-  sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree
+  sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
-  $ pre >> playSound file >> post
+    pre >> playSound file >> post
  where
    -- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
    -- to play sound (duh) but libpulse is the package with the paplay binary
    tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
-runVolumeDown :: SometimesX
+runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
-runVolumeUp :: SometimesX
+runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
-runVolumeMute :: SometimesX
+runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 --------------------------------------------------------------------------------
-- | Notification control
+-- Notification control
-runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
+runNotificationCmd
  :: MonadUnliftIO m
  => T.Text
  -> T.Text
  -> Maybe SesClient
  -> Sometimes (m ())
 runNotificationCmd n arg cl =
  sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
  where
    cmd _ = spawnCmd myNotificationCtrl [arg]
-    tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
+    tree =
-      $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
+      toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
-      $ Method_ $ memberName_ "NotificationAction"
+        Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
          Method_ $
            memberName_ "NotificationAction"
-runNotificationClose :: Maybe SesClient -> SometimesX
+runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
-runNotificationCloseAll :: Maybe SesClient -> SometimesX
+runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationCloseAll =
  runNotificationCmd "close all notifications" "close-all"
-runNotificationHistory :: Maybe SesClient -> SometimesX
+runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationHistory =
  runNotificationCmd "see notification history" "history-pop"
-runNotificationContext :: Maybe SesClient -> SometimesX
+runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationContext =
  runNotificationCmd "open notification context" "context"
 --------------------------------------------------------------------------------
-- | System commands
+-- System commands
 -- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
+runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
-runNetAppDaemon cl = Sometimes "network applet" xpfVPN
+runNetAppDaemon cl =
  Sometimes
    "network applet"
    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 _ = snd <$> spawnPipe "nm-applet"
+    cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
-runToggleBluetooth :: Maybe SysClient -> SometimesX
+runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
-runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
+runToggleBluetooth cl =
  Sometimes
    "bluetooth toggle"
    xpfBluetooth
    [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
  where
    tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
-    cmd _ = spawn
+    cmd _ =
-      $ T.unpack
+      S.spawn $
-      $ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""]
+        fmtCmd myBluetooth ["show"]
          #!| "grep -q \"Powered: no\""
          #!&& "a=on"
          #!|| "a=off"
          #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
-runToggleEthernet :: SometimesX
+runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
-runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
+runToggleEthernet =
  Sometimes
    "ethernet toggle"
    xpfEthernet
    [Subfeature root "nmcli"]
  where
-    root = IORoot (spawn . T.unpack . cmd) $ And1 (Only readEthernet) $ Only_
+    root =
-      $ sysExe networkManagerPkgs "nmcli"
+      IORoot cmd $
        And1 (Only readEthernet) $
          Only_ $
            sysExe networkManagerPkgs "nmcli"
    -- TODO make this less noisy
    cmd iface =
-      T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"]
+      S.spawn $
        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
+-- Configuration commands
 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
  -- assume that the conf directory contains a valid stack project
  confDir <- asks (cfgDir . directories)
-  spawnAt confDir
+  spawn $
-    $ T.unpack
+    fmtCmd "cd" [T.pack confDir]
-    $ fmtCmd "stack" ["install"]
+      #!&& fmtCmd "stack" ["install"]
      #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
      #!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
 --------------------------------------------------------------------------------
-- | Screen capture commands
+-- Screen capture commands
-getCaptureDir :: IO FilePath
+getCaptureDir :: MonadIO m => m FilePath
 getCaptureDir = do
  e <- lookupEnv "XDG_DATA_HOME"
  parent <- case e of
@ -320,28 +364,38 @@ getCaptureDir = do
  where
    fallback = (</> ".local/share") <$> getHomeDirectory
-runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
+runFlameshot
  :: MonadUnliftIO m
  => T.Text
  -> T.Text
  -> Maybe SesClient
  -> Sometimes (m ())
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
  where
    cmd _ = spawnCmd myCapture [mode]
-    tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
+    tree =
-      $ Bus [] $ busName_ "org.flameshot.Flameshot"
+      toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
        Bus [] $
          busName_ "org.flameshot.Flameshot"
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: Maybe SesClient -> SometimesX
+runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 -- myWindowCap = "screencap -w" --external script
-runDesktopCapture :: Maybe SesClient -> SometimesX
+runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
-runScreenCapture :: Maybe SesClient -> SometimesX
+runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
-runCaptureBrowser :: SometimesX
+runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
-runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
+runCaptureBrowser = sometimesIO_
-  (Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
+  "screen capture browser"
-  dir <- io getCaptureDir
+  "feh"
  (Only_ $ sysExe [Package Official "feh"] myImageBrowser)
  $ do
    dir <- getCaptureDir
    spawnCmd myImageBrowser [T.pack dir]
--- a/lib/XMonad/Internal/Command/Power.hs
+++ b/lib/XMonad/Internal/Command/Power.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Commands for controlling power
+-- Commands for controlling power
 module XMonad.Internal.Command.Power
 -- commands
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
  , runSuspend
  , runSuspendPrompt
  , runQuitPrompt
  -- daemons
  , runAutolock
  -- functions
  , hasBattery
  , suspendPrompt
@ -25,35 +23,25 @@ module XMonad.Internal.Command.Power
  , powerPrompt
  , defFontPkgs
  , promptFontDep
-  ) where
+  )
-
+where
 import           Control.Arrow               (first)
 import           Data.Internal.Dependency
 import           Data.Either
 import qualified Data.Map                    as M
 import Data.Internal.XIO
 import Graphics.X11.Types
-
+import RIO
 import RIO.Directory
 import RIO.FilePath
 import qualified RIO.Map as M
 import qualified RIO.Process as P
 import qualified RIO.Text as T
-
+import XMonad.Core hiding (spawn)
 import           System.Directory
 import           System.Exit
 import           System.IO.Error
 import           System.Process              (ProcessHandle)
 import           XMonad.Core
 import           XMonad.Internal.Process     (spawnPipeArgs)
 import XMonad.Internal.Shell
 import qualified XMonad.Internal.Theme as XT
 import XMonad.Prompt
 import XMonad.Prompt.ConfirmPrompt
 --------------------------------------------------------------------------------
-- | Executables
+-- Executables
 myScreenlock :: FilePath
 myScreenlock = "screenlock"
@ -64,42 +52,49 @@ myPrimeOffload :: FilePath
 myPrimeOffload = "prime-offload"
 --------------------------------------------------------------------------------
-- | Packages
+-- Packages
 optimusPackages :: [Fulfillment]
 optimusPackages = [Package AUR "optimus-manager"]
 --------------------------------------------------------------------------------
-- | Core commands
+-- Core commands
 runScreenLock :: SometimesX
-runScreenLock = sometimesExe "screen locker" "i3lock script"
+runScreenLock =
-  [Package AUR "i3lock-color"] False myScreenlock
+  sometimesExe
    "screen locker"
    "i3lock script"
    [Package AUR "i3lock-color"]
    False
    myScreenlock
-runPowerOff :: X ()
+runPowerOff :: MonadUnliftIO m => m ()
 runPowerOff = spawn "systemctl poweroff"
-runSuspend :: X ()
+runSuspend :: MonadUnliftIO m => m ()
 runSuspend = spawn "systemctl suspend"
-runHibernate :: X ()
+runHibernate :: MonadUnliftIO m => m ()
 runHibernate = spawn "systemctl hibernate"
-runReboot :: X ()
+runReboot :: MonadUnliftIO m => m ()
 runReboot = spawn "systemctl reboot"
 --------------------------------------------------------------------------------
-- | Autolock
+-- Autolock
-runAutolock :: Sometimes (IO ProcessHandle)
+runAutolock :: Sometimes (XIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
  where
-    tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
+    tree =
-      $ Only_ $ IOSometimes_ runScreenLock
+      And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
-    cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
+        Only_ $
          IOSometimes_ runScreenLock
    cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
 --------------------------------------------------------------------------------
-- | Confirmation prompts
+-- Confirmation prompts
 promptFontDep :: IOTree XT.FontBuilder
 promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
@ -111,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?" runSuspend
+suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
 quitPrompt :: XT.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -127,21 +122,24 @@ runQuitPrompt :: SometimesX
 runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
 --------------------------------------------------------------------------------
-- | Nvidia Optimus
+-- Nvidia Optimus
 -- TODO for some reason the screen never wakes up after suspend when
 -- the nvidia card is up, so block suspend if nvidia card is running
 -- and warn user
-isUsingNvidia :: IO Bool
+isUsingNvidia :: MonadUnliftIO m => m Bool
 isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
-hasBattery :: IO (Maybe T.Text)
+hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
 hasBattery = do
-  ps <- fromRight [] <$> tryIOError (listDirectory syspath)
+  ps <- fromRight [] <$> tryIO (listDirectory syspath)
-  ts <- mapM readType ps
+  ts <- catMaybes <$> mapM readType ps
-  return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
+  return $
    if any (T.isPrefixOf "Battery") ts
      then Nothing
      else Just "battery not found"
  where
-    readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
+    readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
    syspath = "/sys/class/power_supply"
 runOptimusPrompt' :: XT.FontBuilder -> X ()
@ -151,27 +149,32 @@ runOptimusPrompt' fb = do
  where
    switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
    prompt mode = T.concat ["gpu switch to ", mode, "?"]
-    cmd mode = spawn $
+    cmd mode =
-      T.unpack
+      spawn $
-      $ T.pack myPrimeOffload
+        T.pack myPrimeOffload
          #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
          #!&& "killall xmonad"
 runOptimusPrompt :: SometimesX
-runOptimusPrompt = Sometimes "graphics switcher"
+runOptimusPrompt =
-  (\x -> xpfOptimus x && xpfBattery x) [s]
+  Sometimes
    "graphics switcher"
    (\x -> xpfOptimus x && xpfBattery x)
    [s]
  where
    s = Subfeature {sfData = r, sfName = "optimus manager"}
    r = IORoot runOptimusPrompt' t
-    t = And1 promptFontDep
+    t =
-      $ listToAnds (socketExists "optimus-manager" [] socketName)
+      And1 promptFontDep $
-      $ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
+        listToAnds (socketExists "optimus-manager" [] socketName) $
          sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
    socketName = (</> "optimus-manager") <$> getTemporaryDirectory
 --------------------------------------------------------------------------------
-- | Universal power prompt
+-- Universal power prompt
-data PowerMaybeAction = Poweroff
+data PowerMaybeAction
  = Poweroff
  | Shutdown
  | Hibernate
  | Reboot
@ -207,9 +210,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
  where
    comp = mkComplFunFromList theme []
    theme = (XT.promptTheme fb) {promptKeymap = keymap}
-    keymap = M.fromList
+    keymap =
-      $ ((controlMask, xK_g), quit) :
+      M.fromList $
-      map (first $ (,) 0)
+        ((controlMask, xK_g), quit)
          : map
            (first $ (,) 0)
            [ (xK_p, sendMaybeAction Poweroff)
            , (xK_s, sendMaybeAction Shutdown)
            , (xK_h, sendMaybeAction Hibernate)
@ -219,7 +224,7 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
            ]
    sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
    executeMaybeAction a = case toEnum $ read a of
-      Poweroff  -> runPowerOff
+      Poweroff -> liftIO runPowerOff
-      Shutdown  -> lock >> runSuspend
+      Shutdown -> lock >> liftIO runSuspend
-      Hibernate -> lock >> runHibernate
+      Hibernate -> lock >> liftIO runHibernate
-      Reboot    -> runReboot
+      Reboot -> liftIO runReboot
--- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs
+++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs
@ -2,26 +2,19 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Concurrent module to handle events from acpid
+-- Concurrent module to handle events from acpid
 module XMonad.Internal.Concurrent.ACPIEvent
  ( runPowermon
  , runHandleACPI
-  ) where
+  )
-
+where
 import           Control.Exception
 import           Control.Monad
 import           Data.ByteString                          hiding (readFile)
 import           Data.ByteString.Char8                    as C hiding (readFile)
 import           Data.Connection
 import           Data.Internal.Dependency
 import           Text.Read                                (readMaybe)
 import           System.IO.Streams                        as S (read)
 import           System.IO.Streams.UnixSocket
 import Data.Internal.XIO
 import Network.Socket
 import Network.Socket.ByteString
 import RIO
 import qualified RIO.ByteString as B
 import XMonad.Core
 import XMonad.Internal.Command.Power
 import XMonad.Internal.Concurrent.ClientMessage
@ -29,12 +22,13 @@ import           XMonad.Internal.Shell
 import XMonad.Internal.Theme (FontBuilder)
 --------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about
+-- Data structure to hold the ACPI events I care about
 --
 -- Enumerate so these can be converted to strings and back when sent in a
 -- ClientMessage event to X
-data ACPIEvent = Power
+data ACPIEvent
  = Power
  | Sleep
  | LidClose
  deriving (Eq)
@ -50,7 +44,7 @@ instance Enum ACPIEvent where
  fromEnum LidClose = 2
 --------------------------------------------------------------------------------
-- | Internal functions
+-- Internal functions
 -- | Convert a string to an ACPI event (this string is assumed to come from
 -- the acpid socket)
@ -64,7 +58,9 @@ parseLine line =
    (_ : "LID" : "close" : _) -> Just LidClose
    _ -> Nothing
  where
-    splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
+    splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
    newline = 10
    space = 32
 -- | Send an ACPIEvent to the X server as a ClientMessage
 sendACPIEvent :: ACPIEvent -> IO ()
@ -72,20 +68,18 @@ sendACPIEvent = sendXMsg ACPI . show . fromEnum
 isDischarging :: IO (Maybe Bool)
 isDischarging = do
-  status <- try $ readFile "/sys/class/power_supply/BAT0/status"
+  status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
    :: IO (Either IOException String)
  case status of
    Left _ -> return Nothing
    Right s -> return $ Just (s == "Discharging")
 listenACPI :: IO ()
 listenACPI = do
-  Connection { source = s } <- connect acpiPath
+  sock <- socket AF_UNIX Stream defaultProtocol
-  forever $ readStream s
+  connect sock $ SockAddrUnix acpiPath
-  where
+  forever $ do
-    readStream s = do
+    out <- recv sock 1024
-      out <- S.read s
+    mapM_ sendACPIEvent $ parseLine out
      mapM_ sendACPIEvent $ parseLine =<< out
 acpiPath :: FilePath
 acpiPath = "/var/run/acpid.socket"
@ -104,22 +98,24 @@ handleACPI fb lock tag = do
    LidClose -> do
      status <- io isDischarging
      -- only run suspend if battery exists and is discharging
-      forM_ status $ flip when runSuspend
+      forM_ status $ flip when $ liftIO runSuspend
      lock
 --------------------------------------------------------------------------------
-- | Exported API
+-- Exported API
 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
 -- and send ClientMessage events when it receives them
 runPowermon :: SometimesIO
-runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
+runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep $ io listenACPI
 runHandleACPI :: Always (String -> X ())
 runHandleACPI = Always "ACPI event handler" $ Option sf fallback
  where
    sf = Subfeature withLock "acpid prompt"
-    withLock = IORoot (uncurry handleACPI)
+    withLock =
-      $ And12 (,) promptFontDep $ Only
+      IORoot (uncurry handleACPI) $
-      $ IOSometimes runScreenLock id
+        And12 (,) promptFontDep $
          Only $
            IOSometimes runScreenLock id
    fallback = Always_ $ FallbackAlone $ const skip
--- a/lib/XMonad/Internal/Concurrent/ClientMessage.hs
+++ b/lib/XMonad/Internal/Concurrent/ClientMessage.hs
@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
-- | Core ClientMessage module to 'achieve' concurrency in XMonad
+-- Core ClientMessage module to 'achieve' concurrency in XMonad
 --
 -- Since XMonad is single threaded, the only way to have multiple threads that
 -- listen/react to non-X events is to spawn other threads the run outside of
@ -19,23 +19,25 @@ module XMonad.Internal.Concurrent.ClientMessage
  ( XMsgType (..)
  , sendXMsg
  , splitXMsg
-  ) where
+  )
 where
 import Data.Char
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Display
 import Graphics.X11.Xlib.Event
 import Graphics.X11.Xlib.Extras
 import XMonad.Internal.IO
 --------------------------------------------------------------------------------
-- | Data structure for the ClientMessage
+-- Data structure for the ClientMessage
 --
 -- These are the "types" of client messages to send; add more here as needed
 -- TODO is there a way to do this in the libraries that import this one?
-data XMsgType = ACPI
+data XMsgType
  = ACPI
  | Workspace
  | Unknown
  deriving (Eq, Show)
@ -50,7 +52,7 @@ instance Enum XMsgType where
  fromEnum Unknown = 2
 --------------------------------------------------------------------------------
-- | Exported API
+-- Exported API
 -- | Given a string from the data field in a ClientMessage event, return the
 -- type and payload
@ -58,13 +60,12 @@ splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
 splitXMsg [] = (Unknown, "")
 splitXMsg (x : xs) = (xtype, tag)
  where
-    xtype = toEnum $ fromInteger $ toInteger x
+    xtype = toEnum $ fromIntegral x
-    tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs
+    tag = chr . fromIntegral <$> takeWhile (/= 0) xs
 -- | Emit a ClientMessage event to the X server with the given type and payloud
 sendXMsg :: XMsgType -> String -> IO ()
-sendXMsg xtype tag = do
+sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
  dpy <- openDisplay ""
  root <- rootWindow dpy $ defaultScreen dpy
  allocaXEvent $ \e -> do
    setEventType e clientMessage
@ -84,8 +85,6 @@ sendXMsg xtype tag = do
    -- for more details.
    setClientMessageEvent' e root bITMAP 8 (x : t)
    sendEvent dpy root False substructureNotifyMask e
  flush dpy
  closeDisplay dpy
  where
    x = fromIntegral $ fromEnum xtype
    t = fmap (fromIntegral . fromEnum) tag
--- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
+++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
@ -1,7 +1,7 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Automatically Manage Dynamic Workspaces
+-- Automatically Manage Dynamic Workspaces
 -- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
 -- in the contrib library. The general behavior this allows:
 -- 1) launch app
@ -33,25 +33,26 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
  , runWorkspaceMon
  , spawnOrSwitch
  , doSink
-  ) where
+  )
-
+where
 import           Data.List                                (deleteBy, find)
 import qualified Data.Map                                 as M
 import           Data.Maybe
 import           Control.Concurrent
 import           Control.Monad
 import           Control.Monad.Reader
 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
 import Graphics.X11.Xlib.Event
 import Graphics.X11.Xlib.Extras
 import Graphics.X11.Xlib.Misc
 import Graphics.X11.Xlib.Types
-
+import RIO hiding
  ( Display
  , display
  )
 import RIO.List (deleteBy, find)
 import qualified RIO.Map as M
 import qualified RIO.Set as S
 import System.Process
 import XMonad.Actions.DynamicWorkspaces
 import XMonad.Core
  ( ManageHook
@ -62,14 +63,14 @@ import           XMonad.Core
  )
 import XMonad.Hooks.ManageHelpers (MaybeManageHook)
 import XMonad.Internal.Concurrent.ClientMessage
-import           XMonad.Internal.Process
+import XMonad.Internal.IO
 import XMonad.ManageHook
 import XMonad.Operations
 import qualified XMonad.StackSet as W
 --------------------------------------------------------------------------------
-- | Dynamic Workspace datatype
+-- Dynamic Workspace datatype
-- This hold all the data needed to tie an app to a particular dynamic workspace
+-- This holds all the data needed to tie an app to a particular dynamic workspace
 data DynWorkspace = DynWorkspace
  { dwName :: String
@ -82,7 +83,7 @@ data DynWorkspace = DynWorkspace
  }
 --------------------------------------------------------------------------------
-- | Manager thread
+-- Manager thread
 -- The main thread that watches for new windows. When a match is found, this
 -- thread spawns a new thread the waits for the PID of the window to exit. When
 -- the PID exits, it sends a ClientMessage event to X
@ -91,79 +92,93 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String
-type WatchedPIDs = MVar [Pid]
+data WEnv = WEnv
-
+  { wDisplay :: !Display
-data WConf = WConf
+  , wDynWorkspaces :: ![DynWorkspace]
-    { display       :: Display
+  , wCurPIDs :: !(MVar (S.Set Pid))
-    , dynWorkspaces :: [DynWorkspace]
+  , wXEnv :: !XEnv
  }
-newtype W a = W (ReaderT WConf IO a)
+instance HasLogFunc WEnv where
-  deriving (Functor, Monad, MonadIO, MonadReader WConf)
+  logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
-instance Applicative W where
+type WIO a = RIO WEnv a
  pure = return
  (<*>) = ap
-runW :: WConf -> W a -> IO a
+runWorkspaceMon :: [DynWorkspace] -> XIO ()
-runW c (W a) = runReaderT a c
+runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
-
+  root <- liftIO $ rootWindow dpy $ defaultScreen dpy
 runWorkspaceMon :: [DynWorkspace] -> IO ()
 runWorkspaceMon dws = do
  dpy <- openDisplay ""
  root <- rootWindow dpy $ defaultScreen dpy
  curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
  -- listen only for substructure change events (which includes MapNotify)
-  allocaSetWindowAttributes $ \a -> do
+  liftIO $ allocaSetWindowAttributes $ \a -> do
    set_event_mask a substructureNotifyMask
    changeWindowAttributes dpy root cWEventMask a
-  let c = WConf { display = dpy, dynWorkspaces = dws }
+  withRunInIO $ \runIO -> do
-  _ <- allocaXEvent $ \e ->
+    void $ allocaXEvent $ runIO . withEvents dpy
-    runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
+  where
-  return ()
+    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
        forever $
          handleEvent =<< io (nextEvent dpy e >> getEvent e)
-handle :: WatchedPIDs -> Event -> W ()
+handleEvent :: Event -> WIO ()
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
-handle curPIDs MapNotifyEvent { ev_window = w } = do
+handleEvent MapNotifyEvent {ev_window = w} = do
-  dpy <- asks display
+  dpy <- asks wDisplay
  hint <- io $ getClassHint dpy w
-  dws <- asks dynWorkspaces
+  dws <- asks wDynWorkspaces
-  let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
+  let tag =
-  let tag = M.lookup (resClass hint) m
+        M.lookup (resClass hint) $
-  io $ forM_ tag $ \t -> do
+          M.fromList $
-    a <- internAtom dpy "_NET_WM_PID" False
+            fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
-    pid <- getWindowProperty32 dpy a w
+  forM_ tag $ \t -> do
    a <- io $ internAtom dpy "_NET_WM_PID" False
    pid <- io $ getWindowProperty32 dpy a w
    case pid of
      -- ASSUMPTION windows will only have one PID at one time
-      Just [p] -> let p' = fromIntegral p
+      Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
        in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
      _ -> return ()
 handleEvent _ = return ()
-handle _ _ = return ()
+withUniquePid :: Pid -> String -> WIO ()
-
+withUniquePid pid tag = do
-waitAndKill :: String -> Pid -> IO ()
+  ps <- asks wCurPIDs
-waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
+  pids <- readMVar ps
-
+  unless (pid `elem` pids)
-withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
+    $ bracket_
-withUniquePid curPIDs pid f = do
+      (modifyMVar_ ps (return . S.insert pid))
-  pids <- readMVar curPIDs
+      (modifyMVar_ ps (return . S.delete pid))
-  unless (pid `elem` pids) $ do
+    $ do
-    modifyMVar_ curPIDs (return . (pid:))
+      logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
-    f
+      waitUntilExit pid
-    modifyMVar_ curPIDs (return . filter (/=pid))
+      logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
      liftIO $ sendXMsg Workspace tag
  where
    pid_ = "'" <> displayShow pid <> "'"
    tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
 --------------------------------------------------------------------------------
-- | Launching apps
+-- 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 $ map W.tag $ filter (isJust . W.stack)
+wsOccupied tag ws =
  elem tag $
    map W.tag $
      filter (isJust . W.stack)
      -- list of all workspaces with windows on them
      -- TODO is there not a better way to do this?
-  $ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
+      $
        W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
 spawnOrSwitch :: WorkspaceId -> X () -> X ()
 spawnOrSwitch tag cmd = do
@ -171,7 +186,7 @@ spawnOrSwitch tag cmd = do
  if occupied then windows $ W.view tag else cmd
 --------------------------------------------------------------------------------
-- | Managehook
+-- Managehook
 -- Move windows to new workspace if they are part of a dynamic workspace
 -- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
@ -196,25 +211,27 @@ doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
  Nothing -> s
 --------------------------------------------------------------------------------
-- | Eventhook
+-- Eventhook
 -- When an app is closed, this will respond the event that is sent in the main
 -- XMonad thread
 removeDynamicWorkspace :: WorkspaceId -> X ()
 removeDynamicWorkspace target = windows removeIfEmpty
  where
    -- remove workspace if it is empty and if there are hidden workspaces
    removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
      -- if hidden, delete from hidden
-      | Just x <- find isEmptyTarget hall
+      | Just x <- find isEmptyTarget hall =
-      = s { W.hidden = deleteBy (eq W.tag) x hall }
+          s {W.hidden = deleteBy (eq W.tag) x hall}
      -- if visible, delete from visible and move first hidden to its place
-      | Just x <- find (isEmptyTarget . W.workspace) vis
+      | Just x <- find (isEmptyTarget . W.workspace) vis =
-      = s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
+          s
-          , W.hidden = hs }
+            { W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
            , W.hidden = hs
            }
      -- if current, move the first hidden workspace to the current
-      | isEmptyTarget $ W.workspace $ W.current s
+      | isEmptyTarget $ W.workspace $ W.current s =
-      = s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs }
+          s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
      -- otherwise do nothing
      | otherwise = s
    removeIfEmpty s = s
--- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs
+++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs
@ -2,26 +2,21 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 --------------------------------------------------------------------------------
-- | VirtualBox-specific functions
+-- VirtualBox-specific functions
 module XMonad.Internal.Concurrent.VirtualBox
  ( vmExists
  , vmInstanceConfig
  , qual
-  ) where
+  )
-
+where
 import           Control.Exception
 import           Data.Internal.Dependency
 import           Text.XML.Light
 import Data.Internal.XIO
 import RIO hiding (try)
 import RIO.Directory
 import RIO.FilePath
 import qualified RIO.Text as T
-
+import Text.XML.Light
 import           System.Directory
 import XMonad.Internal.Shell
 vmExists :: T.Text -> IO (Maybe Msg)
@ -41,13 +36,15 @@ vmInstanceConfig vmName = do
 vmDirectory :: IO (Either String String)
 vmDirectory = do
  p <- vmConfig
-  (s :: Either IOException String) <- try $ readFile p
+  s <- tryIO $ readFile p
  return $ case s of
    (Left _) -> Left "could not read VirtualBox config file"
-    (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
+    (Right x) ->
-                 $ findDir =<< parseXMLDoc x
+      maybe (Left "Could not parse VirtualBox config file") Right $
        findDir =<< parseXMLDoc x
  where
-    findDir e = findAttr (unqual "defaultMachineFolder")
+    findDir e =
      findAttr (unqual "defaultMachineFolder")
        =<< findChild (qual e "SystemProperties")
        =<< findChild (qual e "Global") e
--- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | DBus module for Clevo Keyboard control
+-- DBus module for Clevo Keyboard control
 module XMonad.Internal.DBus.Brightness.ClevoKeyboard
  ( callGetBrightnessCK
@ -10,24 +11,20 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
  , clevoKeyboardControls
  , clevoKeyboardSignalDep
  , blPath
-  ) where
+  )
-
+where
 import           Control.Monad                          (when)
 import           Data.Int                               (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
 import XMonad.Internal.IO
 --------------------------------------------------------------------------------
-- | Low level sysfs functions
+-- Low level sysfs functions
--
+
 type Brightness = Float
 type RawBrightness = Int32
@ -50,41 +47,41 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
 stateFile :: FilePath
 stateFile = backlightDir </> "state"
-stateChange :: Bool -> IO ()
+stateChange :: MonadUnliftIO m => Bool -> m ()
 stateChange = writeBool stateFile
-stateOn :: IO ()
+stateOn :: MonadUnliftIO m => m ()
 stateOn = stateChange True
-stateOff :: IO ()
+stateOff :: MonadUnliftIO m => m ()
 stateOff = stateChange False
 brightnessFile :: FilePath
 brightnessFile = backlightDir </> "brightness"
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds brightnessFile
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = do
  b <- writePercentMin bounds brightnessFile
  stateOff
  return b
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness bounds = do
  b <- decPercent steps brightnessFile bounds
  when (b == 0) stateOff
  return b
 --------------------------------------------------------------------------------
-- | DBus interface
+-- DBus interface
 blPath :: ObjectPath
 blPath = objectPath_ "/clevo_keyboard"
@ -92,8 +89,9 @@ blPath = objectPath_ "/clevo_keyboard"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
-clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
+clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
-clevoKeyboardConfig = BrightnessConfig
+clevoKeyboardConfig =
  BrightnessConfig
    { bcMin = minBrightness
    , bcMax = maxBrightness
    , bcInc = incBrightness
@ -107,7 +105,7 @@ clevoKeyboardConfig = BrightnessConfig
    }
 --------------------------------------------------------------------------------
-- | Exported haskell API
+-- Exported haskell API
 stateFileDep :: IODependency_
 stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
@ -116,17 +114,39 @@ brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 clevoKeyboardSignalDep :: DBusDependency_ SesClient
-clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
+clevoKeyboardSignalDep =
  -- TODO do I need to get rid of the IO here?
  signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
-exportClevoKeyboard :: Maybe SesClient -> SometimesIO
+exportClevoKeyboard
-exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  [stateFileDep, brightnessFileDep] clevoKeyboardConfig
+  => Maybe SesClient
  -> Sometimes (m (), m ())
 exportClevoKeyboard =
  brightnessExporter
    xpfClevoBacklight
    []
    [stateFileDep, brightnessFileDep]
    clevoKeyboardConfig
-clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
+clevoKeyboardControls
  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
  => Maybe SesClient
  -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
-callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessCK
  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
  => m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
-matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalCK
  :: ( SafeClient c
     , HasLogFunc (env c)
     , HasClient env
     , MonadReader (env c) m
     , MonadUnliftIO m
     )
  => (Maybe Brightness -> m ())
  -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig
--- a/lib/XMonad/Internal/DBus/Brightness/Common.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs
@ -1,7 +1,9 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 --------------------------------------------------------------------------------
-- | DBus module for DBus brightness controls
+-- DBus module for DBus brightness controls
 module XMonad.Internal.DBus.Brightness.Common
  ( BrightnessConfig (..)
@ -11,53 +13,52 @@ module XMonad.Internal.DBus.Brightness.Common
  , callGetBrightness
  , matchSignal
  , signalDep
-  ) where
+  )
-
+where
 import           Control.Monad               (void)
 import           Data.Int                    (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
 import           XMonad.Core                 (io)
 import XMonad.Internal.DBus.Common
 --------------------------------------------------------------------------------
-- | External API
+-- External API
 --
 -- Define four methods to increase, decrease, maximize, or minimize the
 -- brightness. These methods will all return the current brightness as a 32-bit
 -- integer and emit a signal with the same brightness value. Additionally, there
 -- is one method to get the current brightness.
-data BrightnessConfig a b = BrightnessConfig
+data BrightnessConfig m a b = BrightnessConfig
-  { bcMin       :: (a, a) -> IO b
+  { bcMin :: (a, a) -> m b
-  , bcMax       :: (a, a) -> IO b
+  , bcMax :: (a, a) -> m b
-  , bcDec       :: (a, a) -> IO b
+  , bcDec :: (a, a) -> m b
-  , bcInc       :: (a, a) -> IO b
+  , bcInc :: (a, a) -> m b
-  , bcGet       :: (a, a) -> IO b
+  , bcGet :: (a, a) -> m b
  , bcMinRaw :: a
-  , bcGetMax    :: IO a
+  , bcGetMax :: m a
  , bcPath :: ObjectPath
  , bcInterface :: InterfaceName
  , bcName :: T.Text
  }
-data BrightnessControls = BrightnessControls
+data BrightnessControls m = BrightnessControls
-  { bctlMax :: SometimesIO
+  { bctlMax :: Sometimes (m ())
-  , bctlMin :: SometimesIO
+  , bctlMin :: Sometimes (m ())
-  , bctlInc :: SometimesIO
+  , bctlInc :: Sometimes (m ())
-  , bctlDec :: SometimesIO
+  , bctlDec :: Sometimes (m ())
  }
-brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
+brightnessControls
-  -> BrightnessControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
  => XPQuery
  -> BrightnessConfig m a b
  -> Maybe SesClient
  -> BrightnessControls m
 brightnessControls q bc cl =
  BrightnessControls
    { bctlMax = cb "max brightness" memMax
@ -68,91 +69,131 @@ brightnessControls q bc cl =
  where
    cb = callBacklight q cl bc
-callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
+callGetBrightness
-  -> IO (Maybe n)
+  :: ( HasClient env
-callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
+     , MonadReader (env c) m
     , MonadUnliftIO m
     , SafeClient c
     , Num n
     )
  => BrightnessConfig m a b
  -> m (Maybe n)
 callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
  either (const Nothing) bodyGetBrightness
-  <$> callMethod client xmonadBusName p i memGet
+    <$> callMethod xmonadBusName p i memGet
-signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
+signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
  Endpoint [] xmonadBusName p i $ Signal_ memCur
-matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
+matchSignal
-  -> (Maybe n-> IO ()) -> c -> IO ()
+  :: ( HasClient env
     , HasLogFunc (env c)
     , MonadReader (env c) m
     , MonadUnliftIO m
     , SafeClient c
     , Num n
     )
  => BrightnessConfig m a b
  -> (Maybe n -> m ())
  -> 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 = matchAny
+    brMatcher =
      matchAny
        { matchPath = Just p
        , matchInterface = Just i
        , matchMember = Just memCur
        }
 --------------------------------------------------------------------------------
-- | Internal DBus Crap
+-- Internal DBus Crap
-brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
+brightnessExporter
-  -> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
  => XPQuery
  -> [Fulfillment]
  -> [IODependency_]
  -> BrightnessConfig m a b
  -> Maybe SesClient
  -> Sometimes (m (), m ())
 brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
  Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
  where
-    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
+    root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
-exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
+exportBrightnessControlsInner
-exportBrightnessControls' bc cl = do
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
-  let ses = toClient cl
+  => BrightnessConfig m a b
-  maxval <- bcGetMax bc -- assume the max value will never change
+  -> SesClient
-  let bounds = (bcMinRaw bc, maxval)
+  -> (m (), m ())
-  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
+exportBrightnessControlsInner bc = cmd
-  let funget = bcGet bc
+  where
-  export ses (bcPath bc) defaultInterface
+    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 bounds :: IO Int32)
+              , autoMethod memGet (round <$> funget :: IO Int32)
              ]
          , interfaceSignals = [sig]
          }
-  where
+    sig =
-    sig = I.Signal
+      I.Signal
        { I.signalName = memCur
        , I.signalArgs =
-        [
+            [ I.SignalArg
          I.SignalArg
                { I.signalArgName = "brightness"
                , I.signalArgType = TypeInt32
                }
            ]
        }
-emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
+emitBrightness
  :: (MonadUnliftIO m, RealFrac b)
  => BrightnessConfig m a b
  -> Client
  -> b
  -> m ()
 emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
-  emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
+  liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
  where
    sig = signal p i memCur
-callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
+callBacklight
-  -> MemberName -> SometimesIO
+  :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
-callBacklight q cl BrightnessConfig { bcPath = p
+  => XPQuery
-                                    , bcInterface = i
+  -> Maybe SesClient
-                                    , bcName = n } controlName m =
+  -> BrightnessConfig m 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 [] xmonadBusName p i $ Method_ m) cl
-    cmd c = io $ void $ callMethod c xmonadBusName p i m
+    cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
 bodyGetBrightness _ = Nothing
 --------------------------------------------------------------------------------
-- | DBus Members
+-- DBus Members
 memCur :: MemberName
 memCur = memberName_ "CurrentBrightness"
--- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | DBus module for Intel Backlight control
+-- DBus module for Intel Backlight control
 module XMonad.Internal.DBus.Brightness.IntelBacklight
  ( callGetBrightnessIB
@ -10,22 +11,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
  , intelBacklightControls
  , intelBacklightSignalDep
  , blPath
-  ) where
+  )
-
+where
 import           Data.Int                               (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
 import XMonad.Internal.IO
 --------------------------------------------------------------------------------
-- | Low level sysfs functions
+-- Low level sysfs functions
--
+
 type Brightness = Float
 type RawBrightness = Int32
@ -47,26 +46,26 @@ maxFile = backlightDir </> "max_brightness"
 curFile :: FilePath
 curFile = backlightDir </> "brightness"
-getMaxRawBrightness :: IO RawBrightness
+getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
 getMaxRawBrightness = readInt maxFile
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds curFile
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = writePercentMin bounds curFile
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = writePercentMax bounds curFile
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness = incPercent steps curFile
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness = decPercent steps curFile
 --------------------------------------------------------------------------------
-- | DBus interface
+-- DBus interface
 blPath :: ObjectPath
 blPath = objectPath_ "/intelbacklight"
@ -74,8 +73,11 @@ blPath = objectPath_ "/intelbacklight"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
-intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
+intelBacklightConfig
-intelBacklightConfig = BrightnessConfig
+  :: MonadUnliftIO m
  => BrightnessConfig m RawBrightness Brightness
 intelBacklightConfig =
  BrightnessConfig
    { bcMin = minBrightness
    , bcMax = maxBrightness
    , bcInc = incBrightness
@ -89,7 +91,7 @@ intelBacklightConfig = BrightnessConfig
    }
 --------------------------------------------------------------------------------
-- | Exported haskell API
+-- Exported haskell API
 curFileDep :: IODependency_
 curFileDep = pathRW curFile []
@ -98,17 +100,39 @@ maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []
 intelBacklightSignalDep :: DBusDependency_ SesClient
-intelBacklightSignalDep = signalDep intelBacklightConfig
+intelBacklightSignalDep =
  -- TODO do I need to get rid of the IO here?
  signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
-exportIntelBacklight :: Maybe SesClient -> SometimesIO
+exportIntelBacklight
-exportIntelBacklight = brightnessExporter xpfIntelBacklight []
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  [curFileDep, maxFileDep] intelBacklightConfig
+  => Maybe SesClient
  -> Sometimes (m (), m ())
 exportIntelBacklight =
  brightnessExporter
    xpfIntelBacklight
    []
    [curFileDep, maxFileDep]
    intelBacklightConfig
-intelBacklightControls :: Maybe SesClient -> BrightnessControls
+intelBacklightControls
  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
  => Maybe SesClient
  -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
-callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessIB
  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
  => m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig
-matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalIB
  :: ( SafeClient c
     , HasLogFunc (env c)
     , HasClient env
     , MonadReader (env c) m
     , MonadUnliftIO m
     )
  => (Maybe Brightness -> m ())
  -> m ()
 matchSignalIB = matchSignal intelBacklightConfig
--- a/lib/XMonad/Internal/DBus/Common.hs
+++ b/lib/XMonad/Internal/DBus/Common.hs
@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
+-- High-level interface for managing XMonad's DBus
 module XMonad.Internal.DBus.Common
  ( xmonadBusName
@ -7,7 +7,8 @@ module XMonad.Internal.DBus.Common
  , notifyBus
  , notifyPath
  , networkManagerBus
-  ) where
+  )
 where
 import DBus
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
 networkManagerBus :: BusName
 networkManagerBus = busName_ "org.freedesktop.NetworkManager"
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@ -1,11 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 --------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
+-- High-level interface for managing XMonad's DBus
 module XMonad.Internal.DBus.Control
  ( Client
  , DBusState (..)
  , withDBusInterfaces
  , withDBusX
  , withDBusX_
  , withDBus
  , withDBus_
  , connectDBus
  , connectDBusX
  , disconnectDBus
@ -15,16 +21,15 @@ module XMonad.Internal.DBus.Control
  , withDBusClient_
  , disconnect
  , dbusExporters
-  ) where
+  )
-
+where
 import           Control.Monad
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
 import DBus.Client
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Common
@ -36,48 +41,109 @@ data DBusState = DBusState
  , dbSysClient :: Maybe SysClient
  }
 withDBusX_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m ()
 withDBusX_ = void . withDBusX
 withDBusX
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m (Maybe a)
 withDBusX f = withDBus $ \db -> do
  forM (dbSesClient db) $ \ses -> do
    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
 withDBus_
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m ()
 withDBus_ = void . withDBus
 withDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => (DBusState -> m a)
  -> m a
 withDBus = bracket connectDBus disconnectDBus
 -- | Connect to the DBus
-connectDBus :: IO DBusState
+connectDBus
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => m DBusState
 connectDBus = do
  ses <- getDBusClient
  sys <- getDBusClient
  return DBusState {dbSesClient = ses, dbSysClient = sys}
 -- | Disconnect from the DBus
-disconnectDBus :: DBusState -> IO ()
+disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
  where
    disc f = maybe (return ()) disconnectDBusClient $ f db
 -- | Connect to the DBus and request the XMonad name
-connectDBusX :: IO DBusState
+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 :: DBusState -> IO ()
+disconnectDBusX
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => DBusState
  -> m ()
 disconnectDBusX db = do
  forM_ (dbSesClient db) releaseXMonadName
  disconnectDBus db
 withDBusInterfaces
  :: DBusState
  -> [Maybe SesClient -> 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
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: [Maybe SesClient -> SometimesIO]
+dbusExporters
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
-releaseXMonadName :: SesClient -> IO ()
+releaseXMonadName
-releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SesClient
  -> m ()
 releaseXMonadName ses = do
  -- TODO this might error?
  liftIO $ void $ releaseName (toClient ses) xmonadBusName
  logInfo "released xmonad name"
-requestXMonadName :: SesClient -> IO ()
+requestXMonadName
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => SesClient
  -> m ()
 requestXMonadName ses = do
-  res <- requestName (toClient ses) xmonadBusName []
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
-  -- TODO if the client is not released on shutdown the owner will be different
+  let msg
-  let msg | res == NamePrimaryOwner = Nothing
+        | res == NamePrimaryOwner = "registering name"
-          | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
+        | res == NameAlreadyOwner = "this process already owns name"
        | res == NameInQueue
-            || res == NameExists = Just $ "another process owns " ++ xn
+            || res == NameExists =
-          | otherwise = Just $ "unknown error when requesting " ++ xn
+            "another process owns name"
-  forM_ msg putStrLn
+        | otherwise = "unknown error when requesting name"
  logInfo $ msg <> ": " <> xn
  where
-    xn = "'" ++ formatBusName xmonadBusName ++ "'"
+    xn =
      Utf8Builder $
        encodeUtf8Builder $
          T.pack $
            formatBusName xmonadBusName
--- a/lib/XMonad/Internal/DBus/Removable.hs
+++ b/lib/XMonad/Internal/DBus/Removable.hs
@ -1,22 +1,20 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Module for monitoring removable drive events
+-- Module for monitoring removable drive events
 --
 -- Currently, its only purpose is to play Super Mario sounds when a drive is
 -- inserted or removed. Why? Because I can.
 module XMonad.Internal.DBus.Removable (runRemovableMon) where
 import           Control.Monad
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import           Data.Map.Strict                 (Map, member)
 import DBus
 import DBus.Client
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import qualified RIO.Map as M
 import XMonad.Core (io)
 import XMonad.Internal.Command.Desktop
@ -51,7 +49,8 @@ driveRemovedSound :: FilePath
 driveRemovedSound = "smb_pipe.wav"
 ruleUdisks :: MatchRule
-ruleUdisks = matchAny
+ruleUdisks =
  matchAny
    { matchPath = Just path
    , matchInterface = Just interface
    }
@ -60,31 +59,52 @@ driveFlag :: String
 driveFlag = "org.freedesktop.UDisks2.Drive"
 addedHasDrive :: [Variant] -> Bool
-addedHasDrive [_, a] = maybe False (member driveFlag)
+addedHasDrive [_, a] =
  maybe
    False
    (M.member driveFlag)
    (fromVariant a :: Maybe (Map String (Map String Variant)))
 addedHasDrive _ = False
 removedHasDrive :: [Variant] -> Bool
-removedHasDrive [_, a] = maybe False (driveFlag `elem`)
+removedHasDrive [_, a] =
  maybe
    False
    (driveFlag `elem`)
    (fromVariant a :: Maybe [String])
 removedHasDrive _ = False
-playSoundMaybe :: FilePath -> Bool -> IO ()
+playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
 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 :: SysClient -> IO ()
+listenDevices
  :: ( HasClient (DBusEnv env)
     , HasLogFunc (DBusEnv env SysClient)
     , MonadReader env m
     , MonadUnliftIO m
     )
  => SysClient
  -> m ()
 listenDevices cl = do
  addMatch' memAdded driveInsertedSound addedHasDrive
  addMatch' memRemoved driveRemovedSound removedHasDrive
  where
-    addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
+    addMatch' m p f = do
-      $ playSoundMaybe p . f . signalBody
+      let rule = ruleUdisks {matchMember = Just m}
      void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
-runRemovableMon :: Maybe SysClient -> SometimesIO
+runRemovableMon
  :: ( HasClient (DBusEnv env)
     , HasLogFunc (DBusEnv env SysClient)
     , MonadReader env m
     , MonadUnliftIO m
     )
  => Maybe SysClient
  -> Sometimes (m ())
 runRemovableMon cl =
  sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
  where
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/lib/XMonad/Internal/DBus/Screensaver.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | DBus module for X11 screensave/DPMS control
+-- DBus module for X11 screensave/DPMS control
 module XMonad.Internal.DBus.Screensaver
  ( exportScreensaver
@ -9,46 +10,40 @@ module XMonad.Internal.DBus.Screensaver
  , callQuery
  , matchSignal
  , ssSignalDep
-  ) where
+  )
-
+where
 import           Control.Monad               (void)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import Graphics.X11.XScreenSaver
-import           Graphics.X11.Xlib.Display
+import RIO
 import XMonad.Internal.DBus.Common
-import           XMonad.Internal.Process
+import XMonad.Internal.IO
 import XMonad.Internal.Shell
 --------------------------------------------------------------------------------
-- | Low-level functions
+-- Low-level functions
 type SSState = Bool -- true is enabled
-ssExecutable :: String
+ssExecutable :: FilePath
 ssExecutable = "xset"
-toggle :: IO SSState
+toggle :: MonadUnliftIO m => m SSState
 toggle = do
  st <- query
-  -- TODO figure out how not to do this with shell commands
+  let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
-  void $ createProcess' $ proc ssExecutable $ "s" : args st
+  -- this needs to be done with shell commands, because as far as I know there
-  -- TODO this assumes the command succeeds
+  -- are no Haskell bindings for DPMSDisable/Enable (from libxext)
-  return $ not st
+  rc <- runProcess (proc ssExecutable $ "s" : args)
-  where
+  return $ if rc == ExitSuccess then not st else st
    args s = if s then ["off", "-dpms"] else ["on", "+dpms"]
-query :: IO SSState
+query :: MonadUnliftIO m => m SSState
 query = do
-  dpy <- openDisplay ""
+  xssi <- withOpenDisplay (liftIO . xScreenSaverQueryInfo)
  xssi <- xScreenSaverQueryInfo dpy
  closeDisplay dpy
  return $ case xssi of
    Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
    Just XScreenSaverInfo {xssi_state = _} -> True
@ -56,7 +51,7 @@ query = do
    Nothing -> False
 --------------------------------------------------------------------------------
-- | DBus Interface
+-- DBus Interface
 --
 -- Define a methods to toggle the screensaver. This methods will emit signal
 -- with the new state when called. Define another method to get the current
@ -81,40 +76,47 @@ sigCurrentState :: Signal
 sigCurrentState = signal ssPath interface memState
 ruleCurrentState :: MatchRule
-ruleCurrentState = matchAny
+ruleCurrentState =
  matchAny
    { matchPath = Just ssPath
    , matchInterface = Just interface
    , matchMember = Just memState
    }
-emitState :: Client -> SSState -> IO ()
+emitState :: MonadUnliftIO m => Client -> SSState -> m ()
-emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] }
+emitState client sss =
  liftIO $ emit client $ sigCurrentState {signalBody = [toVariant sss]}
 bodyGetCurrentState :: [Variant] -> Maybe SSState
 bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
 bodyGetCurrentState _ = Nothing
 --------------------------------------------------------------------------------
-- | Exported haskell API
+-- Exported haskell API
-exportScreensaver :: Maybe SesClient -> SometimesIO
+exportScreensaver
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Maybe SesClient
  -> Sometimes (m (), m ())
 exportScreensaver ses =
  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
  where
-    cmd cl = let cl' = toClient cl in
+    cmd = exportPair ssPath $ \cl_ -> do
-      export cl' ssPath defaultInterface
+      liftIO $ withRunInIO $ \run ->
        return $
          defaultInterface
            { interfaceName = interface
            , interfaceMethods =
-        [ autoMethod memToggle $ emitState cl' =<< toggle
+                [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
-        , autoMethod memQuery query
+                , autoMethod memQuery (run query)
                ]
            , interfaceSignals = [sig]
            }
-    sig = I.Signal
+    sig =
      I.Signal
        { I.signalName = memState
        , I.signalArgs =
-        [
+            [ I.SignalArg
          I.SignalArg
                { I.signalArgName = "enabled"
                , I.signalArgType = TypeBoolean
                }
@ -123,18 +125,40 @@ exportScreensaver ses =
    bus = Bus [] xmonadBusName
    ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
-callToggle :: Maybe SesClient -> SometimesIO
+callToggle
-callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  xmonadBusName ssPath interface memToggle
+  => Maybe SesClient
  -> Sometimes (m ())
 callToggle =
  sometimesEndpoint
    "screensaver toggle"
    "dbus switch"
    []
    xmonadBusName
    ssPath
    interface
    memToggle
-callQuery :: SesClient -> IO (Maybe SSState)
+callQuery
-callQuery ses = do
+  :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
-  reply <- callMethod ses xmonadBusName ssPath interface memQuery
+  => m (Maybe SSState)
 callQuery = do
  reply <- callMethod xmonadBusName ssPath interface memQuery
  return $ either (const Nothing) bodyGetCurrentState reply
-matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
+matchSignal
-matchSignal cb ses = void $ addMatchCallback ruleCurrentState
+  :: ( HasLogFunc (env SesClient)
-  (cb . bodyGetCurrentState) ses
+     , HasClient env
     , MonadReader (env SesClient) m
     , MonadUnliftIO m
     )
  => (Maybe SSState -> m ())
  -> m ()
 matchSignal cb =
  void $
    addMatchCallback
      ruleCurrentState
      (cb . bodyGetCurrentState)
 ssSignalDep :: DBusDependency_ SesClient
 ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
--- a/lib/XMonad/Internal/IO.hs
+++ b/lib/XMonad/Internal/IO.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE ViewPatterns #-}
 --------------------------------------------------------------------------------
-- | Random IO-ish functions used throughtout xmonad
+-- Random IO-ish functions used throughtout xmonad
 --
 -- Most (probably all) of these functions are intended to work with sysfs where
 -- some safe assumptions can be made about file contents.
@ -21,84 +21,122 @@ module XMonad.Internal.IO
  -- , isWritable
  , PermResult (..)
  , getPermissionsSafe
-  ) where
+  , waitUntilExit
  , withOpenDisplay
  )
 where
 import Data.Char
-import           Data.Text        (pack, unpack)
+import Graphics.X11.Xlib.Display
-import           Data.Text.IO     as T (readFile, writeFile)
+import Graphics.X11.Xlib.Event
-
+import Graphics.X11.Xlib.Types
-import           System.Directory
+import RIO hiding (Display)
 import RIO.Directory
 import RIO.FilePath
 import qualified RIO.Text as T
 import System.IO.Error
 import System.Process
 --------------------------------------------------------------------------------
-- | read
+-- read
-readInt :: (Read a, Integral a) => FilePath -> IO a
+readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
-readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
+readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
-readBool :: FilePath -> IO Bool
+readBool :: MonadIO m => FilePath -> m Bool
 readBool = fmap (== (1 :: Int)) . readInt
 --------------------------------------------------------------------------------
-- | write
+-- write
-writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
+writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
-writeInt f = T.writeFile f . pack . show
+writeInt f = writeFileUtf8 f . T.pack . show
-writeBool :: FilePath -> Bool -> IO ()
+writeBool :: MonadIO m => FilePath -> Bool -> m ()
 writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
 --------------------------------------------------------------------------------
-- | percent-based read/write
+-- percent-based read/write
 --
 -- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
 -- 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, Read b, RealFrac c) => (a, a) -> b -> c
 rawToPercent (lower, upper) raw =
  100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
 -- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
-readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
 readPercent bounds path = do
  i <- readInt path
  return $ rawToPercent bounds (i :: Integer)
 percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
-percentToRaw (lower, upper) perc = round $
+percentToRaw (lower, upper) perc =
  round $
    fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
-writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
+writePercent
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> b
  -> m b
 writePercent bounds path perc = do
-  let t | perc > 100 = 100
+  let t
        | perc > 100 = 100
        | perc < 0 = 0
        | otherwise = perc
  writeInt path (percentToRaw bounds t :: Int)
  return t
-writePercentMin :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+writePercentMin
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> m b
 writePercentMin bounds path = writePercent bounds path 0
-writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+writePercentMax
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> m b
 writePercentMax bounds path = writePercent bounds path 100
-shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
+shiftPercent
-  -> (a, a) -> IO b
+  :: (MonadIO m, Integral a, RealFrac b)
-shiftPercent f steps path bounds = writePercent bounds path . f stepsize
+  => (b -> b -> b)
  -> Int
  -> FilePath
  -> (a, a)
  -> m b
 shiftPercent f steps path bounds =
  writePercent bounds path . f stepsize
    =<< readPercent bounds path
  where
    stepsize = 100 / fromIntegral steps
-incPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
+incPercent
  :: (MonadIO m, Integral a, RealFrac b)
  => Int
  -> FilePath
  -> (a, a)
  -> m b
 incPercent = shiftPercent (+)
-decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
+decPercent
  :: (MonadIO m, Integral a, RealFrac b)
  => Int
  -> FilePath
  -> (a, a)
  -> m b
 decPercent = shiftPercent subtract -- silly (-) operator thingy error
 --------------------------------------------------------------------------------
-- | permission query
+-- permission query
 data PermResult a = PermResult a | NotFoundError | PermError
  deriving (Show, Eq)
@ -108,9 +146,9 @@ data PermResult a = PermResult a | NotFoundError | PermError
 --   fmap _ NotFoundError  = NotFoundError
 --   fmap _ PermError      = PermError
-getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
+getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
 getPermissionsSafe f = do
-  r <- tryIOError $ getPermissions f
+  r <- tryIO $ getPermissions f
  return $ case r of
    Right z -> PermResult z
    Left (isPermissionError -> True) -> PermError
@ -124,3 +162,20 @@ getPermissionsSafe f = do
 -- isWritable :: FilePath -> IO (PermResult Bool)
 -- isWritable = fmap (fmap writable) . getPermissionsSafe
 -- | 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 pid = do
  res <- doesDirectoryExist $ "/proc" </> show pid
  when res $ do
    threadDelay 100000
    waitUntilExit pid
 withOpenDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
 withOpenDisplay = bracket (liftIO $ openDisplay "") cleanup
  where
    cleanup dpy = liftIO $ do
      flush dpy
      closeDisplay dpy
--- a/lib/XMonad/Internal/Notify.hs
+++ b/lib/XMonad/Internal/Notify.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Functions for formatting and sending notifications
+-- Functions for formatting and sending notifications
 --
 -- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
 -- notifications (just formation them into 'notify-send' commands and spawn a
@ -16,33 +16,34 @@ module XMonad.Internal.Notify
  , defNoteError
  , fmtNotifyCmd
  , spawnNotify
-  ) where
+  )
-
+where
 import           Control.Monad.IO.Class
 import           Data.Maybe
 import DBus.Notify
-
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.Shell
 --------------------------------------------------------------------------------
-- | Some nice default notes
+-- Some nice default notes
 defNote :: Note
 defNote = blankNote {summary = "\"xmonad\""}
 defNoteInfo :: Note
-defNoteInfo = defNote
+defNoteInfo =
-  { appImage = Just $ Icon "dialog-information-symbolic" }
+  defNote
    { appImage = Just $ Icon "dialog-information-symbolic"
    }
 defNoteError :: Note
-defNoteError = defNote
+defNoteError =
-  { appImage = Just $ Icon "dialog-error-symbolic" }
+  defNote
    { appImage = Just $ Icon "dialog-error-symbolic"
    }
 --------------------------------------------------------------------------------
-- | Format a 'notify-send' command to be send to the shell
+-- Format a 'notify-send' command to be send to the shell
 parseBody :: Body -> Maybe T.Text
 parseBody (Text s) = Just $ T.pack s
@ -60,6 +61,6 @@ fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
    -- TODO add the rest of the options as needed
    getSummary = (: []) . doubleQuote . T.pack . summary
    getIcon n' =
-      maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
+      maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
-      $ appImage n'
+        appImage n'
    getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
--- a/lib/XMonad/Internal/Process.hs
+++ b/lib/XMonad/Internal/Process.hs
@ -1,96 +0,0 @@
 --------------------------------------------------------------------------------
 -- | Functions for managing processes
 module XMonad.Internal.Process
  ( waitUntilExit
  , killHandle
  , spawnPipe'
  , spawnPipe
  , spawnPipeArgs
  , createProcess'
  , readCreateProcessWithExitCode'
  , proc'
  , shell'
  , spawn
  , spawnAt
  , module System.Process
  ) where
 import           Control.Concurrent
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Maybe
 import qualified RIO.Text               as T
 import           System.Directory
 import           System.Exit
 import           System.IO
 import           System.Posix.Signals
 import           System.Process
 import           XMonad.Core            hiding (spawn)
 -- | Block until a PID has exited (in any form)
 -- ASSUMPTION on linux PIDs will always increase until they overflow, in which
 -- case they will start to recycle. Barring any fork bombs, this code should
 -- work because we can reasonably expect that no processes will spawn with the
 -- same PID within the delay limit
 -- TODO this will not work if the process is a zombie (maybe I care...)
 waitUntilExit :: Show t => t -> IO ()
 waitUntilExit pid = do
  res <- doesDirectoryExist $ "/proc/" ++ show pid
  when res $ threadDelay 100000 >> waitUntilExit pid
 killHandle :: ProcessHandle -> IO ()
 killHandle ph = do
  ec <- getProcessExitCode ph
  unless (isJust ec) $ do
    pid <- getPid ph
    forM_ pid $ signalProcess sigTERM
    -- this may fail if the process exits instantly and the handle
    -- is destroyed by the time we get to this line (I think?)
    void (try $ waitForProcess ph :: IO (Either IOException ExitCode))
 withDefaultSignalHandlers :: IO a -> IO a
 withDefaultSignalHandlers =
  bracket_ uninstallSignalHandlers installSignalHandlers
 addGroupSession :: CreateProcess -> CreateProcess
 addGroupSession cp = cp { create_group = True, new_session = True }
 createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 createProcess' = withDefaultSignalHandlers . createProcess
 readCreateProcessWithExitCode' :: CreateProcess -> String
  -> IO (ExitCode, T.Text, T.Text)
 readCreateProcessWithExitCode' c i = withDefaultSignalHandlers $ do
  (r, e, p) <- readCreateProcessWithExitCode c i
  return (r, T.pack e, T.pack p)
 shell' :: String -> CreateProcess
 shell' = addGroupSession . shell
 proc' :: FilePath -> [String] -> CreateProcess
 proc' cmd args = addGroupSession $ proc cmd args
 spawn :: MonadIO m => String -> m ()
 spawn = io . void . createProcess' . shell'
 spawnAt :: MonadIO m => FilePath -> String -> m ()
 spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
 spawnPipe' :: CreateProcess -> IO (Handle, ProcessHandle)
 spawnPipe' cp = do
  -- ASSUME creating a pipe will always succeed in making a Just Handle
  (Just h, _, _, p) <- createProcess' $ cp { std_in = CreatePipe }
  hSetBuffering h LineBuffering
  return (h, p)
 spawnPipe :: String -> IO (Handle, ProcessHandle)
 spawnPipe = spawnPipe' . shell
 spawnPipeArgs :: FilePath -> [String] -> IO (Handle, ProcessHandle)
 spawnPipeArgs cmd = spawnPipe' . proc cmd
--- a/lib/XMonad/Internal/Shell.hs
+++ b/lib/XMonad/Internal/Shell.hs
@ -1,64 +1,159 @@
 {-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
+-- Functions for formatting and spawning shell commands
 -- | Functions for formatting and spawning shell commands
 module XMonad.Internal.Shell
  ( fmtCmd
  , spawnCmd
  , spawn
  , spawnPipe
  , doubleQuote
  , singleQuote
  , skip
  , runProcess
  , proc
  , shell
  , (#!&&)
  , (#!||)
  , (#!|)
  , (#!>>)
-  ) where
+  )
-
+where
 import           Control.Monad.IO.Class
 import RIO
 import qualified RIO.Text as T
 import qualified System.Process.Typed as P
 import qualified XMonad.Core as X
 import qualified XMonad.Util.Run as XR
-import           XMonad.Internal.Process
+-- | Fork a new process and wait for its exit code.
 --
 -- This function will work despite xmonad ignoring SIGCHLD.
 --
 -- A few facts about xmonad (and window managers in general):
 -- 1) It is single-threaded (since X is single threaded)
 -- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
 --    by xmonad will instantly be reaped after spawning. This guarantees the
 --    main thread running the WM will never be blocked.
 --
 -- In general, this means I can't wait for exit codes (since wait() doesn't
 -- work) See https://github.com/xmonad/xmonad/issues/113.
 --
 -- If I want an exit code, The best solution (I can come up with), is to use
 -- bracket to uninstall handlers, run process (with wait), and then reinstall
 -- handlers. I can use this with a much higher-level interface which will make
 -- things easier. This obviously means that if the process is running in the
 -- main thread, it needs to be almost instantaneous. Note if using a high-level
 -- API for this, the process needs to spawn, finish, and be reaped by the
 -- xmonad process all while the signal handlers are 'disabled' (which limits
 -- the functions I can use to those that call waitForProcess).
 --
 -- XMonad and contrib use their own method of spawning subprocesses using the
 -- extremely low-level 'System.Process.Posix' API. See the code for
 -- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
 -- sequence is (in terms of the low level Linux API):
 -- 1) call fork()
 -- 2) uninstall signal handlers (to allow wait() to work in subprocesses)
 -- 3) call setsid() (so killing the child will kill its children, if any)
 -- 4) start new thing with exec()
 --
 -- In contrast with high-level APIs like 'System.Process', this will leave no
 -- trailing data structures to clean up, at the cost of being gross to look at
 -- and possibly more error-prone.
 runProcess :: MonadUnliftIO m => P.ProcessConfig a b c -> m ExitCode
 runProcess = withDefaultSignalHandlers . P.runProcess
--------------------------------------------------------------------------------
+-- | Run an action without xmonad's signal handlers.
-- | Opening subshell
+withDefaultSignalHandlers :: MonadUnliftIO m => m a -> m a
 withDefaultSignalHandlers =
  bracket_ X.uninstallSignalHandlers X.installSignalHandlers
 -- | Set a child process to create a new group and session
 addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
 addGroupSession = P.setCreateGroup True . P.setNewSession True
 -- | Create a 'ProcessConfig' for a shell command
 shell :: T.Text -> P.ProcessConfig () () ()
 shell = addGroupSession . P.shell . T.unpack
 -- | Create a 'ProcessConfig' for a command with arguments
 proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
 proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
 -- | Run 'XMonad.Core.spawn' with 'Text' input.
 spawn :: MonadIO m => T.Text -> m ()
 spawn = X.spawn . T.unpack
 -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
 spawnPipe
  :: (MonadReader env m, HasLogFunc env, 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
 -- | Run 'XMonad.Core.spawn' with a command and arguments
 spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
-spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args
+spawnCmd cmd = spawn . fmtCmd cmd
 --------------------------------------------------------------------------------
 -- | Formatting commands
 -- | Format a command and list of arguments as 'Text'
 fmtCmd :: FilePath -> [T.Text] -> T.Text
 fmtCmd cmd args = T.unwords $ T.pack cmd : args
 op :: T.Text -> T.Text -> T.Text -> T.Text
 op a x b = T.unwords [a, x, b]
 -- | Format two shell expressions separated by "&&"
 (#!&&) :: T.Text -> T.Text -> T.Text
 cmdA #!&& cmdB = op cmdA "&&" cmdB
 infixr 0 #!&&
 -- | Format two shell expressions separated by "|"
 (#!|) :: T.Text -> T.Text -> T.Text
 cmdA #!| cmdB = op cmdA "|" cmdB
 infixr 0 #!|
 -- | Format two shell expressions separated by "||"
 (#!||) :: T.Text -> T.Text -> T.Text
 cmdA #!|| cmdB = op cmdA "||" cmdB
 infixr 0 #!||
 -- | Format two shell expressions separated by ";"
 (#!>>) :: T.Text -> T.Text -> T.Text
 cmdA #!>> cmdB = op cmdA ";" cmdB
 infixr 0 #!>>
 -- | Wrap input in double quotes
 doubleQuote :: T.Text -> T.Text
 doubleQuote s = T.concat ["\"", s, "\""]
 -- | Wrap input in single quotes
 singleQuote :: T.Text -> T.Text
 singleQuote s = T.concat ["'", s, "'"]
--- a/lib/XMonad/Internal/Theme.hs
+++ b/lib/XMonad/Internal/Theme.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Theme for XMonad and Xmobar
+-- Theme for XMonad and Xmobar
 module XMonad.Internal.Theme
  ( baseColor
@ -28,18 +28,17 @@ module XMonad.Internal.Theme
  , defFontData
  , tabbedTheme
  , promptTheme
-  ) where
+  )
 where
 import Data.Colour
 import Data.Colour.SRGB
 import qualified RIO.Text as T
 import qualified XMonad.Layout.Decoration as D
 import qualified XMonad.Prompt as P
 --------------------------------------------------------------------------------
-- | Colors - vocabulary roughly based on GTK themes
+-- Colors - vocabulary roughly based on GTK themes
 baseColor :: T.Text
 baseColor = "#f7f7f7"
@ -78,7 +77,7 @@ backdropFgColor :: T.Text
 backdropFgColor = blend' 0.75 fgColor bgColor
 --------------------------------------------------------------------------------
-- | Color functions
+-- Color functions
 blend' :: Float -> T.Text -> T.Text -> T.Text
 blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
@ -93,14 +92,16 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
 sRGB24showT = T.pack . sRGB24show
 --------------------------------------------------------------------------------
-- | Fonts
+-- Fonts
-data Slant = Roman
+data Slant
  = Roman
  | Italic
  | Oblique
  deriving (Eq, Show)
-data Weight = Light
+data Weight
  = Light
  | Medium
  | Demibold
  | Bold
@ -119,15 +120,21 @@ type FontBuilder = FontData -> T.Text
 buildFont :: Maybe T.Text -> FontData -> T.Text
 buildFont Nothing _ = "fixed"
-buildFont (Just fam) FontData { weight = w
+buildFont
  (Just fam)
  FontData
    { weight = w
    , slant = l
    , size = s
    , pixelsize = p
    , antialias = a
-                            }
+    } =
-  = T.intercalate ":" $ ["xft", fam] ++ elems
+    T.intercalate ":" $ ["xft", fam] ++ elems
    where
-    elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
+      elems =
        [ T.concat [k, "=", v]
        | (k, Just v) <-
            [ ("weight", showLower w)
            , ("slant", showLower l)
            , ("size", showLower s)
            , ("pixelsize", showLower p)
@ -141,10 +148,11 @@ fallbackFont :: FontBuilder
 fallbackFont = buildFont Nothing
 --------------------------------------------------------------------------------
-- | Default font and data
+-- Default font and data
 defFontData :: FontData
-defFontData = FontData
+defFontData =
  FontData
    { size = Just 10
    , antialias = Just True
    , weight = Nothing
@ -162,36 +170,34 @@ defFontFamily = "DejaVu Sans"
 -- defFontTree = fontTree "DejaVu Sans"
 --------------------------------------------------------------------------------
-- | Complete themes
+-- Complete themes
 tabbedTheme :: FontBuilder -> D.Theme
-tabbedTheme fb = D.def
+tabbedTheme fb =
  D.def
    { D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
    , D.activeTextColor = T.unpack fgColor
    , D.activeColor = T.unpack bgColor
    , D.activeBorderColor = T.unpack bgColor
    , D.inactiveTextColor = T.unpack backdropTextColor
    , D.inactiveColor = T.unpack backdropFgColor
    , D.inactiveBorderColor = T.unpack backdropFgColor
    , D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
    , D.urgentColor = T.unpack errorColor
    , D.urgentBorderColor = T.unpack errorColor
-
+    , -- this is in a newer version
  -- this is in a newer version
      -- , D.activeBorderWidth     = 0
      -- , D.inactiveBorderWidth   = 0
      -- , D.urgentBorderWidth     = 0
-  , D.decoHeight            = 20
+      D.decoHeight = 20
    , D.windowTitleAddons = []
    , D.windowTitleIcons = []
    }
 promptTheme :: FontBuilder -> P.XPConfig
-promptTheme fb = P.def
+promptTheme fb =
  P.def
    { P.font = T.unpack $ fb $ defFontData {size = Just 12}
    , P.bgColor = T.unpack bgColor
    , P.fgColor = T.unpack fgColor
--- a/lib/Xmobar/Plugins/BacklightCommon.hs
+++ b/lib/Xmobar/Plugins/BacklightCommon.hs
@ -1,25 +1,28 @@
 {-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
+-- Common backlight plugin bits
 -- | 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 Data.Internal.DBus
-
+import RIO
 import qualified RIO.Text as T
 import Xmobar.Plugins.Common
-startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
+startBacklight
-  -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
+  :: (MonadUnliftIO m, RealFrac a)
-startBacklight matchSignal callGetBrightness icon cb = do
+  => Maybe FilePath
-    withDBusClientConnection cb $ \c -> do
+  -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-      matchSignal display c
+  -> DIO SimpleApp SesClient (Maybe a)
-      display =<< callGetBrightness c
+  -> T.Text
  -> Callback
  -> m ()
 startBacklight name matchSignal callGetBrightness icon cb = do
  withDBusClientConnection cb name $ \c -> withDIO c $ do
    matchSignal dpy
    dpy =<< callGetBrightness
  where
    formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
-      display = displayMaybe cb formatBrightness
+    dpy = displayMaybe cb formatBrightness
--- a/lib/Xmobar/Plugins/Bluetooth.hs
+++ b/lib/Xmobar/Plugins/Bluetooth.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Bluetooth plugin
+-- Bluetooth plugin
 --
 -- Use the bluez interface on DBus to check status
 --
@ -36,23 +36,18 @@ module Xmobar.Plugins.Bluetooth
  ( Bluetooth (..)
  , btAlias
  , btDep
-  ) where
+  )
-
+where
 import           Control.Concurrent.MVar
 import           Control.Monad
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import           Data.List
 import           Data.List.Split
 import qualified Data.Map                    as M
 import           Data.Maybe
 import DBus
 import DBus.Client
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import RIO.List
 import qualified RIO.Map as M
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Common
 import Xmobar
 import Xmobar.Plugins.Common
@ -61,36 +56,44 @@ btAlias :: T.Text
 btAlias = "bluetooth"
 btDep :: DBusDependency_ SysClient
-btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
+btDep =
-  $ Method_ getManagedObjects
+  Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
    Method_ getManagedObjects
 data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
  alias (Bluetooth _ _) = T.unpack btAlias
  start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb $ startAdapter icons colors cb
+    withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
-startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
+startAdapter
  :: Icons
  -> Colors
  -> Callback
  -> SysClient
  -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
  ot <- getBtObjectTree cl
  state <- newMVar emptyState
-  let display = displayIcon cb (iconFormatter is cs) state
+  let dpy = displayIcon cb (iconFormatter is cs)
-  forM_ (findAdapter ot) $ \adapter -> do
+  mapRIO (BTEnv cl state dpy) $ do
    ot <- getBtObjectTree
    case findAdapter ot of
      Nothing -> logError "could not find bluetooth adapter"
      Just adapter -> do
        -- set up adapter
-    initAdapter state adapter cl
+        initAdapter adapter
-    -- TODO this step could fail; at least warn the user...
+        void $ addAdaptorListener adapter
    void $ addAdaptorListener state display adapter cl
        -- set up devices on the adapter (and listeners for adding/removing devices)
        let devices = findDevices adapter ot
-    addDeviceAddedListener state display adapter cl
+        addDeviceAddedListener adapter
-    addDeviceRemovedListener state display adapter cl
+        addDeviceRemovedListener adapter
-    forM_ devices $ \d -> addAndInitDevice state display d cl
+        forM_ devices $ \d -> addAndInitDevice d
        -- after setting things up, show the icon based on the initialized state
-    display
+        dpy
 --------------------------------------------------------------------------------
-- | Icon Display
+-- Icon Display
 --
 -- Color corresponds to the adaptor powered state, and the icon corresponds to
 -- if it is paired or not. If the adaptor state is undefined, display "N/A"
@ -99,9 +102,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 type Icons = (T.Text, T.Text)
-displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon :: Callback -> IconFormatter -> BTIO ()
 displayIcon callback formatter =
-  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
@ -111,13 +114,28 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
    icon = if connected then iconConn else iconDisc
 --------------------------------------------------------------------------------
-- | Connection State
+-- 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.
 data BTEnv c = BTEnv
  { btClient :: !c
  , btState :: !(MVar BtState)
  , btDisplay :: !(BTIO ())
  , btEnv :: !SimpleApp
  }
 instance HasClient BTEnv where
  clientL = lens btClient (\x y -> x {btClient = y})
 instance HasLogFunc (BTEnv a) where
  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
 type BTIO = RIO (BTEnv SysClient)
 data BTDevice = BTDevice
  { btDevConnected :: Maybe Bool
  , btDevSigHandler :: SignalHandler
@ -130,22 +148,29 @@ data BtState = BtState
  , btPowered :: Maybe Bool
  }
 type MutableBtState = MVar BtState
 emptyState :: BtState
-emptyState = BtState
+emptyState =
  BtState
    { btDevices = M.empty
    , btPowered = Nothing
    }
-readState :: MutableBtState -> IO (Maybe Bool, Bool)
+readState :: BTIO (Maybe Bool, Bool)
-readState state = do
+readState = do
-  p <- readPowered state
+  p <- readPowered
-  c <- readDevices state
+  c <- readDevices
  return (p, anyDevicesConnected c)
 modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
 modifyState f = do
  m <- asks btState
  modifyMVar m f
 beforeDisplay :: BTIO () -> BTIO ()
 beforeDisplay f = f >> join (asks btDisplay)
 --------------------------------------------------------------------------------
-- | Object manager
+-- Object manager
 findAdapter :: ObjectTree -> Maybe ObjectPath
 findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
@ -154,73 +179,136 @@ findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
 findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
 adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
-adaptorHasDevice adaptor device = case splitPath device of
+adaptorHasDevice adaptor device = case splitPathNoRoot device of
-  [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
+  [org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
  _ -> False
-splitPath :: ObjectPath -> [T.Text]
+splitPathNoRoot :: ObjectPath -> [FilePath]
-splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
+splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
-getBtObjectTree :: SysClient -> IO ObjectTree
+getBtObjectTree
-getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
+  :: ( HasClient env
     , SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => m ObjectTree
 getBtObjectTree = callGetManagedObjects btBus btOMPath
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
-addBtOMListener :: SignalCallback -> SysClient -> IO ()
+addBtOMListener
-addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
+  :: ( HasClient env
     , SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
 addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceAddedListener :: ObjectPath -> BTIO ()
-addDeviceAddedListener state display adapter client =
+addDeviceAddedListener adapter = addBtOMListener addDevice
  addBtOMListener addDevice client
  where
-    addDevice = pathCallback adapter display $ \d ->
+    addDevice = pathCallback adapter $ \d ->
-      addAndInitDevice state display d client
+      addAndInitDevice d
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceRemovedListener :: ObjectPath -> BTIO ()
-addDeviceRemovedListener state display adapter sys =
+addDeviceRemovedListener adapter =
-  addBtOMListener remDevice sys
+  addBtOMListener remDevice
  where
-    remDevice = pathCallback adapter display $ \d -> do
+    remDevice = pathCallback adapter $ \d -> do
-      old <- removeDevice state d
+      old <- removeDevice d
-      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
+      cl <- asks btClient
      forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler
-pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
+pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
-pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
+pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
-  when (adaptorHasDevice adapter d) $ f d >> display
+  when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
-pathCallback _ _ _ _ = return ()
+pathCallback _ _ _ = return ()
 --------------------------------------------------------------------------------
-- | Adapter
+-- Adapter
-initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
+initAdapter :: ObjectPath -> BTIO ()
-initAdapter state adapter client = do
+initAdapter adapter = do
-  reply <- callGetPowered adapter client
+  reply <- callGetPowered adapter
-  putPowered state $ fromSingletonVariant reply
+  logInfo $ "initializing adapter at path " <> adapter_
-
+  -- TODO this could fail if the variant is something weird; the only
-matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
+  -- indication I will get is "NA"
-matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
+  putPowered $ fromSingletonVariant reply
 addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
  -> IO (Maybe SignalHandler)
 addAdaptorListener state display adaptor sys = do
  rule <- matchBTProperty sys adaptor
  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
  where
-    procMatch = withSignalMatch $ \b -> putPowered state b >> display
+    adapter_ = displayWrapQuote $ displayObjectPath adapter
-callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
+matchBTProperty
-callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
+  :: ( SafeClient c
-  $ memberName_ $ T.unpack adaptorPowered
+     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m (Maybe MatchRule)
 matchBTProperty p = matchPropertyFull btBus (Just p)
-matchPowered :: [Variant] -> SignalMatch Bool
+withBTPropertyRule
-matchPowered = matchPropertyChanged adapterInterface adaptorPowered
+  :: ( SafeClient c
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , HasClient env
     , MonadUnliftIO m
     , IsVariant a
     )
  => ObjectPath
  -> (Maybe a -> m ())
  -> InterfaceName
  -> T.Text
  -> m (Maybe SignalHandler)
 withBTPropertyRule path update iface prop = do
  res <- matchBTProperty path
  case res of
    Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
    Nothing -> do
      logError $
        "could not add listener for prop "
          <> prop_
          <> " on path "
          <> path_
      return Nothing
  where
    path_ = displayObjectPath path
    prop_ = Utf8Builder $ encodeUtf8Builder prop
    signalToUpdate = withSignalMatch update
    matchConnected = matchPropertyChanged iface prop
-putPowered :: MutableBtState -> Maybe Bool -> IO ()
+addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
-putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
+addAdaptorListener adaptor =
  withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
  where
    procMatch = beforeDisplay . putPowered
-readPowered :: MutableBtState -> IO (Maybe Bool)
+callGetPowered
-readPowered = fmap btPowered . readMVar
+  :: ( HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , SafeClient c
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m [Variant]
 callGetPowered adapter =
  callPropertyGet btBus adapter adapterInterface $
    memberName_ $
      T.unpack adaptorPowered
 putPowered :: Maybe Bool -> BTIO ()
 putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
 readPowered :: BTIO (Maybe Bool)
 readPowered = fmap btPowered $ readMVar =<< asks btState
 adapterInterface :: InterfaceName
 adapterInterface = interfaceName_ "org.bluez.Adapter1"
@ -229,57 +317,68 @@ adaptorPowered :: T.Text
 adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
-- | Devices
+-- Devices
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addAndInitDevice :: ObjectPath -> BTIO ()
-addAndInitDevice state display device client = do
+addAndInitDevice device = do
-  sh <- addDeviceListener state display device client
+  res <- addDeviceListener device
-  -- TODO add some intelligent error messages here
+  case res of
-  forM_ sh $ \s -> initDevice state s device client
+    Just handler -> do
      logInfo $ "initializing device at path " <> device_
      initDevice handler device
    Nothing -> logError $ "could not initialize device at path " <> device_
  where
    device_ = displayWrapQuote $ displayObjectPath device
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
+initDevice :: SignalHandler -> ObjectPath -> BTIO ()
-initDevice state sh device sys = do
+initDevice sh device = do
-  reply <- callGetConnected device sys
+  reply <- callGetConnected device
-  void $ insertDevice state device $
+  void $
-    BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
+    insertDevice device $
      BTDevice
        { btDevConnected = fromVariant =<< listToMaybe reply
        , btDevSigHandler = sh
        }
-addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
+addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
-  -> IO (Maybe SignalHandler)
+addDeviceListener device =
-addDeviceListener state display device sys = do
+  withBTPropertyRule device procMatch devInterface devConnected
  rule <- matchBTProperty sys device
  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
  where
-    procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
+    procMatch = beforeDisplay . void . updateDevice device
-matchConnected :: [Variant] -> SignalMatch Bool
+callGetConnected
-matchConnected = matchPropertyChanged devInterface devConnected
+  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> m [Variant]
 callGetConnected p =
  callPropertyGet btBus p devInterface $
    memberName_ (T.unpack devConnected)
-callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
+insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
-callGetConnected p = callPropertyGet btBus p devInterface
+insertDevice device dev = modifyState $ \s -> do
  $ memberName_ (T.unpack devConnected)
 insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
 insertDevice m device dev = modifyMVar m $ \s -> do
  let new = M.insert device dev $ btDevices s
  return (s {btDevices = new}, anyDevicesConnected new)
-updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
+updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
-updateDevice m device status = modifyMVar m $ \s -> do
+updateDevice device status = modifyState $ \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 :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
+removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
-removeDevice m device = modifyMVar m $ \s -> do
+removeDevice device = modifyState $ \s -> do
  let devs = btDevices s
  return (s {btDevices = M.delete device devs}, M.lookup device devs)
-readDevices :: MutableBtState -> IO ConnectedDevices
+readDevices :: BTIO ConnectedDevices
-readDevices = fmap btDevices . readMVar
+readDevices = fmap btDevices $ readMVar =<< asks btState
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"
--- a/lib/Xmobar/Plugins/ClevoKeyboard.hs
+++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Clevo Keyboard plugin
+-- Clevo Keyboard plugin
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
@ -9,15 +9,13 @@
 module Xmobar.Plugins.ClevoKeyboard
  ( ClevoKeyboard (..)
  , ckAlias
-  ) where
+  )
 where
 import qualified RIO.Text as T
 import           Xmobar
 import           Xmobar.Plugins.BacklightCommon
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import Xmobar
 import Xmobar.Plugins.BacklightCommon
 newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
  alias (ClevoKeyboard _) = T.unpack ckAlias
  start (ClevoKeyboard icon) =
-     startBacklight matchSignalCK callGetBrightnessCK icon
+    startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
--- a/lib/Xmobar/Plugins/Common.hs
+++ b/lib/Xmobar/Plugins/Common.hs
@ -15,15 +15,12 @@ module Xmobar.Plugins.Common
  )
 where
 import           Control.Monad
 import           Data.Internal.DBus
 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)
 -- use string here since all the callbacks in xmobar use strings :(
@ -35,17 +32,29 @@ data Colors = Colors
  }
  deriving (Eq, Show, Read)
-startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
+startListener
-  -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
+  :: ( HasLogFunc (env c)
-  -> c -> IO ()
+     , HasClient env
-startListener rule getProp fromSignal toColor cb client = do
+     , MonadReader (env c) m
-  reply <- getProp client
+     , MonadUnliftIO m
     , SafeClient c
     , IsVariant a
     )
  => MatchRule
  -> m [Variant]
  -> ([Variant] -> SignalMatch a)
  -> (a -> m T.Text)
  -> Callback
  -> m ()
 startListener rule getProp fromSignal toColor cb = do
  reply <- getProp
  displayMaybe cb toColor $ fromSingletonVariant reply
-  void $ addMatchCallback rule (procMatch . fromSignal) client
+  void $ addMatchCallback rule (procMatch . fromSignal)
  where
    procMatch = procSignalMatch cb toColor
-procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
+procSignalMatch
  :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
 procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
 colorText :: Colors -> Bool -> T.Text -> T.Text
@ -58,11 +67,23 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
 na :: T.Text
 na = "N/A"
-displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
+displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
-displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
+displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
-displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
+displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
-displayMaybe' cb = maybe (cb $ T.unpack na)
+displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
-withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
+withDBusClientConnection
-withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
+  :: (MonadUnliftIO m, SafeClient c)
  => Callback
  -> Maybe FilePath
  -> (c -> RIO SimpleApp ())
  -> m ()
 withDBusClientConnection cb 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
--- a/lib/Xmobar/Plugins/Device.hs
+++ b/lib/Xmobar/Plugins/Device.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 --------------------------------------------------------------------------------
-- | Device plugin
+-- Device plugin
 --
 -- Display different text depending on whether or not the interface has
 -- connectivity
@ -9,18 +10,14 @@
 module Xmobar.Plugins.Device
  ( Device (..)
  , devDep
-  ) where
+  )
-
+where
 import           Control.Monad
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import           Data.Word
 import DBus
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
 import Xmobar
@ -44,33 +41,49 @@ devSignal :: T.Text
 devSignal = "Ip4Connectivity"
 devDep :: DBusDependency_ SysClient
-devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
+devDep =
-  $ Method_ getByIP
+  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
    Method_ getByIP
-getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
+getDevice
-getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
+  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
  => T.Text
  -> m (Maybe ObjectPath)
 getDevice iface = bodyToMaybe <$> callMethod' mc
  where
-    mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
+    mc =
      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
        { methodCallBody = [toVariant iface]
        }
-getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
+getDeviceConnected
-getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
+  :: ( SafeClient c
-  $ memberName_ $ T.unpack devSignal
+     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => ObjectPath
  -> 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
+  start (Device (iface, text, colors)) cb =
-    withDBusClientConnection cb $ \sys -> do
+    withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
-      path <- getDevice sys iface
+      path <- getDevice iface
-      displayMaybe' cb (listener sys) path
+      displayMaybe' cb listener path
    where
-      listener sys path = do
+      logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
-        rule <- matchPropertyFull sys networkManagerBus (Just path)
+      listener path = do
-        -- TODO warn the user here rather than silently drop the listener
+        res <- matchPropertyFull networkManagerBus (Just path)
-        forM_ rule $ \r ->
+        case res of
-          startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
+          Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
          Nothing -> logError "could not start listener"
      chooseColor' = return . (\s -> colorText colors s text) . (> 1)
--- a/lib/Xmobar/Plugins/IntelBacklight.hs
+++ b/lib/Xmobar/Plugins/IntelBacklight.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Intel backlight plugin
+-- Intel backlight plugin
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
@ -9,15 +9,13 @@
 module Xmobar.Plugins.IntelBacklight
  ( IntelBacklight (..)
  , blAlias
-  ) where
+  )
 where
 import qualified RIO.Text as T
 import           Xmobar
 import           Xmobar.Plugins.BacklightCommon
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import Xmobar
 import Xmobar.Plugins.BacklightCommon
 newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ blAlias = "intelbacklight"
 instance Exec IntelBacklight where
  alias (IntelBacklight _) = T.unpack blAlias
  start (IntelBacklight icon) =
-     startBacklight matchSignalIB callGetBrightnessIB icon
+    startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
--- a/lib/Xmobar/Plugins/Screensaver.hs
+++ b/lib/Xmobar/Plugins/Screensaver.hs
@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | Screensaver plugin
+-- Screensaver plugin
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
@ -9,13 +9,13 @@
 module Xmobar.Plugins.Screensaver
  ( Screensaver (..)
  , ssAlias
-  ) where
+  )
 where
 import Data.Internal.DBus
 import qualified RIO.Text as T
 import           Xmobar
 import XMonad.Internal.DBus.Screensaver
 import Xmobar
 import Xmobar.Plugins.Common
 newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
@ -25,10 +25,9 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
  alias (Screensaver _) = T.unpack ssAlias
-  start (Screensaver (text, colors)) cb = do
+  start (Screensaver (text, colors)) cb =
-    withDBusClientConnection cb $ \sys -> do
+    withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
-      matchSignal display sys
+      matchSignal dpy
-      display =<< callQuery sys
+      dpy =<< callQuery
    where
-      display = displayMaybe cb $ return . (\s -> colorText colors s text)
+      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
--- a/lib/Xmobar/Plugins/VPN.hs
+++ b/lib/Xmobar/Plugins/VPN.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 --------------------------------------------------------------------------------
-- | VPN plugin
+-- 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
@ -11,21 +12,16 @@ module Xmobar.Plugins.VPN
  ( VPN (..)
  , vpnAlias
  , vpnDep
-  ) where
+  )
-
+where
 import           Control.Concurrent.MVar
 import           Control.Monad
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 import qualified Data.Map                        as M
 import           Data.Maybe
 import qualified Data.Set                        as S
 import DBus
-
+import Data.Internal.DBus
 import Data.Internal.XIO
 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
@ -36,80 +32,128 @@ 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
+    withDBusClientConnection cb (Just "vpn.log") $ \c -> do
-    state <- initState c
+      let dpy = displayMaybe cb iconFormatter . Just =<< readState
-    let display = displayMaybe cb iconFormatter . Just =<< readState state
+      s <- newEmptyMVar
-    let signalCallback' f = f state display
+      mapRIO (VEnv c s dpy) $ do
-    vpnAddedListener (signalCallback' addedCallback) c
+        initState
-    vpnRemovedListener (signalCallback' removedCallback) c
+        vpnAddedListener addedCallback
-    display
+        vpnRemovedListener removedCallback
        dpy
    where
      iconFormatter b = return $ colorText colors b text
 --------------------------------------------------------------------------------
-- | VPN State
+-- 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.
 data VEnv c = VEnv
  { vClient :: !c
  , vState :: !(MVar VPNState)
  , vDisplay :: !(VIO ())
  , vEnv :: !SimpleApp
  }
 instance SafeClient c => HasLogFunc (VEnv c) where
  logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
 instance HasClient VEnv where
  clientL = lens vClient (\x y -> x {vClient = y})
 type VIO = RIO (VEnv SysClient)
 type VPNState = S.Set ObjectPath
-type MutableVPNState = MVar VPNState
+initState :: VIO ()
 initState = do
  ot <- getVPNObjectTree
  s <- asks vState
  putMVar s $ findTunnels ot
-initState :: SysClient -> IO MutableVPNState
+readState :: VIO Bool
-initState client = do
+readState = fmap (not . null) . readMVar =<< asks vState
  ot <- getVPNObjectTree client
  newMVar $ findTunnels ot
-readState :: MutableVPNState -> IO Bool
+updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
-readState = fmap (not . null) . readMVar
+updateState f op = do
  s <- asks vState
  modifyMVar_ s $ return . f op
-updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
+beforeDisplay :: VIO () -> VIO ()
-  -> ObjectPath -> IO ()
+beforeDisplay f = f >> join (asks vDisplay)
 updateState f state op = modifyMVar_ state $ return . f op
 --------------------------------------------------------------------------------
-- | Tunnel Device Detection
+-- Tunnel Device Detection
 --
-getVPNObjectTree :: SysClient -> IO ObjectTree
+getVPNObjectTree
-getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
+  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => m ObjectTree
 getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
 findTunnels :: ObjectTree -> VPNState
 findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
-vpnAddedListener :: SignalCallback -> SysClient -> IO ()
+vpnAddedListener
-vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
+  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
 vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
-vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
+vpnRemovedListener
-vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
+  :: ( SafeClient c
     , HasClient env
     , MonadReader (env c) m
     , HasLogFunc (env c)
     , MonadUnliftIO m
     )
  => SignalCallback m
  -> m ()
 vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
-addedCallback :: MutableVPNState -> IO () -> SignalCallback
+addedCallback :: SignalCallback VIO
-addedCallback state display [device, added] = update >> display
+addedCallback [device, added] =
  beforeDisplay $
    updateDevice S.insert device $
      M.keys $
        fromMaybe M.empty added'
  where
    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
-    is = M.keys $ fromMaybe M.empty added'
+addedCallback _ = return ()
    update = updateDevice S.insert state device is
 addedCallback _ _ _                       = return ()
-removedCallback :: MutableVPNState -> IO () -> SignalCallback
+removedCallback :: SignalCallback VIO
-removedCallback state display [device, interfaces] = update >> display
+removedCallback [device, interfaces] =
-  where
+  beforeDisplay $
-    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
+    updateDevice S.delete device $
-    update = updateDevice S.delete state device is
+      fromMaybe [] $
-removedCallback _ _ _                       = return ()
+        fromVariant interfaces
 removedCallback _ = return ()
-updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
+updateDevice
-  -> Variant -> [T.Text] -> IO ()
+  :: (ObjectPath -> VPNState -> VPNState)
-updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
+  -> Variant
-  forM_ d $ updateState f state
+  -> [T.Text]
  -> VIO ()
 updateDevice f device interfaces =
  when (vpnDeviceTun `elem` interfaces) $
    forM_ d $
      updateState f
  where
    d = fromVariant device :: Maybe ObjectPath
 --------------------------------------------------------------------------------
-- | DBus Interface
+-- DBus Interface
 --
 vpnBus :: BusName
 vpnBus = busName_ "org.freedesktop.NetworkManager"
@ -124,5 +168,6 @@ vpnAlias :: T.Text
 vpnAlias = "vpn"
 vpnDep :: DBusDependency_ SysClient
-vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
+vpnDep =
-  $ Method_ getManagedObjects
+  Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
    Method_ getManagedObjects
--- a/package.yaml
+++ b/package.yaml
@ -7,7 +7,7 @@ copyright:           "2022 Nathan Dwarshuis"
 extra-source-files:
 - README.md
- .stylish-haskell.yaml
+- fourmolu.yaml
 - make_pkgs
 - icons/*
 - scripts/*
@ -19,28 +19,23 @@ dependencies:
  - base
  - bytestring >= 0.10.8.2
  - colour >= 2.3.5
  - containers >= 0.6.0.1
  - dbus >= 1.2.7
  - fdo-notify
  - io-streams >= 1.5.1.0
  - mtl >= 2.2.2
  - unix >= 2.7.2.2
  - tcp-streams >= 1.0.1.1
  - text >= 1.2.3.1
  - directory >= 1.3.3.0
  - process >= 1.6.5.0
  - split >= 0.2.3.4
  - xmobar
  - xmonad-extras >= 0.15.2
  - xmonad >= 0.13
  - xmonad-contrib >= 0.13
  - aeson >= 2.0.3.0
  - yaml >=0.11.8.0
  - unordered-containers >= 0.2.16.0
  - hashable >= 1.3.5.0
  - xml >= 1.3.14
  - lifted-base >= 0.2.3.12
  - utf8-string >= 1.0.2
  - typed-process >= 0.2.8.0
  - network >= 3.1.2.7
  - unliftio >= 0.2.21.0
  - optparse-applicative >= 0.16.1.0
 library:
  source-dirs: lib/