ENH use firefox

This reverts commit 769df2fb00.

.stylish-haskell.yaml

@@ -1,357 +0,0 @@
-# stylish-haskell configuration file
-# ==================================
-
-# The stylish-haskell tool is mainly configured by specifying steps. These steps
-# are a list, so they have an order, and one specific step may appear more than
-# once (if needed). Each file is processed by these steps in the given order.
-steps:
-  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
-  # by default.
-  # - unicode_syntax:
-  #     # In order to make this work, we also need to insert the UnicodeSyntax
-  #     # language pragma. If this flag is set to true, we insert it when it's
-  #     # not already present. You may want to disable it if you configure
-  #     # language extensions using some other method than pragmas. Default:
-  #     # true.
-  #     add_language_pragma: true
-
-  # Format module header
-  #
-  # Currently, this option is not configurable and will format all exports and
-  # module declarations to minimize diffs
-  #
-  # - module_header:
-  #     # How many spaces use for indentation in the module header.
-  #     indent: 4
-  #
-  #     # Should export lists be sorted?  Sorting is only performed within the
-  #     # export section, as delineated by Haddock comments.
-  #     sort: true
-  #
-  #     # See `separate_lists` for the `imports` step.
-  #     separate_lists: true
-
-  # Format record definitions. This is disabled by default.
-  #
-  # You can control the layout of record fields. The only rules that can't be configured
-  # are these:
-  #
-  # - "|" is always aligned with "="
-  # - "," in fields is always aligned with "{"
-  # - "}" is likewise always aligned with "{"
-  #
-  # - records:
-  #     # How to format equals sign between type constructor and data constructor.
-  #     # Possible values:
-  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
-  #     equals: "indent 2"
-  #
-  #     # How to format first field of each record constructor.
-  #     # Possible values:
-  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
-  #     first_field: "indent 2"
-  #
-  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
-  #     field_comment: 2
-  #
-  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
-  #     deriving: 2
-  #
-  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
-  #     # Possible values:
-  #     # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
-  #     # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
-  #     via: "indent 2"
-  #
-  #     # Sort typeclass names in the "deriving" list alphabetically.
-  #     sort_deriving: true
-  #
-  #     # Wheter or not to break enums onto several lines
-  #     #
-  #     # Default: false
-  #     break_enums: false
-  #
-  #     # Whether or not to break single constructor data types before `=` sign
-  #     #
-  #     # Default: true
-  #     break_single_constructors: true
-  #
-  #     # Whether or not to curry constraints on function.
-  #     #
-  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
-  #     #
-  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
-  #     #
-  #     # Default: false
-  #     curried_context: false
-
-  # Align the right hand side of some elements.  This is quite conservative
-  # and only applies to statements where each element occupies a single
-  # line.
-  # Possible values:
-  # - always - Always align statements.
-  # - adjacent - Align statements that are on adjacent lines in groups.
-  # - never - Never align statements.
-  # All default to always.
-  - simple_align:
-      cases: always
-      top_level_patterns: always
-      records: always
-      multi_way_if: always
-
-  # Import cleanup
-  - imports:
-      # There are different ways we can align names and lists.
-      #
-      # - global: Align the import names and import list throughout the entire
-      #   file.
-      #
-      # - file: Like global, but don't add padding when there are no qualified
-      #   imports in the file.
-      #
-      # - group: Only align the imports per group (a group is formed by adjacent
-      #   import lines).
-      #
-      # - none: Do not perform any alignment.
-      #
-      # Default: global.
-      align: global
-
-      # The following options affect only import list alignment.
-      #
-      # List align has following options:
-      #
-      # - after_alias: Import list is aligned with end of import including
-      #   'as' and 'hiding' keywords.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                          init, last, length)
-      #
-      # - with_alias: Import list is aligned with start of alias or hiding.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                 init, last, length)
-      #
-      # - with_module_name: Import list is aligned `list_padding` spaces after
-      #   the module name.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #                          init, last, length)
-      #
-      #   This is mainly intended for use with `pad_module_names: false`.
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, head,
-      #                          init, last, length, scanl, scanr, take, drop,
-      #                          sort, nub)
-      #
-      # - new_line: Import list starts always on new line.
-      #
-      #   > import qualified Data.List      as List
-      #   >     (concat, foldl, foldr, head, init, last, length)
-      #
-      # - repeat: Repeat the module name to align the import list.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head)
-      #   > import qualified Data.List      as List (init, last, length)
-      #
-      # Default: after_alias
-      list_align: after_alias
-
-      # Right-pad the module names to align imports in a group:
-      #
-      # - true: a little more readable
-      #
-      #   > import qualified Data.List       as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # - false: diff-safe
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, init,
-      #   >                                     last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # Default: true
-      pad_module_names: true
-
-      # Long list align style takes effect when import is too long. This is
-      # determined by 'columns' setting.
-      #
-      # - inline: This option will put as much specs on same line as possible.
-      #
-      # - new_line: Import list will start on new line.
-      #
-      # - new_line_multiline: Import list will start on new line when it's
-      #   short enough to fit to single line. Otherwise it'll be multiline.
-      #
-      # - multiline: One line per import list entry.
-      #   Type with constructor list acts like single import.
-      #
-      #   > import qualified Data.Map as M
-      #   >     ( empty
-      #   >     , singleton
-      #   >     , ...
-      #   >     , delete
-      #   >     )
-      #
-      # Default: inline
-      long_list_align: multiline
-
-      # Align empty list (importing instances)
-      #
-      # Empty list align has following options
-      #
-      # - inherit: inherit list_align setting
-      #
-      # - right_after: () is right after the module name:
-      #
-      #   > import Vector.Instances ()
-      #
-      # Default: inherit
-      empty_list_align: inherit
-
-      # List padding determines indentation of import list on lines after import.
-      # This option affects 'long_list_align'.
-      #
-      # - <integer>: constant value
-      #
-      # - module_name: align under start of module name.
-      #   Useful for 'file' and 'group' align settings.
-      #
-      # Default: 4
-      list_padding: 4
-
-      # Separate lists option affects formatting of import list for type
-      # or class. The only difference is single space between type and list
-      # of constructors, selectors and class functions.
-      #
-      # - true: There is single space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
-      #
-      # - false: There is no space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
-      #
-      # Default: true
-      separate_lists: true
-
-      # Space surround option affects formatting of import lists on a single
-      # line. The only difference is single space after the initial
-      # parenthesis and a single space before the terminal parenthesis.
-      #
-      # - true: There is single space associated with the enclosing
-      #   parenthesis.
-      #
-      #   > import Data.Foo ( foo )
-      #
-      # - false: There is no space associated with the enclosing parenthesis
-      #
-      #   > import Data.Foo (foo)
-      #
-      # Default: false
-      space_surround: false
-
-      # Enabling this argument will use the new GHC lib parse to format imports.
-      #
-      # This currently assumes a few things, it will assume that you want post
-      # qualified imports. It is also not as feature complete as the old
-      # imports formatting.
-      #
-      # It does not remove redundant lines or merge lines. As such, the full
-      # feature scope is still pending.
-      #
-      # It _is_ however, a fine alternative if you are using features that are
-      # not parseable by haskell src extensions and you're comfortable with the
-      # presets.
-      #
-      # Default: false
-      ghc_lib_parser: false
-
-  # Language pragmas
-  - language_pragmas:
-      # We can generate different styles of language pragma lists.
-      #
-      # - vertical: Vertical-spaced language pragmas, one per line.
-      #
-      # - compact: A more compact style.
-      #
-      # - compact_line: Similar to compact, but wrap each line with
-      #   `{-#LANGUAGE #-}'.
-      #
-      # Default: vertical.
-      style: vertical
-
-      # Align affects alignment of closing pragma brackets.
-      #
-      # - true: Brackets are aligned in same column.
-      #
-      # - false: Brackets are not aligned together. There is only one space
-      #   between actual import and closing bracket.
-      #
-      # Default: true
-      align: true
-
-      # stylish-haskell can detect redundancy of some language pragmas. If this
-      # is set to true, it will remove those redundant pragmas. Default: true.
-      remove_redundant: true
-
-      # Language prefix to be used for pragma declaration, this allows you to
-      # use other options non case-sensitive like "language" or "Language".
-      # If a non correct String is provided, it will default to: LANGUAGE.
-      language_prefix: LANGUAGE
-
-  # Replace tabs by spaces. This is disabled by default.
-  # - tabs:
-  #     # Number of spaces to use for each tab. Default: 8, as specified by the
-  #     # Haskell report.
-  #     spaces: 8
-
-  # Remove trailing whitespace
-  - trailing_whitespace: {}
-
-  # Squash multiple spaces between the left and right hand sides of some
-  # elements into single spaces. Basically, this undoes the effect of
-  # simple_align but is a bit less conservative.
-  # - squash: {}
-
-# A common setting is the number of columns (parts of) code will be wrapped
-# to. Different steps take this into account.
-#
-# Set this to null to disable all line wrapping.
-#
-# Default: 80.
-columns: 80
-
-# By default, line endings are converted according to the OS. You can override
-# preferred format here.
-#
-# - native: Native newline format. CRLF on Windows, LF on other OSes.
-#
-# - lf: Convert to LF ("\n").
-#
-# - crlf: Convert to CRLF ("\r\n").
-#
-# Default: native.
-newline: native
-
-# Sometimes, language extensions are specified in a cabal file or from the
-# command line instead of using language pragmas in the file. stylish-haskell
-# needs to be aware of these, so it can parse the file correctly.
-#
-# No language extensions are enabled by default.
-# language_extensions:
-  # - TemplateHaskell
-  # - QuasiQuotes
-
-# Attempt to find the cabal file in ancestors of the current directory, and
-# parse options (currently only language extensions) from that.
-#
-# Default: true
-cabal: true

README.md

@@ -18,3 +18,33 @@ Built just for me...although you may fork if you like it ;)
    * selecting Wifi networks (networkmanager_dmenu)
    * clipboard management (greenclip)
    * mounting disks
+
+# Installation
+
+The "easy" way will only work on Arch out of the box.
+
+After cloning this repo, move to the root of this repo and install the build
+dependency packages:
+
+```
+pacman -S --needed - < make_pkgs
+```
+
+Build/install xmonad/xmobar binaries:
+
+```
+stack install
+```
+
+Install official runtime dependencies:
+
+```
+pacman -S --needed $(./scripts/pacman_deps)
+```
+
+Install unofficial runtime dependencies with your favorite AUR helper (which is
+obviously yay):
+
+```
+yay -S $(./scripts/aur_deps)
+```

bin/vbox-start.hs

@@ -0,0 +1,74 @@
+-- | Start a VirtualBox instance with a sentinel wrapper process.
+--
+-- The only reason why this is needed is because I want to manage virtualboxes
+-- in their own dynamic workspaces, which are currently set up to correspond to
+-- one process. The problem with Virtualbox is that the VBoxManage command
+-- spawns a new VM and then exits, which means the process that was originally
+-- attached to the dynamic workspace only exists for a few seconds when the VM
+-- is starting.
+--
+-- Solution: Run VBoxManage in a wrapper binary that launches the VM and sleeps
+-- 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 XMonad.Internal.Concurrent.VirtualBox
+import XMonad.Internal.IO
+
+main :: IO ()
+main = do
+  args <- getArgs
+  runSimpleApp $
+    runAndWait args
+
+runAndWait :: [String] -> RIO SimpleApp ()
+runAndWait [n] = do
+  c <- liftIO $ vmInstanceConfig (T.pack n)
+  either (logError . displayBytesUtf8 . encodeUtf8) runConfig c
+  where
+    runConfig c = maybe err runID =<< vmMachineID c
+    runID i = do
+      vmLaunch i
+      p <- vmPID i
+      liftIO $ mapM_ waitUntilExit p
+    err = logError "Could not get machine ID"
+runAndWait _ = logInfo "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: "
+          <> displayBytesUtf8 (encodeUtf8 i)
+
+vmPID :: T.Text -> RIO SimpleApp (Maybe Pid)
+vmPID vid = do
+  (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
+  return $ case rc of
+    ExitSuccess -> readMaybe $ BU.toString out
+    _ -> Nothing
+
+vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text)
+vmMachineID iPath = do
+  res <- tryAny $ readFileUtf8 iPath
+  case res of
+    Right contents -> return $ findMachineID contents
+    Left e -> logError (displayShow e) >> return Nothing
+  where
+    findMachineID c =
+      T.stripSuffix "}"
+        =<< T.stripPrefix "{"
+        =<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
+        =<< (\e -> findChild (qual e "Machine") e)
+        =<< parseXMLDoc c

bin/xmobar.hs

@@ -1,6 +1,3 @@
-module Main (main) where
-
---------------------------------------------------------------------------------
 -- | Xmobar binary
 --
 -- Features:
@@ -10,52 +7,80 @@ module Main (main) where
 -- * Some custom plugins (imported below)
 -- * Theme integration with xmonad (shared module imported below)
 -- * A custom Locks plugin from my own forked repo
+module Main (main) where
 
-import           Data.Internal.DBus
-import           Data.Internal.Dependency
-import           Data.List
-import           Data.Maybe
-
-import           System.Exit
-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.Hooks.DynamicLog                        hiding (xmobar)
-import           XMonad.Internal.Command.Desktop
-import           XMonad.Internal.Command.Power
-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 T
-import           Xmobar                                         hiding
-    ( iconOffset
-    )
-import           Xmobar.Plugins.Common
+import Data.Internal.DBus
+import Data.Internal.XIO
+import GHC.Enum (enumFrom)
+import Options.Applicative
+import RIO hiding (hFlush)
+import RIO.FilePath
+import RIO.List
+import qualified RIO.NonEmpty as NE
+import qualified RIO.Text as T
+import XMonad.Core hiding (config)
+import XMonad.Internal.Command.Power
+import XMonad.Internal.DBus.Brightness.ClevoKeyboard
+import XMonad.Internal.DBus.Brightness.IntelBacklight
+import XMonad.Internal.DBus.Control
+import XMonad.Internal.DBus.Screensaver (ssSignalDep)
+import qualified XMonad.Internal.Theme as XT
+import Xmobar hiding
+  ( iconOffset
+  , run
+  )
+import Xmobar.Plugins.ActiveConnection
+import Xmobar.Plugins.Bluetooth
+import Xmobar.Plugins.ClevoKeyboard
+import Xmobar.Plugins.Common
+import Xmobar.Plugins.IntelBacklight
+import Xmobar.Plugins.Screensaver
 
 main :: IO ()
-main = do
-  db <- connectDBus
-  c <- withCache $ evalConfig db
-  disconnectDBus db
-  -- this is needed to prevent waitForProcess error when forking in plugins (eg
-  -- alsacmd)
-  _ <- installHandler sigCHLD Default Nothing
-  -- this is needed to see any printed messages
-  hFlush stdout
-  xmobar c
+main = parse >>= xio
 
-evalConfig :: DBusState -> FIO Config
+parse :: IO XOpts
+parse = execParser opts
+  where
+    parseOpts = parseDeps <|> parseTest <|> pure XRun
+    opts =
+      info (parseOpts <**> helper) $
+        fullDesc <> header "xmobar: the best taskbar ever"
+
+data XOpts = XDeps | XTest | XRun
+
+parseDeps :: Parser XOpts
+parseDeps =
+  flag'
+    XDeps
+    (long "deps" <> short 'd' <> help "print dependencies")
+
+parseTest :: Parser XOpts
+parseTest =
+  flag'
+    XTest
+    (long "test" <> short 't' <> help "test dependencies without running")
+
+xio :: XOpts -> IO ()
+xio o = case o of
+  XDeps -> hRunXIO False stderr printDeps
+  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
+  XRun -> runXIO "xmobar.log" run
+
+run :: XIO ()
+run = do
+  -- IDK why this is needed, I thought this was default
+  liftIO $ hSetBuffering stdout LineBuffering
+  -- this isn't totally necessary except for the fact that killing xmobar
+  -- will make it print something about catching SIGTERM, and without
+  -- linebuffering it usually only prints the first few characters (even then
+  -- it only prints 10-20% of the time)
+  liftIO $ hSetBuffering stderr LineBuffering
+  -- TODO do these dbus things really need to remain connected?
+  c <- withDBus Nothing Nothing evalConfig
+  liftIO $ xmobar c
+
+evalConfig :: DBusState -> XIO Config
 evalConfig db = do
   cs <- getAllCommands <$> rightPlugins db
   bf <- getTextFont
@@ -63,11 +88,20 @@ evalConfig db = do
   d <- io $ cfgDir <$> getDirectories
   return $ config bf ifs ios cs d
 
+printDeps :: XIO ()
+printDeps = withDBus_ Nothing Nothing $ \db ->
+  mapM_ logInfo $
+    fmap showFulfillment $
+      sort $
+        nub $
+          concatMap dumpFeature $
+            allFeatures db
+
 --------------------------------------------------------------------------------
--- | toplevel configuration
+-- toplevel configuration
 
 -- | The text font family
-textFont :: Always T.FontBuilder
+textFont :: Always XT.FontBuilder
 textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs
 
 -- | Offset of the text in the bar
@@ -75,84 +109,94 @@ textFontOffset :: Int
 textFontOffset = 16
 
 -- | Attributes for the bar font (size, weight, etc)
-textFontData :: T.FontData
-textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
+textFontData :: XT.FontData
+textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
 
 -- | The icon font family
-iconFont :: Sometimes T.FontBuilder
-iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
-  [Package Official "ttf-nerd-fonts-symbols"]
+iconFont :: Sometimes XT.FontBuilder
+iconFont =
+  fontSometimes
+    "XMobar Icon Font"
+    "Symbols Nerd Font"
+    [Package Official "ttf-nerd-fonts-symbols"]
 
 -- | Offsets for the icons in the bar (relative to the text offset)
 iconOffset :: BarFont -> Int
-iconOffset IconSmall  = 0
+iconOffset IconSmall = 0
 iconOffset IconMedium = 1
-iconOffset IconLarge  = 1
+iconOffset IconLarge = 1
 iconOffset IconXLarge = 2
 
 -- | Sizes (in pixels) for the icon fonts
 iconSize :: BarFont -> Int
-iconSize IconSmall  = 13
+iconSize IconSmall = 13
 iconSize IconMedium = 15
-iconSize IconLarge  = 18
+iconSize IconLarge = 18
 iconSize IconXLarge = 20
 
 -- | Attributes for icon fonts
-iconFontData :: Int -> T.FontData
-iconFontData s = T.defFontData { T.pixelsize = Just s, T.size = Nothing }
+iconFontData :: Int -> XT.FontData
+iconFontData s = XT.defFontData {XT.pixelsize = Just s, XT.size = Nothing}
 
 -- | Global configuration
 -- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
 -- only one) text font, and all other fonts are icon fonts. If this assumption
 -- changes the code will need to change significantly
-config :: String -> [String] -> [Int] -> BarRegions -> FilePath -> Config
-config bf ifs ios br confDir = defaultConfig
-  { font = bf
-  , additionalFonts = ifs
-  , textOffset = textFontOffset
-  , textOffsets = ios
-  , bgColor = T.bgColor
-  , fgColor = T.fgColor
-  , position = BottomSize C 100 24
-  , border = NoBorder
-  , borderColor = T.bordersColor
-
-  , sepChar = pSep
-  , alignSep = [lSep, rSep]
-  , template = fmtRegions br
-
-  , lowerOnStart = False
-  , hideOnStart = False
-  , allDesktops = True
-  , overrideRedirect = True
-  , pickBroadest = False
-  , persistent = True
-  -- store the icons with the xmonad/xmobar stack project
-  , iconRoot = confDir ++ "/icons"
-
-  , commands = csRunnable <$> concatRegions br
-  }
+config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
+config bf ifs ios br confDir =
+  defaultConfig
+    { font = T.unpack bf
+    , additionalFonts = fmap T.unpack ifs
+    , textOffset = textFontOffset
+    , textOffsets = ios
+    , bgColor = T.unpack XT.bgColor
+    , fgColor = T.unpack XT.fgColor
+    , 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
+      iconRoot = confDir </> "assets" </> "icons"
+    , commands = csRunnable <$> concatRegions br
+    }
 
 --------------------------------------------------------------------------------
--- | plugin features
+--  plugin features
 --
 -- some commands depend on the presence of interfaces that can only be
 -- determined at runtime; define these checks here
 
 getAllCommands :: [Maybe CmdSpec] -> BarRegions
-getAllCommands right = BarRegions
-  { brLeft = [ CmdSpec
-               { csAlias = "UnsafeStdinReader"
-               , csRunnable = Run UnsafeStdinReader
-               }
-             ]
-  , brCenter = []
-  , brRight = catMaybes right
-  }
+getAllCommands right =
+  BarRegions
+    { brLeft =
+        [ CmdSpec
+            { csAlias = "UnsafeStdinReader"
+            , csRunnable = Run UnsafeStdinReader
+            }
+        ]
+    , brCenter = []
+    , brRight = catMaybes right
+    }
 
-rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
-rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
-  = mapM evalFeature
+rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
+rightPlugins db =
+  mapM evalFeature $
+    allFeatures db
+      ++ [always' "date indicator" dateCmd]
+  where
+    always' n = Right . Always n . Always_ . FallbackAlone
+
+allFeatures :: DBusState -> [Feature CmdSpec]
+allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
   [ Left getWireless
   , Left $ getEthernet sys
   , Left $ getVPN sys
@@ -163,56 +207,67 @@ rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
   , Left $ getCk ses
   , Left $ getSs ses
   , Right getLock
-  , always' "date indicator" dateCmd
   ]
-  where
-    always' n = Right . Always n . Always_ . FallbackAlone
 
 type BarFeature = Sometimes CmdSpec
 
 -- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
-getWireless = Sometimes "wireless status indicator" xpfWireless
-  [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
+getWireless =
+  Sometimes
+    "wireless status indicator"
+    xpfWireless
+    [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe SysClient -> BarFeature
-getEthernet cl = iconDBus "ethernet status indicator" (const True) root tree
+getEthernet :: Maybe NamedSysConnection -> BarFeature
+getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
   where
-    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
-    tree = And1 (Only readEthernet) (Only_ devDep)
+    root useIcon tree' =
+      DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
 
 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
-    tree = Only_ $ IOTest_ "Test if battery is present" []
-      $ fmap (Msg Error) <$> hasBattery
+    tree =
+      Only_ $
+        IOTest_ "Test if battery is present" [] $
+          io $
+            fmap (Msg LevelError) <$> hasBattery
 
-getVPN :: Maybe SysClient -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
+getVPN :: Maybe NamedSysConnection -> BarFeature
+getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
-    test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
-      networkManagerPkgs vpnPresent
 
-getBt :: Maybe SysClient -> BarFeature
+getBt :: Maybe NamedSysConnection -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
-getAlsa = iconIO_ "volume level indicator" (const True) root
-  $ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
+getAlsa =
+  iconIO_ "volume level indicator" (const True) root $
+    Only_ $
+      sysExe [Package Official "alsa-utils"] "alsactl"
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe SesClient -> BarFeature
-getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
-  intelBacklightSignalDep blCmd
+getBl :: Maybe NamedSesConnection -> BarFeature
+getBl =
+  xmobarDBus
+    "Intel backlight indicator"
+    xpfIntelBacklight
+    intelBacklightSignalDep
+    blCmd
 
-getCk :: Maybe SesClient -> BarFeature
-getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
-  clevoKeyboardSignalDep ckCmd
+getCk :: Maybe NamedSesConnection -> BarFeature
+getCk =
+  xmobarDBus
+    "Clevo keyboard indicator"
+    xpfClevoBacklight
+    clevoKeyboardSignalDep
+    ckCmd
 
-getSs :: Maybe SesClient -> BarFeature
+getSs :: Maybe NamedSesConnection -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -221,205 +276,268 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
     root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
 
 --------------------------------------------------------------------------------
--- | bar feature constructors
+-- bar feature constructors
 
-xmobarDBus :: SafeClient c => String -> XPQuery -> DBusDependency_ c
-  -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
+xmobarDBus
+  :: SafeClient c
+  => T.Text
+  -> XPQuery
+  -> DBusDependency_ c
+  -> (Fontifier -> CmdSpec)
+  -> Maybe (NamedConnection 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_ :: String -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
-  -> IOTree_ -> BarFeature
+iconIO_
+  :: T.Text
+  -> XPQuery
+  -> (Fontifier -> IOTree_ -> Root CmdSpec)
+  -> IOTree_
+  -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus :: SafeClient c => String -> XPQuery
-  -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
-iconDBus = iconSometimes' And1 $ Only_ . DBusIO
+-- iconDBus
+--   :: T.Text
+--   -> XPQuery
+--   -> (Fontifier -> DBusTree c p -> Root CmdSpec)
+--   -> DBusTree c p
+--   -> BarFeature
+-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
-iconDBus_ :: SafeClient c => String -> XPQuery
-  -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
+iconDBus_
+  :: T.Text
+  -> XPQuery
+  -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
+  -> DBusTree_ c
+  -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
 
-iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> 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"
-  ]
+iconSometimes'
+  :: (t -> t_ -> t)
+  -> (IODependency_ -> t_)
+  -> T.Text
+  -> XPQuery
+  -> (Fontifier -> t -> Root CmdSpec)
+  -> t
+  -> BarFeature
+iconSometimes' c d n q r t =
+  Sometimes
+    n
+    q
+    [ Subfeature icon "icon indicator"
+    , Subfeature text "text indicator"
+    ]
   where
     icon = r fontifyIcon $ c t $ d iconDependency
     text = r fontifyAlt t
 
 --------------------------------------------------------------------------------
--- | command specifications
+-- command specifications
 
 data BarRegions = BarRegions
-  { brLeft   :: [CmdSpec]
+  { brLeft :: [CmdSpec]
   , brCenter :: [CmdSpec]
-  , brRight  :: [CmdSpec]
-  } deriving Show
+  , brRight :: [CmdSpec]
+  }
+  deriving (Show)
 
 data CmdSpec = CmdSpec
-  { csAlias    :: String
+  { csAlias :: T.Text
   , csRunnable :: Runnable
-  } deriving Show
+  }
+  deriving (Show)
 
 concatRegions :: BarRegions -> [CmdSpec]
 concatRegions (BarRegions l c r) = l ++ c ++ r
 
-wirelessCmd :: String -> CmdSpec
-wirelessCmd iface = CmdSpec
-  { csAlias = iface ++ "wi"
-  , csRunnable = Run
-    $ Wireless iface
-    [ "-t", "<qualityipat><essid>"
-    , "--"
-    , "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
-    ] 5
-  }
-
-ethernetCmd :: Fontifier -> String -> CmdSpec
-ethernetCmd fontify iface = CmdSpec
-  { csAlias = iface
-  , csRunnable = Run
-    $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
-  }
-
-batteryCmd :: Fontifier -> CmdSpec
-batteryCmd fontify = CmdSpec
-  { csAlias = "battery"
-  , csRunnable = Run
-    $ Battery
-    [ "--template", "<acstatus><left>"
-    , "--Low", "10"
-    , "--High", "80"
-    , "--low", "red"
-    , "--normal", T.fgColor
-    , "--high", T.fgColor
-    , "--"
-    , "-P"
-    , "-o" , fontify' "\xf0e7" "BAT"
-    , "-O" , fontify' "\xf1e6" "AC"
-    , "-i" , fontify' "\xf1e6" "AC"
-    ] 50
-  }
+wirelessCmd :: T.Text -> CmdSpec
+wirelessCmd iface =
+  CmdSpec
+    { csAlias = T.append iface "wi"
+    , csRunnable = Run $ Wireless (T.unpack iface) args 5
+    }
   where
-    fontify' = fontify IconSmall
+    args =
+      fmap
+        T.unpack
+        [ "-t"
+        , "<qualityipat><essid>"
+        , "--"
+        , "--quality-icon-pattern"
+        , "<icon=wifi_%%.xpm/>"
+        ]
+
+ethernetCmd :: Fontifier -> CmdSpec
+ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
 
 vpnCmd :: Fontifier -> CmdSpec
-vpnCmd fontify = CmdSpec
-  { csAlias = vpnAlias
-  , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
-  }
+vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
+
+connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
+connCmd icon abbr contypes fontify =
+  CmdSpec
+    { csAlias = connAlias contypes
+    , csRunnable =
+        Run $
+          ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
+    }
+
+batteryCmd :: Fontifier -> CmdSpec
+batteryCmd fontify =
+  CmdSpec
+    { csAlias = "battery"
+    , csRunnable = Run $ Battery args 50
+    }
+  where
+    fontify' = fontify IconSmall
+    args =
+      fmap
+        T.unpack
+        [ "--template"
+        , "<acstatus><left>"
+        , "--Low"
+        , "10"
+        , "--High"
+        , "80"
+        , "--low"
+        , "red"
+        , "--normal"
+        , XT.fgColor
+        , "--high"
+        , XT.fgColor
+        , "--"
+        , "-P"
+        , "-o"
+        , fontify' "\xf0e7" "BAT"
+        , "-O"
+        , fontify' "\xf1e6" "AC"
+        , "-i"
+        , fontify' "\xf1e6" "AC"
+        ]
 
 btCmd :: Fontifier -> CmdSpec
-btCmd fontify = CmdSpec
-  { csAlias = btAlias
-  , csRunnable = Run
-    $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
-  }
+btCmd fontify =
+  CmdSpec
+    { csAlias = btAlias
+    , csRunnable =
+        Run $
+          Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
+    }
   where
-    fontify' i = fontify IconLarge i . ("BT" ++)
+    fontify' i = fontify IconLarge i . T.append "BT"
 
 alsaCmd :: Fontifier -> CmdSpec
-alsaCmd fontify = CmdSpec
-  { csAlias = "alsa:default:Master"
-  , csRunnable = Run
-    $ Alsa "default" "Master"
-    [ "-t", "<status><volume>%"
-    , "--"
-    , "-O", fontify' "\xf028" "+"
-    , "-o", fontify' "\xf026" "-" ++ " "
-    , "-c", T.fgColor
-    , "-C", T.fgColor
-    ]
-  }
+alsaCmd fontify =
+  CmdSpec
+    { csAlias = "alsa:default:Master"
+    , csRunnable =
+        Run $
+          Alsa "default" "Master" $
+            fmap
+              T.unpack
+              [ "-t"
+              , "<status><volume>%"
+              , "--"
+              , "-O"
+              , fontify' "\xf028" "+"
+              , "-o"
+              , T.append (fontify' "\xf026" "-") " "
+              , "-c"
+              , XT.fgColor
+              , "-C"
+              , XT.fgColor
+              ]
+    }
   where
-    fontify' i = fontify IconSmall i . ("VOL" ++)
+    fontify' i = fontify IconSmall i . T.append "VOL"
 
 blCmd :: Fontifier -> CmdSpec
-blCmd fontify = CmdSpec
-  { csAlias = blAlias
-  , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
-  }
+blCmd fontify =
+  CmdSpec
+    { csAlias = blAlias
+    , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
+    }
 
 ckCmd :: Fontifier -> CmdSpec
-ckCmd fontify = CmdSpec
-  { csAlias = ckAlias
-  , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
-  }
+ckCmd fontify =
+  CmdSpec
+    { csAlias = ckAlias
+    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
+    }
 
 ssCmd :: Fontifier -> CmdSpec
-ssCmd fontify = CmdSpec
-  { csAlias = ssAlias
-  , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
-  }
+ssCmd fontify =
+  CmdSpec
+    { csAlias = ssAlias
+    , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
+    }
 
 lockCmd :: Fontifier -> CmdSpec
-lockCmd fontify = CmdSpec
-  { csAlias = "locks"
-  , csRunnable = Run
-    $ Locks
-    [ "-N", numIcon
-    , "-n", disabledColor numIcon
-    , "-C", capIcon
-    , "-c", disabledColor capIcon
-    , "-s", ""
-    , "-S", ""
-    , "-d", " "
-    ]
-  }
+lockCmd fontify =
+  CmdSpec
+    { csAlias = "locks"
+    , csRunnable =
+        Run $
+          Locks $
+            fmap
+              T.unpack
+              [ "-N"
+              , numIcon
+              , "-n"
+              , disabledColor numIcon
+              , "-C"
+              , capIcon
+              , "-c"
+              , disabledColor capIcon
+              , "-s"
+              , ""
+              , "-S"
+              , ""
+              , "-d"
+              , " "
+              ]
+    }
   where
-    numIcon = fontify' "\xf8a5" "N"
-    capIcon = fontify' "\xf657" "C"
+    numIcon = fontify' "\x0f03a6" "N"
+    capIcon = fontify' "\x0f0bf1" "C"
     fontify' = fontify IconXLarge
-    disabledColor = xmobarFGColor T.backdropFgColor
+    disabledColor = xmobarFGColor XT.backdropFgColor
 
 dateCmd :: CmdSpec
-dateCmd = CmdSpec
-  { csAlias = "date"
-  , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
-  }
+dateCmd =
+  CmdSpec
+    { csAlias = "date"
+    , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
+    }
 
 --------------------------------------------------------------------------------
--- | low-level testing functions
-
-vpnPresent :: IO (Maybe Msg)
-vpnPresent =
-  go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
-  where
-    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
-    go (Right (ExitSuccess, out, _))   = if "vpn" `elem` lines out then Nothing
-                                         else Just $ Msg Error "vpn not found"
-    go (Right (ExitFailure c, _, err)) = Just $ Msg Error
-                                         $ "vpn search exited with code "
-                                         ++ show c ++ ": " ++ err
-    go (Left e)                        = Just $ Msg Error $ 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 :: FIO String
+getTextFont :: XIO T.Text
 getTextFont = do
   fb <- evalAlways textFont
   return $ fb textFontData
 
 --------------------------------------------------------------------------------
--- | icon fonts
+-- icon fonts
 
-getIconFonts :: FIO ([String], [Int])
+getIconFonts :: XIO ([T.Text], [Int])
 getIconFonts = do
   fb <- evalSometimes iconFont
   return $ maybe ([], []) apply fb
   where
-    apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
-      <$> iconFonts
+    apply fb =
+      unzip $
+        (\i -> (iconString fb i, iconOffset i + textFontOffset))
+          <$> iconFonts
 
-data BarFont = IconSmall
+data BarFont
+  = IconSmall
   | IconMedium
   | IconLarge
   | IconXLarge
@@ -428,16 +546,17 @@ data BarFont = IconSmall
 iconFonts :: [BarFont]
 iconFonts = enumFrom minBound
 
-iconString :: T.FontBuilder -> BarFont -> String
+iconString :: XT.FontBuilder -> BarFont -> T.Text
 iconString fb i = fb $ iconFontData $ iconSize i
 
 iconDependency :: IODependency_
 iconDependency = IOSometimes_ iconFont
 
-fontifyText :: BarFont -> String -> String
-fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
+fontifyText :: BarFont -> T.Text -> T.Text
+fontifyText fnt txt =
+  T.concat ["<fn=", T.pack $ show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
 
-type Fontifier = BarFont -> String -> String -> String
+type Fontifier = BarFont -> T.Text -> T.Text -> T.Text
 
 fontifyAlt :: Fontifier
 fontifyAlt _ _ alt = alt
@@ -446,13 +565,13 @@ fontifyIcon :: Fontifier
 fontifyIcon f i _ = fontifyText f i
 
 --------------------------------------------------------------------------------
--- | various formatting things
+-- various formatting things
 
 colors :: Colors
-colors = Colors { colorsOn = T.fgColor, colorsOff = T.backdropFgColor }
+colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
 
-sep :: String
-sep = xmobarFGColor T.backdropFgColor " : "
+sep :: T.Text
+sep = xmobarFGColor XT.backdropFgColor " : "
 
 lSep :: Char
 lSep = '}'
@@ -460,14 +579,15 @@ lSep = '}'
 rSep :: Char
 rSep = '{'
 
-pSep :: String
+pSep :: T.Text
 pSep = "%"
 
-fmtSpecs :: [CmdSpec] -> String
-fmtSpecs = intercalate sep . fmap go
+fmtSpecs :: [CmdSpec] -> T.Text
+fmtSpecs = T.intercalate sep . fmap go
   where
-    go CmdSpec { csAlias = a } = wrap pSep pSep a
+    go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
 
-fmtRegions :: BarRegions -> String
-fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
-  fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r
+fmtRegions :: BarRegions -> T.Text
+fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
+  T.concat
+    [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

fourmolu.yaml

@@ -0,0 +1,14 @@
+indentation: 2
+function-arrows: leading
+comma-style: leading
+import-export-style: leading
+indent-wheres: true
+record-brace-space: true
+newlines-between-decls: 1
+haddock-style: single-line
+haddock-style-module:
+let-style: inline
+in-style: right-align
+respectful: false
+fixities: []
+unicode: never

install_deps

@@ -1,64 +0,0 @@
-#!/bin/bash
-
-## Build xmonad and install packages to make it run at full capacity
-
-prebuild () {
-    # TODO this can be integrated into stack with nix
-    # for x11
-    make_pkgs=(libx11 libxrandr libxss)
-    # for alsa
-    make_pkgs=(alsa-lib)
-    # for iwlib
-    make_pkgs=(wireless_tools)
-    # for x11-xft
-    make_pkgs+=(libxft)
-    # for xmobar
-    make_pkgs+=(libxpm)
-
-    sudo pacman --noconfirm -S "${make_pkgs[@]}"
-}
-
-build () {
-    stack install
-}
-
-query='.[].success |
-objects |
-.root.tree |
-..|.left?.data, ..|.right?.data, .data? |
-select(. != null) |
-.fulfillment |
-select(. != null) |
-add | select(. != null)'
-
-jq_type () {
-    echo "$1" | jq --raw-output "select(.type==\"$2\") | .name" | sort | uniq
-}
-
-postbuild () {
-    # these are extra packages that pertain to processes outside xmonad but are
-    # still required/desired to make it work correctly
-    xmonad_pkgs=(xinit autorandr picom)
-
-    raw=$(xmonad --deps | jq "$query")
-
-    mapfile -t official < <(jq_type "$raw" "Official")
-    mapfile -t local < <(jq_type "$raw" "AUR")
-
-    if ! pacman -Si "${official[@]}" > /dev/null; then
-        echo "At least one official package doesn't exist."
-        exit 1
-    fi
-
-    if ! yay -Si "${local[@]}"; then
-        echo "At least one local package doesn't exist."
-        exit 1
-    fi
-    
-    sudo pacman --noconfirm -S "${xmonad_pkgs[@]}" "${official[@]}"
-    yay --needed --noconfirm --norebuild --removemake -S "${local[@]}"
-}
-
-prebuild
-build
-postbuild

lib/Data/Internal/DBus.hs

@@ -1,15 +1,25 @@
 --------------------------------------------------------------------------------
--- | Common internal DBus functions
+-- Common internal DBus functions
 
 module Data.Internal.DBus
-  ( SafeClient(..)
-  , SysClient(..)
-  , SesClient(..)
+  ( SafeClient (..)
+  , SysClient (..)
+  , SesClient (..)
+  , NamedConnection (..)
+  , NamedSesConnection
+  , NamedSysConnection
+  , DBusEnv (..)
+  , DIO
+  , HasClient (..)
+  , releaseBusName
+  , withDIO
   , addMatchCallback
+  , addMatchCallbackSignal
+  , matchSignalFull
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
-  , SignalMatch(..)
+  , SignalMatch (..)
   , SignalCallback
   , MethodBody
   , withSignalMatch
@@ -25,97 +35,258 @@ module Data.Internal.DBus
   , addInterfaceRemovedListener
   , fromSingletonVariant
   , bodyToMaybe
-  ) where
+  , exportPair
+  , displayBusName
+  , displayObjectPath
+  , displayMemberName
+  , displayInterfaceName
+  , displayWrapQuote
+  , busNameT
+  , interfaceNameT
+  , memberNameT
+  , objectPathT
+  )
+where
 
-import           Control.Exception
-import           Control.Monad
-
-import           Data.Bifunctor
-import qualified Data.Map.Strict   as M
-import           Data.Maybe
-
-import           DBus
-import           DBus.Client
+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
+
+data NamedConnection c = NamedConnection
+  { ncClient :: !Client
+  , ncHumanName :: !(Maybe BusName)
+  --, ncUniqueName :: !BusName
+  , ncType :: !c
+  }
+
+type NamedSesConnection = NamedConnection SesClient
+
+type NamedSysConnection = NamedConnection SysClient
 
 class SafeClient c where
-  toClient :: c -> Client
+  getDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> m (Maybe (NamedConnection c))
 
-  getDBusClient :: IO (Maybe c)
+  disconnectDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => NamedConnection c
+    -> m ()
+  disconnectDBusClient c = do
+    releaseBusName c
+    liftIO $ disconnect $ ncClient c
 
-  disconnectDBusClient :: c -> IO ()
-  disconnectDBusClient = disconnect . toClient
+  withDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> m a)
+    -> m (Maybe a)
+  withDBusClient n f =
+    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
 
-  withDBusClient :: (c -> IO a) -> IO (Maybe a)
-  withDBusClient f = do
-    client <- getDBusClient
-    forM client $ \c -> do
-      r <- f c
-      disconnect (toClient c)
-      return r
+  withDBusClient_
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> m ())
+    -> m ()
+  withDBusClient_ n = void . withDBusClient n
 
-  withDBusClient_ :: (c -> IO ()) -> IO ()
-  withDBusClient_ = void . withDBusClient
+  fromDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> a)
+    -> m (Maybe a)
+  fromDBusClient n f = withDBusClient n (return . f)
 
-  fromDBusClient :: (c -> a) -> IO (Maybe a)
-  fromDBusClient f = withDBusClient (return . f)
-
-newtype SysClient = SysClient Client
+data SysClient = SysClient
 
 instance SafeClient SysClient where
-  toClient (SysClient cl) = cl
+  getDBusClient = connectToDBusWithName True SysClient
 
-  getDBusClient = fmap SysClient <$> getDBusClient' True
-
-newtype SesClient = SesClient Client
+data SesClient = SesClient
 
 instance SafeClient SesClient where
-  toClient (SesClient cl) = cl
+  -- TODO wet
+  getDBusClient = connectToDBusWithName False SesClient
 
-  getDBusClient = fmap SesClient <$> getDBusClient' False
+connectToDBusWithName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> c
+  -> Maybe BusName
+  -> m (Maybe (NamedConnection c))
+connectToDBusWithName sys t n = do
+  clRes <- getDBusClient' sys
+  case clRes of
+    Nothing -> do
+      logError "could not get client"
+      return Nothing
+    Just cl -> do
+      --helloRes <- liftIO $ callHello cl
+      --case helloRes of
+      --  Nothing -> do
+      --    logError "count not get unique name"
+      --    return Nothing
+      --  Just unique -> do
+          n' <- maybe (return Nothing) (`requestBusName` cl) n
+          return $
+            Just $
+              NamedConnection
+                { ncClient = cl
+                , ncHumanName = n'
+      --          , ncUniqueName = unique
+                , ncType = t
+                }
 
-getDBusClient' :: Bool -> IO (Maybe Client)
-getDBusClient' sys = do
-  res <- try $ if sys then connectSystem else connectSession
+releaseBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => NamedConnection c
+  -> m ()
+releaseBusName NamedConnection {ncClient, ncHumanName} = do
+  -- TODO this might error?
+  case ncHumanName of
+    Just n -> do
+      liftIO $ void $ releaseName ncClient n
+      logInfo $ "released bus name: " <> displayBusName n
+    Nothing -> return ()
+
+requestBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => BusName
+  -> Client
+  -> m (Maybe BusName)
+requestBusName n cl = do
+  res <- try $ liftIO $ requestName cl n []
   case res of
-    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> do
+      logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      return Nothing
+    Right r -> do
+      let msg
+            | r == NamePrimaryOwner = "registering name"
+            | r == NameAlreadyOwner = "this process already owns name"
+            | r == NameInQueue
+                || r == NameExists =
+                "another process owns name"
+            -- this should never happen
+            | otherwise = "unknown error when requesting name"
+      logInfo $ msg <> ": " <> displayBusName n
+      case r of
+        NamePrimaryOwner -> return $ Just n
+        _ -> return Nothing
+
+getDBusClient'
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> m (Maybe Client)
+getDBusClient' sys = do
+  res <- try $ liftIO $ if sys then connectSystem else connectSession
+  case res of
+    Left e -> do
+      logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      return Nothing
     Right c -> return $ Just c
 
+--callHello :: Client -> IO (Maybe BusName)
+--callHello cl = do
+--  reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
+--  case methodReturnBody reply of
+--    [name] | Just nameStr <- fromVariant name -> do
+--      busName <- parseBusName nameStr
+--      return $ Just busName
+--    _ -> return Nothing
+--
+data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
+
+type DIO env c = RIO (DBusEnv env c)
+
+instance HasClient (DBusEnv SimpleApp) where
+  clientL = lens dClient (\x y -> x {dClient = y})
+
+instance HasLogFunc (DBusEnv SimpleApp c) where
+  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
+
+withDIO
+  :: (MonadUnliftIO m, MonadReader env m)
+  => NamedConnection c
+  -> DIO env c a
+  -> m a
+withDIO cl x = do
+  env <- ask
+  runRIO (DBusEnv cl env) x
+
+class HasClient env where
+  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
+
 --------------------------------------------------------------------------------
--- | Methods
+-- Methods
 
-type MethodBody = Either String [Variant]
+type MethodBody = Either T.Text [Variant]
 
-callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
-callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody)
-  . call (toClient cl)
+callMethod'
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+  => MethodCall
+  -> m MethodBody
+callMethod' mc = do
+  cl <- ncClient <$> view clientL
+  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
-callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-  -> MemberName -> IO MethodBody
-callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
+callMethod
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+  => BusName
+  -> ObjectPath
+  -> InterfaceName
+  -> MemberName
+  -> m MethodBody
+callMethod bus path iface = callMethod' . methodCallBus bus path iface
 
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
-methodCallBus b p i m = (methodCall p i m)
-    { methodCallDestination = Just b }
+methodCallBus b p i m =
+  (methodCall p i m)
+    { methodCallDestination = Just b
+    }
 
 --------------------------------------------------------------------------------
--- | Bus names
+-- Bus names
 
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
-callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
+callGetNameOwner
+  :: ( SafeClient c
+     , MonadUnliftIO m
+     , MonadReader (env c) m
+     , HasClient env
+     , HasLogFunc (env c)
+     )
+  => BusName
+  -> m (Maybe BusName)
+callGetNameOwner name = do
+  res <- callMethod' mc
+  case res of
+    Left err -> do
+      logError $ Utf8Builder $ encodeUtf8Builder err
+      return Nothing
+    Right body -> return $ fromSingletonVariant body
   where
-    mc = (methodCallBus dbusName dbusPath dbusInterface mem)
-      { methodCallBody = [toVariant name] }
+    mc =
+      (methodCallBus dbusName dbusPath dbusInterface mem)
+        { methodCallBody = [toVariant name]
+        }
     mem = memberName_ "GetNameOwner"
 
 --------------------------------------------------------------------------------
--- | Variant parsing
+-- Variant parsing
 
+-- TODO log failures here?
 fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
 fromSingletonVariant = fromVariant <=< listToMaybe
 
@@ -123,30 +294,81 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
 bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 --------------------------------------------------------------------------------
--- | Signals
+-- Signals
 
-type SignalCallback = [Variant] -> IO ()
+type SignalCallback m = [Variant] -> m ()
 
-addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
-  -> IO SignalHandler
-addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
+addMatchCallbackSignal
+  :: ( MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => MatchRule
+  -> (Signal -> m ())
+  -> m SignalHandler
+addMatchCallbackSignal rule cb = do
+  cl <- ncClient <$> view clientL
+  withRunInIO $ \run -> addMatch cl rule $ run . cb
 
-matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-  -> Maybe MemberName -> MatchRule
-matchSignal b p i m = matchAny
-  { matchPath = p
-  , matchSender = b
-  , matchInterface = i
-  , matchMember = m
-  }
+addMatchCallback
+  :: ( MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => MatchRule
+  -> SignalCallback m
+  -> m SignalHandler
+addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
 
-matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-  -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
-matchSignalFull client b p i m =
-  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
+matchSignal
+  :: Maybe BusName
+  -> Maybe ObjectPath
+  -> Maybe InterfaceName
+  -> Maybe MemberName
+  -> MatchRule
+matchSignal b p i m =
+  matchAny
+    { matchPath = p
+    , matchSender = b
+    , matchInterface = i
+    , matchMember = m
+    }
+
+matchSignalFull
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> Maybe ObjectPath
+  -> Maybe InterfaceName
+  -> Maybe MemberName
+  -> m (Maybe MatchRule)
+matchSignalFull b p i m = do
+  res <- callGetNameOwner b
+  case res of
+    Just o -> return $ Just $ matchSignal (Just o) p i m
+    Nothing -> do
+      logError msg
+      return Nothing
+  where
+    bus_ = displayWrapQuote $ displayBusName b
+    iface_ = displayWrapQuote . displayInterfaceName <$> i
+    path_ = displayWrapQuote . displayObjectPath <$> p
+    mem_ = displayWrapQuote . displayMemberName <$> m
+    match =
+      intersperse ", " $
+        mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
+          zip ["interface", "path", "member"] [iface_, path_, mem_]
+    stem = "could not get match rule for bus " <> bus_
+    msg = if null match then stem else stem <> " where " <> mconcat match
 
 --------------------------------------------------------------------------------
--- | Properties
+-- Properties
 
 propertyInterface :: InterfaceName
 propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
@@ -154,45 +376,74 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
-callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
-  -> MemberName -> c -> IO [Variant]
-callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
-  $ getProperty (toClient cl) $ methodCallBus bus path iface property
+callPropertyGet
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     )
+  => BusName
+  -> ObjectPath
+  -> InterfaceName
+  -> MemberName
+  -> m [Variant]
+callPropertyGet bus path iface property = do
+  cl <- ncClient <$> view clientL
+  res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
+  case res of
+    Left err -> do
+      logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
+      return []
+    Right v -> return [v]
 
 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
   matchSignal b p (Just propertyInterface) (Just propertySignal)
 
-matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-  -> IO (Maybe MatchRule)
-matchPropertyFull cl b p =
-  matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
+matchPropertyFull
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> Maybe ObjectPath
+  -> m (Maybe MatchRule)
+matchPropertyFull b p =
+  matchSignalFull b p (Just propertyInterface) (Just propertySignal)
 
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
-withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
+withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
 withSignalMatch f (Match x) = f (Just x)
-withSignalMatch f Failure   = f Nothing
-withSignalMatch _ NoMatch   = return ()
+withSignalMatch f Failure = f Nothing
+withSignalMatch _ NoMatch = return ()
 
-matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant]
+matchPropertyChanged
+  :: IsVariant a
+  => InterfaceName
+  -> MemberName
+  -> [Variant]
   -> SignalMatch a
-matchPropertyChanged iface property [i, body, _] =
-  let i' = (fromVariant i :: Maybe String)
-      b = toMap body in
-    case (i', b) of
-      (Just i'', Just b') -> if i'' == formatInterfaceName iface then
-        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
-        else NoMatch
-      _                   -> Failure
-  where
-    toMap v = fromVariant v :: Maybe (M.Map String Variant)
+matchPropertyChanged iface property [sigIface, sigValues, _] =
+  let i = fromVariant sigIface :: Maybe T.Text
+      v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
+   in case (i, v) of
+        (Just i', Just v') ->
+          if i' == interfaceNameT iface
+            then
+              maybe NoMatch Match $
+                fromVariant =<< M.lookup (memberNameT property) v'
+            else NoMatch
+        _ -> Failure
 matchPropertyChanged _ _ _ = Failure
 
 --------------------------------------------------------------------------------
--- | Object Manager
+-- Object Manager
 
-type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
+type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
 
 omInterface :: InterfaceName
 omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@@ -206,24 +457,133 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
 omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
-callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
-  -> IO ObjectTree
-callGetManagedObjects cl bus path =
-  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
-  <$> callMethod cl bus path omInterface getManagedObjects
+callGetManagedObjects
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> ObjectPath
+  -> m ObjectTree
+callGetManagedObjects bus path = do
+  res <- callMethod bus path omInterface getManagedObjects
+  case res of
+    Left err -> do
+      logError $ Utf8Builder $ encodeUtf8Builder err
+      return M.empty
+    Right v ->
+      return $
+        fmap (M.mapKeys interfaceName_) $
+          fromMaybe M.empty $
+            fromSingletonVariant v
 
-addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
-  -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
-addInterfaceChangedListener bus prop path sc cl = do
-  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
-  forM rule $ \r -> addMatchCallback r sc cl
+addInterfaceChangedListener
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> MemberName
+  -> ObjectPath
+  -> SignalCallback m
+  -> m (Maybe SignalHandler)
+addInterfaceChangedListener bus prop path sc = do
+  res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
+  case res of
+    Nothing -> do
+      logError $
+        "could not add listener for property"
+          <> prop_
+          <> " at path "
+          <> path_
+          <> " on bus "
+          <> bus_
+      return Nothing
+    Just rule -> Just <$> addMatchCallback rule sc
+  where
+    bus_ = "'" <> displayBusName bus <> "'"
+    path_ = "'" <> displayObjectPath path <> "'"
+    prop_ = "'" <> displayMemberName prop <> "'"
 
-addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+addInterfaceAddedListener
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> ObjectPath
+  -> SignalCallback m
+  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
-addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+addInterfaceRemovedListener
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
+  -> ObjectPath
+  -> SignalCallback m
+  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
   addInterfaceChangedListener bus omInterfacesRemoved
+
+--------------------------------------------------------------------------------
+-- Interface export/unexport
+
+exportPair
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => ObjectPath
+  -> (Client -> m Interface)
+  -> NamedConnection c
+  -> (m (), m ())
+exportPair path toIface cl = (up, down)
+  where
+    cl_ = ncClient cl
+    up = do
+      logInfo $ "adding interface: " <> path_
+      i <- toIface cl_
+      liftIO $ export cl_ path i
+    down = do
+      logInfo $ "removing interface: " <> path_
+      liftIO $ unexport cl_ path
+    path_ = displayObjectPath path
+
+--------------------------------------------------------------------------------
+-- logging helpers
+
+busNameT :: BusName -> T.Text
+busNameT = T.pack . formatBusName
+
+objectPathT :: ObjectPath -> T.Text
+objectPathT = T.pack . formatObjectPath
+
+interfaceNameT :: InterfaceName -> T.Text
+interfaceNameT = T.pack . formatInterfaceName
+
+memberNameT :: MemberName -> T.Text
+memberNameT = T.pack . formatMemberName
+
+displayBusName :: BusName -> Utf8Builder
+displayBusName = displayBytesUtf8 . BC.pack . formatBusName
+
+displayObjectPath :: ObjectPath -> Utf8Builder
+displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
+
+displayMemberName :: MemberName -> Utf8Builder
+displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
+
+displayInterfaceName :: InterfaceName -> Utf8Builder
+displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
+
+displayWrapQuote :: Utf8Builder -> Utf8Builder
+displayWrapQuote x = "'" <> x <> "'"

lib/XMonad/Internal/Command/DMenu.hs

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | Dmenu (Rofi) Commands
+-- Dmenu (Rofi) Commands
 
 module XMonad.Internal.Command.DMenu
   ( runCmdMenu
@@ -13,60 +13,58 @@ 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           Graphics.X11.Types
-
-import           System.Directory
-    ( XdgDirectory (..)
-    , getXdgDirectory
-    )
-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
+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 RIO.Directory
+  ( XdgDirectory (..)
+  , getXdgDirectory
+  )
+import qualified RIO.Text as T
+-- import System.IO
+import XMonad.Core hiding (spawn)
+import XMonad.Internal.Command.Desktop
+import XMonad.Internal.DBus.Common
+import XMonad.Internal.Notify
+import XMonad.Internal.Shell
+import XMonad.Util.NamedActions
 
 --------------------------------------------------------------------------------
--- | DMenu executables
+-- DMenu executables
 
-myDmenuCmd :: String
+myDmenuCmd :: FilePath
 myDmenuCmd = "rofi"
 
-myDmenuDevices :: String
+myDmenuDevices :: FilePath
 myDmenuDevices = "rofi-dev"
 
-myDmenuPasswords :: String
+myDmenuPasswords :: FilePath
 myDmenuPasswords = "rofi-bw"
 
-myDmenuBluetooth :: String
+myDmenuBluetooth :: FilePath
 myDmenuBluetooth = "rofi-bt"
 
-myDmenuVPN :: String
+myDmenuVPN :: FilePath
 myDmenuVPN = "rofi-evpn"
 
-myDmenuMonitors :: String
+myDmenuMonitors :: FilePath
 myDmenuMonitors = "rofi-autorandr"
 
-myDmenuNetworks :: String
+myDmenuNetworks :: FilePath
 myDmenuNetworks = "networkmanager_dmenu"
 
-myClipboardManager :: String
+myClipboardManager :: FilePath
 myClipboardManager = "greenclip"
 
 --------------------------------------------------------------------------------
--- | Packages
+-- Packages
 
 dmenuPkgs :: [Fulfillment]
 dmenuPkgs = [Package Official "rofi"]
@@ -75,19 +73,19 @@ clipboardPkgs :: [Fulfillment]
 clipboardPkgs = [Package AUR "rofi-greenclip"]
 
 --------------------------------------------------------------------------------
--- | Other internal functions
+-- Other internal functions
 
-spawnDmenuCmd :: String -> [String] -> SometimesX
+spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
 spawnDmenuCmd n =
   sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
 
-themeArgs :: String -> [String]
+themeArgs :: T.Text -> [T.Text]
 themeArgs hexColor =
   [ "-theme-str"
-  , "'#element.selected.normal { background-color: " ++ hexColor ++ "; }'"
+  , T.concat ["'#element.selected.normal { background-color: ", hexColor, "; }'"]
   ]
 
-myDmenuMatchingArgs :: [String]
+myDmenuMatchingArgs :: [T.Text]
 myDmenuMatchingArgs = ["-i"] -- case insensitivity
 
 dmenuTree :: IOTree_ -> IOTree_
@@ -97,109 +95,153 @@ dmenuDep :: IODependency_
 dmenuDep = sysExe dmenuPkgs myDmenuCmd
 
 --------------------------------------------------------------------------------
--- | Exported Commands
+-- Exported Commands
 
 -- TODO test that veracrypt and friends are installed
-runDevMenu :: SometimesX
+runDevMenu :: MonadUnliftIO m => Sometimes (m ())
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
   where
     t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
     x = do
-      c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
-      spawnCmd myDmenuDevices
-        $ ["-c", c]
-        ++ "--" : themeArgs "#999933"
-        ++ myDmenuMatchingArgs
+      c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
+      spawnCmd myDmenuDevices $
+        ["-c", T.pack c]
+          ++ "--"
+          : themeArgs "#999933"
+          ++ myDmenuMatchingArgs
 
 -- TODO test that bluetooth interface exists
-runBTMenu :: SometimesX
-runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
-  [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
+runBTMenu :: MonadUnliftIO m => Sometimes (m ())
+runBTMenu =
+  Sometimes
+    "bluetooth selector"
+    xpfBluetooth
+    [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
   where
-    cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
+    cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
     tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
 
-runVPNMenu :: SometimesX
-runVPNMenu = Sometimes "VPN selector" xpfVPN
-  [Subfeature (IORoot_ cmd tree) "rofi VPN"]
+runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
+runVPNMenu =
+  Sometimes
+    "VPN selector"
+    xpfVPN
+    [Subfeature (IORoot_ cmd tree) "rofi VPN"]
   where
-    cmd = spawnCmd myDmenuVPN
-      $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
-    tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
-      $ socketExists "expressVPN" []
-      $ return "/var/lib/expressvpn/expressvpnd.socket"
+    cmd =
+      spawnCmd myDmenuVPN $
+        ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
+    tree =
+      dmenuTree $
+        toAnd_ (localExe [] myDmenuVPN) $
+          socketExists "expressVPN" [] $
+            return "/var/lib/expressvpn/expressvpnd.socket"
 
-runCmdMenu :: SometimesX
+runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
 
-runAppMenu :: SometimesX
+runAppMenu :: MonadUnliftIO m => Sometimes (m ())
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
-runWinMenu :: SometimesX
+runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: Maybe SysClient -> SometimesX
+runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runNetMenu cl =
-  sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
+  Sometimes
+    "network control menu"
+    enabled
+    [Subfeature root "network control menu"]
   where
+    enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
+    root = DBusRoot_ cmd tree cl
     cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
-    tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
-      $ toAnd_ (DBusIO dmenuDep) $ DBusIO
-      $ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
+    tree =
+      And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
+        toAnd_ (DBusIO dmenuDep) $
+          DBusIO $
+            sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
 
-runAutorandrMenu :: SometimesX
+runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
 runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
   where
     cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
     tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
 
 --------------------------------------------------------------------------------
--- | Password manager
+-- Password manager
 
-runBwMenu :: Maybe SesClient -> SometimesX
+runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
-    cmd _ = spawnCmd myDmenuPasswords
-      $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-    tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
-      $ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
+    cmd _ =
+      spawnCmd myDmenuPasswords $
+        ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
+    tree =
+      And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
+        toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
 
 --------------------------------------------------------------------------------
--- | Clipboard
+-- Clipboard
 
-runClipMenu :: SometimesX
+runClipMenu :: MonadUnliftIO m => Sometimes (m ())
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
-    tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
-                               , process [] myClipboardManager
-                               ]
-    args = [ "-modi", "\"clipboard:greenclip print\""
-           , "-show", "clipboard"
-           , "-run-command", "'{cmd}'"
-           ] ++ themeArgs "#00c44e"
+    tree =
+      listToAnds
+        dmenuDep
+        [ sysExe clipboardPkgs myClipboardManager
+        , process [] $ T.pack myClipboardManager
+        ]
+    args =
+      [ "-modi"
+      , "\"clipboard:greenclip print\""
+      , "-show"
+      , "clipboard"
+      , "-run-command"
+      , "'{cmd}'"
+      ]
+        ++ themeArgs "#00c44e"
 
 --------------------------------------------------------------------------------
--- | Shortcut menu
+-- Shortcut menu
 
-runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
-runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
-  $ FallbackAlone fallback
+runShowKeys
+  :: (MonadReader env m, MonadUnliftIO m)
+  => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
+runShowKeys =
+  Always "keyboard menu" $
+    Option showKeysDMenu $
+      Always_ $
+        FallbackAlone fallback
   where
     -- TODO this should technically depend on dunst
-    fallback = const $ spawnNotify
-      $ defNoteError { body = Just $ Text "could not display keymap" }
+    fallback =
+      const $
+        spawnNotify $
+          defNoteError {body = Just $ Text "could not display keymap"}
 
-showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
-showKeysDMenu = Subfeature
-  { sfName = "keyboard shortcut menu"
-  , sfData = IORoot_ showKeys $ Only_ dmenuDep
-  }
+showKeysDMenu
+  :: (MonadReader env m, MonadUnliftIO m)
+  => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
+showKeysDMenu =
+  Subfeature
+    { sfName = "keyboard shortcut menu"
+    , sfData = IORoot_ showKeys $ Only_ dmenuDep
+    }
 
-showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
-showKeys kbs = io $ do
-      (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
-      forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
+showKeys
+  :: (MonadReader env m, MonadUnliftIO m)
+  => [((KeyMask, KeySym), NamedAction)]
+  -> m ()
+showKeys kbs = do
+  h <- spawnPipe cmd
+  B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
+  hClose h
   where
-    cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
-      ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
+    cmd =
+      fmtCmd myDmenuCmd $
+        ["-dmenu", "-p", "commands"]
+          ++ themeArgs "#7f66ff"
+          ++ myDmenuMatchingArgs

lib/XMonad/Internal/Command/Desktop.hs

@@ -1,10 +1,9 @@
 --------------------------------------------------------------------------------
--- | General commands
+-- General commands
 
 module XMonad.Internal.Command.Desktop
   ( myTerm
   , playSound
-
   -- commands
   , runTerm
   , runTMux
@@ -20,7 +19,8 @@ module XMonad.Internal.Command.Desktop
   , runVolumeUp
   , runVolumeMute
   , runToggleBluetooth
-  , runToggleEthernet
+  , runToggleNetworking
+  , runToggleWifi
   , runRestart
   , runRecompile
   , runAreaCapture
@@ -31,76 +31,70 @@ 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           System.Directory
-import           System.Environment
-import           System.FilePath
-import           System.Posix.User
-
-import           XMonad                      (asks)
-import           XMonad.Actions.Volume
-import           XMonad.Core                 hiding (spawn)
-import           XMonad.Internal.DBus.Common
-import           XMonad.Internal.Notify
-import           XMonad.Internal.Process
-import           XMonad.Internal.Shell
-import           XMonad.Operations
+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.Posix.User
+import UnliftIO.Environment
+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.Operations
 
 --------------------------------------------------------------------------------
--- | My Executables
+-- My Executables
 
-myTerm :: String
-myTerm = "urxvt"
+myTerm :: FilePath
+myTerm = "alacritty"
 
-myCalc :: String
+myCalc :: FilePath
 myCalc = "bc"
 
-myBrowser :: String
-myBrowser = "brave-accel"
+myBrowser :: FilePath
+myBrowser = "firefox"
 
-myEditor :: String
+myEditor :: FilePath
 myEditor = "emacsclient"
 
-myEditorServer :: String
+myEditorServer :: FilePath
 myEditorServer = "emacs"
 
-myMultimediaCtl :: String
+myMultimediaCtl :: FilePath
 myMultimediaCtl = "playerctl"
 
-myBluetooth :: String
+myBluetooth :: FilePath
 myBluetooth = "bluetoothctl"
 
-myCapture :: String
+myCapture :: FilePath
 myCapture = "flameshot"
 
-myImageBrowser :: String
+myImageBrowser :: FilePath
 myImageBrowser = "feh"
 
-myNotificationCtrl :: String
+myNotificationCtrl :: FilePath
 myNotificationCtrl = "dunstctl"
 
 --------------------------------------------------------------------------------
--- | Packages
+-- Packages
 
 myTermPkgs :: [Fulfillment]
-myTermPkgs = [ Package Official "rxvt-unicode"
-             , Package Official "urxvt-perls"
-             ]
+myTermPkgs =
+  [ Package Official "alacritty"
+  ]
 
 myEditorPkgs :: [Fulfillment]
 myEditorPkgs = [Package Official "emacs-nativecomp"]
@@ -114,186 +108,258 @@ bluetoothPkgs = [Package Official "bluez-utils"]
 networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]
 
+nmcli :: IODependency_
+nmcli = sysExe networkManagerPkgs "nmcli"
+
 --------------------------------------------------------------------------------
--- | Misc constants
+-- Misc constants
 
 volumeChangeSound :: FilePath
 volumeChangeSound = "smb_fireball.wav"
 
 --------------------------------------------------------------------------------
--- | Some nice apps
+-- Some nice apps
 
-runTerm :: SometimesX
-runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
+runTerm :: MonadUnliftIO m => Sometimes (m ())
+runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
 
-runTMux :: SometimesX
+runTMux :: MonadUnliftIO m => Sometimes (m ())
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
-    deps = listToAnds (socketExists "tmux" [] socketName)
-      $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
-    act = spawn
-      $ "tmux has-session"
-      #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
-      #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
+    deps =
+      listToAnds (socketExists "tmux" [] socketName) $
+        fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
+    act =
+      S.spawn $
+        fmtCmd "tmux" ["has-session"]
+          #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
+          #!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
     c = "exec tmux attach-session -d"
     msg = "could not connect to tmux session"
     socketName = do
-      u <- getEffectiveUserID
+      u <- liftIO getEffectiveUserID
       t <- getTemporaryDirectory
       return $ t </> "tmux-" ++ show u </> "default"
 
-runCalc :: SometimesX
+runCalc :: MonadUnliftIO m => Sometimes (m ())
 runCalc = sometimesIO_ "calculator" "bc" deps act
   where
     deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
-    act = spawnCmd myTerm ["-e", myCalc, "-l"]
+    act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
 
-runBrowser :: SometimesX
-runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
-  False myBrowser
+runBrowser :: MonadUnliftIO m => Sometimes (m ())
+runBrowser =
+  sometimesExe
+    "web browser"
+    "brave"
+    [Package AUR "brave-bin"]
+    False
+    myBrowser
 
-runEditor :: SometimesX
+runEditor :: MonadUnliftIO m => Sometimes (m ())
 runEditor = sometimesIO_ "text editor" "emacs" tree cmd
   where
-    cmd = spawnCmd myEditor
-      ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
+    cmd =
+      spawnCmd
+        myEditor
+        ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
     -- NOTE 1: we could test if the emacs socket exists, but it won't come up
     -- before xmonad starts, so just check to see if the process has started
-    tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] myEditorServer
+    tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
 
-runFileManager :: SometimesX
-runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
-  True "pcmanfm"
+runFileManager :: MonadUnliftIO m => Sometimes (m ())
+runFileManager =
+  sometimesExe
+    "file browser"
+    "pcmanfm"
+    [Package Official "pcmanfm"]
+    True
+    "pcmanfm"
 
 --------------------------------------------------------------------------------
--- | Multimedia Commands
+-- Multimedia Commands
 
-runMultimediaIfInstalled :: String -> String -> SometimesX
-runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
-  "playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
+runMultimediaIfInstalled
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Sometimes (m ())
+runMultimediaIfInstalled n cmd =
+  sometimesExeArgs
+    (T.append n " multimedia control")
+    "playerctl"
+    [Package Official "playerctl"]
+    True
+    myMultimediaCtl
+    [cmd]
 
-runTogglePlay :: SometimesX
+runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
 
-runPrevTrack :: SometimesX
+runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
 
-runNextTrack :: SometimesX
+runNextTrack :: MonadUnliftIO m => Sometimes (m ())
 runNextTrack = runMultimediaIfInstalled "next track" "next"
 
-runStopPlay :: SometimesX
+runStopPlay :: MonadUnliftIO m => Sometimes (m ())
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 
 --------------------------------------------------------------------------------
--- | Volume Commands
+-- Volume Commands
 
 soundDir :: FilePath
-soundDir = "sound"
+soundDir = "assets" </> "sound"
 
 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
   -- manually look up directories to avoid the X monad
   p <- io $ (</> soundDir </> file) . cfgDir <$> getDirectories
   -- paplay seems to have less latency than aplay
-  spawnCmd "paplay" [p]
+  spawnCmd "paplay" [T.pack p]
 
-featureSound :: String -> FilePath -> X () -> X () -> SometimesX
+featureSound
+  :: MonadUnliftIO m
+  => T.Text
+  -> FilePath
+  -> m ()
+  -> m ()
+  -> Sometimes (m ())
 featureSound n file pre post =
-  sometimesIO_ ("volume " ++ n ++ " control") "paplay" tree
-  $ pre >> playSound file >> post
+  sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
+    pre >> playSound file >> post
   where
-    tree = Only_ $ sysExe [Package Official "libpulse"] "paplay"
+    -- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
+    -- to play sound (duh) but libpulse is the package with the paplay binary
+    tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
 
-runVolumeDown :: SometimesX
+runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
 
-runVolumeUp :: SometimesX
+runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
 
-runVolumeMute :: SometimesX
+runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
--- | Notification control
+-- Notification control
 
-runNotificationCmd :: String -> FilePath -> Maybe SesClient -> SometimesX
+runNotificationCmd
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Maybe NamedSesConnection
+  -> Sometimes (m ())
 runNotificationCmd n arg cl =
-  sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
+  sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
   where
     cmd _ = spawnCmd myNotificationCtrl [arg]
-    tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
-      $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
-      $ Method_ $ memberName_ "NotificationAction"
+    tree =
+      toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
+        Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
+          Method_ $
+            memberName_ "NotificationAction"
 
-runNotificationClose :: Maybe SesClient -> SometimesX
+runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: Maybe SesClient -> SometimesX
+runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: Maybe SesClient -> SometimesX
+runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: Maybe SesClient -> SometimesX
+runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
 --------------------------------------------------------------------------------
--- | System commands
+-- System commands
 
--- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
-runNetAppDaemon cl = Sometimes "network applet" xpfVPN
-  [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
+-- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
+runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
+runNetAppDaemon cl =
+  Sometimes
+    "network applet"
+    (\x -> xpfVPN x || xpfWireless x)
+    [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
   where
     tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
     app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
-    cmd _ = snd <$> spawnPipe "nm-applet"
+    cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
 
-runToggleBluetooth :: Maybe SysClient -> SometimesX
-runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
-  [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
+runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
+runToggleBluetooth cl =
+  Sometimes
+    "bluetooth toggle"
+    xpfBluetooth
+    [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
   where
     tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
-    cmd _ = spawn
-      $ myBluetooth ++ " show | grep -q \"Powered: no\""
-      #!&& "a=on"
-      #!|| "a=off"
-      #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
-      #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
+    cmd _ =
+      S.spawn $
+        fmtCmd myBluetooth ["show"]
+          #!| "grep -q \"Powered: no\""
+          #!&& "a=on"
+          #!|| "a=off"
+          #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
 
-runToggleEthernet :: SometimesX
-runToggleEthernet = sometimes1 "ethernet toggle" "nmcli" $ IORoot (spawn . cmd) $
-  And1 (Only readEthernet) (Only_ $ sysExe networkManagerPkgs "nmcli")
+runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
+runToggleNetworking =
+  Sometimes
+    "network toggle"
+    (\x -> xpfEthernet x || xpfWireless x)
+    [Subfeature root "nmcli"]
   where
-    -- TODO make this less noisy
-    cmd iface =
-      "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"  }
+    root = IORoot_ cmd $ Only_ nmcli
+    cmd =
+      S.spawn $
+        fmtCmd "nmcli" ["networking"]
+          #!| "grep -q enabled"
+          #!&& "a=off"
+          #!|| "a=on"
+          #!>> fmtCmd "nmcli" ["networking", "$a"]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
+
+runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
+runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
+  where
+    root = IORoot_ cmd $ Only_ nmcli
+    cmd =
+      S.spawn $
+        fmtCmd "nmcli" ["radio", "wifi"]
+          #!| "grep -q enabled"
+          #!&& "a=off"
+          #!|| "a=on"
+          #!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
 
 --------------------------------------------------------------------------------
--- | Configuration commands
+-- Configuration commands
 
 runRestart :: X ()
 runRestart = restart "xmonad" True
 
+-- TODO use rio in here so I don't have to fill my xinit log with stack poop
+-- TODO only recompile the VM binary if we have virtualbox enabled
 runRecompile :: X ()
 runRecompile = do
   -- assume that the conf directory contains a valid stack project
   confDir <- asks (cfgDir . directories)
-  spawnAt confDir $ fmtCmd "stack" ["install"]
-    #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
-    #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
+  spawn $
+    fmtCmd "cd" [T.pack confDir]
+      #!&& fmtCmd "stack" ["install"]
+      #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
+      #!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
 
 --------------------------------------------------------------------------------
--- | Screen capture commands
+-- Screen capture commands
 
-getCaptureDir :: IO FilePath
+getCaptureDir :: MonadIO m => m FilePath
 getCaptureDir = do
   e <- lookupEnv "XDG_DATA_HOME"
   parent <- case e of
@@ -307,28 +373,38 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: String -> String -> Maybe SesClient -> SometimesX
-runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
+runFlameshot
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Maybe NamedSesConnection
+  -> Sometimes (m ())
+runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
   where
     cmd _ = spawnCmd myCapture [mode]
-    tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
-      $ Bus [] $ busName_ "org.flameshot.Flameshot"
+    tree =
+      toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
+        Bus [] $
+          busName_ "org.flameshot.Flameshot"
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: Maybe SesClient -> SometimesX
+runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: Maybe SesClient -> SometimesX
+runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: Maybe SesClient -> SometimesX
+runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
 
-runCaptureBrowser :: SometimesX
-runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
-  (Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
-  dir <- io getCaptureDir
-  spawnCmd myImageBrowser [dir]
+runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
+runCaptureBrowser = sometimesIO_
+  "screen capture browser"
+  "feh"
+  (Only_ $ sysExe [Package Official "feh"] myImageBrowser)
+  $ do
+    dir <- getCaptureDir
+    spawnCmd myImageBrowser [T.pack dir]

lib/XMonad/Internal/Command/Power.hs

@@ -1,8 +1,8 @@
 --------------------------------------------------------------------------------
--- | Commands for controlling power
+-- Commands for controlling power
 
 module XMonad.Internal.Command.Power
-  -- commands
+-- commands
   ( runHibernate
   , runOptimusPrompt
   , runPowerOff
@@ -12,10 +12,8 @@ module XMonad.Internal.Command.Power
   , runSuspend
   , runSuspendPrompt
   , runQuitPrompt
-
   -- daemons
   , runAutolock
-
   -- functions
   , hasBattery
   , suspendPrompt
@@ -23,97 +21,97 @@ 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           Graphics.X11.Types
-
-import           System.Directory
-import           System.Exit
-import           System.FilePath.Posix
-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 T
-import           XMonad.Prompt
-import           XMonad.Prompt.ConfirmPrompt
+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 XMonad.Internal.Shell
+import qualified XMonad.Internal.Theme as XT
+import XMonad.Prompt
+import XMonad.Prompt.ConfirmPrompt
 
 --------------------------------------------------------------------------------
--- | Executables
-
-myScreenlock :: String
+-- Executables
+myScreenlock :: FilePath
 myScreenlock = "screenlock"
 
-myOptimusManager :: String
+myOptimusManager :: FilePath
 myOptimusManager = "optimus-manager"
 
-myPrimeOffload :: String
+myPrimeOffload :: FilePath
 myPrimeOffload = "prime-offload"
 
 --------------------------------------------------------------------------------
--- | Packages
+-- Packages
 
 optimusPackages :: [Fulfillment]
 optimusPackages = [Package AUR "optimus-manager"]
 
 --------------------------------------------------------------------------------
--- | Core commands
+-- Core commands
 
 runScreenLock :: SometimesX
-runScreenLock = sometimesExe "screen locker" "i3lock script"
-  [Package AUR "i3lock-color"] False myScreenlock
+runScreenLock =
+  sometimesExe
+    "screen locker"
+    "i3lock script"
+    [Package AUR "i3lock-color"]
+    False
+    myScreenlock
 
-runPowerOff :: X ()
+runPowerOff :: MonadUnliftIO m => m ()
 runPowerOff = spawn "systemctl poweroff"
 
-runSuspend :: X ()
+runSuspend :: MonadUnliftIO m => m ()
 runSuspend = spawn "systemctl suspend"
 
-runHibernate :: X ()
+runHibernate :: MonadUnliftIO m => m ()
 runHibernate = spawn "systemctl hibernate"
 
-runReboot :: X ()
+runReboot :: MonadUnliftIO m => m ()
 runReboot = spawn "systemctl reboot"
 
 --------------------------------------------------------------------------------
--- | Autolock
+-- Autolock
 
-runAutolock :: Sometimes (IO ProcessHandle)
+runAutolock :: Sometimes (XIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
   where
-    tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
-      $ Only_ $ IOSometimes_ runScreenLock
-    cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
+    tree =
+      And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
+        Only_ $
+          IOSometimes_ runScreenLock
+    cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
+    args = ["--ignore-sleep", "--", "screenlock", "true"]
 
 --------------------------------------------------------------------------------
--- | Confirmation prompts
+-- Confirmation prompts
 
-promptFontDep :: IOTree T.FontBuilder
-promptFontDep = fontTreeAlt T.defFontFamily defFontPkgs
+promptFontDep :: IOTree XT.FontBuilder
+promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
 
 defFontPkgs :: [Fulfillment]
 defFontPkgs = [Package Official "ttf-dejavu"]
 
-confirmPrompt' :: String -> X () -> T.FontBuilder -> X ()
-confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
+confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
+confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
 
-suspendPrompt :: T.FontBuilder -> X ()
-suspendPrompt = confirmPrompt' "suspend?" runSuspend
+suspendPrompt :: XT.FontBuilder -> X ()
+suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
 
-quitPrompt :: T.FontBuilder -> X ()
+quitPrompt :: XT.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
 
-sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
-sometimesPrompt n = sometimesIO n (n ++ " command") promptFontDep
+sometimesPrompt :: T.Text -> (XT.FontBuilder -> X ()) -> SometimesX
+sometimesPrompt n = sometimesIO n (T.append n " command") promptFontDep
 
 -- TODO doesn't this need to also lock the screen?
 runSuspendPrompt :: SometimesX
@@ -123,71 +121,83 @@ runQuitPrompt :: SometimesX
 runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
 
 --------------------------------------------------------------------------------
--- | Nvidia Optimus
+-- Nvidia Optimus
 
 -- TODO for some reason the screen never wakes up after suspend when
 -- the nvidia card is up, so block suspend if nvidia card is running
 -- and warn user
-isUsingNvidia :: IO Bool
+isUsingNvidia :: MonadUnliftIO m => m Bool
 isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
 
-hasBattery :: IO (Maybe String)
+hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
 hasBattery = do
-  ps <- fromRight [] <$> tryIOError (listDirectory syspath)
-  ts <- mapM readType ps
-  return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
+  ps <- fromRight [] <$> tryIO (listDirectory syspath)
+  ts <- catMaybes <$> mapM readType ps
+  return $
+    if any (T.isPrefixOf "Battery") ts
+      then Nothing
+      else Just "battery not found"
   where
-    readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
+    readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
     syspath = "/sys/class/power_supply"
 
-runOptimusPrompt' :: T.FontBuilder -> X ()
+runOptimusPrompt' :: XT.FontBuilder -> X ()
 runOptimusPrompt' fb = do
   nvidiaOn <- io isUsingNvidia
   switch $ if nvidiaOn then "integrated" else "nvidia"
   where
     switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
-    prompt mode = "gpu switch to " ++ mode ++ "?"
-    cmd mode = spawn $
-      myPrimeOffload
-      #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
-      #!&& "killall xmonad"
+    prompt mode = T.concat ["gpu switch to ", mode, "?"]
+    cmd mode =
+      spawn $
+        T.pack myPrimeOffload
+          #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
+          #!&& "killall xmonad"
 
 runOptimusPrompt :: SometimesX
-runOptimusPrompt = Sometimes "graphics switcher"
-  (\x -> xpfOptimus x && xpfBattery x) [s]
+runOptimusPrompt =
+  Sometimes
+    "graphics switcher"
+    (\x -> xpfOptimus x && xpfBattery x)
+    [s]
   where
-    s = Subfeature { sfData = r, sfName = "optimus manager" }
+    s = Subfeature {sfData = r, sfName = "optimus manager"}
     r = IORoot runOptimusPrompt' t
-    t = And1 promptFontDep
-      $ listToAnds (socketExists "optimus-manager" [] socketName)
-      $ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
+    t =
+      And1 promptFontDep $
+        listToAnds (socketExists "optimus-manager" [] socketName) $
+          sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
     socketName = (</> "optimus-manager") <$> getTemporaryDirectory
 
 --------------------------------------------------------------------------------
--- | Universal power prompt
+-- Universal power prompt
 
-data PowerMaybeAction = Poweroff
-    | Shutdown
-    | Hibernate
-    | Reboot
-    deriving (Eq)
+data PowerMaybeAction
+  = Poweroff
+  | Shutdown
+  | Hibernate
+  | Reboot
+  deriving (Eq)
 
-instance Enum PowerMaybeAction where
-  toEnum 0 = Poweroff
-  toEnum 1 = Shutdown
-  toEnum 2 = Hibernate
-  toEnum 3 = Reboot
-  toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
+fromPMA :: PowerMaybeAction -> Int
+fromPMA a = case a of
+  Poweroff -> 0
+  Shutdown -> 1
+  Hibernate -> 2
+  Reboot -> 3
 
-  fromEnum Poweroff  = 0
-  fromEnum Shutdown  = 1
-  fromEnum Hibernate = 2
-  fromEnum Reboot    = 3
+toPMA :: Int -> Maybe PowerMaybeAction
+toPMA x = case x of
+  0 -> Just Poweroff
+  1 -> Just Shutdown
+  2 -> Just Hibernate
+  3 -> Just Reboot
+  _ -> Nothing
 
 data PowerPrompt = PowerPrompt
 
 instance XPrompt PowerPrompt where
-    showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
+  showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
 
 runPowerPrompt :: SometimesX
 runPowerPrompt = Sometimes "power prompt" (const True) [sf]
@@ -197,24 +207,28 @@ runPowerPrompt = Sometimes "power prompt" (const True) [sf]
     tree = And12 (,) lockTree promptFontDep
     lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
 
-powerPrompt :: X () -> T.FontBuilder -> X ()
+powerPrompt :: X () -> XT.FontBuilder -> X ()
 powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
   where
     comp = mkComplFunFromList theme []
-    theme = (T.promptTheme fb) { promptKeymap = keymap }
-    keymap = M.fromList
-      $ ((controlMask, xK_g), quit) :
-      map (first $ (,) 0)
-      [ (xK_p, sendMaybeAction Poweroff)
-      , (xK_s, sendMaybeAction Shutdown)
-      , (xK_h, sendMaybeAction Hibernate)
-      , (xK_r, sendMaybeAction Reboot)
-      , (xK_Return, quit)
-      , (xK_Escape, quit)
-      ]
-    sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
-    executeMaybeAction a = case toEnum $ read a of
-      Poweroff  -> runPowerOff
-      Shutdown  -> lock >> runSuspend
-      Hibernate -> lock >> runHibernate
-      Reboot    -> runReboot
+    theme = (XT.promptTheme fb) {promptKeymap = keymap}
+    keymap =
+      M.fromList $
+        ((controlMask, xK_g), quit)
+          : map
+            (first $ (,) 0)
+            [ (xK_p, sendMaybeAction Poweroff)
+            , (xK_s, sendMaybeAction Shutdown)
+            , (xK_h, sendMaybeAction Hibernate)
+            , (xK_r, sendMaybeAction Reboot)
+            , (xK_Return, quit)
+            , (xK_Escape, quit)
+            ]
+    sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
+    executeMaybeAction a = case toPMA =<< readMaybe a of
+      Just Poweroff -> liftIO runPowerOff
+      Just Shutdown -> lock >> liftIO runSuspend
+      Just Hibernate -> lock >> liftIO runHibernate
+      Just Reboot -> liftIO runReboot
+      -- TODO log an error here since this should never happen
+      Nothing -> skip

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -1,91 +1,85 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# 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           XMonad.Core
-import           XMonad.Internal.Command.Power
-import           XMonad.Internal.Concurrent.ClientMessage
-import           XMonad.Internal.Shell
-import           XMonad.Internal.Theme                    (FontBuilder)
+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
+import XMonad.Internal.Shell
+import XMonad.Internal.Theme (FontBuilder)
 
 --------------------------------------------------------------------------------
--- | Data structure to hold the ACPI events I care about
+-- Data structure to hold the ACPI events I care about
 --
 -- Enumerate so these can be converted to strings and back when sent in a
 -- ClientMessage event to X
 
-data ACPIEvent = Power
-    | Sleep
-    | LidClose
-    deriving (Eq)
+data ACPIEvent
+  = Power
+  | Sleep
+  | LidClose
+  deriving (Eq)
 
-instance Enum ACPIEvent where
-  toEnum 0 = Power
-  toEnum 1 = Sleep
-  toEnum 2 = LidClose
-  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
+fromACPIEvent :: ACPIEvent -> Int
+fromACPIEvent x = case x of
+  Power -> 0
+  Sleep -> 1
+  LidClose -> 2
 
-  fromEnum Power    = 0
-  fromEnum Sleep    = 1
-  fromEnum LidClose = 2
+toACPIEvent :: Int -> Maybe ACPIEvent
+toACPIEvent x = case x of
+  0 -> Just Power
+  1 -> Just Sleep
+  2 -> Just LidClose
+  _ -> Nothing
 
 --------------------------------------------------------------------------------
--- | Internal functions
+-- Internal functions
 
 -- | Convert a string to an ACPI event (this string is assumed to come from
 -- the acpid socket)
 parseLine :: ByteString -> Maybe ACPIEvent
 parseLine line =
   case splitLine line of
-    (_:"PBTN":_)        -> Just Power
-    (_:"PWRF":_)        -> Just Power
-    (_:"SLPB":_)        -> Just Sleep
-    (_:"SBTN":_)        -> Just Sleep
-    (_:"LID":"close":_) -> Just LidClose
-    _                   -> Nothing
+    (_ : "PBTN" : _) -> Just Power
+    (_ : "PWRF" : _) -> Just Power
+    (_ : "SLPB" : _) -> Just Sleep
+    (_ : "SBTN" : _) -> Just Sleep
+    (_ : "LID" : "close" : _) -> Just LidClose
+    _ -> Nothing
   where
-    splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
+    splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
+    newline = 10
+    space = 32
 
 -- | Send an ACPIEvent to the X server as a ClientMessage
 sendACPIEvent :: ACPIEvent -> IO ()
-sendACPIEvent = sendXMsg ACPI . show . fromEnum
+sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
 
 isDischarging :: IO (Maybe Bool)
 isDischarging = do
-  status <- try $ readFile "/sys/class/power_supply/BAT0/status"
-    :: IO (Either IOException String)
+  status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
   case status of
-    Left _  -> return Nothing
+    Left _ -> return Nothing
     Right s -> return $ Just (s == "Discharging")
 
 listenACPI :: IO ()
 listenACPI = do
-  Connection { source = s } <- connect acpiPath
-  forever $ readStream s
-  where
-    readStream s = do
-      out <- S.read s
-      mapM_ sendACPIEvent $ parseLine =<< out
+  sock <- socket AF_UNIX Stream defaultProtocol
+  connect sock $ SockAddrUnix acpiPath
+  forever $ do
+    out <- recv sock 1024
+    mapM_ sendACPIEvent $ parseLine out
 
 acpiPath :: FilePath
 acpiPath = "/var/run/acpid.socket"
@@ -97,29 +91,31 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
 -- Xmonad's event hook)
 handleACPI :: FontBuilder -> X () -> String -> X ()
 handleACPI fb lock tag = do
-  let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
+  let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
   forM_ acpiTag $ \case
     Power -> powerPrompt lock fb
     Sleep -> suspendPrompt fb
     LidClose -> do
       status <- io isDischarging
       -- only run suspend if battery exists and is discharging
-      forM_ status $ flip when runSuspend
+      forM_ status $ flip when $ liftIO runSuspend
       lock
 
 --------------------------------------------------------------------------------
--- | Exported API
+-- Exported API
 
 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
 -- and send ClientMessage events when it receives them
 runPowermon :: SometimesIO
-runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
+runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep $ io listenACPI
 
 runHandleACPI :: Always (String -> X ())
 runHandleACPI = Always "ACPI event handler" $ Option sf fallback
   where
     sf = Subfeature withLock "acpid prompt"
-    withLock = IORoot (uncurry handleACPI)
-      $ And12 (,) promptFontDep $ Only
-      $ IOSometimes runScreenLock id
+    withLock =
+      IORoot (uncurry handleACPI) $
+        And12 (,) promptFontDep $
+          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
@@ -16,55 +16,61 @@
 -- much like something from X even though it isn't
 
 module XMonad.Internal.Concurrent.ClientMessage
-  ( XMsgType(..)
+  ( 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 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 RIO
+import XMonad.Internal.IO
 
 --------------------------------------------------------------------------------
--- | Data structure for the ClientMessage
+-- Data structure for the ClientMessage
 --
 -- These are the "types" of client messages to send; add more here as needed
 
 -- TODO is there a way to do this in the libraries that import this one?
-data XMsgType = ACPI
-    | Workspace
-    | Unknown
-    deriving (Eq, Show)
+data XMsgType
+  = ACPI
+  | Workspace
+  | Unknown
+  deriving (Eq, Show)
 
-instance Enum XMsgType where
-  toEnum 0 = ACPI
-  toEnum 1 = Workspace
-  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
+fromXMsgType :: XMsgType -> Int
+fromXMsgType x = case x of
+  ACPI -> 0
+  Workspace -> 1
+  Unknown -> 2
 
-  fromEnum ACPI      = 0
-  fromEnum Workspace = 1
-  fromEnum Unknown   = 2
+toXMsgType :: Int -> Maybe XMsgType
+toXMsgType x = case x of
+  0 -> Just ACPI
+  1 -> Just Workspace
+  2 -> Just Unknown
+  _ -> Nothing
 
 --------------------------------------------------------------------------------
--- | Exported API
+-- Exported API
 
 -- | Given a string from the data field in a ClientMessage event, return the
 -- type and payload
 splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
 splitXMsg [] = (Unknown, "")
-splitXMsg (x:xs) = (xtype, tag)
+splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
   where
-    xtype = toEnum $ fromInteger $ toInteger x
-    tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs
+    xtype = toXMsgType $ fromIntegral x
+    tag = chr . fromIntegral <$> takeWhile (/= 0) xs
 
 -- | Emit a ClientMessage event to the X server with the given type and payloud
 sendXMsg :: XMsgType -> String -> IO ()
-sendXMsg xtype tag = do
-  dpy <- openDisplay ""
+sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
   root <- rootWindow dpy $ defaultScreen dpy
   allocaXEvent $ \e -> do
     setEventType e clientMessage
@@ -82,10 +88,8 @@ sendXMsg xtype tag = do
     -- longer will be clipped to 19, and anything less than 19 will be padded
     -- with 0 (note this used to be random garbage before). See this function
     -- for more details.
-    setClientMessageEvent' e root bITMAP 8 (x:t)
+    setClientMessageEvent' e root bITMAP 8 (x : t)
     sendEvent dpy root False substructureNotifyMask e
-  flush dpy
-  closeDisplay dpy
   where
-    x = fromIntegral $ fromEnum xtype
+    x = fromIntegral $ fromXMsgType xtype
     t = fmap (fromIntegral . fromEnum) tag

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

@@ -1,7 +1,5 @@
-{-# 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
@@ -26,63 +24,64 @@
 -- 3) Virtualbox (should always be by itself anyways)
 
 module XMonad.Internal.Concurrent.DynamicWorkspaces
-  ( DynWorkspace(..)
+  ( DynWorkspace (..)
   , appendShift
   , appendViewShift
   , removeDynamicWorkspace
   , 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           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           XMonad.Actions.DynamicWorkspaces
-import           XMonad.Core
-    ( ManageHook
-    , WorkspaceId
-    , X
-    , io
-    , withWindowSet
-    )
-import           XMonad.Hooks.ManageHelpers               (MaybeManageHook)
-import           XMonad.Internal.Concurrent.ClientMessage
-import           XMonad.Internal.Process
-import           XMonad.ManageHook
-import           XMonad.Operations
-import qualified XMonad.StackSet                          as W
+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
+  , WorkspaceId
+  , X
+  , io
+  , withWindowSet
+  )
+import XMonad.Hooks.ManageHelpers (MaybeManageHook)
+import XMonad.Internal.Concurrent.ClientMessage
+import XMonad.Internal.IO
+import XMonad.ManageHook
+import XMonad.Operations
+import qualified XMonad.StackSet as W
 
 --------------------------------------------------------------------------------
--- | Dynamic Workspace datatype
--- This hold all the data needed to tie an app to a particular dynamic workspace
+-- Dynamic Workspace datatype
+-- This holds all the data needed to tie an app to a particular dynamic workspace
 
 data DynWorkspace = DynWorkspace
-    { dwName  :: String
-    , dwTag   :: WorkspaceId
-    , dwClass :: String
-    , dwHook  :: [MaybeManageHook]
-    , dwKey   :: Char
-    , dwCmd   :: Maybe (X ())
-    -- TODO this should also have the layout for this workspace
-    }
+  { dwName :: String
+  , dwTag :: WorkspaceId
+  , dwClass :: String
+  , dwHook :: [MaybeManageHook]
+  , dwKey :: Char
+  , dwCmd :: Maybe (X ())
+  -- TODO this should also have the layout for this workspace
+  }
 
 --------------------------------------------------------------------------------
--- | Manager thread
+-- Manager thread
 -- The main thread that watches for new windows. When a match is found, this
 -- thread spawns a new thread the waits for the PID of the window to exit. When
 -- the PID exits, it sends a ClientMessage event to X
@@ -91,79 +90,93 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String
 
-type WatchedPIDs = MVar [Pid]
+data WEnv = WEnv
+  { wDisplay :: !Display
+  , wDynWorkspaces :: ![DynWorkspace]
+  , wCurPIDs :: !(MVar (S.Set Pid))
+  , wXEnv :: !XEnv
+  }
 
-data WConf = WConf
-    { display       :: Display
-    , dynWorkspaces :: [DynWorkspace]
-    }
+instance HasLogFunc WEnv where
+  logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
 
-newtype W a = W (ReaderT WConf IO a)
-  deriving (Functor, Monad, MonadIO, MonadReader WConf)
+type WIO a = RIO WEnv a
 
-instance Applicative W where
-  pure = return
-  (<*>) = ap
-
-runW :: WConf -> W a -> IO a
-runW c (W a) = runReaderT a c
-
-runWorkspaceMon :: [DynWorkspace] -> IO ()
-runWorkspaceMon dws = do
-  dpy <- openDisplay ""
-  root <- rootWindow dpy $ defaultScreen dpy
-  curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
+runWorkspaceMon :: [DynWorkspace] -> XIO ()
+runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
+  root <- liftIO $ rootWindow dpy $ defaultScreen dpy
   -- listen only for substructure change events (which includes MapNotify)
-  allocaSetWindowAttributes $ \a -> do
+  liftIO $ allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
-  let c = WConf { display = dpy, dynWorkspaces = dws }
-  _ <- allocaXEvent $ \e ->
-    runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
-  return ()
+  withRunInIO $ \runIO -> do
+    void $ allocaXEvent $ runIO . withEvents dpy
+  where
+    wrapEnv dpy ps x =
+      WEnv
+        { wDisplay = dpy
+        , wDynWorkspaces = dws
+        , wCurPIDs = ps
+        , wXEnv = x
+        }
+    withEvents dpy e = do
+      ps <- newMVar S.empty
+      mapRIO (wrapEnv dpy ps) $ do
+        forever $
+          handleEvent =<< io (nextEvent dpy e >> getEvent e)
 
-handle :: WatchedPIDs -> Event -> W ()
+handleEvent :: Event -> WIO ()
 
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
-handle curPIDs MapNotifyEvent { ev_window = w } = do
-  dpy <- asks display
+handleEvent MapNotifyEvent {ev_window = w} = do
+  dpy <- asks wDisplay
   hint <- io $ getClassHint dpy w
-  dws <- asks dynWorkspaces
-  let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
-  let tag = M.lookup (resClass hint) m
-  io $ forM_ tag $ \t -> do
-    a <- internAtom dpy "_NET_WM_PID" False
-    pid <- getWindowProperty32 dpy a w
+  dws <- asks wDynWorkspaces
+  let tag =
+        M.lookup (resClass hint) $
+          M.fromList $
+            fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
+  forM_ tag $ \t -> do
+    a <- io $ internAtom dpy "_NET_WM_PID" False
+    pid <- io $ getWindowProperty32 dpy a w
     case pid of
       -- ASSUMPTION windows will only have one PID at one time
-      Just [p] -> let p' = fromIntegral p
-        in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
-      _        -> return ()
+      Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
+      _ -> return ()
+handleEvent _ = return ()
 
-handle _ _ = return ()
-
-waitAndKill :: String -> Pid -> IO ()
-waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
-
-withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
-withUniquePid curPIDs pid f = do
-  pids <- readMVar curPIDs
-  unless (pid `elem` pids) $ do
-    modifyMVar_ curPIDs (return . (pid:))
-    f
-    modifyMVar_ curPIDs (return . filter (/=pid))
+withUniquePid :: Pid -> String -> WIO ()
+withUniquePid pid tag = do
+  ps <- asks wCurPIDs
+  pids <- readMVar ps
+  unless (pid `elem` pids)
+    $ bracket_
+      (modifyMVar_ ps (return . S.insert pid))
+      (modifyMVar_ ps (return . S.delete pid))
+    $ do
+      logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
+      waitUntilExit pid
+      logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
+      liftIO $ sendXMsg Workspace tag
+  where
+    pid_ = "'" <> displayShow pid <> "'"
+    tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
 
 --------------------------------------------------------------------------------
--- | Launching apps
+-- Launching apps
 -- When launching apps on dymamic workspaces, first check if they are running
 -- and launch if not, then switch to their workspace
 
 wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
-wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
-  -- 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)
+wsOccupied tag ws =
+  elem tag $
+    map W.tag $
+      filter (isJust . W.stack)
+      -- list of all workspaces with windows on them
+      -- TODO is there not a better way to do this?
+      $
+        W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
 
 spawnOrSwitch :: WorkspaceId -> X () -> X ()
 spawnOrSwitch tag cmd = do
@@ -171,7 +184,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)
@@ -192,29 +205,31 @@ appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
 -- TODO surprisingly this doesn't exist? We shouldn't need to TBH
 doSink :: ManageHook
 doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
-                       Just s' -> W.sink (W.focus s') s
-                       Nothing -> s
+  Just s' -> W.sink (W.focus s') s
+  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) }
+    removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
       -- if hidden, delete from hidden
-      | Just x <- find isEmptyTarget hall
-      = s { W.hidden = deleteBy (eq W.tag) x hall }
+      | Just x <- find isEmptyTarget 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
-      = s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
-          , W.hidden = hs }
+      | Just x <- find (isEmptyTarget . W.workspace) vis =
+          s
+            { W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
+            , W.hidden = hs
+            }
       -- if current, move the first hidden workspace to the current
-      | isEmptyTarget $ W.workspace $ W.current s
-      = s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs }
+      | isEmptyTarget $ W.workspace $ W.current s =
+          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

@@ -1,44 +1,52 @@
-{-# LANGUAGE ScopedTypeVariables #-}
 --------------------------------------------------------------------------------
--- | VirtualBox-specific functions
+-- VirtualBox-specific functions
 
 module XMonad.Internal.Concurrent.VirtualBox
   ( vmExists
-  ) where
+  , vmInstanceConfig
+  , qual
+  )
+where
 
-import           Control.Exception
+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 XMonad.Internal.Shell
 
-import           Data.Internal.Dependency
+vmExists :: T.Text -> IO (Maybe Msg)
+vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
 
-import           Text.XML.Light
-
-import           System.Directory
-
-import           XMonad.Internal.Shell
-
-vmExists :: String -> IO (Maybe Msg)
-vmExists vm = do
-  d <- vmDirectory
-  either (return . Just . Msg Error) findVMDir d
+vmInstanceConfig :: T.Text -> IO (Either T.Text FilePath)
+vmInstanceConfig vmName = do
+  either (return . Right) findInstance =<< vmDirectory
   where
-    findVMDir vd = do
-      vs <- listDirectory vd
-      return $ if vm `elem` vs then Nothing
-        else Just $ Msg Error $ "could not find " ++ singleQuote vm
+    path = T.unpack vmName </> addExtension (T.unpack vmName) "vbox"
+    findInstance dir = do
+      res <- findFile [dir] path
+      return $ case res of
+        Just p -> Right p
+        Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
 
 vmDirectory :: IO (Either String String)
 vmDirectory = do
   p <- vmConfig
-  (s :: Either IOException String) <- try $ readFile p
+  s <- tryIO $ readFileUtf8 p
   return $ case s of
     (Left _) -> Left "could not read VirtualBox config file"
-    (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
-                 $ findDir =<< parseXMLDoc x
+    (Right x) ->
+      maybe (Left "Could not parse VirtualBox config file") Right $
+        findDir =<< parseXMLDoc x
   where
-    findDir e = findAttr (unqual "defaultMachineFolder")
-      =<< findChild (qual e "SystemProperties")
-      =<< findChild (qual e "Global") e
-    qual e n = (elName e) { qName = n }
+    findDir e =
+      findAttr (unqual "defaultMachineFolder")
+        =<< findChild (qual e "SystemProperties")
+        =<< findChild (qual e "Global") e
+
+qual :: Element -> String -> QName
+qual e n = (elName e) {qName = n}
 
 vmConfig :: IO FilePath
 vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"

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

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | DBus module for Clevo Keyboard control
+-- DBus module for Clevo Keyboard control
 
 module XMonad.Internal.DBus.Brightness.ClevoKeyboard
   ( callGetBrightnessCK
@@ -8,24 +8,20 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
   , clevoKeyboardControls
   , clevoKeyboardSignalDep
   , blPath
-  ) where
+  )
+where
 
-import           Control.Monad                          (when)
-
-import           Data.Int                               (Int32)
-import           Data.Internal.DBus
-import           Data.Internal.Dependency
-
-import           DBus
-
-import           System.FilePath.Posix
-
-import           XMonad.Internal.DBus.Brightness.Common
-import           XMonad.Internal.IO
+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
@@ -48,41 +44,41 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
 stateFile :: FilePath
 stateFile = backlightDir </> "state"
 
-stateChange :: Bool -> IO ()
+stateChange :: MonadUnliftIO m => Bool -> m ()
 stateChange = writeBool stateFile
 
-stateOn :: IO ()
+stateOn :: MonadUnliftIO m => m ()
 stateOn = stateChange True
 
-stateOff :: IO ()
+stateOff :: MonadUnliftIO m => m ()
 stateOff = stateChange False
 
 brightnessFile :: FilePath
 brightnessFile = backlightDir </> "brightness"
 
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds brightnessFile
 
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = do
   b <- writePercentMin bounds brightnessFile
   stateOff
   return b
 
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
 
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
 
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness bounds = do
   b <- decPercent steps brightnessFile bounds
   when (b == 0) stateOff
   return b
 
 --------------------------------------------------------------------------------
--- | DBus interface
+-- DBus interface
 
 blPath :: ObjectPath
 blPath = objectPath_ "/clevo_keyboard"
@@ -90,22 +86,23 @@ blPath = objectPath_ "/clevo_keyboard"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
-clevoKeyboardConfig = BrightnessConfig
-  { bcMin = minBrightness
-  , bcMax = maxBrightness
-  , bcInc = incBrightness
-  , bcDec = decBrightness
-  , bcGet = getBrightness
-  , bcGetMax = return maxRawBrightness
-  , bcMinRaw = minRawBrightness
-  , bcPath = blPath
-  , bcInterface = interface
-  , bcName = "Clevo keyboard"
-  }
+clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
+clevoKeyboardConfig =
+  BrightnessConfig
+    { bcMin = minBrightness
+    , bcMax = maxBrightness
+    , bcInc = incBrightness
+    , bcDec = decBrightness
+    , bcGet = getBrightness
+    , bcGetMax = return maxRawBrightness
+    , bcMinRaw = minRawBrightness
+    , bcPath = blPath
+    , bcInterface = interface
+    , bcName = "Clevo keyboard"
+    }
 
 --------------------------------------------------------------------------------
--- | Exported haskell API
+-- Exported haskell API
 
 stateFileDep :: IODependency_
 stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
@@ -114,17 +111,38 @@ brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 
 clevoKeyboardSignalDep :: DBusDependency_ SesClient
-clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
+clevoKeyboardSignalDep =
+  -- TODO do I need to get rid of the IO here?
+  signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportClevoKeyboard :: Maybe SesClient -> SometimesIO
-exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
-  [stateFileDep, brightnessFileDep] clevoKeyboardConfig
+exportClevoKeyboard
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
+exportClevoKeyboard =
+  brightnessExporter
+    xpfClevoBacklight
+    []
+    [stateFileDep, brightnessFileDep]
+    clevoKeyboardConfig
 
-clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
+clevoKeyboardControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
-callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessCK
+  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+  => m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
 
-matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalCK
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     )
+  => (Maybe Brightness -> m ())
+  -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig

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

@@ -1,154 +1,194 @@
 --------------------------------------------------------------------------------
--- | DBus module for DBus brightness controls
+-- DBus module for DBus brightness controls
 
 module XMonad.Internal.DBus.Brightness.Common
-  ( BrightnessConfig(..)
-  , BrightnessControls(..)
+  ( BrightnessConfig (..)
+  , BrightnessControls (..)
   , brightnessControls
   , brightnessExporter
   , 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           XMonad.Core                 (io)
-import           XMonad.Internal.DBus.Common
+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.Internal.DBus.Common
 
 --------------------------------------------------------------------------------
--- | External API
+-- External API
 --
 -- Define four methods to increase, decrease, maximize, or minimize the
 -- brightness. These methods will all return the current brightness as a 32-bit
 -- integer and emit a signal with the same brightness value. Additionally, there
 -- is one method to get the current brightness.
 
-data BrightnessConfig a b = BrightnessConfig
-  { bcMin       :: (a, a) -> IO b
-  , bcMax       :: (a, a) -> IO b
-  , bcDec       :: (a, a) -> IO b
-  , bcInc       :: (a, a) -> IO b
-  , bcGet       :: (a, a) -> IO b
-  , bcMinRaw    :: a
-  , bcGetMax    :: IO a
-  , bcPath      :: ObjectPath
+data BrightnessConfig m a b = BrightnessConfig
+  { bcMin :: (a, a) -> m b
+  , bcMax :: (a, a) -> m b
+  , bcDec :: (a, a) -> m b
+  , bcInc :: (a, a) -> m b
+  , bcGet :: (a, a) -> m b
+  , bcMinRaw :: a
+  , bcGetMax :: m a
+  , bcPath :: ObjectPath
   , bcInterface :: InterfaceName
-  , bcName      :: String
+  , bcName :: T.Text
   }
 
-data BrightnessControls = BrightnessControls
-  { bctlMax :: SometimesIO
-  , bctlMin :: SometimesIO
-  , bctlInc :: SometimesIO
-  , bctlDec :: SometimesIO
+data BrightnessControls m = BrightnessControls
+  { bctlMax :: Sometimes (m ())
+  , bctlMin :: Sometimes (m ())
+  , bctlInc :: Sometimes (m ())
+  , bctlDec :: Sometimes (m ())
   }
 
-brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
-  -> BrightnessControls
+brightnessControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => XPQuery
+  -> BrightnessConfig m a b
+  -> Maybe NamedSesConnection
+  -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
-  { bctlMax = cb "max brightness" memMax
-  , bctlMin = cb "min brightness" memMin
-  , bctlInc = cb "increase brightness" memInc
-  , bctlDec = cb "decrease brightness" memDec
-  }
+    { bctlMax = cb "max brightness" memMax
+    , bctlMin = cb "min brightness" memMin
+    , bctlInc = cb "increase brightness" memInc
+    , bctlDec = cb "decrease brightness" memDec
+    }
   where
     cb = callBacklight q cl bc
 
-callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
-  -> IO (Maybe n)
-callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
+callGetBrightness
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , Num n
+     )
+  => BrightnessConfig m a b
+  -> m (Maybe n)
+callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-  <$> callMethod client xmonadBusName p i memGet
+    <$> callMethod xmonadSesBusName p i memGet
 
-signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
-signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
-  Endpoint [] xmonadBusName p i $ Signal_ memCur
+signalDep :: BrightnessConfig m a b -> DBusDependency_ c
+signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
+  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
 
-matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
-  -> (Maybe n-> IO ()) -> c -> IO ()
-matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-  void . addMatchCallback brMatcher (cb . bodyGetBrightness)
+matchSignal
+  :: ( HasClient env
+     , 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)
   where
     -- TODO add busname to this
-    brMatcher = matchAny
-      { matchPath = Just p
-      , matchInterface = Just i
-      , matchMember = Just memCur
-      }
+    brMatcher =
+      matchAny
+        { matchPath = Just p
+        , matchInterface = Just i
+        , matchMember = Just memCur
+        }
 
 --------------------------------------------------------------------------------
--- | Internal DBus Crap
+-- Internal DBus Crap
 
-brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-  -> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
-brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
-  Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
+brightnessExporter
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+  => XPQuery
+  -> [Fulfillment]
+  -> [IODependency_]
+  -> BrightnessConfig m a b
+  -> Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
+brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
+  Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
   where
-    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
-    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
+    root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
+    tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
 
-exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
-exportBrightnessControls' bc cl = do
-  let ses = toClient cl
-  maxval <- bcGetMax bc -- assume the max value will never change
-  let bounds = (bcMinRaw bc, maxval)
-  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
-  let funget = bcGet bc
-  export ses (bcPath bc) defaultInterface
-    { interfaceName = bcInterface bc
-    , interfaceMethods =
-      [ autoMethod' memMax bcMax
-      , autoMethod' memMin bcMin
-      , autoMethod' memInc bcInc
-      , autoMethod' memDec bcDec
-      , autoMethod memGet (round <$> funget bounds :: IO Int32)
-      ]
-    , interfaceSignals = [sig]
-    }
+exportBrightnessControlsInner
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+  => BrightnessConfig m a b
+  -> NamedSesConnection
+  -> (m (), m ())
+exportBrightnessControlsInner bc = cmd
   where
-    sig = I.Signal
-      { I.signalName = memCur
-      , I.signalArgs =
-        [
-          I.SignalArg
-          { I.signalArgName = "brightness"
-          , I.signalArgType = TypeInt32
+    cmd = exportPair (bcPath bc) $ \cl_ -> do
+      -- assume the max value will never change
+      bounds <- (bcMinRaw bc,) <$> bcGetMax bc
+      runIO <- askRunInIO
+      let autoMethod' m f = autoMethod m $ runIO $ do
+            val <- f bc bounds
+            emitBrightness bc cl_ val
+      funget <- toIO $ bcGet bc bounds
+      return $
+        defaultInterface
+          { interfaceName = bcInterface bc
+          , interfaceMethods =
+              [ autoMethod' memMax bcMax
+              , autoMethod' memMin bcMin
+              , autoMethod' memInc bcInc
+              , autoMethod' memDec bcDec
+              , autoMethod memGet (round <$> funget :: IO Int32)
+              ]
+          , interfaceSignals = [sig]
           }
-        ]
-      }
+    sig =
+      I.Signal
+        { I.signalName = memCur
+        , I.signalArgs =
+            [ I.SignalArg
+                { I.signalArgName = "brightness"
+                , I.signalArgType = TypeInt32
+                }
+            ]
+        }
 
-emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
-emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
-  emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
+emitBrightness
+  :: (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)]}
   where
     sig = signal p i memCur
 
-callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> String
-  -> MemberName -> SometimesIO
-callBacklight q cl BrightnessConfig { bcPath = p
-                                    , bcInterface = i
-                                    , bcName = n } controlName m =
-  Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
+callBacklight
+  :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
+  => XPQuery
+  -> Maybe NamedSesConnection
+  -> BrightnessConfig m a b
+  -> T.Text
+  -> MemberName
+  -> Sometimes (m ())
+callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
+  Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
   where
-    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
-    cmd c = io $ void $ callMethod c xmonadBusName p i m
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
+    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
-bodyGetBrightness _   = Nothing
+bodyGetBrightness _ = Nothing
 
 --------------------------------------------------------------------------------
--- | DBus Members
+-- DBus Members
 
 memCur :: MemberName
 memCur = memberName_ "CurrentBrightness"

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

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | DBus module for Intel Backlight control
+-- DBus module for Intel Backlight control
 
 module XMonad.Internal.DBus.Brightness.IntelBacklight
   ( callGetBrightnessIB
@@ -8,22 +8,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
   , intelBacklightControls
   , intelBacklightSignalDep
   , blPath
-  ) where
+  )
+where
 
-import           Data.Int                               (Int32)
-import           Data.Internal.DBus
-import           Data.Internal.Dependency
-
-import           DBus
-
-import           System.FilePath.Posix
-
-import           XMonad.Internal.DBus.Brightness.Common
-import           XMonad.Internal.IO
+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
@@ -45,26 +43,26 @@ maxFile = backlightDir </> "max_brightness"
 curFile :: FilePath
 curFile = backlightDir </> "brightness"
 
-getMaxRawBrightness :: IO RawBrightness
+getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
 getMaxRawBrightness = readInt maxFile
 
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds curFile
 
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = writePercentMin bounds curFile
 
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = writePercentMax bounds curFile
 
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness = incPercent steps curFile
 
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness = decPercent steps curFile
 
 --------------------------------------------------------------------------------
--- | DBus interface
+-- DBus interface
 
 blPath :: ObjectPath
 blPath = objectPath_ "/intelbacklight"
@@ -72,22 +70,25 @@ blPath = objectPath_ "/intelbacklight"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
-intelBacklightConfig = BrightnessConfig
-  { bcMin = minBrightness
-  , bcMax = maxBrightness
-  , bcInc = incBrightness
-  , bcDec = decBrightness
-  , bcGet = getBrightness
-  , bcGetMax = getMaxRawBrightness
-  , bcMinRaw = minRawBrightness
-  , bcPath = blPath
-  , bcInterface = interface
-  , bcName = "Intel backlight"
-  }
+intelBacklightConfig
+  :: MonadUnliftIO m
+  => BrightnessConfig m RawBrightness Brightness
+intelBacklightConfig =
+  BrightnessConfig
+    { bcMin = minBrightness
+    , bcMax = maxBrightness
+    , bcInc = incBrightness
+    , bcDec = decBrightness
+    , bcGet = getBrightness
+    , bcGetMax = getMaxRawBrightness
+    , bcMinRaw = minRawBrightness
+    , bcPath = blPath
+    , bcInterface = interface
+    , bcName = "Intel backlight"
+    }
 
 --------------------------------------------------------------------------------
--- | Exported haskell API
+-- Exported haskell API
 
 curFileDep :: IODependency_
 curFileDep = pathRW curFile []
@@ -96,17 +97,38 @@ maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []
 
 intelBacklightSignalDep :: DBusDependency_ SesClient
-intelBacklightSignalDep = signalDep intelBacklightConfig
+intelBacklightSignalDep =
+  -- TODO do I need to get rid of the IO here?
+  signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportIntelBacklight :: Maybe SesClient -> SometimesIO
-exportIntelBacklight = brightnessExporter xpfIntelBacklight []
-  [curFileDep, maxFileDep] intelBacklightConfig
+exportIntelBacklight
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
+exportIntelBacklight =
+  brightnessExporter
+    xpfIntelBacklight
+    []
+    [curFileDep, maxFileDep]
+    intelBacklightConfig
 
-intelBacklightControls :: Maybe SesClient -> BrightnessControls
+intelBacklightControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
-callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessIB
+  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+  => m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
-matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalIB
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     )
+  => (Maybe Brightness -> m ())
+  -> m ()
 matchSignalIB = matchSignal intelBacklightConfig

lib/XMonad/Internal/DBus/Common.hs

@@ -1,18 +1,23 @@
 --------------------------------------------------------------------------------
--- | High-level interface for managing XMonad's DBus
+-- High-level interface for managing XMonad's DBus
 
 module XMonad.Internal.DBus.Common
-  ( xmonadBusName
+  ( xmonadSesBusName
+  , xmonadSysBusName
   , btBus
   , notifyBus
   , notifyPath
   , networkManagerBus
-  ) where
+  )
+where
 
-import           DBus
+import DBus
 
-xmonadBusName :: BusName
-xmonadBusName = busName_ "org.xmonad"
+xmonadSesBusName :: BusName
+xmonadSesBusName = busName_ "org.xmonad.session"
+
+xmonadSysBusName :: BusName
+xmonadSysBusName = busName_ "org.xmonad.system"
 
 btBus :: BusName
 btBus = busName_ "org.bluez"
@@ -25,4 +30,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
 
 networkManagerBus :: BusName
 networkManagerBus = busName_ "org.freedesktop.NetworkManager"
-

lib/XMonad/Internal/DBus/Control.hs

@@ -1,83 +1,188 @@
-{-# 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(..)
+  , DBusState (..)
+  , withDBusInterfaces
+  , withDBusX
+  , withDBusX_
+  , withDBus
+  , withDBus_
   , connectDBus
-  , connectDBusX
   , disconnectDBus
-  , disconnectDBusX
+  -- , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
   , disconnect
   , dbusExporters
-  ) where
+  )
+where
 
-import           Control.Monad
-
-import           Data.Internal.DBus
-import           Data.Internal.Dependency
-
-import           DBus
-import           DBus.Client
-
-import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
-import           XMonad.Internal.DBus.Brightness.IntelBacklight
-import           XMonad.Internal.DBus.Common
-import           XMonad.Internal.DBus.Screensaver
+import DBus
+import DBus.Client
+import Data.Internal.DBus
+import Data.Internal.XIO
+import RIO
+import XMonad.Internal.DBus.Brightness.ClevoKeyboard
+import XMonad.Internal.DBus.Brightness.IntelBacklight
+import XMonad.Internal.DBus.Common
+import XMonad.Internal.DBus.Screensaver
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-    { dbSesClient :: Maybe SesClient
-    , dbSysClient :: Maybe SysClient
-    }
+  { dbSesClient :: Maybe NamedSesConnection
+  , dbSysClient :: Maybe NamedSysConnection
+  }
+
+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 a
+withDBusX = withDBus (Just xmonadSesBusName) Nothing
+
+withDBus_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
+  -> m ()
+withDBus_ sesname sysname = void . withDBus sesname sysname
+
+withDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
+  -> m a
+withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
 
 -- | Connect to the DBus
-connectDBus :: IO DBusState
-connectDBus = do
-  ses <- getDBusClient
-  sys <- getDBusClient
-  return DBusState { dbSesClient = ses, dbSysClient = sys }
+connectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> m DBusState
+connectDBus sesname sysname = do
+  ses <- getDBusClient sesname
+  sys <- getDBusClient sysname
+  return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus :: DBusState -> IO ()
+disconnectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => DBusState
+  -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
+    disc
+      :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
+      => (DBusState -> Maybe (NamedConnection c))
+      -> m ()
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
--- | Connect to the DBus and request the XMonad name
-connectDBusX :: IO DBusState
-connectDBusX = do
-  db <- connectDBus
-  forM_ (dbSesClient db) requestXMonadName
-  return db
+-- -- | Connect to the DBus and request the XMonad name
+-- connectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => m DBusState
+-- connectDBusX = do
+--   db <- connectDBus
+--   requestXMonadName2 db
+--   return db
 
--- | Disconnect from DBus and release the XMonad name
-disconnectDBusX :: DBusState -> IO ()
-disconnectDBusX db = do
-  forM_ (dbSesClient db) releaseXMonadName
-  disconnectDBus db
+-- -- | Disconnect from DBus and release the XMonad name
+-- disconnectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- disconnectDBusX db = do
+--   forM_ (dbSesClient db) releaseBusName
+--   forM_ (dbSysClient db) releaseBusName
+--   disconnectDBus db
+
+-- requestXMonadName2
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- requestXMonadName2 db = do
+--   forM_ (dbSesClient db) requestXMonadName
+--   forM_ (dbSysClient db) requestXMonadName
+
+withDBusInterfaces
+  :: DBusState
+  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  -> ([XIO ()] -> XIO a)
+  -> XIO a
+withDBusInterfaces db interfaces = bracket up sequence
+  where
+    up = do
+      pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
+      mapM_ fst pairs
+      return $ snd <$> pairs
 
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: [Maybe SesClient -> SometimesIO]
+dbusExporters
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName :: SesClient -> IO ()
-releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
+-- releaseXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- releaseXMonadName cl = do
+--   -- TODO this might error?
+--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
+--   logInfo "released xmonad name"
 
-requestXMonadName :: SesClient -> IO ()
-requestXMonadName ses = do
-  res <- requestName (toClient ses) xmonadBusName []
-  -- TODO if the client is not released on shutdown the owner will be different
-  let msg | res == NamePrimaryOwner = Nothing
-          | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
-          | res == NameInQueue
-            || res == NameExists = Just $ "another process owns " ++ xn
-          | otherwise = Just $ "unknown error when requesting " ++ xn
-  forM_ msg putStrLn
-  where
-    xn = "'" ++ formatBusName xmonadBusName ++ "'"
+-- releaseBusName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => BusName
+--   -> c
+--   -> m ()
+-- releaseBusName n cl = do
+--   -- TODO this might error?
+--   liftIO $ void $ releaseName (toClient cl) n
+--   logInfo $ "released bus name: " <> displayBusName n
+
+-- requestBusName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => BusName
+--   -> c
+--   -> m ()
+-- requestBusName n cl = do
+--   res <- try $ liftIO $ requestName (toClient cl) n []
+--   case res of
+--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+--     Right r -> do
+--       let msg
+--             | r == NamePrimaryOwner = "registering name"
+--             | r == NameAlreadyOwner = "this process already owns name"
+--             | r == NameInQueue
+--                 || r == NameExists =
+--                 "another process owns name"
+--             -- this should never happen
+--             | otherwise = "unknown error when requesting name"
+--       logInfo $ msg <> ": " <> displayBusName n
+
+-- requestXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- requestXMonadName cl = do
+--   res <- liftIO $ requestName (toClient cl) xmonadBusName []
+--   let msg
+--         | res == NamePrimaryOwner = "registering name"
+--         | res == NameAlreadyOwner = "this process already owns name"
+--         | res == NameInQueue
+--             || res == NameExists =
+--             "another process owns name"
+--         | otherwise = "unknown error when requesting name"
+--   logInfo $ msg <> ": " <> displayBusName xmonadBusName

lib/XMonad/Internal/DBus/Removable.hs

@@ -1,22 +1,19 @@
 --------------------------------------------------------------------------------
--- | 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           XMonad.Core                     (io)
-import           XMonad.Internal.Command.Desktop
+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
 
 bus :: BusName
 bus = busName_ "org.freedesktop.UDisks2"
@@ -49,40 +46,60 @@ driveRemovedSound :: FilePath
 driveRemovedSound = "smb_pipe.wav"
 
 ruleUdisks :: MatchRule
-ruleUdisks = matchAny
-  { matchPath = Just path
-  , matchInterface = Just interface
-  }
+ruleUdisks =
+  matchAny
+    { matchPath = Just path
+    , matchInterface = Just interface
+    }
 
 driveFlag :: String
 driveFlag = "org.freedesktop.UDisks2.Drive"
 
 addedHasDrive :: [Variant] -> Bool
-addedHasDrive [_, a] = maybe False (member driveFlag)
-  (fromVariant a :: Maybe (Map String (Map String Variant)))
+addedHasDrive [_, a] =
+  maybe
+    False
+    (M.member driveFlag)
+    (fromVariant a :: Maybe (Map String (Map String Variant)))
 addedHasDrive _ = False
 
 removedHasDrive :: [Variant] -> Bool
-removedHasDrive [_, a] = maybe False (driveFlag `elem`)
-  (fromVariant a :: Maybe [String])
+removedHasDrive [_, a] =
+  maybe
+    False
+    (driveFlag `elem`)
+    (fromVariant a :: Maybe [String])
 removedHasDrive _ = False
 
-playSoundMaybe :: FilePath -> Bool -> IO ()
+playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
 playSoundMaybe p b = when b $ io $ playSound p
 
 -- NOTE: the udisks2 service should be already running for this module to work.
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices :: SysClient -> IO ()
+listenDevices
+  :: ( HasClient (DBusEnv env)
+     , MonadReader env m
+     , MonadUnliftIO m
+     )
+  => NamedSysConnection
+  -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
   addMatch' memRemoved driveRemovedSound removedHasDrive
   where
-    addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
-      $ playSoundMaybe p . f . signalBody
+    addMatch' m p f = do
+      let rule = ruleUdisks {matchMember = Just m}
+      void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
 
-runRemovableMon :: Maybe SysClient -> SometimesIO
+runRemovableMon
+  :: ( HasClient (DBusEnv env)
+     , MonadReader env m
+     , MonadUnliftIO m
+     )
+  => Maybe NamedSysConnection
+  -> Sometimes (m ())
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
   where

lib/XMonad/Internal/DBus/Screensaver.hs

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

lib/XMonad/Internal/IO.hs

@@ -1,7 +1,5 @@
-{-# 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.
@@ -19,86 +17,124 @@ module XMonad.Internal.IO
   , incPercent
   -- , isReadable
   -- , isWritable
-  , PermResult(..)
+  , PermResult (..)
   , getPermissionsSafe
-  ) where
+  , waitUntilExit
+  , withOpenDisplay
+  )
+where
 
-import           Data.Char
-import           Data.Text        (pack, unpack)
-import           Data.Text.IO     as T (readFile, writeFile)
-
-import           System.Directory
-import           System.IO.Error
+import Data.Char
+import Graphics.X11.Xlib.Display
+import Graphics.X11.Xlib.Event
+import Graphics.X11.Xlib.Types
+import RIO hiding (Display)
+import RIO.Directory
+import RIO.FilePath
+import qualified RIO.Text as T
+import System.IO.Error
+import System.Process
 
 --------------------------------------------------------------------------------
--- | read
+-- read
 
-readInt :: (Read a, Integral a) => FilePath -> IO a
-readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
+readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
+readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
 
-readBool :: FilePath -> IO Bool
-readBool = fmap (==(1 :: Int)) . readInt
+readBool :: MonadIO m => FilePath -> m Bool
+readBool = fmap (== (1 :: Int)) . readInt
 
 --------------------------------------------------------------------------------
--- | write
+-- write
 
-writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
-writeInt f = T.writeFile f . pack . show
+writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
+writeInt f = writeFileUtf8 f . T.pack . show
 
-writeBool :: FilePath -> Bool -> IO ()
+writeBool :: MonadIO m => FilePath -> Bool -> m ()
 writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
 
 --------------------------------------------------------------------------------
--- | percent-based read/write
+-- percent-based read/write
 --
 -- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
 -- value. Assume that the file being read has a min of 0 and an unchanging max
 -- given by a runtime argument, which is scaled linearly to the range 0-100
 -- (percent).
-
-rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
+rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
 rawToPercent (lower, upper) raw =
   100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
+
 -- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
 
-readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
 readPercent bounds path = do
   i <- readInt path
   return $ rawToPercent bounds (i :: Integer)
 
 percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
-percentToRaw (lower, upper) perc = round $
-  fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
+percentToRaw (lower, upper) perc =
+  round $
+    fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
 
-writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
+writePercent
+  :: (MonadIO m, Integral a, RealFrac b)
+  => (a, a)
+  -> FilePath
+  -> b
+  -> m b
 writePercent bounds path perc = do
-  let t | perc > 100 = 100
+  let t
+        | perc > 100 = 100
         | perc < 0 = 0
         | otherwise = perc
   writeInt path (percentToRaw bounds t :: Int)
   return t
 
-writePercentMin :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+writePercentMin
+  :: (MonadIO m, Integral a, RealFrac b)
+  => (a, a)
+  -> FilePath
+  -> m b
 writePercentMin bounds path = writePercent bounds path 0
 
-writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
+writePercentMax
+  :: (MonadIO m, Integral a, RealFrac b)
+  => (a, a)
+  -> FilePath
+  -> m b
 writePercentMax bounds path = writePercent bounds path 100
 
-shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
-  -> (a, a) -> IO b
-shiftPercent f steps path bounds = writePercent bounds path . f stepsize
+shiftPercent
+  :: (MonadIO m, Integral a, RealFrac b)
+  => (b -> b -> b)
+  -> Int
+  -> FilePath
+  -> (a, a)
+  -> m b
+shiftPercent f steps path bounds =
+  writePercent bounds path . f stepsize
     =<< readPercent bounds path
   where
     stepsize = 100 / fromIntegral steps
 
-incPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
+incPercent
+  :: (MonadIO m, Integral a, RealFrac b)
+  => Int
+  -> FilePath
+  -> (a, a)
+  -> m b
 incPercent = shiftPercent (+)
 
-decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
+decPercent
+  :: (MonadIO m, Integral a, RealFrac b)
+  => Int
+  -> FilePath
+  -> (a, a)
+  -> m b
 decPercent = shiftPercent subtract -- silly (-) operator thingy error
 
 --------------------------------------------------------------------------------
--- | permission query
+-- permission query
 
 data PermResult a = PermResult a | NotFoundError | PermError
   deriving (Show, Eq)
@@ -108,19 +144,36 @@ data PermResult a = PermResult a | NotFoundError | PermError
 --   fmap _ NotFoundError  = NotFoundError
 --   fmap _ PermError      = PermError
 
-getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
+getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
 getPermissionsSafe f = do
-  r <- tryIOError $ getPermissions f
+  r <- tryIO $ getPermissions f
   return $ case r of
-    Right z                            -> PermResult z
-    Left (isPermissionError -> True)   -> PermError
+    Right z -> PermResult z
+    Left (isPermissionError -> True) -> PermError
     Left (isDoesNotExistError -> True) -> NotFoundError
     -- the above error should be the only ones thrown by getPermission,
     -- so the catchall case should never happen
-    _                                  -> error "Unknown permission error"
+    _ -> error "Unknown permission error"
 
 -- isReadable :: FilePath -> IO (PermResult Bool)
 -- isReadable = fmap (fmap readable) . getPermissionsSafe
 
 -- 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,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | 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
@@ -7,54 +7,58 @@
 -- decide to switch to using the DBus it will be easy.
 
 module XMonad.Internal.Notify
-  ( Note(..)
-  , Body(..)
+  ( Note (..)
+  , Body (..)
   , defNote
   , defNoteInfo
   , defNoteError
   , fmtNotifyCmd
   , spawnNotify
-  ) where
+  )
+where
 
-import           Control.Monad.IO.Class
-import           Data.Maybe
-
-import           DBus.Notify
-
-import           XMonad.Internal.Shell
+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\"" }
+defNote = blankNote {summary = "\"xmonad\""}
 
 defNoteInfo :: Note
-defNoteInfo = defNote
-  { appImage = Just $ Icon "dialog-information-symbolic" }
+defNoteInfo =
+  defNote
+    { appImage = Just $ Icon "dialog-information-symbolic"
+    }
 
 defNoteError :: Note
-defNoteError = defNote
-  { appImage = Just $ Icon "dialog-error-symbolic" }
+defNoteError =
+  defNote
+    { appImage = Just $ Icon "dialog-error-symbolic"
+    }
 
 --------------------------------------------------------------------------------
--- | Format a 'notify-send' command to be send to the shell
+-- Format a 'notify-send' command to be send to the shell
 
-parseBody :: Body -> Maybe String
-parseBody (Text s) = Just s
-parseBody _        = Nothing
+parseBody :: Body -> Maybe T.Text
+parseBody (Text s) = Just $ T.pack s
+parseBody _ = Nothing
 
-fmtNotifyCmd :: Note -> String
+fmtNotifyCmd :: Note -> T.Text
 fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
 
 spawnNotify :: MonadIO m => Note -> m ()
 spawnNotify = spawnCmd "notify-send" . fmtNotifyArgs
 
-fmtNotifyArgs :: Note -> [String]
+fmtNotifyArgs :: Note -> [T.Text]
 fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
   where
     -- TODO add the rest of the options as needed
-    getSummary = (:[]) . doubleQuote . summary
-    getIcon n' = maybe [] (\i -> ["-i", case i of { Icon s -> s; File s -> s }])
-      $ appImage n'
+    getSummary = (: []) . doubleQuote . T.pack . summary
+    getIcon n' =
+      maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
+        appImage n'
     getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'

lib/XMonad/Internal/Process.hs

@@ -1,92 +0,0 @@
---------------------------------------------------------------------------------
--- | Functions for managing processes
-
-module XMonad.Internal.Process
-  ( waitUntilExit
-  , killHandle
-  , spawnPipe'
-  , spawnPipe
-  , spawnPipeArgs
-  , createProcess'
-  , readCreateProcessWithExitCode'
-  , proc'
-  , shell'
-  , spawn
-  , spawnAt
-  , module System.Process
-  ) where
-
-import           Control.Concurrent
-import           Control.Exception
-import           Control.Monad
-import           Control.Monad.IO.Class
-
-import           Data.Maybe
-
-import           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, String, String)
-readCreateProcessWithExitCode' c i = withDefaultSignalHandlers
-  $ readCreateProcessWithExitCode c i
-
-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,59 +1,156 @@
---------------------------------------------------------------------------------
--- | Functions for formatting and spawning shell commands
+-- Functions for formatting and spawning shell commands
 
 module XMonad.Internal.Shell
   ( fmtCmd
   , spawnCmd
+  , spawn
+  , spawnPipe
   , doubleQuote
   , singleQuote
   , skip
+  , runProcess
+  , proc
+  , shell
   , (#!&&)
   , (#!||)
   , (#!|)
   , (#!>>)
-  ) where
+  )
+where
 
-import           Control.Monad.IO.Class
+import RIO
+import qualified RIO.Text as T
+import qualified System.Process.Typed as P
+import qualified XMonad.Core as X
+import qualified XMonad.Util.Run as XR
 
-import           XMonad.Internal.Process
+-- | Fork a new process and wait for its exit code.
+--
+-- This function will work despite xmonad ignoring SIGCHLD.
+--
+-- A few facts about xmonad (and window managers in general):
+-- 1) It is single-threaded (since X is single threaded)
+-- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
+--    by xmonad will instantly be reaped after spawning. This guarantees the
+--    main thread running the WM will never be blocked.
+--
+-- In general, this means I can't wait for exit codes (since wait() doesn't
+-- work) See https://github.com/xmonad/xmonad/issues/113.
+--
+-- If I want an exit code, The best solution (I can come up with), is to use
+-- bracket to uninstall handlers, run process (with wait), and then reinstall
+-- handlers. I can use this with a much higher-level interface which will make
+-- things easier. This obviously means that if the process is running in the
+-- main thread, it needs to be almost instantaneous. Note if using a high-level
+-- API for this, the process needs to spawn, finish, and be reaped by the
+-- xmonad process all while the signal handlers are 'disabled' (which limits
+-- the functions I can use to those that call waitForProcess).
+--
+-- XMonad and contrib use their own method of spawning subprocesses using the
+-- extremely low-level 'System.Process.Posix' API. See the code for
+-- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
+-- sequence is (in terms of the low level Linux API):
+-- 1) call fork()
+-- 2) uninstall signal handlers (to allow wait() to work in subprocesses)
+-- 3) call setsid() (so killing the child will kill its children, if any)
+-- 4) start new thing with exec()
+--
+-- In contrast with high-level APIs like 'System.Process', this will leave no
+-- trailing data structures to clean up, at the cost of being gross to look at
+-- and possibly more error-prone.
+runProcess :: MonadUnliftIO m => P.ProcessConfig a b c -> m ExitCode
+runProcess = withDefaultSignalHandlers . P.runProcess
 
---------------------------------------------------------------------------------
--- | Opening subshell
+-- | Run an action without xmonad's signal handlers.
+withDefaultSignalHandlers :: MonadUnliftIO m => m a -> m a
+withDefaultSignalHandlers =
+  bracket_ X.uninstallSignalHandlers X.installSignalHandlers
 
-spawnCmd :: MonadIO m => String -> [String] -> m ()
-spawnCmd cmd args = spawn $ fmtCmd cmd args
+-- | 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
 
---------------------------------------------------------------------------------
--- | Formatting commands
+-- | Create a 'ProcessConfig' for a shell command
+shell :: T.Text -> P.ProcessConfig () () ()
+shell = addGroupSession . P.shell . T.unpack
 
-fmtCmd :: String -> [String] -> String
-fmtCmd cmd args = unwords $ cmd : args
+-- | Create a 'ProcessConfig' for a command with arguments
+proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
+proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
 
-(#!&&) :: String -> String -> String
-cmdA #!&& cmdB = cmdA ++ " && " ++ cmdB
+-- | 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 :: 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
+
+-- | 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 #!&&
 
-(#!|) :: String -> String -> String
-cmdA #!| cmdB = cmdA ++ " | " ++ cmdB
+-- | Format two shell expressions separated by "|"
+(#!|) :: T.Text -> T.Text -> T.Text
+cmdA #!| cmdB = op cmdA "|" cmdB
 
 infixr 0 #!|
 
-(#!||) :: String -> String -> String
-cmdA #!|| cmdB = cmdA ++ " || " ++ cmdB
+-- | Format two shell expressions separated by "||"
+(#!||) :: T.Text -> T.Text -> T.Text
+cmdA #!|| cmdB = op cmdA "||" cmdB
 
 infixr 0 #!||
 
-(#!>>) :: String -> String -> String
-cmdA #!>> cmdB = cmdA ++ "; " ++ cmdB
+-- | Format two shell expressions separated by ";"
+(#!>>) :: T.Text -> T.Text -> T.Text
+cmdA #!>> cmdB = op cmdA ";" cmdB
 
 infixr 0 #!>>
 
-doubleQuote :: String -> String
-doubleQuote s = "\"" ++ s ++ "\""
+-- | Wrap input in double quotes
+doubleQuote :: T.Text -> T.Text
+doubleQuote s = T.concat ["\"", s, "\""]
 
-singleQuote :: String -> String
-singleQuote s = "'" ++ s ++ "'"
+-- | Wrap input in single quotes
+singleQuote :: T.Text -> T.Text
+singleQuote s = T.concat ["'", s, "'"]
 
 skip :: Monad m => m ()
 skip = return ()

lib/XMonad/Internal/Theme.hs

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | Theme for XMonad and Xmobar
+-- Theme for XMonad and Xmobar
 
 module XMonad.Internal.Theme
   ( baseColor
@@ -16,9 +16,9 @@ module XMonad.Internal.Theme
   , backdropTextColor
   , blend'
   , darken'
-  , Slant(..)
-  , Weight(..)
-  , FontData(..)
+  , Slant (..)
+  , Weight (..)
+  , FontData (..)
   , FontBuilder
   , buildFont
   , fallbackFont
@@ -26,125 +26,140 @@ module XMonad.Internal.Theme
   , defFontData
   , tabbedTheme
   , promptTheme
-  ) where
-
-import           Data.Char
-import           Data.Colour
-import           Data.Colour.SRGB
-import           Data.List
+  )
+where
 
+import Data.Colour
+import Data.Colour.SRGB
+import RIO
+import qualified RIO.Text as T
 import qualified XMonad.Layout.Decoration as D
-import qualified XMonad.Prompt            as P
+import qualified XMonad.Prompt as P
 
 --------------------------------------------------------------------------------
--- | Colors - vocabulary roughly based on GTK themes
+-- Colors - vocabulary roughly based on GTK themes
 
-baseColor :: String
+baseColor :: T.Text
 baseColor = "#f7f7f7"
 
-bgColor :: String
+bgColor :: T.Text
 bgColor = "#d6d6d6"
 
-fgColor :: String
+fgColor :: T.Text
 fgColor = "#2c2c2c"
 
-bordersColor :: String
+bordersColor :: T.Text
 bordersColor = darken' 0.3 bgColor
 
-warningColor :: String
+warningColor :: T.Text
 warningColor = "#ffca28"
 
-errorColor :: String
+errorColor :: T.Text
 errorColor = "#e53935"
 
-selectedFgColor :: String
+selectedFgColor :: T.Text
 selectedFgColor = "#ffffff"
 
-selectedBgColor :: String
+selectedBgColor :: T.Text
 selectedBgColor = "#4a79c7"
 
-selectedBordersColor :: String
+selectedBordersColor :: T.Text
 selectedBordersColor = "#4a79c7"
 
-backdropBaseColor :: String
+backdropBaseColor :: T.Text
 backdropBaseColor = baseColor
 
-backdropTextColor :: String
+backdropTextColor :: T.Text
 backdropTextColor = blend' 0.95 fgColor backdropBaseColor
 
-backdropFgColor :: String
+backdropFgColor :: T.Text
 backdropFgColor = blend' 0.75 fgColor bgColor
 
 --------------------------------------------------------------------------------
--- | Color functions
+-- Color functions
 
-blend' :: Float -> String -> String -> String
-blend' wt c0 c1 = sRGB24show $ blend wt (sRGB24read c0) (sRGB24read c1)
+blend' :: Float -> T.Text -> T.Text -> T.Text
+blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
 
-darken' :: Float -> String -> String
-darken' wt = sRGB24show . darken wt . sRGB24read
+darken' :: Float -> T.Text -> T.Text
+darken' wt = sRGB24showT . darken wt . sRGB24readT
+
+sRGB24readT :: (RealFrac a, Floating a) => T.Text -> Colour a
+sRGB24readT = sRGB24read . T.unpack
+
+sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
+sRGB24showT = T.pack . sRGB24show
 
 --------------------------------------------------------------------------------
--- | Fonts
+-- Fonts
 
-data Slant = Roman
-    | Italic
-    | Oblique
-    deriving (Eq, Show)
+data Slant
+  = Roman
+  | Italic
+  | Oblique
+  deriving (Eq, Show)
 
-data Weight = Light
-    | Medium
-    | Demibold
-    | Bold
-    | Black
-    deriving (Eq, Show)
+data Weight
+  = Light
+  | Medium
+  | Demibold
+  | Bold
+  | Black
+  deriving (Eq, Show)
 
 data FontData = FontData
-    { weight    :: Maybe Weight
-    , slant     :: Maybe Slant
-    , size      :: Maybe Int
-    , pixelsize :: Maybe Int
-    , antialias :: Maybe Bool
-    }
+  { weight :: Maybe Weight
+  , slant :: Maybe Slant
+  , size :: Maybe Int
+  , pixelsize :: Maybe Int
+  , antialias :: Maybe Bool
+  }
 
-type FontBuilder = FontData -> String
+type FontBuilder = FontData -> T.Text
 
-buildFont :: Maybe String -> FontData -> String
+buildFont :: Maybe T.Text -> FontData -> T.Text
 buildFont Nothing _ = "fixed"
-buildFont (Just fam) FontData { weight = w
-                            , slant = l
-                            , size = s
-                            , pixelsize = p
-                            , antialias = a
-                            }
-  = intercalate ":" $ ["xft", fam] ++ elems
-  where
-    elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w)
-                                             , ("slant", showLower l)
-                                             , ("size", showLower s)
-                                             , ("pixelsize", showLower p)
-                                             , ("antialias", showLower a)
-                                             ]
-                            ]
-    showLower :: Show a => Maybe a -> Maybe String
-    showLower = fmap (fmap toLower . show)
+buildFont
+  (Just fam)
+  FontData
+    { weight = w
+    , slant = l
+    , size = s
+    , pixelsize = p
+    , antialias = a
+    } =
+    T.intercalate ":" $ ["xft", fam] ++ elems
+    where
+      elems =
+        [ T.concat [k, "=", v]
+        | (k, Just v) <-
+            [ ("weight", showLower w)
+            , ("slant", showLower l)
+            , ("size", showLower s)
+            , ("pixelsize", showLower p)
+            , ("antialias", showLower a)
+            ]
+        ]
+      showLower :: Show a => Maybe a -> Maybe T.Text
+      showLower = fmap (T.toLower . T.pack . show)
 
 fallbackFont :: FontBuilder
 fallbackFont = buildFont Nothing
 
 --------------------------------------------------------------------------------
--- | Default font and data
+-- Default font and data
 
 defFontData :: FontData
-defFontData = FontData
-  { size = Just 10
-  , antialias = Just True
-  , weight = Nothing
-  , slant = Nothing
-  , pixelsize = Nothing
-  }
+defFontData =
+  FontData
+    { size = Just 10
+    , antialias = Just True
+    , weight = Nothing
+    , slant = Nothing
+    , pixelsize = Nothing
+    }
 
-defFontFamily :: String
+defFontFamily :: T.Text
 defFontFamily = "DejaVu Sans"
 
 -- defFontDep :: IODependency FontBuilder
@@ -154,44 +169,42 @@ defFontFamily = "DejaVu Sans"
 -- defFontTree = fontTree "DejaVu Sans"
 
 --------------------------------------------------------------------------------
--- | Complete themes
+-- Complete themes
 
 tabbedTheme :: FontBuilder -> D.Theme
-tabbedTheme fb = D.def
-  { D.fontName              = fb $ defFontData { weight = Just Bold }
+tabbedTheme fb =
+  D.def
+    { D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
+    , D.activeTextColor = T.unpack fgColor
+    , D.activeColor = T.unpack bgColor
+    , D.activeBorderColor = T.unpack bgColor
+    , D.inactiveTextColor = T.unpack backdropTextColor
+    , D.inactiveColor = T.unpack backdropFgColor
+    , D.inactiveBorderColor = T.unpack backdropFgColor
+    , D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
+    , D.urgentColor = T.unpack errorColor
+    , D.urgentBorderColor = T.unpack errorColor
+    , -- this is in a newer version
+      -- , D.activeBorderWidth     = 0
+      -- , D.inactiveBorderWidth   = 0
+      -- , D.urgentBorderWidth     = 0
 
-  , D.activeTextColor       = fgColor
-  , D.activeColor           = bgColor
-  , D.activeBorderColor     = bgColor
-
-  , D.inactiveTextColor     = backdropTextColor
-  , D.inactiveColor         = backdropFgColor
-  , D.inactiveBorderColor   = backdropFgColor
-
-  , D.urgentTextColor       = darken' 0.5 errorColor
-  , D.urgentColor           = errorColor
-  , D.urgentBorderColor     = errorColor
-
-  -- this is in a newer version
-  -- , D.activeBorderWidth     = 0
-  -- , D.inactiveBorderWidth   = 0
-  -- , D.urgentBorderWidth     = 0
-
-  , D.decoHeight            = 20
-  , D.windowTitleAddons     = []
-  , D.windowTitleIcons      = []
-  }
+      D.decoHeight = 20
+    , D.windowTitleAddons = []
+    , D.windowTitleIcons = []
+    }
 
 promptTheme :: FontBuilder -> P.XPConfig
-promptTheme fb = P.def
-  { P.font              = fb $ defFontData { size = Just 12 }
-  , P.bgColor           = bgColor
-  , P.fgColor           = fgColor
-  , P.fgHLight          = selectedFgColor
-  , P.bgHLight          = selectedBgColor
-  , P.borderColor       = bordersColor
-  , P.promptBorderWidth = 1
-  , P.height            = 35
-  , P.position          = P.CenteredAt 0.5 0.5
-  , P.historySize       = 0
-  }
+promptTheme fb =
+  P.def
+    { P.font = T.unpack $ fb $ defFontData {size = Just 12}
+    , P.bgColor = T.unpack bgColor
+    , P.fgColor = T.unpack fgColor
+    , P.fgHLight = T.unpack selectedFgColor
+    , P.bgHLight = T.unpack selectedBgColor
+    , P.borderColor = T.unpack bordersColor
+    , P.promptBorderWidth = 1
+    , P.height = 35
+    , P.position = P.CenteredAt 0.5 0.5
+    , P.historySize = 0
+    }

lib/Xmobar/Plugins/ActiveConnection.hs

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

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -1,21 +1,28 @@
---------------------------------------------------------------------------------
--- | 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 DBus
+import Data.Internal.DBus
+import RIO
+import qualified RIO.Text as T
+import Xmobar.Plugins.Common
 
-import           Xmobar.Plugins.Common
-
-startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-  -> (SesClient -> IO (Maybe a)) -> String -> Callback -> IO ()
-startBacklight matchSignal callGetBrightness icon cb = do
-    withDBusClientConnection cb $ \c -> do
-      matchSignal display c
-      display =<< callGetBrightness c
-    where
-      formatBrightness b = return $ icon ++ show (round b :: Integer) ++ "%"
-      display = displayMaybe cb formatBrightness
+startBacklight
+  :: (MonadUnliftIO m, RealFrac a)
+  => Maybe BusName
+  -> Maybe FilePath
+  -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
+  -> DIO SimpleApp SesClient (Maybe a)
+  -> T.Text
+  -> Callback
+  -> m ()
+startBacklight n name matchSignal callGetBrightness icon cb = do
+  withDBusClientConnection cb n name $ \c -> withDIO c $ do
+    matchSignal dpy
+    dpy =<< callGetBrightness
+  where
+    formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
+    dpy = displayMaybe cb formatBrightness

lib/Xmobar/Plugins/Bluetooth.hs

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
--- | Bluetooth plugin
+-- Bluetooth plugin
 --
 -- Use the bluez interface on DBus to check status
 --
@@ -7,97 +7,89 @@
 -- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
 -- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
 --
--- This plugin will reflect if the adapter is powered and if any device is
--- connected to it. The rough outline for this procedure:
--- 1) get the adapter from the object manager
--- 2) get all devices associated with the adapter using the object interface
--- 3) determine if the adapter is powered
--- 4) determine if any devices are connected
--- 5) format the icon; powered vs not powered controls the color and connected
---    vs not connected controls the icon (connected bluetooth symbol has two
---    dots flanking it)
---
--- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
--- querying the "Powered" property. Step 4 can be done using the
--- "org.bluez.Device1" interface and the "Connected" property for each device
--- path. Since these are properties, we can asynchronously read changes to them
--- via the "PropertiesChanged" signal.
---
--- If any devices are added/removed, steps 2-4 will need to be redone and any
--- listeners will need to be updated. (TODO not sure which signals to use in
--- determining if a device is added)
+-- Simple and somewhat crude way to do this is to have two monitors, one
+-- watching the powered state of the adaptor and one listening for connection
+-- changes. The former is easy since this is just one /org/bluez/hciX. For the
+-- latter, each 'Connected' property is embedded in each individual device path
+-- on `org.bluez.Device1', so just watch the entire bluez bus for property
+-- changes and filter those that correspond to the aforementioned
+-- interface/property. Track all this in a state which keeps the powered
+-- property and a running list of connected devices.
 --
 -- TODO also not sure if I need to care about multiple adapters and/or the
--- adapter changing.
+-- adapter changing. For now it should just get the first adaptor and only pay
+-- attention to devices associated with it.
 
 module Xmobar.Plugins.Bluetooth
-  ( Bluetooth(..)
+  ( Bluetooth (..)
   , btAlias
   , btDep
-  ) where
+  )
+where
 
-import           Control.Concurrent.MVar
-import           Control.Monad
+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.Set as S
+import qualified RIO.Text as T
+import XMonad.Internal.DBus.Common
+import Xmobar
+import Xmobar.Plugins.Common
 
-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           XMonad.Internal.DBus.Common
-import           Xmobar
-import           Xmobar.Plugins.Common
-
-btAlias :: String
+btAlias :: T.Text
 btAlias = "bluetooth"
 
 btDep :: DBusDependency_ SysClient
-btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
-  $ Method_ getManagedObjects
+btDep =
+  Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
+    Method_ getManagedObjects
 
 data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 
 instance Exec Bluetooth where
-  alias (Bluetooth _ _) = btAlias
+  alias (Bluetooth _ _) = T.unpack btAlias
   start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb $ startAdapter icons colors cb
+    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
+      startAdapter icons colors cb
 
-startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
+startAdapter
+  :: Icons
+  -> Colors
+  -> Callback
+  -> NamedSysConnection
+  -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
-  ot <- getBtObjectTree cl
   state <- newMVar emptyState
-  let display = displayIcon cb (iconFormatter is cs) state
-  forM_ (findAdapter ot) $ \adapter -> do
-    -- set up adapter
-    initAdapter state adapter cl
-    -- TODO this step could fail; at least warn the user...
-    void $ addAdaptorListener state display adapter cl
-    -- set up devices on the adapter (and listeners for adding/removing devices)
-    let devices = findDevices adapter ot
-    addDeviceAddedListener state display adapter cl
-    addDeviceRemovedListener state display adapter cl
-    forM_ devices $ \d -> addAndInitDevice state display d cl
-    -- after setting things up, show the icon based on the initialized state
-    display
+  let dpy cb' = displayIcon cb' (iconFormatter is cs)
+  mapRIO (PluginEnv cl state dpy cb) $ do
+    ot <- getBtObjectTree
+    case findAdaptor ot of
+      Nothing -> logError "could not find bluetooth adapter"
+      Just adaptor -> do
+        initAdapterState adaptor
+        initDevicesState adaptor ot
+        startAdaptorListener adaptor
+        startConnectedListener adaptor
+        pluginDisplay
 
 --------------------------------------------------------------------------------
--- | 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"
 
-type IconFormatter = (Maybe Bool -> Bool -> String)
+type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
-type Icons = (String, String)
+type Icons = (T.Text, T.Text)
 
-displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon :: Callback -> IconFormatter -> BTIO ()
 displayIcon callback formatter =
-  callback . uncurry formatter <=< readState
+  liftIO . callback . T.unpack . uncurry formatter =<< readState
 
 -- TODO maybe I want this to fail when any of the device statuses are Nothing
 iconFormatter :: Icons -> Colors -> IconFormatter
@@ -107,177 +99,176 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
     icon = if connected then iconConn else iconDisc
 
 --------------------------------------------------------------------------------
--- | 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.
+-- Connection State
 
-data BTDevice = BTDevice
-  { btDevConnected  :: Maybe Bool
-  , btDevSigHandler :: SignalHandler
-  }
-
-type ConnectedDevices = M.Map ObjectPath BTDevice
+type BTIO = PluginIO BtState SysClient
 
 data BtState = BtState
-  { btDevices :: ConnectedDevices
+  { btDevices :: S.Set ObjectPath
   , btPowered :: Maybe Bool
   }
 
-type MutableBtState = MVar BtState
-
 emptyState :: BtState
-emptyState = BtState
-  { btDevices = M.empty
-  , btPowered = Nothing
-  }
+emptyState =
+  BtState
+    { btDevices = S.empty
+    , btPowered = Nothing
+    }
 
-readState :: MutableBtState -> IO (Maybe Bool, Bool)
-readState state = do
-  p <- readPowered state
-  c <- readDevices state
-  return (p, anyDevicesConnected c)
+readState :: BTIO (Maybe Bool, Bool)
+readState = do
+  p <- readPowered
+  c <- readDevices
+  return (p, not $ null c)
+
+modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
+modifyState f = do
+  m <- asks plugState
+  modifyMVar m f
+
+beforeDisplay :: BTIO () -> BTIO ()
+beforeDisplay f = f >> pluginDisplay
 
 --------------------------------------------------------------------------------
--- | Object manager
+-- Object manager
 
-findAdapter :: ObjectTree -> Maybe ObjectPath
-findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+findAdaptor :: ObjectTree -> Maybe ObjectPath
+findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
 
-findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
-findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
+-- | Search the object tree for devices which are in a connected state.
+-- Return the object path for said devices.
+findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
+findConnectedDevices adaptor =
+  filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
+  where
+    isConnectedDev m = Just True == lookupState m
+    lookupState =
+      fromVariant
+        <=< M.lookup (memberNameT devConnected)
+        <=< M.lookup devInterface
 
 adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
-adaptorHasDevice adaptor device = case splitPath device of
-  [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
-  _                     -> False
+adaptorHasDevice adaptor device = case splitPathNoRoot device of
+  [org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
+  _ -> False
 
-splitPath :: ObjectPath -> [String]
-splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
+splitPathNoRoot :: ObjectPath -> [FilePath]
+splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
 
-getBtObjectTree :: SysClient -> IO ObjectTree
-getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
+getBtObjectTree
+  :: ( HasClient env
+     , SafeClient c
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     )
+  => m ObjectTree
+getBtObjectTree = callGetManagedObjects btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener :: SignalCallback -> SysClient -> IO ()
-addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
-
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceAddedListener state display adapter client =
-  addBtOMListener addDevice client
-  where
-    addDevice = pathCallback adapter display $ \d ->
-      addAndInitDevice state display d client
-
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceRemovedListener state display adapter sys =
-  addBtOMListener remDevice sys
-  where
-    remDevice = pathCallback adapter display $ \d -> do
-      old <- removeDevice state d
-      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
-
-pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
-pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
-  when (adaptorHasDevice adapter d) $ f d >> display
-pathCallback _ _ _ _ = return ()
-
 --------------------------------------------------------------------------------
--- | Adapter
+-- Adapter
 
-initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
-initAdapter state adapter client = do
-  reply <- callGetPowered adapter client
-  putPowered state $ fromSingletonVariant reply
+-- | Get powered state of adaptor and log the result
+initAdapterState :: ObjectPath -> BTIO ()
+initAdapterState adapter = do
+  reply <- callGetPowered adapter
+  putPowered $ fromSingletonVariant reply
 
-matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
-matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
+matchBTProperty
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     )
+  => ObjectPath
+  -> m (Maybe MatchRule)
+matchBTProperty p = matchPropertyFull 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
+-- | Start a listener that monitors changes to the powered state of an adaptor
+startAdaptorListener :: ObjectPath -> BTIO ()
+startAdaptorListener adaptor = do
+  res <- matchBTProperty adaptor
+  case res of
+    Just rule -> void $ addMatchCallback rule callback
+    Nothing -> do
+      logError $
+        "could not add listener for prop "
+          <> displayMemberName adaptorPowered
+          <> " on path "
+          <> displayObjectPath adaptor
   where
-    procMatch = withSignalMatch $ \b -> putPowered state b >> display
+    callback sig =
+      withNestedDBusClientConnection Nothing Nothing $
+        withSignalMatch procMatch $
+          matchPropertyChanged adaptorInterface adaptorPowered sig
+    procMatch = beforeDisplay . putPowered
 
-callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
-callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
-  $ memberName_ adaptorPowered
+callGetPowered
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , SafeClient c
+     , MonadUnliftIO m
+     )
+  => ObjectPath
+  -> m [Variant]
+callGetPowered adapter =
+  callPropertyGet btBus adapter adaptorInterface adaptorPowered
 
-matchPowered :: [Variant] -> SignalMatch Bool
-matchPowered = matchPropertyChanged adapterInterface adaptorPowered
+putPowered :: Maybe Bool -> BTIO ()
+putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
 
-putPowered :: MutableBtState -> Maybe Bool -> IO ()
-putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
+readPowered :: BTIO (Maybe Bool)
+readPowered = fmap btPowered $ readMVar =<< asks plugState
 
-readPowered :: MutableBtState -> IO (Maybe Bool)
-readPowered = fmap btPowered . readMVar
+adaptorInterface :: InterfaceName
+adaptorInterface = interfaceName_ "org.bluez.Adapter1"
 
-adapterInterface :: InterfaceName
-adapterInterface = interfaceName_ "org.bluez.Adapter1"
-
-adaptorPowered :: String
+adaptorPowered :: MemberName
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
--- | Devices
+-- Devices
 
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addAndInitDevice state display device client = do
-  sh <- addDeviceListener state display device client
-  -- TODO add some intelligent error messages here
-  forM_ sh $ \s -> initDevice state s device client
+initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
+initDevicesState adaptor ot = do
+  let devices = findConnectedDevices adaptor ot
+  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
 
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
-initDevice state sh device sys = do
-  reply <- callGetConnected device sys
-  void $ insertDevice state device $
-    BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
-             , btDevSigHandler = sh
-             }
-
-addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-  -> IO (Maybe SignalHandler)
-addDeviceListener state display device sys = do
-  rule <- matchBTProperty sys device
-  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
+startConnectedListener :: ObjectPath -> BTIO ()
+startConnectedListener adaptor = do
+  reply <- matchPropertyFull btBus Nothing
+  case reply of
+    Just rule -> do
+      void $ addMatchCallbackSignal rule callback
+      logInfo $ "Started listening for device connections on " <> adaptor_
+    Nothing -> logError "Could not listen for connection changes"
   where
-    procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
+    adaptor_ = displayWrapQuote $ displayObjectPath adaptor
+    callback sig =
+      withNestedDBusClientConnection Nothing Nothing $ do
+        let devpath = signalPath sig
+        when (adaptorHasDevice adaptor devpath) $
+          withSignalMatch (update devpath) $
+            matchConnected $
+              signalBody sig
+    matchConnected = matchPropertyChanged devInterface devConnected
+    update _ Nothing = return ()
+    update devpath (Just x) = do
+      let f = if x then S.insert else S.delete
+      beforeDisplay $
+        modifyState $
+          \s -> return (s {btDevices = f devpath $ btDevices s}, ())
 
-matchConnected :: [Variant] -> SignalMatch Bool
-matchConnected = matchPropertyChanged devInterface devConnected
-
-callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
-callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ devConnected
-
-insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
-insertDevice m device dev = modifyMVar m $ \s -> do
-  let new = M.insert device dev $ btDevices s
-  return (s { btDevices = new }, anyDevicesConnected new)
-
-updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
-updateDevice 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 :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
-removeDevice m device = modifyMVar m $ \s -> do
-  let devs = btDevices s
-  return (s { btDevices = M.delete device devs }, M.lookup device devs)
-
-readDevices :: MutableBtState -> IO ConnectedDevices
-readDevices = fmap btDevices . readMVar
+readDevices :: BTIO (S.Set ObjectPath)
+readDevices = fmap btDevices $ readMVar =<< asks plugState
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"
 
-devConnected :: String
+devConnected :: MemberName
 devConnected = "Connected"

lib/Xmobar/Plugins/ClevoKeyboard.hs

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

lib/Xmobar/Plugins/Common.hs

@@ -4,60 +4,137 @@ module Xmobar.Plugins.Common
   , procSignalMatch
   , na
   , fromSingletonVariant
+  , withNestedDBusClientConnection
   , withDBusClientConnection
   , Callback
-  , Colors(..)
+  , Colors (..)
   , displayMaybe
   , displayMaybe'
   , xmobarFGColor
+  , PluginEnv (..)
+  , PluginIO
+  , pluginDisplay
   )
-  where
+where
 
-import           Control.Monad
+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)
 
-import           Data.Internal.DBus
+data PluginEnv s c = PluginEnv
+  { plugClient :: !(NamedConnection c)
+  , plugState :: !(MVar s)
+  , plugDisplay :: !(Callback -> PluginIO s c ())
+  , plugCallback :: !Callback
+  , plugEnv :: !SimpleApp
+  }
 
-import           DBus
-import           DBus.Client
+pluginDisplay :: PluginIO s c ()
+pluginDisplay = do
+  cb <- asks plugCallback
+  dpy <- asks plugDisplay
+  dpy cb
 
-import           XMonad.Hooks.DynamicLog (xmobarColor)
+type PluginIO s c = RIO (PluginEnv s c)
 
+instance HasClient (PluginEnv s) where
+  clientL = lens plugClient (\x y -> x {plugClient = y})
+
+instance HasLogFunc (PluginEnv s c) where
+  logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL
+
+-- use string here since all the callbacks in xmobar use strings :(
 type Callback = String -> IO ()
 
 data Colors = Colors
-  { colorsOn  :: String
-  , colorsOff :: String
+  { colorsOn :: T.Text
+  , colorsOff :: T.Text
   }
   deriving (Eq, Show, Read)
 
-startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
-  -> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback
-  -> c -> IO ()
-startListener rule getProp fromSignal toColor cb client = do
-  reply <- getProp client
+startListener
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , IsVariant a
+     )
+  => MatchRule
+  -> m [Variant]
+  -> ([Variant] -> SignalMatch a)
+  -> (a -> m T.Text)
+  -> Callback
+  -> m ()
+startListener rule getProp fromSignal toColor cb = do
+  reply <- getProp
   displayMaybe cb toColor $ fromSingletonVariant reply
-  void $ addMatchCallback rule (procMatch . fromSignal) client
+  void $ addMatchCallback rule (procMatch . fromSignal)
   where
     procMatch = procSignalMatch cb toColor
 
-procSignalMatch :: Callback -> (a -> IO String) -> SignalMatch a -> IO ()
+procSignalMatch
+  :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
 procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
 
-colorText :: Colors -> Bool -> String -> String
-colorText Colors { colorsOn = c } True   = xmobarFGColor c
-colorText Colors { colorsOff = c } False = xmobarFGColor c
+colorText :: Colors -> Bool -> T.Text -> T.Text
+colorText Colors {colorsOn = c} True = xmobarFGColor c
+colorText Colors {colorsOff = c} False = xmobarFGColor c
 
-xmobarFGColor :: String -> String -> String
-xmobarFGColor c = xmobarColor c ""
+xmobarFGColor :: T.Text -> T.Text -> T.Text
+xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
 
-na :: String
+na :: T.Text
 na = "N/A"
 
-displayMaybe :: Callback -> (a -> IO String) -> Maybe a -> IO ()
-displayMaybe cb f = cb <=< maybe (return na) f
+displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
+displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
 
-displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
-displayMaybe' cb = maybe (cb na)
+displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
+displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 
-withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
-withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
+withDBusClientConnection
+  :: (MonadUnliftIO m, SafeClient c)
+  => Callback
+  -> Maybe BusName
+  -> Maybe FilePath
+  -> (NamedConnection c -> RIO SimpleApp ())
+  -> m ()
+withDBusClientConnection cb n logfile f =
+  maybe (run stderr) (`withLogFile` run) logfile
+  where
+    run h = do
+      logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
+      withLogFunc logOpts $ \lf -> do
+        env <- mkSimpleApp lf Nothing
+        runRIO env $ displayMaybe' cb f =<< getDBusClient n
+
+-- | Run a plugin action with a new DBus client and logfile path. This is
+-- necessary for DBus callbacks which run in separate threads, which will
+-- usually fire when the parent thread already exited and killed off its DBus
+-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
+-- this function will open and new logfile and client connection and close both
+-- on completion. 'withDBusClientConnection' will only close the log file but
+-- keep the client connection active upon termination; this client will only be
+-- killed when the entire process is killed. This distinction is important
+-- because callbacks only need ephemeral connections, while listeners (started
+-- with 'withDBusClientConnection') need long-lasting connections.
+withNestedDBusClientConnection
+  :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
+  => Maybe BusName
+  -> Maybe FilePath
+  -> PluginIO s c ()
+  -> m ()
+withNestedDBusClientConnection n logfile f = do
+  dpy <- asks plugDisplay
+  s <- asks plugState
+  cb <- asks plugCallback
+  let run h = do
+        logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
+        withLogFunc logOpts $ \lf -> do
+          env <- mkSimpleApp lf Nothing
+          runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
+  maybe (run stderr) (`withLogFile` run) logfile

lib/Xmobar/Plugins/Device.hs

@@ -1,72 +0,0 @@
---------------------------------------------------------------------------------
--- | Device plugin
---
--- Display different text depending on whether or not the interface has
--- connectivity
-
-module Xmobar.Plugins.Device
-  ( Device(..)
-  , devDep
-  ) where
-
-import           Control.Monad
-
-import           Data.Internal.DBus
-import           Data.Internal.Dependency
-import           Data.Word
-
-import           DBus
-
-import           XMonad.Internal.Command.Desktop
-import           XMonad.Internal.DBus.Common
-import           Xmobar
-import           Xmobar.Plugins.Common
-
-newtype Device = Device (String, String, Colors) deriving (Read, Show)
-
-nmPath :: ObjectPath
-nmPath = objectPath_ "/org/freedesktop/NetworkManager"
-
-nmInterface :: InterfaceName
-nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
-
-nmDeviceInterface :: InterfaceName
-nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
-
-getByIP :: MemberName
-getByIP = memberName_ "GetDeviceByIpIface"
-
-devSignal :: String
-devSignal = "Ip4Connectivity"
-
-devDep :: DBusDependency_ SysClient
-devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
-  $ Method_ getByIP
-
-getDevice :: SysClient -> String -> IO (Maybe ObjectPath)
-getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
-  where
-    mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
-      { methodCallBody = [toVariant iface]
-      }
-
-getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
-getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
-  $ memberName_ devSignal
-
-matchStatus :: [Variant] -> SignalMatch Word32
-matchStatus = matchPropertyChanged nmDeviceInterface devSignal
-
-instance Exec Device where
-  alias (Device (iface, _, _)) = iface
-  start (Device (iface, text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
-      path <- getDevice sys iface
-      displayMaybe' cb (listener sys) path
-    where
-      listener sys path = do
-        rule <- matchPropertyFull sys networkManagerBus (Just path)
-        -- TODO warn the user here rather than silently drop the listener
-        forM_ rule $ \r ->
-          startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
-      chooseColor' = return . (\s -> colorText colors s text) . (> 1)

lib/Xmobar/Plugins/IntelBacklight.hs

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

lib/Xmobar/Plugins/Screensaver.hs

@@ -1,30 +1,36 @@
 --------------------------------------------------------------------------------
--- | Screensaver plugin
+-- Screensaver plugin
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
 
 module Xmobar.Plugins.Screensaver
-  ( Screensaver(..)
+  ( Screensaver (..)
   , ssAlias
-  ) where
+  )
+where
 
-import           Xmobar
+import Data.Internal.DBus
+import RIO
+import qualified RIO.Text as T
+import XMonad.Internal.DBus.Screensaver
+import Xmobar
+import Xmobar.Plugins.Common
 
-import           XMonad.Internal.DBus.Screensaver
-import           Xmobar.Plugins.Common
+newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
 
-newtype Screensaver = Screensaver (String, Colors) deriving (Read, Show)
-
-ssAlias :: String
+ssAlias :: T.Text
 ssAlias = "screensaver"
 
 instance Exec Screensaver where
-  alias (Screensaver _) = ssAlias
-  start (Screensaver (text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
-      matchSignal display sys
-      display =<< callQuery sys
+  alias (Screensaver _) = T.unpack ssAlias
+  start (Screensaver (text, colors)) cb =
+    withDBusClientConnection
+      cb
+      (Just "org.xmobar.screensaver")
+      (Just "screensaver.log")
+      $ \cl -> withDIO cl $ do
+        matchSignal dpy
+        dpy =<< callQuery
     where
-      display = displayMaybe cb $ return . (\s -> colorText colors s text)
-
+      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

lib/Xmobar/Plugins/VPN.hs

@@ -1,124 +0,0 @@
---------------------------------------------------------------------------------
--- | VPN plugin
---
--- Use the networkmanager to detect when a VPN interface is added or removed.
--- Specifically, monitor the object tree to detect paths with the interface
--- "org.freedesktop.NetworkManager.Device.Tun".
-
-module Xmobar.Plugins.VPN
-  ( VPN(..)
-  , vpnAlias
-  , vpnDep
-  ) where
-
-import           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           XMonad.Internal.Command.Desktop
-import           XMonad.Internal.DBus.Common
-import           Xmobar
-import           Xmobar.Plugins.Common
-
-newtype VPN = VPN (String, Colors) deriving (Read, Show)
-
-instance Exec VPN where
-  alias (VPN _) = vpnAlias
-  start (VPN (text, colors)) cb =
-    withDBusClientConnection cb $ \c -> do
-    state <- initState c
-    let display = displayMaybe cb iconFormatter . Just =<< readState state
-    let signalCallback' f = f state display
-    vpnAddedListener (signalCallback' addedCallback) c
-    vpnRemovedListener (signalCallback' removedCallback) c
-    display
-    where
-      iconFormatter b = return $ colorText colors b text
-
---------------------------------------------------------------------------------
--- | VPN State
---
--- Maintain a set of paths which are the currently active VPNs. Most of the time
--- this will be a null or singleton set, but this setup could handle the edge
--- case of multiple VPNs being active at once without puking.
-
-type VPNState = S.Set ObjectPath
-
-type MutableVPNState = MVar VPNState
-
-initState :: SysClient -> IO MutableVPNState
-initState client = do
-  ot <- getVPNObjectTree client
-  newMVar $ findTunnels ot
-
-readState :: MutableVPNState -> IO Bool
-readState = fmap (not . null) . readMVar
-
-updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-  -> ObjectPath -> IO ()
-updateState f state op = modifyMVar_ state $ return . f op
-
---------------------------------------------------------------------------------
--- | Tunnel Device Detection
---
-
-getVPNObjectTree :: SysClient -> IO ObjectTree
-getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
-
-findTunnels :: ObjectTree -> VPNState
-findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
-
-vpnAddedListener :: SignalCallback -> SysClient -> IO ()
-vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
-
-vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
-vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
-
-addedCallback :: MutableVPNState -> IO () -> SignalCallback
-addedCallback state display [device, added] = update >> display
-  where
-    added' = fromVariant added :: Maybe (M.Map String (M.Map String Variant))
-    is = M.keys $ fromMaybe M.empty added'
-    update = updateDevice S.insert state device is
-addedCallback _ _ _                       = return ()
-
-removedCallback :: MutableVPNState -> IO () -> SignalCallback
-removedCallback state display [device, interfaces] = update >> display
-  where
-    is = fromMaybe [] $ fromVariant interfaces :: [String]
-    update = updateDevice S.delete state device is
-removedCallback _ _ _                       = return ()
-
-updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-  -> Variant -> [String] -> IO ()
-updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
-  forM_ d $ updateState f state
-  where
-    d = fromVariant device :: Maybe ObjectPath
-
---------------------------------------------------------------------------------
--- | DBus Interface
---
-
-vpnBus :: BusName
-vpnBus = busName_ "org.freedesktop.NetworkManager"
-
-vpnPath :: ObjectPath
-vpnPath = objectPath_ "/org/freedesktop"
-
-vpnDeviceTun :: String
-vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
-
-vpnAlias :: String
-vpnAlias = "vpn"
-
-vpnDep :: DBusDependency_ SysClient
-vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
-  $ Method_ getManagedObjects

make_pkgs

@@ -0,0 +1,8 @@
+libx11
+libxrandr
+libxinerama
+libxss
+alsa-lib
+wireless_tools
+libxft
+libxpm

my-xmonad.cabal

@@ -1,90 +0,0 @@
-name:                my-xmonad
-version:             0.1.0.0
-build-type:          Simple
-cabal-version:       >=1.10
-                  
-library
-    hs-source-dirs: lib
-    exposed-modules: XMonad.Internal.Concurrent.ClientMessage
-                   , XMonad.Internal.Concurrent.ACPIEvent
-                   , XMonad.Internal.Concurrent.DynamicWorkspaces
-                   , XMonad.Internal.Concurrent.VirtualBox
-                   , XMonad.Internal.Theme
-                   , XMonad.Internal.Notify
-                   , XMonad.Internal.Shell
-                   , XMonad.Internal.IO
-                   , XMonad.Internal.Command.Desktop
-                   , XMonad.Internal.Command.DMenu
-                   , XMonad.Internal.Command.Power
-                   , XMonad.Internal.DBus.Brightness.IntelBacklight
-                   , XMonad.Internal.DBus.Brightness.ClevoKeyboard
-                   , XMonad.Internal.DBus.Brightness.Common
-                   , XMonad.Internal.DBus.Control
-                   , XMonad.Internal.DBus.Common
-                   , XMonad.Internal.DBus.Screensaver
-                   , XMonad.Internal.DBus.Removable
-                   , XMonad.Internal.Process
-                   , Xmobar.Plugins.Common
-                   , Xmobar.Plugins.BacklightCommon
-                   , Xmobar.Plugins.Bluetooth
-                   , Xmobar.Plugins.ClevoKeyboard
-                   , Xmobar.Plugins.Device
-                   , Xmobar.Plugins.IntelBacklight
-                   , Xmobar.Plugins.Screensaver
-                   , Xmobar.Plugins.VPN
-                   , Data.Internal.Dependency
-                   , Data.Internal.DBus
-    build-depends: X11 >= 1.9.1
-                 , 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
-                 , filepath >= 1.4.2.1
-                 , 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
-    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures
-    default-language: Haskell2010
-
-executable xmonad
-    main-is: bin/xmonad.hs
-    build-depends: X11 >= 1.9.1
-                 , base
-                 , process >= 1.6.5.0
-                 , my-xmonad
-                 , xmonad >= 0.13
-                 , xmonad-contrib >= 0.13
-                 , lifted-base >= 0.2.3.12
-    default-language: Haskell2010
-    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded
-
-executable xmobar
-    main-is: bin/xmobar.hs
-    build-depends: base
-                 , dbus >= 1.2.7
-                 , my-xmonad
-                 , xmobar
-                 , xmonad >= 0.13
-                 , process >= 1.6.5.0
-                 , filepath >= 1.4.2.1
-                 , xmonad-contrib >= 0.13
-                 , directory >= 1.3.3.0
-                 , unix >= 2.7.2.2
-    default-language: Haskell2010
-    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded

package.yaml

@@ -0,0 +1,111 @@
+name:                xmonad-config
+version:             0.1.0.0
+license:             BSD3
+author:              "Nathan Dwarshuis"
+maintainer:          "ndwar@yavin4.ch"
+copyright:           "2022 Nathan Dwarshuis"
+
+extra-source-files:
+- README.md
+- fourmolu.yaml
+- make_pkgs
+- runtime_pkgs
+- assets/icons/*
+- assets/sound/*
+- scripts/*
+
+default-extensions:
+  - OverloadedStrings
+  - FlexibleContexts
+  - FlexibleInstances
+  - InstanceSigs
+  - MultiParamTypeClasses
+  - EmptyCase
+  - LambdaCase
+  - MultiWayIf
+  - NamedFieldPuns
+  - TupleSections
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveLift
+  - DeriveTraversable
+  - DerivingStrategies
+  - DeriveDataTypeable
+  - EmptyDataDecls
+  - PartialTypeSignatures
+  - GeneralizedNewtypeDeriving
+  - StandaloneDeriving
+  - BangPatterns
+  - TypeOperators
+  - ScopedTypeVariables
+  - TypeApplications
+  - ConstraintKinds
+  - RankNTypes
+  - GADTs
+  - DefaultSignatures
+  - NoImplicitPrelude
+  - FunctionalDependencies
+  - DataKinds
+  - TypeFamilies
+  - BinaryLiterals
+  - ViewPatterns
+
+dependencies:
+  - rio >= 0.1.21.0
+  - X11 >= 1.9.1
+  - base
+  - bytestring >= 0.10.8.2
+  - colour >= 2.3.5
+  - dbus >= 1.2.7
+  - fdo-notify
+  - unix >= 2.7.2.2
+  - text >= 1.2.3.1
+  - process >= 1.6.5.0
+  - xmobar
+  - xmonad-extras >= 0.15.2
+  - xmonad >= 0.13
+  - xmonad-contrib >= 0.13
+  - aeson >= 2.0.3.0
+  - yaml >=0.11.8.0
+  - xml >= 1.3.14
+  - 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
+
+ghc-options:
+- -Wall
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wredundant-constraints
+- -Wpartial-fields
+- -Werror
+- -O2
+
+library:
+  source-dirs: lib/
+
+executables:
+  xmobar: &bin
+    main:                xmobar.hs
+    source-dirs:         bin
+    dependencies:
+     - xmonad-config
+    ghc-options:
+      - -threaded
+  xmonad: 
+    <<: *bin
+    main:                xmonad.hs
+    ghc-options:
+      - -threaded
+      # this is needed to avoid writing super complex layout types
+      - -fno-warn-missing-signatures
+  vbox-start:
+    <<: *bin
+    main:                vbox-start.hs
+    ghc-options:
+      - -threaded

runtime_pkgs

@@ -0,0 +1,29 @@
+#!/bin/bash
+
+# Print list of packages to be installed via pacman
+
+filter_type () {
+    # echo "$1" | jq --raw-output "select(.type==\"$2\") | .name" | sort | uniq
+    echo "$1" | sed -n "/$2/p" | cut -f2
+}
+
+raw=$(echo -e "$(xmonad --deps)\n$(xmobar --deps)")
+
+# these are extra packages that pertain to processes outside xmonad but are
+# still required/desired to make it work correctly
+xmonad_pkgs=(xorg-xinit xorg-server autorandr picom)
+
+mapfile -t official < <(filter_type "$raw" "Official")
+mapfile -t local < <(filter_type "$raw" "AUR")
+
+if ! pacman -Si "${official[@]}" > /dev/null; then
+    echo "At least one official package doesn't exist."
+    exit 1
+fi
+
+if ! yay -Si "${local[@]}" > /dev/null; then
+    echo "At least one local package doesn't exist."
+    exit 1
+fi
+
+echo "${xmonad_pkgs[@]}" "${official[@]}" "${local[@]}" | tr ' ' '\n'

scripts/screencap

@@ -0,0 +1,22 @@
+#! /bin/bash
+
+## capture a screenshot using scrot
+
+SS_DIR="$XDG_CACHE_HOME/screenshots"
+
+while getopts ":sw" opt; do
+	case ${opt} in
+		s)
+			scrot "$SS_DIR/desktop/%Y-%m-%d-%H:%M:%S_desktop.png"
+			notify-send "Screen captured"
+			;;
+		w)
+			scrot -u "$SS_DIR/window/%Y-%m-%d-%H:%M:%S-\$wx\$h.png"
+			notify-send "Window captured"
+			;;
+		\?)
+			echo "invalid option, read the code"
+			;;
+	esac
+done
+

scripts/screenlock

@@ -0,0 +1,61 @@
+#! /bin/bash
+
+## lock the screen using i3lock (and maybe suspend)
+
+## usage: screenlock [SUSPEND]
+
+# WORKAROUND make the date show up in the right place on 2+ monitor setups
+# I want it to only show up on the primary screen, so use xrandr to get the
+# dimensions and position of the primary monitor and calculate the date position
+# from that
+geometry=$(xrandr | sed -n 's/^.*primary \([0-9]*\)x[0-9]*+\([0-9]\)*+[0-9]* .*/\1 \2/p')
+width=$(echo "$geometry" | cut -f1 -d" ")
+xpos=$(echo "$geometry" | cut -f2 -d" ")
+xoffset=$(("$xpos" + "$width" / 2))
+datepos="$xoffset:600"
+
+# lock and fork so we can suspend with the screen locked
+i3lock --color=000000 \
+       --pass-media-keys \
+       --nofork \
+       --ignore-empty-password \
+       --screen=0 \
+       --indicator \
+       --inside-color=00000055 \
+       --insidever-color=00000055 \
+       --insidewrong-color=00000055 \
+       --ring-color=555555ff \
+       --ringwrong-color=ff3333ff \
+       --ringver-color=99ceffff \
+       --keyhl-color=99ceffff \
+       --bshl-color=9523ffff \
+       --line-color=00000000 \
+       --separator-color=00000000 \
+       --clock \
+       --verif-color=99ceffff \
+       --wrong-color=ff8282ff \
+       --time-color=ffffffff \
+       --time-size=72 \
+       --time-str="%H:%M" \
+       --date-color=ffffffff \
+       --date-size=42 \
+       --date-str="%b %d, %Y" \
+       --date-align 0 \
+       --date-pos="$datepos" \
+       --wrong-size=72 \
+       --verif-size=72 \
+       --radius=300 \
+       --ring-width=25 &
+
+# suspend if we want, and if this machine is currently using a battery
+batpath=/sys/class/power_supply/BAT0/status
+
+if [ -f "$batpath" ] && \
+       [ "$(cat $batpath)" == "Discharging" ] && \
+       [ "$1" == "true" ]; then
+    systemctl suspend
+fi
+
+# block until the screen is unlocked (since xss-lock expects the locker to exit
+# only when unlocked)
+wait

stack.yaml

@@ -17,9 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-#resolver: lts-17.4
-resolver: lts-19.10
-# resolver: nightly-2022-03-03
+resolver: lts-19.33
+#resolver: nightly-2022-03-03
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -87,15 +86,3 @@ flags:
 #
 # Allow a newer minor version of GHC than the snapshot specifies
 # compiler-check: newer-minor
-nix:
-  enable: true
-  packages:
-    - xorg.libX11
-    - xorg.libXrandr
-    - xorg.libXScrnSaver
-    - xorg.libXext
-    - xorg.libXft
-    - xorg.libXpm
-    - alsa-lib
-    - wirelesstools
-    - pkg-config