.stylish-haskell.yaml

@@ -0,0 +1,357 @@
+# 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

bin/vbox-start.hs

@@ -1,6 +1,7 @@
 {-# 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
@@ -14,17 +15,21 @@
 -- 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.IO
+import           XMonad.Internal.Process               (waitUntilExit)
 
 main :: IO ()
 main = do
@@ -41,21 +46,20 @@ runAndWait [n] = do
     runID i = do
       vmLaunch i
       p <- vmPID i
-      liftIO $ mapM_ waitUntilExit p
+      liftIO $ 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 Pid)
+vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
 vmPID vid = do
   (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
   return $ case rc of
@@ -69,8 +73,7 @@ vmMachineID iPath = do
     Right contents -> return $ findMachineID contents
     Left e         -> logError (displayShow e) >> return Nothing
   where
-    findMachineID c =
+    findMachineID c = T.stripSuffix "}"
-      T.stripSuffix "}"
       =<< T.stripPrefix "{"
       =<< (fmap T.pack . findAttr (blank_name { qName = "uuid" }))
       =<< (\e -> findChild (qual e "Machine") e)

bin/xmobar.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+module Main (main) where
+
+--------------------------------------------------------------------------------
 -- | Xmobar binary
 --
 -- Features:
@@ -9,16 +12,29 @@
 -- * 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.XIO
+import           Data.Internal.Dependency
-import Options.Applicative
+import           Data.List
+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
@@ -26,64 +42,37 @@ 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 = parse >>= xio
+main = getArgs >>= parse
 
-parse :: IO XOpts
+parse :: [String] -> IO ()
-parse = execParser opts
+parse []         = run
-  where
+parse ["--deps"] = withCache printDeps
-    parseOpts = parseDeps <|> parseTest <|> pure XRun
+parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
-    opts =
+parse _          = usage
-      info (parseOpts <**> helper) $
-        fullDesc <> header "xmobar: the best taskbar 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 -> hRunXIO False stderr $ withDBus_ evalConfig
-  XRun -> runXIO "xmobar.log" run
-
-run :: XIO ()
 run = do
-  -- IDK why this is needed, I thought this was default
+  db <- connectDBus
-  liftIO $ hSetBuffering stdout LineBuffering
+  c <- withCache $ evalConfig db
-  -- this isn't totally necessary except for the fact that killing xmobar
+  disconnectDBus db
-  -- will make it print something about catching SIGTERM, and without
+  -- this is needed to prevent waitForProcess error when forking in plugins (eg
-  -- linebuffering it usually only prints the first few characters (even then
+  -- alsacmd)
-  -- it only prints 10-20% of the time)
+  _ <- installHandler sigCHLD Default Nothing
-  liftIO $ hSetBuffering stderr LineBuffering
+  -- this is needed to see any printed messages
-  withDBus_ $ \db -> do
+  hFlush stdout
-    c <- evalConfig db
+  xmobar c
-    liftIO $ xmobar c
 
-evalConfig :: DBusState -> XIO Config
+evalConfig :: DBusState -> FIO Config
 evalConfig db = do
   cs <- getAllCommands <$> rightPlugins db
   bf <- getTextFont
@@ -91,17 +80,21 @@ evalConfig db = do
   d <- io $ cfgDir <$> getDirectories
   return $ config bf ifs ios cs d
 
-printDeps :: XIO ()
+printDeps :: FIO ()
-printDeps = withDBus_ $ \db ->
+printDeps = do
-  mapM_ logInfo $
+  db <- io connectDBus
-    fmap showFulfillment $
+  let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
-      sort $
+  io $ mapM_ (putStrLn . T.unpack) ps
-        nub $
+  io $ disconnectDBus db
-          concatMap dumpFeature $
+
-            allFeatures db
+usage :: IO ()
+usage = putStrLn $ intercalate "\n"
+  [ "xmobar: run greatest taskbar"
+  , "xmobar --deps: print dependencies"
+  ]
 
 --------------------------------------------------------------------------------
--- toplevel configuration
+-- | toplevel configuration
 
 -- | The text font family
 textFont :: Always XT.FontBuilder
@@ -117,10 +110,7 @@ textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
 
 -- | The icon font family
 iconFont :: Sometimes XT.FontBuilder
-iconFont =
+iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
-  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)
@@ -146,8 +136,7 @@ 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 =
+config bf ifs ios br confDir = defaultConfig
-  defaultConfig
   { font = T.unpack bf
   , additionalFonts = fmap T.unpack ifs
   , textOffset = textFontOffset
@@ -157,31 +146,32 @@ config bf ifs ios br confDir =
   , 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 =
+getAllCommands right = BarRegions
-  BarRegions
+  { brLeft = [ CmdSpec
-    { brLeft =
-        [ CmdSpec
                { csAlias = "UnsafeStdinReader"
                , csRunnable = Run UnsafeStdinReader
                }
@@ -190,10 +180,8 @@ getAllCommands right =
   , brRight = catMaybes right
   }
 
-rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
+rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
-rightPlugins db =
+rightPlugins db = mapM evalFeature $ allFeatures db
-  mapM evalFeature $
-    allFeatures db
   ++ [always' "date indicator" dateCmd]
   where
     always' n = Right . Always n . Always_ . FallbackAlone
@@ -216,10 +204,7 @@ type BarFeature = Sometimes CmdSpec
 
 -- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
-getWireless =
+getWireless = Sometimes "wireless status indicator" xpfWireless
-  Sometimes
-    "wireless status indicator"
-    xpfWireless
   [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
 getEthernet :: Maybe SysClient -> BarFeature
@@ -232,49 +217,32 @@ getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
-    tree =
+    tree = Only_ $ IOTest_ "Test if battery is present" []
-      Only_ $
+      $ fmap (Msg LevelError) <$> hasBattery
-        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 =
+    test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
-      DBusIO $
+      networkManagerPkgs vpnPresent
-        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 =
+getAlsa = iconIO_ "volume level indicator" (const True) root
-  iconIO_ "volume level indicator" (const True) root $
+  $ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
-    Only_ $
-      sysExe [Package Official "alsa-utils"] "alsactl"
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
 getBl :: Maybe SesClient -> BarFeature
-getBl =
+getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
-  xmobarDBus
+  intelBacklightSignalDep blCmd
-    "Intel backlight indicator"
-    xpfIntelBacklight
-    intelBacklightSignalDep
-    blCmd
 
 getCk :: Maybe SesClient -> BarFeature
-getCk =
+getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
-  xmobarDBus
+  clevoKeyboardSignalDep ckCmd
-    "Clevo keyboard indicator"
-    xpfClevoBacklight
-    clevoKeyboardSignalDep
-    ckCmd
 
 getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
@@ -285,58 +253,29 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
     root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
 
 --------------------------------------------------------------------------------
--- bar feature constructors
+-- | bar feature constructors
 
-xmobarDBus
+xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
-  :: SafeClient c
+  -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
-  => 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_
+iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
-  :: T.Text
+  -> IOTree_ -> BarFeature
-  -> XPQuery
-  -> (Fontifier -> IOTree_ -> Root CmdSpec)
-  -> IOTree_
-  -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus
+iconDBus :: SafeClient c => T.Text -> XPQuery
-  :: SafeClient c
+  -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
-  => T.Text
-  -> XPQuery
-  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-  -> DBusTree c p
-  -> BarFeature
 iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
-iconDBus_
+iconDBus_ :: SafeClient c => T.Text -> XPQuery
-  :: SafeClient c
+  -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
-  => T.Text
-  -> XPQuery
-  -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
-  -> DBusTree_ c
-  -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
 
-iconSometimes'
+iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
-  :: (t -> t_ -> t)
+  -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
-  -> (IODependency_ -> t_)
+iconSometimes' c d n q r t = Sometimes n q
-  -> 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"
   ]
@@ -345,170 +284,125 @@ iconSometimes' c d n q r t =
     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 =
+wirelessCmd iface = CmdSpec
-  CmdSpec
   { csAlias = T.append iface "wi"
   , csRunnable = Run $ Wireless (T.unpack iface) args 5
   }
   where
-    args =
+    args = fmap T.unpack
-      fmap
+      [ "-t", "<qualityipat><essid>"
-        T.unpack
-        [ "-t"
-        , "<qualityipat><essid>"
       , "--"
-        , "--quality-icon-pattern"
+      , "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
-        , "<icon=wifi_%%.xpm/>"
       ]
 
 ethernetCmd :: Fontifier -> T.Text -> CmdSpec
-ethernetCmd fontify iface =
+ethernetCmd fontify iface = CmdSpec
-  CmdSpec
   { csAlias = iface
-    , csRunnable =
+  , csRunnable = Run
-        Run $
+    $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
-          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
   }
 
 batteryCmd :: Fontifier -> CmdSpec
-batteryCmd fontify =
+batteryCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = "battery"
   , csRunnable = Run $ Battery args 50
   }
   where
     fontify' = fontify IconSmall
-    args =
+    args = fmap T.unpack
-      fmap
+      [ "--template", "<acstatus><left>"
-        T.unpack
+      , "--Low", "10"
-        [ "--template"
+      , "--High", "80"
-        , "<acstatus><left>"
+      , "--low", "red"
-        , "--Low"
+      , "--normal", XT.fgColor
-        , "10"
+      , "--high", XT.fgColor
-        , "--High"
-        , "80"
-        , "--low"
-        , "red"
-        , "--normal"
-        , XT.fgColor
-        , "--high"
-        , XT.fgColor
       , "--"
       , "-P"
-        , "-o"
+      , "-o" , fontify' "\xf0e7" "BAT"
-        , fontify' "\xf0e7" "BAT"
+      , "-O" , fontify' "\xf1e6" "AC"
-        , "-O"
+      , "-i" , fontify' "\xf1e6" "AC"
-        , fontify' "\xf1e6" "AC"
-        , "-i"
-        , fontify' "\xf1e6" "AC"
       ]
 
 vpnCmd :: Fontifier -> CmdSpec
-vpnCmd fontify =
+vpnCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = vpnAlias
   , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
   }
 
 btCmd :: Fontifier -> CmdSpec
-btCmd fontify =
+btCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = btAlias
-    , csRunnable =
+  , csRunnable = Run
-        Run $
+    $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
-          Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
   }
   where
     fontify' i = fontify IconLarge i . T.append "BT"
 
 alsaCmd :: Fontifier -> CmdSpec
-alsaCmd fontify =
+alsaCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = "alsa:default:Master"
-    , csRunnable =
+  , csRunnable = Run
-        Run $
+    $ Alsa "default" "Master"
-          Alsa "default" "Master" $
+    $ fmap T.unpack
-            fmap
+    [ "-t", "<status><volume>%"
-              T.unpack
-              [ "-t"
-              , "<status><volume>%"
     , "--"
-              , "-O"
+    , "-O", fontify' "\xf028" "+"
-              , fontify' "\xf028" "+"
+    , "-o", T.append (fontify' "\xf026" "-") " "
-              , "-o"
+    , "-c", XT.fgColor
-              , T.append (fontify' "\xf026" "-") " "
+    , "-C", XT.fgColor
-              , "-c"
-              , XT.fgColor
-              , "-C"
-              , XT.fgColor
     ]
   }
   where
     fontify' i = fontify IconSmall i . T.append "VOL"
 
 blCmd :: Fontifier -> CmdSpec
-blCmd fontify =
+blCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = blAlias
   , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
   }
 
 ckCmd :: Fontifier -> CmdSpec
-ckCmd fontify =
+ckCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = ckAlias
   , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
   }
 
 ssCmd :: Fontifier -> CmdSpec
-ssCmd fontify =
+ssCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = ssAlias
   , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
   }
 
 lockCmd :: Fontifier -> CmdSpec
-lockCmd fontify =
+lockCmd fontify = CmdSpec
-  CmdSpec
   { csAlias = "locks"
-    , csRunnable =
+  , csRunnable = Run
-        Run $
+    $ Locks
-          Locks $
+    $ fmap T.unpack
-            fmap
+    [ "-N", numIcon
-              T.unpack
+    , "-n", disabledColor numIcon
-              [ "-N"
+    , "-C", capIcon
-              , numIcon
+    , "-c", disabledColor capIcon
-              , "-n"
+    , "-s", ""
-              , disabledColor numIcon
+    , "-S", ""
-              , "-C"
+    , "-d", " "
-              , capIcon
-              , "-c"
-              , disabledColor capIcon
-              , "-s"
-              , ""
-              , "-S"
-              , ""
-              , "-d"
-              , " "
     ]
   }
   where
@@ -518,61 +412,51 @@ lockCmd fontify =
     disabledColor = xmobarFGColor XT.backdropFgColor
 
 dateCmd :: CmdSpec
-dateCmd =
+dateCmd = CmdSpec
-  CmdSpec
   { csAlias = "date"
   , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
   }
 
 --------------------------------------------------------------------------------
--- low-level testing functions
+-- | low-level testing functions
 
-vpnPresent :: XIO (Maybe Msg)
+vpnPresent :: IO (Maybe Msg)
-vpnPresent = do
+vpnPresent =
-  res <- proc "nmcli" args readProcess
+  go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
-  return $ case res of
-    (ExitSuccess, out, _)
-      | "vpn" `elem` BL.split 10 out -> Nothing
-      | otherwise -> Just $ Msg LevelError "vpn not found"
-    (ExitFailure c, _, err) ->
-      Just $
-        Msg LevelError $
-          T.concat
-            [ "vpn search exited with code "
-            , T.pack $ show c
-            , ": "
-            , T.decodeUtf8With T.lenientDecode $
-                BL.toStrict err
-            ]
   where
     args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
+    go (Right (ExitSuccess, out, _))   = if "vpn" `elem` T.lines out then Nothing
+                                         else Just $ Msg LevelError "vpn not found"
+    go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
+                                         $ T.concat ["vpn search exited with code "
+                                                    , T.pack $ show c
+                                                    , ": "
+                                                    , err]
+    go (Left e)                        = Just $ Msg LevelError $ T.pack $ show e
 
 --------------------------------------------------------------------------------
--- 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 :: XIO T.Text
+getTextFont :: FIO T.Text
 getTextFont = do
   fb <- evalAlways textFont
   return $ fb textFontData
 
 --------------------------------------------------------------------------------
--- icon fonts
+-- | icon fonts
 
-getIconFonts :: XIO ([T.Text], [Int])
+getIconFonts :: FIO ([T.Text], [Int])
 getIconFonts = do
   fb <- evalSometimes iconFont
   return $ maybe ([], []) apply fb
   where
-    apply fb =
+    apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
-      unzip $
-        (\i -> (iconString fb i, iconOffset i + textFontOffset))
       <$> iconFonts
 
-data BarFont
+data BarFont = IconSmall
-  = IconSmall
   | IconMedium
   | IconLarge
   | IconXLarge
@@ -600,7 +484,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 }
@@ -623,6 +507,5 @@ 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} =
+fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $
-  T.concat
   [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

bin/xmonad.hs

@@ -1,32 +1,36 @@
-{-# 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.XIO
+import           Data.Internal.Dependency
+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
+import           RIO                                            (async)
-import RIO.Directory
-import RIO.List
-import RIO.Process
 import qualified RIO.Text                                       as T
-import System.Posix.Signals
+
-import System.Process
+import           System.Directory
-  ( getPid
+import           System.Environment
-  , getProcessExitCode
+import           System.IO                                      hiding
+    ( hPutStrLn
     )
+import           System.IO.Error
+import           System.Process
+
 import           XMonad
 import           XMonad.Actions.CopyWindow
 import           XMonad.Actions.CycleWS
@@ -49,7 +53,8 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.DBus.Removable
 import           XMonad.Internal.DBus.Screensaver
-import XMonad.Internal.Shell hiding (proc)
+import           XMonad.Internal.Process
+import           XMonad.Internal.Shell
 import qualified XMonad.Internal.Theme                          as XT
 import           XMonad.Layout.MultiToggle
 import           XMonad.Layout.NoBorders
@@ -66,95 +71,23 @@ import XMonad.Util.NamedActions
 import           XMonad.Util.WorkspaceCompare
 
 main :: IO ()
-main = parse >>= xio
+main = getArgs >>= parse
 
-parse :: IO XOpts
+parse :: [String] -> IO ()
-parse = execParser opts
+parse []         = run
-  where
+parse ["--deps"] = withCache printDeps
-    parseOpts = parseDeps <|> parseTest <|> pure XRun
+parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
-    opts =
+parse _          = usage
-      info (parseOpts <**> helper) $
-        fullDesc <> header "xmonad: the best window manager ever"
 
-data XOpts = XDeps | XTest | XRun
 
-parseDeps :: Parser XOpts
+run :: IO ()
-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
-  -- These first two commands are only significant when xmonad is restarted.
+  db <- connectDBusX
-  -- The 'launch' function below this will turn off buffering (so flushes are
+  conf <- withCache $ evalConf db
-  -- required to see stdout) and will also install xmonad's silly signal
+  ds <- getCreateDirectories
-  -- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN).
+  -- IDK why this is necessary; nothing prior to this will print if missing
-  -- Ignoring sigCHLD is particularly bad since most of my setup entails
+  hFlush stdout
-  -- spawning processes and waiting for their exit code, which totally breaks
+  launch conf ds
-  -- 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
@@ -164,21 +97,21 @@ getCreateDirectories = do
   where
     createIfMissing ds f = do
       let d = f ds
-      r <- tryIO $ createDirectoryIfMissing True d
+      r <- tryIOError $ createDirectoryIfMissing True d
       case r of
         (Left e) -> print e
         _        -> return ()
 
 data FeatureSet = FeatureSet
-  { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
+  { fsKeys          :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
+  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
   , fsPowerMon      :: SometimesIO
   , fsRemovableMon  :: Maybe SysClient -> SometimesIO
-  , fsDaemons :: [Sometimes (XIO (Process () () ()))]
+  , fsDaemons       :: [Sometimes (IO ProcessHandle)]
   , fsACPIHandler   :: Always (String -> X ())
   , fsTabbedTheme   :: Always Theme
   , fsDynWorkspaces :: [Sometimes DynWorkspace]
-  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
+  , fsShowKeys      :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
   }
 
 tabbedFeature :: Always Theme
@@ -189,8 +122,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
     fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
 
 features :: Maybe SysClient -> FeatureSet
-features cl =
+features cl = FeatureSet
-  FeatureSet
   { fsKeys = externalBindings
   , fsDBusExporters = dbusExporters
   , fsPowerMon = runPowermon
@@ -202,141 +134,104 @@ features cl =
   , fsDaemons = [runNetAppDaemon cl, runAutolock]
   }
 
-withXmobar :: (Process Handle () () -> XIO a) -> XIO a
+evalConf db@DBusState { dbSysClient = cl } = do
-withXmobar = bracket startXmobar stopXmobar
+  -- start DBus interfaces first since many features after this test these
-
+  -- interfaces as dependencies
-startXmobar :: XIO (Process Handle () ())
+  let fs = features cl
-startXmobar = do
+  startDBusInterfaces fs
-  logInfo "starting xmobar child process"
+  (xmobarHandle, ts) <- startChildDaemons fs
-  p <- proc "xmobar" [] start
+  startRemovableMon fs
-  io $ hSetBuffering (getStdin p) LineBuffering
+  startPowerMon fs
-  return p
+  dws <- startDynWorkspaces fs
+  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
-    start =
+    forkIO_ = void . async
-      startProcess
+    startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
-        . setStdin createPipe
+      $ fsDBusExporters fs
-        . setCreateGroup True
+    startChildDaemons fs = do
+      (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
 
-stopXmobar
+printDeps :: FIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+printDeps = do
-  => Process Handle () ()
+  db <- io connectDBus
-  -> m ()
+  (i, f, d) <- allFeatures db
-stopXmobar p = do
+  io $ mapM_ (putStrLn . T.unpack)
-  logInfo "stopping xmobar child process"
+    $ fmap showFulfillment
-  io $ killNoWait p
+    $ sort
+    $ nub
+    $ concat
+    $ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
+  io $ disconnectDBus db
 
-withChildDaemons
+allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
-  :: FeatureSet
+allFeatures db = do
-  -> ([(Utf8Builder, Process () () ())] -> XIO a)
+  let bfs = concatMap (fmap kbMaybeAction . kgBindings)
-  -> XIO a
+            $ externalBindings ts db
-withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
+  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
-
-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]
-  -- TODO might be better to use glog for this?
+  return (dbus ++ others, Left runScreenLock:bfs, allDWs')
-  mapM_ logInfo $
-    fmap showFulfillment $
-      sort $
-        nub $
-          concat $
-            fmap dumpSometimes dbus
-              ++ fmap dumpSometimes others
-              ++ fmap dumpSometimes allDWs'
-              ++ fmap dumpFeature bfs
   where
-    mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
+    ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
+
+usage :: IO ()
+usage = putStrLn $ intercalate "\n"
+  [ "xmonad: run greatest window manager"
+  , "xmonad --deps: print dependencies"
+  ]
 
 --------------------------------------------------------------------------------
--- Concurrency configuration
+-- | Concurrency configuration
 
-data Cleanup = Cleanup
+data ThreadState = ThreadState
-  { clChildren :: [(Utf8Builder, Process () () ())]
+    { tsChildPIDs    :: [ProcessHandle]
-  , clXmobar :: Maybe (Process Handle () ())
+    , tsChildHandles :: [Handle]
-  , clDBusUnexporters :: [XIO ()]
     }
 
-runCleanup
+-- TODO shouldn't this be run by a signal handler?
-  :: (XIO () -> IO ())
+runCleanup :: ThreadState -> DBusState -> X ()
-  -> Cleanup
+runCleanup ts db = io $ do
-  -> DBusState
+  mapM_ killHandle $ tsChildPIDs ts
-  -> 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 =
+myStartupHook = setDefaultCursor xC_left_ptr
-  setDefaultCursor xC_left_ptr
   <+> startupHook def
 
 --------------------------------------------------------------------------------
--- Workspace configuration
+-- | Workspace configuration
 
 myWorkspaces :: [WorkspaceId]
 myWorkspaces = map show [1..10 :: Int]
@@ -357,8 +252,7 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
   where
     tree = Only_ $ sysExe [Package Official "gimp"] exe
-    dw =
+    dw = DynWorkspace
-      DynWorkspace
          { dwName = "Gimp"
          , dwTag = gimpTag
          , dwClass = c
@@ -372,32 +266,21 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
          , dwCmd = Just $ spawnCmd exe []
          }
     exe = "gimp-2.10"
-    matchGimpRole role =
+    matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
-      isPrefixOf role
+      <&&> className =? c
-        <$> 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 =
+vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
-  Sometimes
-    "virtualbox workspace"
-    xpfVirtualBox
   [Subfeature root "windows 8 VM"]
   where
-    root =
+    root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
-      IORoot_ dw $
+      $ IOTest_ name [] $ vmExists vm
-        toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
-          IOTest_ name [] $
-            io $
-              vmExists vm
     name = T.unwords ["test if", vm, "exists"]
     c = "VirtualBoxVM"
     vm = "win8raw"
-    dw =
+    dw = DynWorkspace
-      DynWorkspace
          { dwName = "Windows VirtualBox"
          , dwTag = vmTag
          , dwClass = c
@@ -407,15 +290,11 @@ vmDynamicWorkspace =
          }
 
 xsaneDynamicWorkspace :: Sometimes DynWorkspace
-xsaneDynamicWorkspace =
+xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
-  Sometimes
-    "scanner workspace"
-    xpfXSANE
   [Subfeature (IORoot_ dw tree) "xsane"]
   where
     tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
-    dw =
+    dw = DynWorkspace
-      DynWorkspace
          { dwName = "XSane"
          , dwTag = xsaneTag
          , dwClass = c
@@ -426,15 +305,11 @@ xsaneDynamicWorkspace =
     c = "Xsane"
 
 f5vpnDynamicWorkspace :: Sometimes DynWorkspace
-f5vpnDynamicWorkspace =
+f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
-  Sometimes
-    "F5 VPN workspace"
-    xpfF5VPN
   [Subfeature (IORoot_ dw tree) "f5vpn"]
   where
     tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
-    dw =
+    dw = DynWorkspace
-      DynWorkspace
          { dwName = "F5Vpn"
          , dwTag = f5Tag
          , dwClass = c
@@ -445,48 +320,42 @@ f5vpnDynamicWorkspace =
     c = "F5 VPN"
 
 allDWs' :: [Sometimes DynWorkspace]
-allDWs' =
+allDWs' = [xsaneDynamicWorkspace
-  [ 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 =
+myLayouts tt = onWorkspace vmTag vmLayout
-  onWorkspace vmTag vmLayout $
+  $ onWorkspace gimpTag gimpLayout
-    onWorkspace gimpTag gimpLayout $
+  $ mkToggle (single HIDE)
-      mkToggle (single HIDE) $
+  $ tall ||| fulltab ||| full
-        tall ||| fulltab ||| full
   where
     addTopBar = noFrillsDeco shrinkText tt
-    tall =
+    tall = renamed [Replace "Tall"]
-      renamed [Replace "Tall"] $
+      $ avoidStruts
-        avoidStruts $
+      $ addTopBar
-          addTopBar $
+      $ noBorders
-            noBorders $
+      $ Tall 1 0.03 0.5
-              Tall 1 0.03 0.5
+    fulltab = renamed [Replace "Tabbed"]
-    fulltab =
+      $ avoidStruts
-      renamed [Replace "Tabbed"] $
+      $ noBorders
-        avoidStruts $
+      $ tabbedAlways shrinkText tt
-          noBorders $
+    full = renamed [Replace "Full"]
-            tabbedAlways shrinkText tt
+      $ noBorders Full
-    full =
-      renamed [Replace "Full"] $
-        noBorders Full
     vmLayout = noBorders Full
     -- TODO use a tabbed layout for multiple master windows
-    gimpLayout =
+    gimpLayout = renamed [Replace "Gimp Layout"]
-      renamed [Replace "Gimp Layout"] $
+      $ avoidStruts
-        avoidStruts $
+      $ noBorders
-          noBorders $
+      $ addTopBar
-            addTopBar $
+      $ Tall 1 0.025 0.8
-              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.
@@ -508,9 +377,10 @@ runHide :: X ()
 runHide = sendMessage $ Toggle HIDE
 
 --------------------------------------------------------------------------------
--- Loghook configuration
+-- | Loghook configuration
+--
 
-myLoghook :: Process Handle () () -> X ()
+myLoghook :: Handle -> X ()
 myLoghook h = do
   logXinerama h
   logViewports
@@ -526,7 +396,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 []
@@ -539,9 +409,8 @@ logViewports = withWindowSet $ \s -> do
   whenChanged (DesktopViewports desktopViewports) $
       setDesktopViewports desktopViewports
   where
-    wsToViewports s w =
+    wsToViewports s w = let cur = W.current s in
-      let cur = W.current s
+      if W.tag w == currentTag cur then currentPos cur else [0, 0]
-       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]
@@ -567,22 +436,20 @@ 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 p = withWindowSet $ \ws ->
+logXinerama :: Handle -> X ()
-  io $
+logXinerama h = withWindowSet $ \ws -> io
-    hPutStrLn (getStdin p) $
+  $ hPutStrLn h
-      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 =
+    onScreen ws = xmobarColor_ hilightFgColor hilightBgColor
-      xmobarColor_ hilightFgColor hilightBgColor $
+      $ (T.pack . pad . T.unpack)
-        (T.pack . pad . T.unpack) $
+      $ T.unwords
-          T.unwords $
+      $ map (fmtTags ws . W.tag . W.workspace)
-            map (fmtTags ws . W.tag . W.workspace) $
+      $ sortBy compareXCoord
-              sortBy compareXCoord $
+      $ W.current ws : W.visible ws
-                W.current ws : W.visible ws
+    offScreen = xmobarColor_ XT.backdropFgColor ""
-    offScreen =
-      xmobarColor_ XT.backdropFgColor ""
       . T.unwords
       . fmap (T.pack . W.tag)
       . filter (isJust . W.stack)
@@ -590,8 +457,7 @@ logXinerama p = withWindowSet $ \ws ->
       . W.hidden
     sep = xmobarColor_ XT.backdropFgColor "" ":"
     layout = T.pack . description . W.layout . W.workspace . W.current
-    nWindows =
+    nWindows = (\x -> T.concat ["(", x, ")"])
-      (\x -> T.concat ["(", x, ")"])
       . T.pack
       . show
       . length
@@ -601,97 +467,76 @@ logXinerama p = withWindowSet $ \ws ->
       . W.current
     hilightBgColor = "#A6D3FF"
     hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
-    fmtTags ws t =
+    fmtTags ws t = let t_ = T.pack t in
-      let t_ = T.pack t
+      if t == W.currentTag ws
-       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
+     -> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
-  -> 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 =
+manageApps dws = composeOne $ concatMap dwHook dws ++
-  composeOne $
+  [ isDialog -?> doCenterFloat
-    concatMap dwHook dws
+  -- the seafile applet
-      ++ [ isDialog -?> doCenterFloat
+  , className =? "Seafile Client" -?> doFloat
-         , -- the seafile applet
+  -- gnucash
-           className =? "Seafile Client" -?> doFloat
+  , (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
-         , -- gnucash
+  -- plots and graphics
-           (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
+  , className =? "R_x11" -?> 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
+myEventHook :: (String -> X ()) -> Event -> X All
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+myEventHook handler = xMsgEventHook handler <+> handleEventHook def
-  => (m () -> IO ())
-  -> (String -> X ())
-  -> Event
-  -> X All
-myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
 
 -- | React to ClientMessage events from concurrent threads
-xMsgEventHook
+xMsgEventHook :: (String -> X ()) -> Event -> X All
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
-  => (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 -> liftIO $ runIO $ logWarn "unknown concurrent message"
+      Unknown   -> io $ putStrLn "WARNING: unknown concurrent message"
     return (All True)
-xMsgEventHook _ _ _ = return (All True)
+xMsgEventHook _ _ = return (All True)
 
 --------------------------------------------------------------------------------
--- Keymap configuration
+-- | Keymap configuration
 
 myModMask :: KeyMask
 myModMask = mod4Mask
 
-addKeymap
+addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
-  :: [DynWorkspace]
+  -> [KeyGroup (X ())] -> XConfig l -> XConfig l
-  -> ([((KeyMask, KeySym), NamedAction)] -> X ())
+addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
-  -> [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
+  [ KeyGroup "Window Layouts"
-      "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
@@ -708,36 +553,32 @@ internalBindings dws c =
     , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
     , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
     ]
-  , KeyGroup
+
-      "Workspaces"
+  , KeyGroup "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, (mods, msg, f) <-
+    ([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces
+      , (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
+  , KeyGroup "Dynamic Workspaces"
-      "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
+
-      "Screens"
+  , KeyGroup "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
@@ -756,9 +597,8 @@ internalBindings dws c =
 
 mkNamedSubmap :: XConfig Layout ->  KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
 mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } =
-  (subtitle h :) $
+  (subtitle h:) $ mkNamedKeymap c
-    mkNamedKeymap c $
+  $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
-      (\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
   <$> b
 
 data KeyBinding a = KeyBinding
@@ -772,13 +612,13 @@ data KeyGroup a = KeyGroup
   , kgBindings :: [KeyBinding a]
   }
 
-evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
+evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
 evalExternal = mapM go
   where
     go k@KeyGroup { kgBindings = bs } =
       (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
 
-evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
+evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
 evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
   (\f -> k { kbMaybeAction = f }) <$> evalFeature a
 
@@ -786,62 +626,59 @@ filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
 filterExternal = fmap go
   where
     go k@KeyGroup { kgBindings = bs } =
-      k
+      k { kgBindings = [ kb { kbMaybeAction = x }
-        { kgBindings =
-            [ kb {kbMaybeAction = x}
                        | kb@KeyBinding { kbMaybeAction = Just x } <- bs
                        ]
         }
 
-externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
+externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-externalBindings runIO cleanup db =
+externalBindings ts db =
-  [ KeyGroup
+  [ KeyGroup "Launchers"
-      "Launchers"
+    [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
-      [ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
+    , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
-      , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
+    , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
-      , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
+    , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
-      , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
+    , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
-      , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
+    , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
-      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
+    , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
-      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
+    , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
-      , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
+    , KeyBinding "M-C-e" "launch editor" $ Left runEditor
-      , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
+    , KeyBinding "M-C-w" "launch browser" $ Left runBrowser
-      , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
+    , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
-      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
+    , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
-      , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
+    , KeyBinding "M-C-q" "launch calc" $ Left runCalc
-      , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
+    , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
-      , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
     ]
-  , KeyGroup
+
-      "Actions"
+  , KeyGroup "Actions"
     [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
-      , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
+    , KeyBinding "M-r" "run program" $ Left runCmdMenu
     , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
-      , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
+    , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
-      , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
+    , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
-      , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
+    , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
-      , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
+    , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
     -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
     ]
-  , KeyGroup
+
-      "Multimedia"
+  , KeyGroup "Multimedia"
-      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
+    [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
-      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
+    , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
-      , KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
+    , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
-      , KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
+    , KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
-      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
+    , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
-      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
+    , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
-      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
+    , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
     ]
-  , KeyGroup
+
-      "Dunst"
+  , KeyGroup "Dunst"
-      [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
+    [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
-      , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
+    , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
-      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
+    , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
-      , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
+    , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
     ]
-  , KeyGroup
+
-      "System"
+  , KeyGroup "System"
     [ KeyBinding "M-." "backlight up" $ ib bctlInc
     , KeyBinding "M-," "backlight down" $ ib bctlDec
     , KeyBinding "M-M1-," "backlight min" $ ib bctlMin
@@ -853,27 +690,25 @@ externalBindings runIO cleanup 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 $ toX runAutorandrMenu
+    , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
-      , KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
+    , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
-      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
+    , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
-      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
+    , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
     , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
     ]
   ]
   where
     ses = dbSesClient db
     sys = dbSysClient db
-    brightessControls ctl getter = (toX . getter . ctl) ses
+    brightessControls ctl getter = (ioSometimes . getter . ctl) ses
     ib = Left . brightessControls intelBacklightControls
     ck = Left . brightessControls clevoKeyboardControls
     ftrAlways n = Right . Always n . Always_ . FallbackAlone
-    restartf = ftrAlways "restart function" (cleanup >> runRestart)
+    restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
     recompilef = ftrAlways "recompile function" runRecompile
-    toX_ = liftIO . runIO
-    toX = fmap toX_
 
 type MaybeX = Maybe (X ())
 

fourmolu.yaml

@@ -1,14 +0,0 @@
-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

lib/Data/Internal/DBus.hs

@@ -1,18 +1,10 @@
-{-# 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
@@ -33,53 +25,43 @@ module Data.Internal.DBus
   , addInterfaceRemovedListener
   , fromSingletonVariant
   , bodyToMaybe
-  , exportPair
+  ) where
-  , displayBusName
+
-  , displayObjectPath
+import           Control.Exception
-  , displayMemberName
+import           Control.Monad
-  , displayInterfaceName
+
-  , displayWrapQuote
+import           Data.Bifunctor
-  )
+import qualified Data.Map.Strict   as M
-where
+import           Data.Maybe
+
+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
+  getDBusClient :: IO (Maybe c)
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => m (Maybe c)
 
-  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
+  disconnectDBusClient :: c -> IO ()
-  disconnectDBusClient = liftIO . disconnect . toClient
+  disconnectDBusClient = disconnect . toClient
 
-  withDBusClient
+  withDBusClient :: (c -> IO a) -> IO (Maybe a)
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  withDBusClient f = do
-    => (c -> m a)
+    client <- getDBusClient
-    -> m (Maybe a)
+    forM client $ \c -> do
-  withDBusClient f =
+      r <- f c
-    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
+      disconnect (toClient c)
+      return r
 
-  withDBusClient_
+  withDBusClient_ :: (c -> IO ()) -> IO ()
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> m ())
-    -> m ()
   withDBusClient_ = void . withDBusClient
 
-  fromDBusClient
+  fromDBusClient :: (c -> a) -> IO (Maybe a)
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> a)
-    -> m (Maybe a)
   fromDBusClient f = withDBusClient (return . f)
 
 newtype SysClient = SysClient Client
@@ -96,101 +78,46 @@ instance SafeClient SesClient where
 
   getDBusClient = fmap SesClient <$> getDBusClient' False
 
-getDBusClient'
+getDBusClient' :: Bool -> IO (Maybe Client)
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Bool
-  -> m (Maybe Client)
 getDBusClient' sys = do
-  res <- try $ liftIO $ if sys then connectSystem else connectSession
+  res <- try $ if sys then connectSystem else connectSession
   case res of
-    Left e -> do
+    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
-      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'
+callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
-  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
-  => MethodCall
+  . call (toClient cl)
-  -> m MethodBody
-callMethod' mc = do
-  cl <- toClient <$> view clientL
-  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
-callMethod
+callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+  -> MemberName -> IO MethodBody
-  => BusName
+callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
-  -> 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 =
+methodCallBus b p i m = (methodCall p i m)
-  (methodCall p i m)
+    { methodCallDestination = Just b }
-    { methodCallDestination = Just b
-    }
 
 --------------------------------------------------------------------------------
--- Bus names
+-- | Bus names
 
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner
+callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
-  :: ( SafeClient c
+callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
-     , 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 =
+    mc = (methodCallBus dbusName dbusPath dbusInterface mem)
-      (methodCallBus dbusName dbusPath dbusInterface mem)
+      { methodCallBody = [toVariant name] }
-        { methodCallBody = [toVariant name]
-        }
     mem = memberName_ "GetNameOwner"
 
 --------------------------------------------------------------------------------
--- Variant parsing
+-- | Variant parsing
 
--- TODO log failures here?
 fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
 fromSingletonVariant = fromVariant <=< listToMaybe
 
@@ -198,72 +125,30 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
 bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 --------------------------------------------------------------------------------
--- Signals
+-- | Signals
 
-type SignalCallback m = [Variant] -> m ()
+type SignalCallback = [Variant] -> IO ()
 
-addMatchCallback
+addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
-  :: ( MonadReader (env c) m
+  -> IO SignalHandler
-     , HasLogFunc (env c)
+addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
-     , 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
+matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-  :: Maybe BusName
+  -> Maybe MemberName -> MatchRule
-  -> Maybe ObjectPath
+matchSignal b p i m = matchAny
-  -> Maybe InterfaceName
-  -> Maybe MemberName
-  -> MatchRule
-matchSignal b p i m =
-  matchAny
   { matchPath = p
   , matchSender = b
   , matchInterface = i
   , matchMember = m
   }
 
-matchSignalFull
+matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-  :: ( MonadReader (env c) m
+  -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
-     , HasLogFunc (env c)
+matchSignalFull client b p i m =
-     , MonadUnliftIO m
+  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
-     , 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"
@@ -271,64 +156,35 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
-callPropertyGet
+callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
-  :: ( HasClient env
+  -> MemberName -> c -> IO [Variant]
-     , MonadReader (env c) m
+callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
-     , HasLogFunc (env c)
+  $ getProperty (toClient cl) $ methodCallBus bus path iface property
-     , 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
+matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-  :: ( MonadReader (env c) m
+  -> IO (Maybe MatchRule)
-     , HasLogFunc (env c)
+matchPropertyFull cl b p =
-     , MonadUnliftIO m
+  matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
-     , 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 :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
+withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
 withSignalMatch f (Match x) = f (Just x)
 withSignalMatch f Failure   = f Nothing
 withSignalMatch _ NoMatch   = return ()
 
-matchPropertyChanged
+matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
-  :: IsVariant a
-  => InterfaceName
-  -> T.Text
-  -> [Variant]
   -> SignalMatch a
 matchPropertyChanged iface property [i, body, _] =
   let i' = (fromVariant i :: Maybe T.Text)
-      b = toMap body
+      b = toMap body in
-   in case (i', b) of
+    case (i', b) of
-        (Just i'', Just b') ->
+      (Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
-          if i'' == T.pack (formatInterfaceName iface)
+        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
-            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
         else NoMatch
       _                   -> Failure
   where
@@ -336,7 +192,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))
 
@@ -352,117 +208,24 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
 omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
-callGetManagedObjects
+callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
-  :: ( MonadReader (env c) m
+  -> IO ObjectTree
-     , HasLogFunc (env c)
+callGetManagedObjects cl bus path =
-     , MonadUnliftIO m
+  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
-     , SafeClient c
+  <$> callMethod cl bus path omInterface getManagedObjects
-     , 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
+addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
-  :: ( MonadReader (env c) m
+  -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
-     , HasLogFunc (env c)
+addInterfaceChangedListener bus prop path sc cl = do
-     , MonadUnliftIO m
+  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
-     , SafeClient c
+  forM rule $ \r -> addMatchCallback r sc cl
-     , 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
+addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
-  :: ( MonadReader (env c) m
+  -> SignalCallback -> c -> IO (Maybe SignalHandler)
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     , SafeClient c
-     , HasClient env
-     )
-  => BusName
-  -> ObjectPath
-  -> SignalCallback m
-  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
-addInterfaceRemovedListener
+addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
-  :: ( MonadReader (env c) m
+  -> SignalCallback -> c -> IO (Maybe SignalHandler)
-     , 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 <> "'"

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,31 +15,35 @@ 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.ByteString as B
+import qualified RIO.Text                        as T
-import RIO.Directory
+
+import           System.Directory
     ( XdgDirectory (..)
     , getXdgDirectory
     )
-import qualified RIO.Text as T
+import           System.IO
--- import System.IO
+
 import           XMonad.Core                     hiding (spawn)
 import           XMonad.Internal.Command.Desktop
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Notify
+import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
 import           XMonad.Util.NamedActions
 
 --------------------------------------------------------------------------------
--- DMenu executables
+-- | DMenu executables
 
 myDmenuCmd :: FilePath
 myDmenuCmd = "rofi"
@@ -66,7 +70,7 @@ myClipboardManager :: FilePath
 myClipboardManager = "greenclip"
 
 --------------------------------------------------------------------------------
--- Packages
+-- | Packages
 
 dmenuPkgs :: [Fulfillment]
 dmenuPkgs = [Package Official "rofi"]
@@ -75,9 +79,9 @@ clipboardPkgs :: [Fulfillment]
 clipboardPkgs = [Package AUR "rofi-greenclip"]
 
 --------------------------------------------------------------------------------
--- Other internal functions
+-- | Other internal functions
 
-spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
+spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
 spawnDmenuCmd n =
   sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
 
@@ -97,153 +101,111 @@ dmenuDep :: IODependency_
 dmenuDep = sysExe dmenuPkgs myDmenuCmd
 
 --------------------------------------------------------------------------------
--- Exported Commands
+-- | Exported Commands
 
 -- TODO test that veracrypt and friends are installed
-runDevMenu :: MonadUnliftIO m => Sometimes (m ())
+runDevMenu :: SometimesX
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
   where
     t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
     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 :: MonadUnliftIO m => Sometimes (m ())
+runBTMenu :: SometimesX
-runBTMenu =
+runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
-  Sometimes
-    "bluetooth selector"
-    xpfBluetooth
   [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
   where
     cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
     tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
 
-runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
+runVPNMenu :: SometimesX
-runVPNMenu =
+runVPNMenu = Sometimes "VPN selector" xpfVPN
-  Sometimes
-    "VPN selector"
-    xpfVPN
   [Subfeature (IORoot_ cmd tree) "rofi VPN"]
   where
-    cmd =
+    cmd = spawnCmd myDmenuVPN
-      spawnCmd myDmenuVPN $
+      $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
-        ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
+    tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
-    tree =
+      $ socketExists "expressVPN" []
-      dmenuTree $
+      $ return "/var/lib/expressvpn/expressvpnd.socket"
-        toAnd_ (localExe [] myDmenuVPN) $
-          socketExists "expressVPN" [] $
-            return "/var/lib/expressvpn/expressvpnd.socket"
 
-runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
+runCmdMenu :: SometimesX
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
 
-runAppMenu :: MonadUnliftIO m => Sometimes (m ())
+runAppMenu :: SometimesX
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
-runWinMenu :: MonadUnliftIO m => Sometimes (m ())
+runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runNetMenu :: Maybe SysClient -> SometimesX
-runNetMenu cl =
+runNetMenu cl = Sometimes "network control menu" enabled
-  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 =
+    tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
-      And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
+      $ toAnd_ (DBusIO dmenuDep) $ DBusIO
-        toAnd_ (DBusIO dmenuDep) $
+      $ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
-          DBusIO $
-            sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
 
-runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
+runAutorandrMenu :: SometimesX
 runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
   where
     cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
     tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
 
 --------------------------------------------------------------------------------
--- Password manager
+-- | Password manager
 
-runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runBwMenu :: Maybe SesClient -> SometimesX
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
-    cmd _ =
+    cmd _ = spawnCmd myDmenuPasswords
-      spawnCmd myDmenuPasswords $
+      $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-        ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
+    tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
-    tree =
+      $ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
-      And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
-        toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
 
 --------------------------------------------------------------------------------
--- Clipboard
+-- | Clipboard
 
-runClipMenu :: MonadUnliftIO m => Sometimes (m ())
+runClipMenu :: SometimesX
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
-    tree =
+    tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
-      listToAnds
-        dmenuDep
-        [ sysExe clipboardPkgs myClipboardManager
                                , process [] $ T.pack myClipboardManager
                                ]
-    args =
+    args = [ "-modi", "\"clipboard:greenclip print\""
-      [ "-modi"
+           , "-show", "clipboard"
-      , "\"clipboard:greenclip print\""
+           , "-run-command", "'{cmd}'"
-      , "-show"
+           ] ++ themeArgs "#00c44e"
-      , "clipboard"
-      , "-run-command"
-      , "'{cmd}'"
-      ]
-        ++ themeArgs "#00c44e"
 
 --------------------------------------------------------------------------------
--- Shortcut menu
+-- | Shortcut menu
 
-runShowKeys
+runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
-  => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
+  $ FallbackAlone fallback
-runShowKeys =
-  Always "keyboard menu" $
-    Option showKeysDMenu $
-      Always_ $
-        FallbackAlone fallback
   where
     -- TODO this should technically depend on dunst
-    fallback =
+    fallback = const $ spawnNotify
-      const $
+      $ defNoteError { body = Just $ Text "could not display keymap" }
-        spawnNotify $
-          defNoteError {body = Just $ Text "could not display keymap"}
 
-showKeysDMenu
+showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+showKeysDMenu = Subfeature
-  => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
-showKeysDMenu =
-  Subfeature
   { sfName = "keyboard shortcut menu"
   , sfData = IORoot_ showKeys $ Only_ dmenuDep
   }
 
-showKeys
+showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+showKeys kbs = io $ do
-  => [((KeyMask, KeySym), NamedAction)]
+      (h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe }
-  -> m ()
+      forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
-showKeys kbs = do
-  h <- spawnPipe cmd
-  B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
-  hClose h
   where
-    cmd =
+    cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
-      fmtCmd myDmenuCmd $
+      ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
-        ["-dmenu", "-p", "commands"]
-          ++ themeArgs "#7f66ff"
-          ++ myDmenuMatchingArgs

lib/XMonad/Internal/Command/Desktop.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
--- General commands
+-- | General commands
 
 module XMonad.Internal.Command.Desktop
   ( myTerm
   , playSound
+
   -- commands
   , runTerm
   , runTMux
@@ -32,32 +33,40 @@ 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.Shell as S
+import           XMonad.Internal.Process
+import           XMonad.Internal.Shell
 import           XMonad.Operations
 
 --------------------------------------------------------------------------------
--- My Executables
+-- | My Executables
 
 myTerm :: FilePath
 myTerm = "urxvt"
@@ -90,11 +99,10 @@ myNotificationCtrl :: FilePath
 myNotificationCtrl = "dunstctl"
 
 --------------------------------------------------------------------------------
--- Packages
+-- | Packages
 
 myTermPkgs :: [Fulfillment]
-myTermPkgs =
+myTermPkgs = [ Package Official "rxvt-unicode"
-  [ Package Official "rxvt-unicode"
              , Package Official "urxvt-perls"
              ]
 
@@ -111,101 +119,78 @@ networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]
 
 --------------------------------------------------------------------------------
--- Misc constants
+-- | Misc constants
 
 volumeChangeSound :: FilePath
 volumeChangeSound = "smb_fireball.wav"
 
 --------------------------------------------------------------------------------
--- Some nice apps
+-- | Some nice apps
 
-runTerm :: MonadUnliftIO m => Sometimes (m ())
+runTerm :: SometimesX
 runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
 
-runTMux :: MonadUnliftIO m => Sometimes (m ())
+runTMux :: SometimesX
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
-    deps =
+    deps = listToAnds (socketExists "tmux" [] socketName)
-      listToAnds (socketExists "tmux" [] socketName) $
+      $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
-        fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
+    act = spawn
-    act =
+      $ T.unpack
-      S.spawn $
+      $ fmtCmd "tmux" ["has-session"]
-        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 <- liftIO getEffectiveUserID
+      u <- getEffectiveUserID
       t <- getTemporaryDirectory
       return $ t </> "tmux-" ++ show u </> "default"
 
-runCalc :: MonadUnliftIO m => Sometimes (m ())
+runCalc :: SometimesX
 runCalc = sometimesIO_ "calculator" "bc" deps act
   where
     deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
     act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
 
-runBrowser :: MonadUnliftIO m => Sometimes (m ())
+runBrowser :: SometimesX
-runBrowser =
+runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
-  sometimesExe
+  False myBrowser
-    "web browser"
-    "brave"
-    [Package AUR "brave-bin"]
-    False
-    myBrowser
 
-runEditor :: MonadUnliftIO m => Sometimes (m ())
+runEditor :: SometimesX
 runEditor = sometimesIO_ "text editor" "emacs" tree cmd
   where
-    cmd =
+    cmd = spawnCmd myEditor
-      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 :: MonadUnliftIO m => Sometimes (m ())
+runFileManager :: SometimesX
-runFileManager =
+runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
-  sometimesExe
+  True "pcmanfm"
-    "file browser"
-    "pcmanfm"
-    [Package Official "pcmanfm"]
-    True
-    "pcmanfm"
 
 --------------------------------------------------------------------------------
--- Multimedia Commands
+-- | Multimedia Commands
 
-runMultimediaIfInstalled
+runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
-  :: MonadUnliftIO m
+runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
-  => T.Text
+  "playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
-  -> T.Text
-  -> Sometimes (m ())
-runMultimediaIfInstalled n cmd =
-  sometimesExeArgs
-    (T.append n " multimedia control")
-    "playerctl"
-    [Package Official "playerctl"]
-    True
-    myMultimediaCtl
-    [cmd]
 
-runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
+runTogglePlay :: SometimesX
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
 
-runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
+runPrevTrack :: SometimesX
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
 
-runNextTrack :: MonadUnliftIO m => Sometimes (m ())
+runNextTrack :: SometimesX
 runNextTrack = runMultimediaIfInstalled "next track" "next"
 
-runStopPlay :: MonadUnliftIO m => Sometimes (m ())
+runStopPlay :: SometimesX
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 
 --------------------------------------------------------------------------------
--- Volume Commands
+-- | Volume Commands
 
 soundDir :: FilePath
 soundDir = "sound"
@@ -217,140 +202,111 @@ playSound file = do
   -- paplay seems to have less latency than aplay
   spawnCmd "paplay" [T.pack p]
 
-featureSound
+featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
-  :: 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 :: MonadUnliftIO m => Sometimes (m ())
+runVolumeDown :: SometimesX
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
 
-runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
+runVolumeUp :: SometimesX
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
 
-runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
+runVolumeMute :: SometimesX
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
--- Notification control
+-- | Notification control
 
-runNotificationCmd
+runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
-  :: 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 =
+    tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
-      toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
+      $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
-        Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
+      $ Method_ $ memberName_ "NotificationAction"
-          Method_ $
-            memberName_ "NotificationAction"
 
-runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationClose :: Maybe SesClient -> SometimesX
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationCloseAll :: Maybe SesClient -> SometimesX
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationHistory :: Maybe SesClient -> SometimesX
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationContext :: Maybe SesClient -> SometimesX
 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 (XIO (P.Process () () ()))
+runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
-runNetAppDaemon cl =
+runNetAppDaemon cl = Sometimes "network applet" xpfVPN
-  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 _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
+    cmd _ = snd <$> spawnPipe "nm-applet"
 
-runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runToggleBluetooth :: Maybe SysClient -> SometimesX
-runToggleBluetooth cl =
+runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
-  Sometimes
-    "bluetooth toggle"
-    xpfBluetooth
   [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
   where
     tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
-    cmd _ =
+    cmd _ = spawn
-      S.spawn $
+      $ T.unpack
-        fmtCmd myBluetooth ["show"]
+      $ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""]
-          #!| "grep -q \"Powered: no\""
       #!&& "a=on"
       #!|| "a=off"
       #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
       #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
 
-runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
+runToggleEthernet :: SometimesX
-runToggleEthernet =
+runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
-  Sometimes
-    "ethernet toggle"
-    xpfEthernet
   [Subfeature root "nmcli"]
   where
-    root =
+    root = IORoot (spawn . T.unpack . cmd) $ And1 (Only readEthernet) $ Only_
-      IORoot cmd $
+      $ sysExe networkManagerPkgs "nmcli"
-        And1 (Only readEthernet) $
-          Only_ $
-            sysExe networkManagerPkgs "nmcli"
     -- TODO make this less noisy
     cmd iface =
-      S.spawn $
+      T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"]
-        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)
-  spawn $
+  spawnAt confDir
-    fmtCmd "cd" [T.pack confDir]
+    $ T.unpack
-      #!&& 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 :: MonadIO m => m FilePath
+getCaptureDir :: IO FilePath
 getCaptureDir = do
   e <- lookupEnv "XDG_DATA_HOME"
   parent <- case e of
@@ -364,38 +320,28 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot
+runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
-  :: 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 =
+    tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
-      toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
+      $ Bus [] $ busName_ "org.flameshot.Flameshot"
-        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 :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runAreaCapture :: Maybe SesClient -> SometimesX
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runDesktopCapture :: Maybe SesClient -> SometimesX
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runScreenCapture :: Maybe SesClient -> SometimesX
 runScreenCapture = runFlameshot "screen capture" "screen"
 
-runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
+runCaptureBrowser :: SometimesX
-runCaptureBrowser = sometimesIO_
+runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
-  "screen capture browser"
+  (Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
-  "feh"
+  dir <- io getCaptureDir
-  (Only_ $ sysExe [Package Official "feh"] myImageBrowser)
-  $ do
-    dir <- getCaptureDir
   spawnCmd myImageBrowser [T.pack dir]

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,8 +14,10 @@ module XMonad.Internal.Command.Power
   , runSuspend
   , runSuspendPrompt
   , runQuitPrompt
+
   -- daemons
   , runAutolock
+
   -- functions
   , hasBattery
   , suspendPrompt
@@ -23,25 +25,35 @@ 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"
 
@@ -52,49 +64,42 @@ myPrimeOffload :: FilePath
 myPrimeOffload = "prime-offload"
 
 --------------------------------------------------------------------------------
--- Packages
+-- | Packages
 
 optimusPackages :: [Fulfillment]
 optimusPackages = [Package AUR "optimus-manager"]
 
 --------------------------------------------------------------------------------
--- Core commands
+-- | Core commands
 
 runScreenLock :: SometimesX
-runScreenLock =
+runScreenLock = sometimesExe "screen locker" "i3lock script"
-  sometimesExe
+  [Package AUR "i3lock-color"] False myScreenlock
-    "screen locker"
-    "i3lock script"
-    [Package AUR "i3lock-color"]
-    False
-    myScreenlock
 
-runPowerOff :: MonadUnliftIO m => m ()
+runPowerOff :: X ()
 runPowerOff = spawn "systemctl poweroff"
 
-runSuspend :: MonadUnliftIO m => m ()
+runSuspend :: X ()
 runSuspend = spawn "systemctl suspend"
 
-runHibernate :: MonadUnliftIO m => m ()
+runHibernate :: X ()
 runHibernate = spawn "systemctl hibernate"
 
-runReboot :: MonadUnliftIO m => m ()
+runReboot :: X ()
 runReboot = spawn "systemctl reboot"
 
 --------------------------------------------------------------------------------
--- Autolock
+-- | Autolock
 
-runAutolock :: Sometimes (XIO (P.Process () () ()))
+runAutolock :: Sometimes (IO ProcessHandle)
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
   where
-    tree =
+    tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
-      And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
+      $ Only_ $ IOSometimes_ runScreenLock
-        Only_ $
+    cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
-          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
@@ -106,7 +111,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
 confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
 
 suspendPrompt :: XT.FontBuilder -> X ()
-suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
+suspendPrompt = confirmPrompt' "suspend?" runSuspend
 
 quitPrompt :: XT.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@@ -122,24 +127,21 @@ 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 :: MonadUnliftIO m => m Bool
+isUsingNvidia :: IO Bool
 isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
 
-hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
+hasBattery :: IO (Maybe T.Text)
 hasBattery = do
-  ps <- fromRight [] <$> tryIO (listDirectory syspath)
+  ps <- fromRight [] <$> tryIOError (listDirectory syspath)
-  ts <- catMaybes <$> mapM readType ps
+  ts <- mapM readType ps
-  return $
+  return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
-    if any (T.isPrefixOf "Battery") ts
-      then Nothing
-      else Just "battery not found"
   where
-    readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
+    readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
     syspath = "/sys/class/power_supply"
 
 runOptimusPrompt' :: XT.FontBuilder -> X ()
@@ -149,32 +151,27 @@ runOptimusPrompt' fb = do
   where
     switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
     prompt mode = T.concat ["gpu switch to ", mode, "?"]
-    cmd mode =
+    cmd mode = spawn $
-      spawn $
+      T.unpack
-        T.pack myPrimeOffload
+      $ T.pack myPrimeOffload
       #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"
 
 runOptimusPrompt :: SometimesX
-runOptimusPrompt =
+runOptimusPrompt = Sometimes "graphics switcher"
-  Sometimes
+  (\x -> xpfOptimus x && xpfBattery x) [s]
-    "graphics switcher"
-    (\x -> xpfOptimus x && xpfBattery x)
-    [s]
   where
     s = Subfeature { sfData = r, sfName = "optimus manager" }
     r = IORoot runOptimusPrompt' t
-    t =
+    t = And1 promptFontDep
-      And1 promptFontDep $
+      $ listToAnds (socketExists "optimus-manager" [] socketName)
-        listToAnds (socketExists "optimus-manager" [] socketName) $
+      $ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
-          sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
     socketName = (</> "optimus-manager") <$> getTemporaryDirectory
 
 --------------------------------------------------------------------------------
--- Universal power prompt
+-- | Universal power prompt
 
-data PowerMaybeAction
+data PowerMaybeAction = Poweroff
-  = Poweroff
     | Shutdown
     | Hibernate
     | Reboot
@@ -210,11 +207,9 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
   where
     comp = mkComplFunFromList theme []
     theme = (XT.promptTheme fb) { promptKeymap = keymap }
-    keymap =
+    keymap = M.fromList
-      M.fromList $
+      $ ((controlMask, xK_g), quit) :
-        ((controlMask, xK_g), quit)
+      map (first $ (,) 0)
-          : map
-            (first $ (,) 0)
       [ (xK_p, sendMaybeAction Poweroff)
       , (xK_s, sendMaybeAction Shutdown)
       , (xK_h, sendMaybeAction Hibernate)
@@ -224,7 +219,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 -> liftIO runPowerOff
+      Poweroff  -> runPowerOff
-      Shutdown -> lock >> liftIO runSuspend
+      Shutdown  -> lock >> runSuspend
-      Hibernate -> lock >> liftIO runHibernate
+      Hibernate -> lock >> runHibernate
-      Reboot -> liftIO runReboot
+      Reboot    -> runReboot

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -2,19 +2,26 @@
 {-# 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
@@ -22,13 +29,12 @@ 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
+data ACPIEvent = Power
-  = Power
     | Sleep
     | LidClose
     deriving (Eq)
@@ -44,7 +50,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)
@@ -58,9 +64,7 @@ parseLine line =
     (_:"LID":"close":_) -> Just LidClose
     _                   -> Nothing
   where
-    splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
+    splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
-    newline = 10
-    space = 32
 
 -- | Send an ACPIEvent to the X server as a ClientMessage
 sendACPIEvent :: ACPIEvent -> IO ()
@@ -68,18 +72,20 @@ sendACPIEvent = sendXMsg ACPI . show . fromEnum
 
 isDischarging :: IO (Maybe Bool)
 isDischarging = do
-  status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
+  status <- try $ 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
-  sock <- socket AF_UNIX Stream defaultProtocol
+  Connection { source = s } <- connect acpiPath
-  connect sock $ SockAddrUnix acpiPath
+  forever $ readStream s
-  forever $ do
+  where
-    out <- recv sock 1024
+    readStream s = do
-    mapM_ sendACPIEvent $ parseLine out
+      out <- S.read s
+      mapM_ sendACPIEvent $ parseLine =<< out
 
 acpiPath :: FilePath
 acpiPath = "/var/run/acpid.socket"
@@ -98,24 +104,22 @@ handleACPI fb lock tag = do
     LidClose -> do
       status <- io isDischarging
       -- only run suspend if battery exists and is discharging
-      forM_ status $ flip when $ liftIO runSuspend
+      forM_ status $ flip when runSuspend
       lock
 
 --------------------------------------------------------------------------------
--- 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 $ io listenACPI
+runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
 
 runHandleACPI :: Always (String -> X ())
 runHandleACPI = Always "ACPI event handler" $ Option sf fallback
   where
     sf = Subfeature withLock "acpid prompt"
-    withLock =
+    withLock = IORoot (uncurry handleACPI)
-      IORoot (uncurry handleACPI) $
+      $ And12 (,) promptFontDep $ Only
-        And12 (,) promptFontDep $
+      $ IOSometimes runScreenLock id
-          Only $
-            IOSometimes runScreenLock id
     fallback = Always_ $ FallbackAlone $ const skip

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,25 +19,23 @@ 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
+data XMsgType = ACPI
-  = ACPI
     | Workspace
     | Unknown
     deriving (Eq, Show)
@@ -52,7 +50,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
@@ -60,12 +58,13 @@ splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
 splitXMsg [] = (Unknown, "")
 splitXMsg (x:xs) = (xtype, tag)
   where
-    xtype = toEnum $ fromIntegral x
+    xtype = toEnum $ fromInteger $ toInteger x
-    tag = chr . fromIntegral <$> takeWhile (/= 0) xs
+    tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs
 
 -- | Emit a ClientMessage event to the X server with the given type and payloud
 sendXMsg :: XMsgType -> String -> IO ()
-sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
+sendXMsg xtype tag = do
+  dpy <- openDisplay ""
   root <- rootWindow dpy $ defaultScreen dpy
   allocaXEvent $ \e -> do
     setEventType e clientMessage
@@ -85,6 +84,8 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> 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

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 --------------------------------------------------------------------------------
--- 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,26 +33,25 @@ 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
@@ -63,14 +62,14 @@ import XMonad.Core
     )
 import           XMonad.Hooks.ManageHelpers               (MaybeManageHook)
 import           XMonad.Internal.Concurrent.ClientMessage
-import XMonad.Internal.IO
+import           XMonad.Internal.Process
 import           XMonad.ManageHook
 import           XMonad.Operations
 import qualified XMonad.StackSet                          as W
 
 --------------------------------------------------------------------------------
--- Dynamic Workspace datatype
+-- | Dynamic Workspace datatype
--- This holds all the data needed to tie an app to a particular dynamic workspace
+-- This hold all the data needed to tie an app to a particular dynamic workspace
 
 data DynWorkspace = DynWorkspace
     { dwName  :: String
@@ -83,7 +82,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
@@ -92,93 +91,79 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String
 
-data WEnv = WEnv
+type WatchedPIDs = MVar [Pid]
-  { wDisplay :: !Display
+
-  , wDynWorkspaces :: ![DynWorkspace]
+data WConf = WConf
-  , wCurPIDs :: !(MVar (S.Set Pid))
+    { display       :: Display
-  , wXEnv :: !XEnv
+    , dynWorkspaces :: [DynWorkspace]
     }
 
-instance HasLogFunc WEnv where
+newtype W a = W (ReaderT WConf IO a)
-  logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
+  deriving (Functor, Monad, MonadIO, MonadReader WConf)
 
-type WIO a = RIO WEnv a
+instance Applicative W where
+  pure = return
+  (<*>) = ap
 
-runWorkspaceMon :: [DynWorkspace] -> XIO ()
+runW :: WConf -> W a -> IO a
-runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
+runW c (W a) = runReaderT a c
-  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)
-  liftIO $ allocaSetWindowAttributes $ \a -> do
+  allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
-  withRunInIO $ \runIO -> do
+  let c = WConf { display = dpy, dynWorkspaces = dws }
-    void $ allocaXEvent $ runIO . withEvents dpy
+  _ <- allocaXEvent $ \e ->
-  where
+    runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
-    wrapEnv dpy ps x =
+  return ()
-      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)
 
-handleEvent :: Event -> WIO ()
+handle :: WatchedPIDs -> Event -> W ()
 
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
-handleEvent MapNotifyEvent {ev_window = w} = do
+handle curPIDs MapNotifyEvent { ev_window = w } = do
-  dpy <- asks wDisplay
+  dpy <- asks display
   hint <- io $ getClassHint dpy w
-  dws <- asks wDynWorkspaces
+  dws <- asks dynWorkspaces
-  let tag =
+  let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
-        M.lookup (resClass hint) $
+  let tag = M.lookup (resClass hint) m
-          M.fromList $
+  io $ forM_ tag $ \t -> do
-            fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
+    a <- internAtom dpy "_NET_WM_PID" False
-  forM_ tag $ \t -> do
+    pid <- getWindowProperty32 dpy a w
-    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 in void $ async $ withUniquePid p' t
+      Just [p] -> let p' = fromIntegral p
+        in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
       _        -> return ()
-handleEvent _ = return ()
 
-withUniquePid :: Pid -> String -> WIO ()
+handle _ _ = return ()
-withUniquePid pid tag = do
+
-  ps <- asks wCurPIDs
+waitAndKill :: String -> Pid -> IO ()
-  pids <- readMVar ps
+waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
-  unless (pid `elem` pids)
+
-    $ bracket_
+withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
-      (modifyMVar_ ps (return . S.insert pid))
+withUniquePid curPIDs pid f = do
-      (modifyMVar_ ps (return . S.delete pid))
+  pids <- readMVar curPIDs
-    $ do
+  unless (pid `elem` pids) $ do
-      logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
+    modifyMVar_ curPIDs (return . (pid:))
-      waitUntilExit pid
+    f
-      logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
+    modifyMVar_ curPIDs (return . filter (/=pid))
-      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 =
+wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
-  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
@@ -186,7 +171,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)
@@ -211,27 +196,25 @@ 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
+      = s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
-            { W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
+          , W.hidden = hs }
-            , 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

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -2,21 +2,26 @@
 {-# 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)
@@ -36,15 +41,13 @@ vmInstanceConfig vmName = do
 vmDirectory :: IO (Either String String)
 vmDirectory = do
   p <- vmConfig
-  s <- tryIO $ readFile p
+  (s :: Either IOException String) <- try $ readFile p
   return $ case s of
     (Left _) -> Left "could not read VirtualBox config file"
-    (Right x) ->
+    (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
-      maybe (Left "Could not parse VirtualBox config file") Right $
+                 $ findDir =<< parseXMLDoc x
-        findDir =<< parseXMLDoc x
   where
-    findDir e =
+    findDir e = findAttr (unqual "defaultMachineFolder")
-      findAttr (unqual "defaultMachineFolder")
       =<< findChild (qual e "SystemProperties")
       =<< findChild (qual e "Global") e
 

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

@@ -1,8 +1,7 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
--- DBus module for Clevo Keyboard control
+-- | DBus module for Clevo Keyboard control
 
 module XMonad.Internal.DBus.Brightness.ClevoKeyboard
   ( callGetBrightnessCK
@@ -11,20 +10,24 @@ 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
@@ -47,41 +50,41 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
 stateFile :: FilePath
 stateFile = backlightDir </> "state"
 
-stateChange :: MonadUnliftIO m => Bool -> m ()
+stateChange :: Bool -> IO ()
 stateChange = writeBool stateFile
 
-stateOn :: MonadUnliftIO m => m ()
+stateOn :: IO ()
 stateOn = stateChange True
 
-stateOff :: MonadUnliftIO m => m ()
+stateOff :: IO ()
 stateOff = stateChange False
 
 brightnessFile :: FilePath
 brightnessFile = backlightDir </> "brightness"
 
-getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+getBrightness :: RawBounds -> IO Brightness
 getBrightness bounds = readPercent bounds brightnessFile
 
-minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+minBrightness :: RawBounds -> IO Brightness
 minBrightness bounds = do
   b <- writePercentMin bounds brightnessFile
   stateOff
   return b
 
-maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+maxBrightness :: RawBounds -> IO Brightness
 maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
 
-incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+incBrightness :: RawBounds -> IO Brightness
 incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
 
-decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+decBrightness :: RawBounds -> IO Brightness
 decBrightness bounds = do
   b <- decPercent steps brightnessFile bounds
   when (b == 0) stateOff
   return b
 
 --------------------------------------------------------------------------------
--- DBus interface
+-- | DBus interface
 
 blPath :: ObjectPath
 blPath = objectPath_ "/clevo_keyboard"
@@ -89,9 +92,8 @@ blPath = objectPath_ "/clevo_keyboard"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
+clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
-clevoKeyboardConfig =
+clevoKeyboardConfig = BrightnessConfig
-  BrightnessConfig
   { bcMin = minBrightness
   , bcMax = maxBrightness
   , bcInc = incBrightness
@@ -105,7 +107,7 @@ clevoKeyboardConfig =
   }
 
 --------------------------------------------------------------------------------
--- Exported haskell API
+-- | Exported haskell API
 
 stateFileDep :: IODependency_
 stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
@@ -114,39 +116,17 @@ brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 
 clevoKeyboardSignalDep :: DBusDependency_ SesClient
-clevoKeyboardSignalDep =
+clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
-  -- TODO do I need to get rid of the IO here?
-  signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportClevoKeyboard
+exportClevoKeyboard :: Maybe SesClient -> SometimesIO
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
-  => Maybe SesClient
+  [stateFileDep, brightnessFileDep] clevoKeyboardConfig
-  -> Sometimes (m (), m ())
-exportClevoKeyboard =
-  brightnessExporter
-    xpfClevoBacklight
-    []
-    [stateFileDep, brightnessFileDep]
-    clevoKeyboardConfig
 
-clevoKeyboardControls
+clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
-  -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
-callGetBrightnessCK
+callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
-  => m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
 
-matchSignalCK
+matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
-  :: ( SafeClient c
-     , HasLogFunc (env c)
-     , HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     )
-  => (Maybe Brightness -> m ())
-  -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig

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

@@ -1,9 +1,7 @@
-{-# 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(..)
@@ -13,52 +11,53 @@ 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 m a b = BrightnessConfig
+data BrightnessConfig a b = BrightnessConfig
-  { bcMin :: (a, a) -> m b
+  { bcMin       :: (a, a) -> IO b
-  , bcMax :: (a, a) -> m b
+  , bcMax       :: (a, a) -> IO b
-  , bcDec :: (a, a) -> m b
+  , bcDec       :: (a, a) -> IO b
-  , bcInc :: (a, a) -> m b
+  , bcInc       :: (a, a) -> IO b
-  , bcGet :: (a, a) -> m b
+  , bcGet       :: (a, a) -> IO b
   , bcMinRaw    :: a
-  , bcGetMax :: m a
+  , bcGetMax    :: IO a
   , bcPath      :: ObjectPath
   , bcInterface :: InterfaceName
   , bcName      :: T.Text
   }
 
-data BrightnessControls m = BrightnessControls
+data BrightnessControls = BrightnessControls
-  { bctlMax :: Sometimes (m ())
+  { bctlMax :: SometimesIO
-  , bctlMin :: Sometimes (m ())
+  , bctlMin :: SometimesIO
-  , bctlInc :: Sometimes (m ())
+  , bctlInc :: SometimesIO
-  , bctlDec :: Sometimes (m ())
+  , bctlDec :: SometimesIO
   }
 
-brightnessControls
+brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  -> BrightnessControls
-  => XPQuery
-  -> BrightnessConfig m a b
-  -> Maybe SesClient
-  -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
   { bctlMax = cb "max brightness" memMax
@@ -69,131 +68,91 @@ brightnessControls q bc cl =
   where
     cb = callBacklight q cl bc
 
-callGetBrightness
+callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
-  :: ( HasClient env
+  -> IO (Maybe n)
-     , MonadReader (env c) m
+callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
-     , MonadUnliftIO m
-     , SafeClient c
-     , Num n
-     )
-  => BrightnessConfig m a b
-  -> m (Maybe n)
-callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-    <$> callMethod xmonadBusName p i memGet
+  <$> callMethod client xmonadBusName p i memGet
 
-signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
+signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
   Endpoint [] xmonadBusName p i $ Signal_ memCur
 
-matchSignal
+matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
-  :: ( HasClient env
+  -> (Maybe n-> IO ()) -> c -> IO ()
-     , 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 =
+    brMatcher = matchAny
-      matchAny
       { matchPath = Just p
       , matchInterface = Just i
       , matchMember = Just memCur
       }
 
 --------------------------------------------------------------------------------
--- Internal DBus Crap
+-- | Internal DBus Crap
 
-brightnessExporter
+brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+  -> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
-  => 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_ (exportBrightnessControlsInner bc) tree cl
+    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
     tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
-exportBrightnessControlsInner
+exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+exportBrightnessControls' bc cl = do
-  => BrightnessConfig m a b
+  let ses = toClient cl
-  -> SesClient
+  maxval <- bcGetMax bc -- assume the max value will never change
-  -> (m (), m ())
+  let bounds = (bcMinRaw bc, maxval)
-exportBrightnessControlsInner bc = cmd
+  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
-  where
+  let funget = bcGet bc
-    cmd = exportPair (bcPath bc) $ \cl_ -> do
+  export ses (bcPath bc) defaultInterface
-      -- assume the max value will never change
-      bounds <- (bcMinRaw bc,) <$> bcGetMax bc
-      runIO <- askRunInIO
-      let autoMethod' m f = autoMethod m $ runIO $ do
-            val <- f bc bounds
-            emitBrightness bc cl_ val
-      funget <- toIO $ bcGet bc bounds
-      return $
-        defaultInterface
     { interfaceName = bcInterface bc
     , interfaceMethods =
       [ autoMethod' memMax bcMax
       , autoMethod' memMin bcMin
       , autoMethod' memInc bcInc
       , autoMethod' memDec bcDec
-              , autoMethod memGet (round <$> funget :: IO Int32)
+      , autoMethod memGet (round <$> funget bounds :: IO Int32)
       ]
     , interfaceSignals = [sig]
     }
-    sig =
+  where
-      I.Signal
+    sig = I.Signal
       { I.signalName = memCur
       , I.signalArgs =
-            [ I.SignalArg
+        [
+          I.SignalArg
           { I.signalArgName = "brightness"
           , I.signalArgType = TypeInt32
           }
         ]
       }
 
-emitBrightness
+emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
-  :: (MonadUnliftIO m, RealFrac b)
-  => BrightnessConfig m a b
-  -> Client
-  -> b
-  -> m ()
 emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
-  liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
+  emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
   where
     sig = signal p i memCur
 
-callBacklight
+callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
-  :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
+  -> MemberName -> SometimesIO
-  => XPQuery
+callBacklight q cl BrightnessConfig { bcPath = p
-  -> Maybe SesClient
+                                    , bcInterface = i
-  -> BrightnessConfig m a b
+                                    , bcName = n } controlName m =
-  -> 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 = void $ withDIO c $ callMethod xmonadBusName p i m
+    cmd c = io $ void $ callMethod c 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"

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

@@ -1,8 +1,7 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
--- DBus module for Intel Backlight control
+-- | DBus module for Intel Backlight control
 
 module XMonad.Internal.DBus.Brightness.IntelBacklight
   ( callGetBrightnessIB
@@ -11,20 +10,22 @@ 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
@@ -46,26 +47,26 @@ maxFile = backlightDir </> "max_brightness"
 curFile :: FilePath
 curFile = backlightDir </> "brightness"
 
-getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
+getMaxRawBrightness :: IO RawBrightness
 getMaxRawBrightness = readInt maxFile
 
-getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+getBrightness :: RawBounds -> IO Brightness
 getBrightness bounds = readPercent bounds curFile
 
-minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+minBrightness :: RawBounds -> IO Brightness
 minBrightness bounds = writePercentMin bounds curFile
 
-maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+maxBrightness :: RawBounds -> IO Brightness
 maxBrightness bounds = writePercentMax bounds curFile
 
-incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+incBrightness :: RawBounds -> IO Brightness
 incBrightness = incPercent steps curFile
 
-decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
+decBrightness :: RawBounds -> IO Brightness
 decBrightness = decPercent steps curFile
 
 --------------------------------------------------------------------------------
--- DBus interface
+-- | DBus interface
 
 blPath :: ObjectPath
 blPath = objectPath_ "/intelbacklight"
@@ -73,11 +74,8 @@ blPath = objectPath_ "/intelbacklight"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-intelBacklightConfig
+intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
-  :: MonadUnliftIO m
+intelBacklightConfig = BrightnessConfig
-  => BrightnessConfig m RawBrightness Brightness
-intelBacklightConfig =
-  BrightnessConfig
   { bcMin = minBrightness
   , bcMax = maxBrightness
   , bcInc = incBrightness
@@ -91,7 +89,7 @@ intelBacklightConfig =
   }
 
 --------------------------------------------------------------------------------
--- Exported haskell API
+-- | Exported haskell API
 
 curFileDep :: IODependency_
 curFileDep = pathRW curFile []
@@ -100,39 +98,17 @@ maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []
 
 intelBacklightSignalDep :: DBusDependency_ SesClient
-intelBacklightSignalDep =
+intelBacklightSignalDep = signalDep intelBacklightConfig
-  -- TODO do I need to get rid of the IO here?
-  signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportIntelBacklight
+exportIntelBacklight :: Maybe SesClient -> SometimesIO
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+exportIntelBacklight = brightnessExporter xpfIntelBacklight []
-  => Maybe SesClient
+  [curFileDep, maxFileDep] intelBacklightConfig
-  -> Sometimes (m (), m ())
-exportIntelBacklight =
-  brightnessExporter
-    xpfIntelBacklight
-    []
-    [curFileDep, maxFileDep]
-    intelBacklightConfig
 
-intelBacklightControls
+intelBacklightControls :: Maybe SesClient -> BrightnessControls
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
-  -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
-callGetBrightnessIB
+callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
-  => m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
-matchSignalIB
+matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
-  :: ( SafeClient c
-     , HasLogFunc (env c)
-     , HasClient env
-     , MonadReader (env c) m
-     , MonadUnliftIO m
-     )
-  => (Maybe Brightness -> m ())
-  -> m ()
 matchSignalIB = matchSignal intelBacklightConfig

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,8 +7,7 @@ module XMonad.Internal.DBus.Common
   , notifyBus
   , notifyPath
   , networkManagerBus
-  )
+  ) where
-where
 
 import           DBus
 
@@ -26,3 +25,4 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
 
 networkManagerBus :: BusName
 networkManagerBus = busName_ "org.freedesktop.NetworkManager"
+

lib/XMonad/Internal/DBus/Control.hs

@@ -1,17 +1,11 @@
-{-# 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
@@ -21,15 +15,16 @@ 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
@@ -41,109 +36,48 @@ 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
+connectDBus :: IO DBusState
-  :: (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 :: MonadUnliftIO m => DBusState -> m ()
+disconnectDBus :: DBusState -> IO ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
 -- | Connect to the DBus and request the XMonad name
-connectDBusX
+connectDBusX :: IO DBusState
-  :: (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
+disconnectDBusX :: DBusState -> IO ()
-  :: (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
+dbusExporters :: [Maybe SesClient -> SometimesIO]
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName
+releaseXMonadName :: SesClient -> IO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
-  => SesClient
-  -> m ()
-releaseXMonadName ses = do
-  -- TODO this might error?
-  liftIO $ void $ releaseName (toClient ses) xmonadBusName
-  logInfo "released xmonad name"
 
-requestXMonadName
+requestXMonadName :: SesClient -> IO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
-  -> m ()
 requestXMonadName ses = do
-  res <- liftIO $ requestName (toClient ses) xmonadBusName []
+  res <- requestName (toClient ses) xmonadBusName []
-  let msg
+  -- TODO if the client is not released on shutdown the owner will be different
-        | res == NamePrimaryOwner = "registering name"
+  let msg | res == NamePrimaryOwner = Nothing
-        | res == NameAlreadyOwner = "this process already owns name"
+          | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
           | res == NameInQueue
-            || res == NameExists =
+            || res == NameExists = Just $ "another process owns " ++ xn
-            "another process owns name"
+          | otherwise = Just $ "unknown error when requesting " ++ xn
-        | otherwise = "unknown error when requesting name"
+  forM_ msg putStrLn
-  logInfo $ msg <> ": " <> xn
   where
-    xn =
+    xn = "'" ++ formatBusName xmonadBusName ++ "'"
-      Utf8Builder $
-        encodeUtf8Builder $
-          T.pack $
-            formatBusName xmonadBusName

lib/XMonad/Internal/DBus/Removable.hs

@@ -1,20 +1,22 @@
-{-# 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
 
@@ -49,8 +51,7 @@ driveRemovedSound :: FilePath
 driveRemovedSound = "smb_pipe.wav"
 
 ruleUdisks :: MatchRule
-ruleUdisks =
+ruleUdisks = matchAny
-  matchAny
   { matchPath = Just path
   , matchInterface = Just interface
   }
@@ -59,52 +60,31 @@ driveFlag :: String
 driveFlag = "org.freedesktop.UDisks2.Drive"
 
 addedHasDrive :: [Variant] -> Bool
-addedHasDrive [_, a] =
+addedHasDrive [_, a] = maybe False (member driveFlag)
-  maybe
-    False
-    (M.member driveFlag)
   (fromVariant a :: Maybe (Map String (Map String Variant)))
 addedHasDrive _ = False
 
 removedHasDrive :: [Variant] -> Bool
-removedHasDrive [_, a] =
+removedHasDrive [_, a] = maybe False (driveFlag `elem`)
-  maybe
-    False
-    (driveFlag `elem`)
   (fromVariant a :: Maybe [String])
 removedHasDrive _ = False
 
-playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
+playSoundMaybe :: FilePath -> Bool -> IO ()
 playSoundMaybe p b = when b $ io $ playSound p
 
 -- NOTE: the udisks2 service should be already running for this module to work.
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices
+listenDevices :: SysClient -> IO ()
-  :: ( 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 = do
+    addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
-      let rule = ruleUdisks {matchMember = Just m}
+      $ playSoundMaybe p . f . signalBody
-      void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
 
-runRemovableMon
+runRemovableMon :: Maybe SysClient -> SometimesIO
-  :: ( 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

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -1,8 +1,7 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
--- DBus module for X11 screensave/DPMS control
+-- | DBus module for X11 screensave/DPMS control
 
 module XMonad.Internal.DBus.Screensaver
   ( exportScreensaver
@@ -10,40 +9,46 @@ 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 RIO
+import           Graphics.X11.Xlib.Display
+
 import           XMonad.Internal.DBus.Common
-import XMonad.Internal.IO
+import           XMonad.Internal.Process
-import XMonad.Internal.Shell
 
 --------------------------------------------------------------------------------
--- Low-level functions
+-- | Low-level functions
 
 type SSState = Bool -- true is enabled
 
-ssExecutable :: FilePath
+ssExecutable :: String
 ssExecutable = "xset"
 
-toggle :: MonadUnliftIO m => m SSState
+toggle :: IO SSState
 toggle = do
   st <- query
-  let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
+  -- TODO figure out how not to do this with shell commands
-  -- this needs to be done with shell commands, because as far as I know there
+  void $ createProcess' $ proc ssExecutable $ "s" : args st
-  -- are no Haskell bindings for DPMSDisable/Enable (from libxext)
+  -- TODO this assumes the command succeeds
-  rc <- runProcess (proc ssExecutable $ "s" : args)
+  return $ not st
-  return $ if rc == ExitSuccess then not st else st
+  where
+    args s = if s then ["off", "-dpms"] else ["on", "+dpms"]
 
-query :: MonadUnliftIO m => m SSState
+query :: IO SSState
 query = do
-  xssi <- withOpenDisplay (liftIO . xScreenSaverQueryInfo)
+  dpy <- openDisplay ""
+  xssi <- xScreenSaverQueryInfo dpy
+  closeDisplay dpy
   return $ case xssi of
     Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
     Just XScreenSaverInfo { xssi_state = _ }                   -> True
@@ -51,7 +56,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
@@ -76,47 +81,40 @@ sigCurrentState :: Signal
 sigCurrentState = signal ssPath interface memState
 
 ruleCurrentState :: MatchRule
-ruleCurrentState =
+ruleCurrentState = matchAny
-  matchAny
   { matchPath = Just ssPath
   , matchInterface = Just interface
   , matchMember = Just memState
   }
 
-emitState :: MonadUnliftIO m => Client -> SSState -> m ()
+emitState :: Client -> SSState -> IO ()
-emitState client sss =
+emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant 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
+exportScreensaver :: Maybe SesClient -> SometimesIO
-  :: (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 = exportPair ssPath $ \cl_ -> do
+    cmd cl = let cl' = toClient cl in
-      liftIO $ withRunInIO $ \run ->
+      export cl' ssPath defaultInterface
-        return $
-          defaultInterface
       { interfaceName = interface
       , interfaceMethods =
-                [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
+        [ autoMethod memToggle $ emitState cl' =<< toggle
-                , autoMethod memQuery (run query)
+        , autoMethod memQuery query
         ]
       , interfaceSignals = [sig]
       }
-    sig =
+    sig = I.Signal
-      I.Signal
       { I.signalName = memState
       , I.signalArgs =
-            [ I.SignalArg
+        [
+          I.SignalArg
           { I.signalArgName = "enabled"
           , I.signalArgType = TypeBoolean
           }
@@ -125,40 +123,18 @@ exportScreensaver ses =
     bus = Bus [] xmonadBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
-callToggle
+callToggle :: Maybe SesClient -> SometimesIO
-  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
-  => Maybe SesClient
+  xmonadBusName ssPath interface memToggle
-  -> Sometimes (m ())
-callToggle =
-  sometimesEndpoint
-    "screensaver toggle"
-    "dbus switch"
-    []
-    xmonadBusName
-    ssPath
-    interface
-    memToggle
 
-callQuery
+callQuery :: SesClient -> IO (Maybe SSState)
-  :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
+callQuery ses = do
-  => m (Maybe SSState)
+  reply <- callMethod ses xmonadBusName ssPath interface memQuery
-callQuery = do
-  reply <- callMethod xmonadBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
-matchSignal
+matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
-  :: ( HasLogFunc (env SesClient)
+matchSignal cb ses = void $ addMatchCallback ruleCurrentState
-     , HasClient env
+  (cb . bodyGetCurrentState) ses
-     , 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

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,122 +21,84 @@ module XMonad.Internal.IO
   -- , isWritable
   , PermResult(..)
   , getPermissionsSafe
-  , waitUntilExit
+  ) where
-  , withOpenDisplay
-  )
-where
 
 import           Data.Char
-import Graphics.X11.Xlib.Display
+import           Data.Text        (pack, unpack)
-import Graphics.X11.Xlib.Event
+import           Data.Text.IO     as T (readFile, writeFile)
-import Graphics.X11.Xlib.Types
+
-import RIO hiding (Display)
+import           System.Directory
-import RIO.Directory
-import RIO.FilePath
-import qualified RIO.Text as T
 import           System.IO.Error
-import System.Process
 
 --------------------------------------------------------------------------------
--- read
+-- | read
 
-readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
+readInt :: (Read a, Integral a) => FilePath -> IO a
-readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
+readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
 
-readBool :: MonadIO m => FilePath -> m Bool
+readBool :: FilePath -> IO Bool
 readBool = fmap (==(1 :: Int)) . readInt
 
 --------------------------------------------------------------------------------
--- write
+-- | write
 
-writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
+writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
-writeInt f = writeFileUtf8 f . T.pack . show
+writeInt f = T.writeFile f . pack . show
 
-writeBool :: MonadIO m => FilePath -> Bool -> m ()
+writeBool :: FilePath -> Bool -> IO ()
 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 :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
+readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO 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 =
+percentToRaw (lower, upper) perc = round $
-  round $
   fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
 
-writePercent
+writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
-  :: (MonadIO m, Integral a, RealFrac b)
-  => (a, a)
-  -> FilePath
-  -> b
-  -> m b
 writePercent bounds path perc = do
-  let t
+  let t | perc > 100 = 100
-        | perc > 100 = 100
         | perc < 0 = 0
         | otherwise = perc
   writeInt path (percentToRaw bounds t :: Int)
   return t
 
-writePercentMin
+writePercentMin :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
-  :: (MonadIO m, Integral a, RealFrac b)
-  => (a, a)
-  -> FilePath
-  -> m b
 writePercentMin bounds path = writePercent bounds path 0
 
-writePercentMax
+writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
-  :: (MonadIO m, Integral a, RealFrac b)
-  => (a, a)
-  -> FilePath
-  -> m b
 writePercentMax bounds path = writePercent bounds path 100
 
-shiftPercent
+shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
-  :: (MonadIO m, Integral a, RealFrac b)
+  -> (a, a) -> IO b
-  => (b -> b -> b)
+shiftPercent f steps path bounds = writePercent bounds path . f stepsize
-  -> 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
+incPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
-  :: (MonadIO m, Integral a, RealFrac b)
-  => Int
-  -> FilePath
-  -> (a, a)
-  -> m b
 incPercent = shiftPercent (+)
 
-decPercent
+decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
-  :: (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)
@@ -146,9 +108,9 @@ data PermResult a = PermResult a | NotFoundError | PermError
 --   fmap _ NotFoundError  = NotFoundError
 --   fmap _ PermError      = PermError
 
-getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
+getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
 getPermissionsSafe f = do
-  r <- tryIO $ getPermissions f
+  r <- tryIOError $ getPermissions f
   return $ case r of
     Right z                            -> PermResult z
     Left (isPermissionError -> True)   -> PermError
@@ -162,20 +124,3 @@ 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

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,34 +16,33 @@ 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 =
+defNoteInfo = defNote
-  defNote
+  { appImage = Just $ Icon "dialog-information-symbolic" }
-    { appImage = Just $ Icon "dialog-information-symbolic"
-    }
 
 defNoteError :: Note
-defNoteError =
+defNoteError = defNote
-  defNote
+  { appImage = Just $ Icon "dialog-error-symbolic" }
-    { 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
@@ -61,6 +60,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'

lib/XMonad/Internal/Process.hs

@@ -0,0 +1,96 @@
+--------------------------------------------------------------------------------
+-- | 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

lib/XMonad/Internal/Shell.hs

@@ -1,159 +1,64 @@
 {-# 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
 
--- | Fork a new process and wait for its exit code.
+import           XMonad.Internal.Process
---
--- 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.
+--------------------------------------------------------------------------------
-withDefaultSignalHandlers :: MonadUnliftIO m => m a -> m a
+-- | Opening subshell
-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 = spawn . fmtCmd cmd
+spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args
+
+--------------------------------------------------------------------------------
+-- | 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, "'"]
 

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,17 +28,18 @@ 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"
@@ -77,7 +78,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)
@@ -92,16 +93,14 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
 sRGB24showT = T.pack . sRGB24show
 
 --------------------------------------------------------------------------------
--- Fonts
+-- | Fonts
 
-data Slant
+data Slant = Roman
-  = Roman
     | Italic
     | Oblique
     deriving (Eq, Show)
 
-data Weight
+data Weight = Light
-  = Light
     | Medium
     | Demibold
     | Bold
@@ -120,21 +119,15 @@ type FontBuilder = FontData -> T.Text
 
 buildFont :: Maybe T.Text -> FontData -> T.Text
 buildFont Nothing _ = "fixed"
-buildFont
+buildFont (Just fam) FontData { weight = w
-  (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 =
+    elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
-        [ T.concat [k, "=", v]
-        | (k, Just v) <-
-            [ ("weight", showLower w)
                                                     , ("slant", showLower l)
                                                     , ("size", showLower s)
                                                     , ("pixelsize", showLower p)
@@ -148,11 +141,10 @@ fallbackFont :: FontBuilder
 fallbackFont = buildFont Nothing
 
 --------------------------------------------------------------------------------
--- Default font and data
+-- | Default font and data
 
 defFontData :: FontData
-defFontData =
+defFontData = FontData
-  FontData
   { size = Just 10
   , antialias = Just True
   , weight = Nothing
@@ -170,34 +162,36 @@ defFontFamily = "DejaVu Sans"
 -- defFontTree = fontTree "DejaVu Sans"
 
 --------------------------------------------------------------------------------
--- Complete themes
+-- | Complete themes
 
 tabbedTheme :: FontBuilder -> D.Theme
-tabbedTheme fb =
+tabbedTheme fb = D.def
-  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 =
+promptTheme fb = P.def
-  P.def
   { P.font              = T.unpack $ fb $ defFontData { size = Just 12 }
   , P.bgColor           = T.unpack bgColor
   , P.fgColor           = T.unpack fgColor

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -1,28 +1,25 @@
 {-# 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
+startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-  :: (MonadUnliftIO m, RealFrac a)
+  -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
-  => Maybe FilePath
+startBacklight matchSignal callGetBrightness icon cb = do
-  -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
+    withDBusClientConnection cb $ \c -> do
-  -> DIO SimpleApp SesClient (Maybe a)
+      matchSignal display c
-  -> T.Text
+      display =<< callGetBrightness c
-  -> 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), "%"]
-    dpy = displayMaybe cb formatBrightness
+      display = displayMaybe cb formatBrightness

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,18 +36,23 @@ 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
@@ -56,44 +61,36 @@ btAlias :: T.Text
 btAlias = "bluetooth"
 
 btDep :: DBusDependency_ SysClient
-btDep =
+btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
-  Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
+  $ Method_ getManagedObjects
-    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 (Just "bluetooth.log") $ startAdapter icons colors cb
+    withDBusClientConnection cb $ startAdapter icons colors cb
 
-startAdapter
+startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
-  :: Icons
-  -> Colors
-  -> Callback
-  -> SysClient
-  -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
+  ot <- getBtObjectTree cl
   state <- newMVar emptyState
-  let dpy = displayIcon cb (iconFormatter is cs)
+  let display = displayIcon cb (iconFormatter is cs) state
-  mapRIO (BTEnv cl state dpy) $ do
+  forM_ (findAdapter ot) $ \adapter -> do
-    ot <- getBtObjectTree
-    case findAdapter ot of
-      Nothing -> logError "could not find bluetooth adapter"
-      Just adapter -> do
     -- set up adapter
-        initAdapter adapter
+    initAdapter state adapter cl
-        void $ addAdaptorListener adapter
+    -- TODO this step could fail; at least warn the user...
+    void $ addAdaptorListener state display adapter cl
     -- set up devices on the adapter (and listeners for adding/removing devices)
     let devices = findDevices adapter ot
-        addDeviceAddedListener adapter
+    addDeviceAddedListener state display adapter cl
-        addDeviceRemovedListener adapter
+    addDeviceRemovedListener state display adapter cl
-        forM_ devices $ \d -> addAndInitDevice d
+    forM_ devices $ \d -> addAndInitDevice state display d cl
     -- after setting things up, show the icon based on the initialized state
-        dpy
+    display
 
 --------------------------------------------------------------------------------
--- 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"
@@ -102,9 +99,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
 type Icons = (T.Text, T.Text)
 
-displayIcon :: Callback -> IconFormatter -> BTIO ()
+displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
 displayIcon callback formatter =
-  liftIO . callback . T.unpack . uncurry formatter =<< readState
+  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
@@ -114,28 +111,13 @@ 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
@@ -148,29 +130,22 @@ data BtState = BtState
   , btPowered :: Maybe Bool
   }
 
+type MutableBtState = MVar BtState
+
 emptyState :: BtState
-emptyState =
+emptyState = BtState
-  BtState
   { btDevices = M.empty
   , btPowered = Nothing
   }
 
-readState :: BTIO (Maybe Bool, Bool)
+readState :: MutableBtState -> IO (Maybe Bool, Bool)
-readState = do
+readState state = do
-  p <- readPowered
+  p <- readPowered state
-  c <- readDevices
+  c <- readDevices state
   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
@@ -179,136 +154,73 @@ findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
 findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
 
 adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
-adaptorHasDevice adaptor device = case splitPathNoRoot device of
+adaptorHasDevice adaptor device = case splitPath device of
-  [org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
+  [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
   _                     -> False
 
-splitPathNoRoot :: ObjectPath -> [FilePath]
+splitPath :: ObjectPath -> [T.Text]
-splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
+splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
 
-getBtObjectTree
+getBtObjectTree :: SysClient -> IO ObjectTree
-  :: ( HasClient env
+getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
-     , SafeClient c
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => m ObjectTree
-getBtObjectTree = callGetManagedObjects btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener
+addBtOMListener :: SignalCallback -> SysClient -> IO ()
-  :: ( HasClient env
+addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
-     , SafeClient c
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
 
-addDeviceAddedListener :: ObjectPath -> BTIO ()
+addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceAddedListener adapter = addBtOMListener addDevice
+addDeviceAddedListener state display adapter client =
+  addBtOMListener addDevice client
   where
-    addDevice = pathCallback adapter $ \d ->
+    addDevice = pathCallback adapter display $ \d ->
-      addAndInitDevice d
+      addAndInitDevice state display d client
 
-addDeviceRemovedListener :: ObjectPath -> BTIO ()
+addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceRemovedListener adapter =
+addDeviceRemovedListener state display adapter sys =
-  addBtOMListener remDevice
+  addBtOMListener remDevice sys
   where
-    remDevice = pathCallback adapter $ \d -> do
+    remDevice = pathCallback adapter display $ \d -> do
-      old <- removeDevice d
+      old <- removeDevice state d
-      cl <- asks btClient
+      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
-      forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler
 
-pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
+pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
-pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
+pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
-  when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
+  when (adaptorHasDevice adapter d) $ f d >> display
-pathCallback _ _ _ = return ()
+pathCallback _ _ _ _ = return ()
 
 --------------------------------------------------------------------------------
--- Adapter
+-- | Adapter
 
-initAdapter :: ObjectPath -> BTIO ()
+initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
-initAdapter adapter = do
+initAdapter state adapter client = do
-  reply <- callGetPowered adapter
+  reply <- callGetPowered adapter client
-  logInfo $ "initializing adapter at path " <> adapter_
+  putPowered state $ fromSingletonVariant reply
-  -- TODO this could fail if the variant is something weird; the only
+
-  -- indication I will get is "NA"
+matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
-  putPowered $ fromSingletonVariant reply
+matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
+
+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
-    adapter_ = displayWrapQuote $ displayObjectPath adapter
+    procMatch = withSignalMatch $ \b -> putPowered state b >> display
 
-matchBTProperty
+callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
-  :: ( SafeClient c
+callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
-     , HasClient env
+  $ memberName_ $ T.unpack adaptorPowered
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => ObjectPath
-  -> m (Maybe MatchRule)
-matchBTProperty p = matchPropertyFull btBus (Just p)
 
-withBTPropertyRule
+matchPowered :: [Variant] -> SignalMatch Bool
-  :: ( SafeClient c
+matchPowered = matchPropertyChanged adapterInterface adaptorPowered
-     , 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
 
-addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
+putPowered :: MutableBtState -> Maybe Bool -> IO ()
-addAdaptorListener adaptor =
+putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
-  withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
-  where
-    procMatch = beforeDisplay . putPowered
 
-callGetPowered
+readPowered :: MutableBtState -> IO (Maybe Bool)
-  :: ( HasClient env
+readPowered = fmap btPowered . readMVar
-     , 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"
@@ -317,68 +229,57 @@ adaptorPowered :: T.Text
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
--- Devices
+-- | Devices
 
-addAndInitDevice :: ObjectPath -> BTIO ()
+addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addAndInitDevice device = do
+addAndInitDevice state display device client = do
-  res <- addDeviceListener device
+  sh <- addDeviceListener state display device client
-  case res of
+  -- TODO add some intelligent error messages here
-    Just handler -> do
+  forM_ sh $ \s -> initDevice state s device client
-      logInfo $ "initializing device at path " <> device_
-      initDevice handler device
-    Nothing -> logError $ "could not initialize device at path " <> device_
-  where
-    device_ = displayWrapQuote $ displayObjectPath device
 
-initDevice :: SignalHandler -> ObjectPath -> BTIO ()
+initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
-initDevice sh device = do
+initDevice state sh device sys = do
-  reply <- callGetConnected device
+  reply <- callGetConnected device sys
-  void $
+  void $ insertDevice state device $
-    insertDevice device $
+    BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
-      BTDevice
-        { btDevConnected = fromVariant =<< listToMaybe reply
              , btDevSigHandler = sh
              }
 
-addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
+addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-addDeviceListener device =
+  -> IO (Maybe SignalHandler)
-  withBTPropertyRule device procMatch devInterface devConnected
+addDeviceListener state display device sys = do
+  rule <- matchBTProperty sys device
+  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
   where
-    procMatch = beforeDisplay . void . updateDevice device
+    procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
 
-callGetConnected
+matchConnected :: [Variant] -> SignalMatch Bool
-  :: ( SafeClient c
+matchConnected = matchPropertyChanged devInterface devConnected
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => ObjectPath
-  -> m [Variant]
-callGetConnected p =
-  callPropertyGet btBus p devInterface $
-    memberName_ (T.unpack devConnected)
 
-insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
+callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
-insertDevice device dev = modifyState $ \s -> do
+callGetConnected p = callPropertyGet btBus p devInterface
+  $ 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 :: ObjectPath -> Maybe Bool -> BTIO Bool
+updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
-updateDevice device status = modifyState $ \s -> do
+updateDevice m device status = modifyMVar m $ \s -> do
   let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s
   return (s { btDevices = new }, anyDevicesConnected new)
 
 anyDevicesConnected :: ConnectedDevices -> Bool
 anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
 
-removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
+removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
-removeDevice device = modifyState $ \s -> do
+removeDevice m device = modifyMVar m $ \s -> do
   let devs = btDevices s
   return (s { btDevices = M.delete device devs }, M.lookup device devs)
 
-readDevices :: BTIO ConnectedDevices
+readDevices :: MutableBtState -> IO ConnectedDevices
-readDevices = fmap btDevices $ readMVar =<< asks btState
+readDevices = fmap btDevices . readMVar
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"

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,14 +9,16 @@
 module Xmobar.Plugins.ClevoKeyboard
   ( ClevoKeyboard(..)
   , ckAlias
-  )
+  ) where
-where
 
 import qualified RIO.Text                                      as T
-import XMonad.Internal.DBus.Brightness.ClevoKeyboard
+
 import           Xmobar
+
 import           Xmobar.Plugins.BacklightCommon
 
+import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
+
 newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
 
 ckAlias :: T.Text
@@ -25,4 +27,4 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = T.unpack ckAlias
   start (ClevoKeyboard icon) =
-    startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
+     startBacklight matchSignalCK callGetBrightnessCK icon

lib/Xmobar/Plugins/Common.hs

@@ -15,12 +15,15 @@ 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 :(
@@ -32,29 +35,17 @@ data Colors = Colors
   }
   deriving (Eq, Show, Read)
 
-startListener
+startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
-  :: ( HasLogFunc (env c)
+  -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
-     , HasClient env
+  -> c -> IO ()
-     , MonadReader (env c) m
+startListener rule getProp fromSignal toColor cb client = do
-     , MonadUnliftIO m
+  reply <- getProp client
-     , 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)
+  void $ addMatchCallback rule (procMatch . fromSignal) client
   where
     procMatch = procSignalMatch cb toColor
 
-procSignalMatch
+procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
-  :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
 procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
 
 colorText :: Colors -> Bool -> T.Text -> T.Text
@@ -67,23 +58,11 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
 na :: T.Text
 na = "N/A"
 
-displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
+displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
-displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
+displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
 
-displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
+displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
-displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
+displayMaybe' cb = maybe (cb $ T.unpack na)
 
-withDBusClientConnection
+withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
-  :: (MonadUnliftIO m, SafeClient c)
+withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
-  => 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

lib/Xmobar/Plugins/Device.hs

@@ -1,8 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 --------------------------------------------------------------------------------
--- Device plugin
+-- | Device plugin
 --
 -- Display different text depending on whether or not the interface has
 -- connectivity
@@ -10,14 +9,18 @@
 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
@@ -41,49 +44,33 @@ devSignal :: T.Text
 devSignal = "Ip4Connectivity"
 
 devDep :: DBusDependency_ SysClient
-devDep =
+devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
-  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
+  $ Method_ getByIP
-    Method_ getByIP
 
-getDevice
+getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
-  => T.Text
-  -> m (Maybe ObjectPath)
-getDevice iface = bodyToMaybe <$> callMethod' mc
   where
-    mc =
+    mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
-      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
       { methodCallBody = [toVariant iface]
       }
 
-getDeviceConnected
+getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
-  :: ( SafeClient c
+getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
-     , HasClient env
+  $ memberName_ $ T.unpack devSignal
-     , 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 =
+  start (Device (iface, text, colors)) cb = do
-    withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
+    withDBusClientConnection cb $ \sys -> do
-      path <- getDevice iface
+      path <- getDevice sys iface
-      displayMaybe' cb listener path
+      displayMaybe' cb (listener sys) path
     where
-      logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
+      listener sys path = do
-      listener path = do
+        rule <- matchPropertyFull sys networkManagerBus (Just path)
-        res <- matchPropertyFull networkManagerBus (Just path)
+        -- TODO warn the user here rather than silently drop the listener
-        case res of
+        forM_ rule $ \r ->
-          Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
+          startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
-          Nothing -> logError "could not start listener"
       chooseColor' = return . (\s -> colorText colors s text) . (> 1)

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,14 +9,16 @@
 module Xmobar.Plugins.IntelBacklight
   ( IntelBacklight(..)
   , blAlias
-  )
+  ) where
-where
 
 import qualified RIO.Text                                       as T
-import XMonad.Internal.DBus.Brightness.IntelBacklight
+
 import           Xmobar
+
 import           Xmobar.Plugins.BacklightCommon
 
+import           XMonad.Internal.DBus.Brightness.IntelBacklight
+
 newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
 
 blAlias :: T.Text
@@ -25,4 +27,4 @@ blAlias = "intelbacklight"
 instance Exec IntelBacklight where
   alias (IntelBacklight _) = T.unpack blAlias
   start (IntelBacklight icon) =
-    startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
+     startBacklight matchSignalIB callGetBrightnessIB icon

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 XMonad.Internal.DBus.Screensaver
+
 import           Xmobar
+
+import           XMonad.Internal.DBus.Screensaver
 import           Xmobar.Plugins.Common
 
 newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
@@ -25,9 +25,10 @@ ssAlias = "screensaver"
 
 instance Exec Screensaver where
   alias (Screensaver _) = T.unpack ssAlias
-  start (Screensaver (text, colors)) cb =
+  start (Screensaver (text, colors)) cb = do
-    withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
+    withDBusClientConnection cb $ \sys -> do
-      matchSignal dpy
+      matchSignal display sys
-      dpy =<< callQuery
+      display =<< callQuery sys
     where
-      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
+      display = displayMaybe cb $ return . (\s -> colorText colors s text)
+

lib/Xmobar/Plugins/VPN.hs

@@ -1,8 +1,7 @@
-{-# 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
@@ -12,16 +11,21 @@ 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
@@ -32,128 +36,80 @@ 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 (Just "vpn.log") $ \c -> do
+    withDBusClientConnection cb $ \c -> do
-      let dpy = displayMaybe cb iconFormatter . Just =<< readState
+    state <- initState c
-      s <- newEmptyMVar
+    let display = displayMaybe cb iconFormatter . Just =<< readState state
-      mapRIO (VEnv c s dpy) $ do
+    let signalCallback' f = f state display
-        initState
+    vpnAddedListener (signalCallback' addedCallback) c
-        vpnAddedListener addedCallback
+    vpnRemovedListener (signalCallback' removedCallback) c
-        vpnRemovedListener removedCallback
+    display
-        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
 
-initState :: VIO ()
+type MutableVPNState = MVar VPNState
-initState = do
-  ot <- getVPNObjectTree
-  s <- asks vState
-  putMVar s $ findTunnels ot
 
-readState :: VIO Bool
+initState :: SysClient -> IO MutableVPNState
-readState = fmap (not . null) . readMVar =<< asks vState
+initState client = do
+  ot <- getVPNObjectTree client
+  newMVar $ findTunnels ot
 
-updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
+readState :: MutableVPNState -> IO Bool
-updateState f op = do
+readState = fmap (not . null) . readMVar
-  s <- asks vState
-  modifyMVar_ s $ return . f op
 
-beforeDisplay :: VIO () -> VIO ()
+updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-beforeDisplay f = f >> join (asks vDisplay)
+  -> ObjectPath -> IO ()
+updateState f state op = modifyMVar_ state $ return . f op
 
 --------------------------------------------------------------------------------
--- Tunnel Device Detection
+-- | Tunnel Device Detection
+--
 
-getVPNObjectTree
+getVPNObjectTree :: SysClient -> IO ObjectTree
-  :: ( SafeClient c
+getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
-     , 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
+vpnAddedListener :: SignalCallback -> SysClient -> IO ()
-  :: ( SafeClient c
+vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
 
-vpnRemovedListener
+vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
-  :: ( SafeClient c
+vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
 
-addedCallback :: SignalCallback VIO
+addedCallback :: MutableVPNState -> IO () -> SignalCallback
-addedCallback [device, added] =
+addedCallback state display [device, added] = update >> display
-  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))
-addedCallback _ = return ()
+    is = M.keys $ fromMaybe M.empty added'
+    update = updateDevice S.insert state device is
+addedCallback _ _ _                       = return ()
 
-removedCallback :: SignalCallback VIO
+removedCallback :: MutableVPNState -> IO () -> SignalCallback
-removedCallback [device, interfaces] =
+removedCallback state display [device, interfaces] = update >> display
-  beforeDisplay $
+  where
-    updateDevice S.delete device $
+    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
-      fromMaybe [] $
+    update = updateDevice S.delete state device is
-        fromVariant interfaces
+removedCallback _ _ _                       = return ()
-removedCallback _ = return ()
 
-updateDevice
+updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-  :: (ObjectPath -> VPNState -> VPNState)
+  -> Variant -> [T.Text] -> IO ()
-  -> Variant
+updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
-  -> [T.Text]
+  forM_ d $ updateState f state
-  -> 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"
@@ -168,6 +124,5 @@ vpnAlias :: T.Text
 vpnAlias = "vpn"
 
 vpnDep :: DBusDependency_ SysClient
-vpnDep =
+vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
-  Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
+  $ Method_ getManagedObjects
-    Method_ getManagedObjects

package.yaml

@@ -7,7 +7,7 @@ copyright:           "2022 Nathan Dwarshuis"
 
 extra-source-files:
 - README.md
-- fourmolu.yaml
+- .stylish-haskell.yaml
 - make_pkgs
 - icons/*
 - scripts/*
@@ -19,23 +19,28 @@ 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/