ENH generalize keyboard stuff

lib/Data/Internal/DBus.hs

@@ -28,13 +28,13 @@ module Data.Internal.DBus
   )
 where
 
-import Control.Exception
 import Control.Monad
 import DBus
 import DBus.Client
 import Data.Bifunctor
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import RIO
 import qualified RIO.Text as T
 
 --------------------------------------------------------------------------------
@@ -43,23 +43,23 @@ import qualified RIO.Text as T
 class SafeClient c where
   toClient :: c -> Client
 
-  getDBusClient :: IO (Maybe c)
+  getDBusClient :: MonadUnliftIO m => m (Maybe c)
 
-  disconnectDBusClient :: c -> IO ()
-  disconnectDBusClient = disconnect . toClient
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
+  disconnectDBusClient = liftIO . disconnect . toClient
 
-  withDBusClient :: (c -> IO a) -> IO (Maybe a)
+  withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
   withDBusClient f = do
     client <- getDBusClient
     forM client $ \c -> do
       r <- f c
-      disconnect (toClient c)
+      liftIO $ disconnect (toClient c)
       return r
 
-  withDBusClient_ :: (c -> IO ()) -> IO ()
+  withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
   withDBusClient_ = void . withDBusClient
 
-  fromDBusClient :: (c -> a) -> IO (Maybe a)
+  fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
   fromDBusClient f = withDBusClient (return . f)
 
 newtype SysClient = SysClient Client
@@ -76,11 +76,11 @@ instance SafeClient SesClient where
 
   getDBusClient = fmap SesClient <$> getDBusClient' False
 
-getDBusClient' :: Bool -> IO (Maybe Client)
+getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
 getDBusClient' sys = do
-  res <- try $ if sys then connectSystem else connectSession
+  res <- try $ liftIO $ if sys then connectSystem else connectSession
   case res of
-    Left e -> putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
     Right c -> return $ Just c
 
 --------------------------------------------------------------------------------
@@ -88,19 +88,20 @@ getDBusClient' sys = do
 
 type MethodBody = Either T.Text [Variant]
 
-callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
+callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
 callMethod' cl =
-  fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
+  liftIO
+    . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
     . call (toClient cl)
 
 callMethod
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> IO MethodBody
+  -> m MethodBody
 callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
 
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@@ -115,7 +116,7 @@ methodCallBus b p i m =
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
+callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
 callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
   where
     mc =
@@ -136,15 +137,16 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 --------------------------------------------------------------------------------
 -- Signals
 
-type SignalCallback = [Variant] -> IO ()
+type SignalCallback m = [Variant] -> m ()
 
 addMatchCallback
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => MatchRule
-  -> SignalCallback
+  -> SignalCallback m
   -> c
-  -> IO SignalHandler
-addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
+  -> m SignalHandler
+addMatchCallback rule cb cl = withRunInIO $ \run -> do
+  addMatch (toClient cl) rule $ run . cb . signalBody
 
 matchSignal
   :: Maybe BusName
@@ -161,13 +163,13 @@ matchSignal b p i m =
     }
 
 matchSignalFull
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> Maybe ObjectPath
   -> Maybe InterfaceName
   -> Maybe MemberName
-  -> IO (Maybe MatchRule)
+  -> m (Maybe MatchRule)
 matchSignalFull client b p i m =
   fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
 
@@ -181,14 +183,15 @@ propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
 callPropertyGet
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
   -> c
-  -> IO [Variant]
+  -> m [Variant]
 callPropertyGet bus path iface property cl =
+  liftIO $
     fmap (either (const []) (: [])) $
       getProperty (toClient cl) $
         methodCallBus bus path iface property
@@ -198,17 +201,17 @@ matchProperty b p =
   matchSignal b p (Just propertyInterface) (Just propertySignal)
 
 matchPropertyFull
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> Maybe ObjectPath
-  -> IO (Maybe MatchRule)
+  -> m (Maybe MatchRule)
 matchPropertyFull cl b p =
   matchSignalFull cl 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 ()
@@ -250,43 +253,43 @@ omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
 callGetManagedObjects
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => c
   -> BusName
   -> ObjectPath
-  -> IO ObjectTree
+  -> m ObjectTree
 callGetManagedObjects cl bus path =
   either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
     <$> callMethod cl bus path omInterface getManagedObjects
 
 addInterfaceChangedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> MemberName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (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
 
 addInterfaceAddedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
 addInterfaceRemovedListener
-  :: SafeClient c
+  :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
   addInterfaceChangedListener bus omInterfacesRemoved

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

@@ -13,11 +13,10 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
   )
 where
 
-import Control.Monad (when)
 import DBus
-import Data.Int (Int32)
 import Data.Internal.DBus
 import Data.Internal.Dependency
+import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
 import XMonad.Internal.IO
@@ -127,8 +126,12 @@ exportClevoKeyboard =
 clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
-callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
 
-matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalCK
+  :: MonadUnliftIO m
+  => (Maybe Brightness -> m ())
+  -> SesClient
+  -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig

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

@@ -14,13 +14,12 @@ module XMonad.Internal.DBus.Brightness.Common
   )
 where
 
-import Control.Monad (void)
 import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
-import Data.Int (Int32)
 import Data.Internal.DBus
 import Data.Internal.Dependency
+import RIO
 import qualified RIO.Text as T
 import XMonad.Core (io)
 import XMonad.Internal.DBus.Common
@@ -69,10 +68,10 @@ brightnessControls q bc cl =
     cb = callBacklight q cl bc
 
 callGetBrightness
-  :: (SafeClient c, Num n)
+  :: (MonadUnliftIO m, SafeClient c, Num n)
   => BrightnessConfig a b
   -> c
-  -> IO (Maybe n)
+  -> m (Maybe n)
 callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
   either (const Nothing) bodyGetBrightness
     <$> callMethod client xmonadBusName p i memGet
@@ -82,11 +81,11 @@ signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
   Endpoint [] xmonadBusName p i $ Signal_ memCur
 
 matchSignal
-  :: (SafeClient c, Num n)
+  :: (MonadUnliftIO m, SafeClient c, Num n)
   => BrightnessConfig a b
-  -> (Maybe n -> IO ())
+  -> (Maybe n -> m ())
   -> c
-  -> IO ()
+  -> m ()
 matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
   void . addMatchCallback brMatcher (cb . bodyGetBrightness)
   where
@@ -115,7 +114,11 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
     root = DBusRoot_ (exportBrightnessControls' bc) tree cl
     tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
-exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
+exportBrightnessControls'
+  :: (MonadUnliftIO m, RealFrac b)
+  => BrightnessConfig a b
+  -> SesClient
+  -> m ()
 exportBrightnessControls' bc cl = io $ do
   let ses = toClient cl
   maxval <- bcGetMax bc -- assume the max value will never change
@@ -148,9 +151,14 @@ exportBrightnessControls' bc cl = io $ do
             ]
         }
 
-emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
+emitBrightness
+  :: (MonadUnliftIO m, RealFrac b)
+  => BrightnessConfig a b
+  -> Client
+  -> b
+  -> m ()
 emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
-  emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
+  liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
   where
     sig = signal p i memCur
 

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

@@ -14,9 +14,9 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
 where
 
 import DBus
-import Data.Int (Int32)
 import Data.Internal.DBus
 import Data.Internal.Dependency
+import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
 import XMonad.Internal.IO
@@ -110,8 +110,12 @@ exportIntelBacklight =
 intelBacklightControls :: Maybe SesClient -> BrightnessControls
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
-callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
+callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
-matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
+matchSignalIB
+  :: MonadUnliftIO m
+  => (Maybe Brightness -> m ())
+  -> SesClient
+  -> m ()
 matchSignalIB = matchSignal intelBacklightConfig

lib/XMonad/Internal/DBus/Control.hs

@@ -18,11 +18,11 @@ module XMonad.Internal.DBus.Control
   )
 where
 
-import Control.Monad
 import DBus
 import DBus.Client
 import Data.Internal.DBus
 import Data.Internal.Dependency
+import RIO
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Common
@@ -35,27 +35,27 @@ data DBusState = DBusState
   }
 
 -- | Connect to the DBus
-connectDBus :: IO DBusState
+connectDBus :: MonadUnliftIO m => m DBusState
 connectDBus = do
   ses <- getDBusClient
   sys <- getDBusClient
   return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus :: DBusState -> IO ()
+disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
 -- | Connect to the DBus and request the XMonad name
-connectDBusX :: IO DBusState
+connectDBusX :: MonadUnliftIO m => m DBusState
 connectDBusX = do
   db <- connectDBus
   forM_ (dbSesClient db) requestXMonadName
   return db
 
 -- | Disconnect from DBus and release the XMonad name
-disconnectDBusX :: DBusState -> IO ()
+disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
 disconnectDBusX db = do
   forM_ (dbSesClient db) releaseXMonadName
   disconnectDBus db
@@ -64,12 +64,12 @@ disconnectDBusX db = do
 dbusExporters :: [Maybe SesClient -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName :: SesClient -> IO ()
-releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
+releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
+releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
 
-requestXMonadName :: SesClient -> IO ()
+requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
 requestXMonadName ses = do
-  res <- requestName (toClient ses) xmonadBusName []
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
   -- TODO if the client is not released on shutdown the owner will be different
   let msg
         | res == NamePrimaryOwner = Nothing
@@ -78,6 +78,6 @@ requestXMonadName ses = do
             || res == NameExists =
             Just $ "another process owns " ++ xn
         | otherwise = Just $ "unknown error when requesting " ++ xn
-  forM_ msg putStrLn
+  liftIO $ forM_ msg putStrLn
   where
     xn = "'" ++ formatBusName xmonadBusName ++ "'"

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -7,20 +7,21 @@
 module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
 import Data.Internal.DBus
+import RIO
 import qualified RIO.Text as T
 import Xmobar.Plugins.Common
 
 startBacklight
-  :: RealFrac a
-  => ((Maybe a -> IO ()) -> SesClient -> IO ())
-  -> (SesClient -> IO (Maybe a))
+  :: (MonadUnliftIO m, RealFrac a)
+  => ((Maybe a -> m ()) -> SesClient -> m ())
+  -> (SesClient -> m (Maybe a))
   -> T.Text
   -> Callback
-  -> IO ()
+  -> m ()
 startBacklight matchSignal callGetBrightness icon cb = do
   withDBusClientConnection cb $ \c -> do
-    matchSignal display c
-    display =<< callGetBrightness c
+    matchSignal dpy c
+    dpy =<< callGetBrightness c
   where
     formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
-    display = displayMaybe cb formatBrightness
+    dpy = displayMaybe cb formatBrightness

lib/Xmobar/Plugins/Bluetooth.hs

@@ -39,7 +39,6 @@ module Xmobar.Plugins.Bluetooth
   )
 where
 
-import Control.Concurrent.MVar
 import Control.Monad
 import DBus
 import DBus.Client
@@ -49,6 +48,7 @@ import Data.List
 import Data.List.Split
 import qualified Data.Map as M
 import Data.Maybe
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Common
 import Xmobar
@@ -69,23 +69,29 @@ instance Exec Bluetooth where
   start (Bluetooth icons colors) cb =
     withDBusClientConnection cb $ startAdapter icons colors cb
 
-startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
+startAdapter
+  :: MonadUnliftIO m
+  => Icons
+  -> Colors
+  -> Callback
+  -> SysClient
+  -> m ()
 startAdapter is cs cb cl = do
   ot <- getBtObjectTree cl
   state <- newMVar emptyState
-  let display = displayIcon cb (iconFormatter is cs) state
+  let dpy = displayIcon cb (iconFormatter is cs) 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
+    void $ addAdaptorListener state dpy adapter cl
     -- set up devices on the adapter (and listeners for adding/removing devices)
     let devices = findDevices adapter ot
-    addDeviceAddedListener state display adapter cl
-    addDeviceRemovedListener state display adapter cl
-    forM_ devices $ \d -> addAndInitDevice state display d cl
+    addDeviceAddedListener state dpy adapter cl
+    addDeviceRemovedListener state dpy adapter cl
+    forM_ devices $ \d -> addAndInitDevice state dpy d cl
     -- after setting things up, show the icon based on the initialized state
-    display
+    dpy
 
 --------------------------------------------------------------------------------
 -- Icon Display
@@ -97,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
 type Icons = (T.Text, T.Text)
 
-displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
 displayIcon callback formatter =
-  callback . T.unpack . uncurry formatter <=< readState
+  liftIO . callback . T.unpack . uncurry formatter <=< readState
 
 -- TODO maybe I want this to fail when any of the device statuses are Nothing
 iconFormatter :: Icons -> Colors -> IconFormatter
@@ -137,7 +143,7 @@ emptyState =
     , btPowered = Nothing
     }
 
-readState :: MutableBtState -> IO (Maybe Bool, Bool)
+readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
 readState state = do
   p <- readPowered state
   c <- readDevices state
@@ -160,59 +166,81 @@ adaptorHasDevice adaptor device = case splitPath device of
 splitPath :: ObjectPath -> [T.Text]
 splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
 
-getBtObjectTree :: SysClient -> IO ObjectTree
+getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
 getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener :: SignalCallback -> SysClient -> IO ()
+addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
 addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
 
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceAddedListener state display adapter client =
+addDeviceAddedListener
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addDeviceAddedListener state dpy adapter client =
   addBtOMListener addDevice client
   where
-    addDevice = pathCallback adapter display $ \d ->
-      addAndInitDevice state display d client
+    addDevice = pathCallback adapter dpy $ \d ->
+      addAndInitDevice state dpy d client
 
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceRemovedListener state display adapter sys =
+addDeviceRemovedListener
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addDeviceRemovedListener state dpy adapter sys =
   addBtOMListener remDevice sys
   where
-    remDevice = pathCallback adapter display $ \d -> do
+    remDevice = pathCallback adapter dpy $ \d -> do
       old <- removeDevice state d
-      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
+      forM_ old $ liftIO . 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 :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
+pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
+  when (adaptorHasDevice adapter d) $ f d >> dpy
 pathCallback _ _ _ _ = return ()
 
 --------------------------------------------------------------------------------
 -- Adapter
 
-initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
+initAdapter
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 initAdapter state adapter client = do
   reply <- callGetPowered adapter client
   putPowered state $ fromSingletonVariant reply
 
-matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
+matchBTProperty
+  :: (MonadUnliftIO m)
+  => SysClient
+  -> ObjectPath
+  -> m (Maybe MatchRule)
 matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
 
 addAdaptorListener
-  :: MutableBtState
-  -> IO ()
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
   -> ObjectPath
   -> SysClient
-  -> IO (Maybe SignalHandler)
-addAdaptorListener state display adaptor sys = do
+  -> m (Maybe SignalHandler)
+addAdaptorListener state dpy adaptor sys = do
   rule <- matchBTProperty sys adaptor
   forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
   where
-    procMatch = withSignalMatch $ \b -> putPowered state b >> display
+    procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
 
-callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
+callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 callGetPowered adapter =
   callPropertyGet btBus adapter adapterInterface $
     memberName_ $
@@ -221,10 +249,10 @@ callGetPowered adapter =
 matchPowered :: [Variant] -> SignalMatch Bool
 matchPowered = matchPropertyChanged adapterInterface adaptorPowered
 
-putPowered :: MutableBtState -> Maybe Bool -> IO ()
+putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
 putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
 
-readPowered :: MutableBtState -> IO (Maybe Bool)
+readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
 readPowered = fmap btPowered . readMVar
 
 adapterInterface :: InterfaceName
@@ -236,13 +264,25 @@ adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addAndInitDevice state display device client = do
-  sh <- addDeviceListener state display device client
+addAndInitDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
+addAndInitDevice state dpy device client = do
+  sh <- addDeviceListener state dpy device client
   -- TODO add some intelligent error messages here
   forM_ sh $ \s -> initDevice state s device client
 
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
+initDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> SignalHandler
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 initDevice state sh device sys = do
   reply <- callGetConnected device sys
   void $
@@ -253,31 +293,42 @@ initDevice state sh device sys = do
         }
 
 addDeviceListener
-  :: MutableBtState
-  -> IO ()
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
   -> ObjectPath
   -> SysClient
-  -> IO (Maybe SignalHandler)
-addDeviceListener state display device sys = do
+  -> m (Maybe SignalHandler)
+addDeviceListener state dpy device sys = do
   rule <- matchBTProperty sys device
   forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
   where
-    procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
+    procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
 
 matchConnected :: [Variant] -> SignalMatch Bool
 matchConnected = matchPropertyChanged devInterface devConnected
 
-callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
+callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 callGetConnected p =
   callPropertyGet btBus p devInterface $
     memberName_ (T.unpack devConnected)
 
-insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
+insertDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> BTDevice
+  -> m Bool
 insertDevice m device dev = modifyMVar m $ \s -> do
   let new = M.insert device dev $ btDevices s
   return (s {btDevices = new}, anyDevicesConnected new)
 
-updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
+updateDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> Maybe Bool
+  -> m Bool
 updateDevice m device status = modifyMVar m $ \s -> do
   let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
   return (s {btDevices = new}, anyDevicesConnected new)
@@ -285,12 +336,16 @@ updateDevice m device status = modifyMVar m $ \s -> do
 anyDevicesConnected :: ConnectedDevices -> Bool
 anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
 
-removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
+removeDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> ObjectPath
+  -> m (Maybe BTDevice)
 removeDevice m device = modifyMVar m $ \s -> do
   let devs = btDevices s
   return (s {btDevices = M.delete device devs}, M.lookup device devs)
 
-readDevices :: MutableBtState -> IO ConnectedDevices
+readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
 readDevices = fmap btDevices . readMVar
 
 devInterface :: InterfaceName

lib/Xmobar/Plugins/Common.hs

@@ -15,10 +15,10 @@ module Xmobar.Plugins.Common
   )
 where
 
-import Control.Monad
 import DBus
 import DBus.Client
 import Data.Internal.DBus
+import RIO
 import qualified RIO.Text as T
 import XMonad.Hooks.DynamicLog (xmobarColor)
 
@@ -32,14 +32,14 @@ data Colors = Colors
   deriving (Eq, Show, Read)
 
 startListener
-  :: (SafeClient c, IsVariant a)
+  :: (MonadUnliftIO m, SafeClient c, IsVariant a)
   => MatchRule
-  -> (c -> IO [Variant])
+  -> (c -> m [Variant])
   -> ([Variant] -> SignalMatch a)
-  -> (a -> IO T.Text)
+  -> (a -> m T.Text)
   -> Callback
   -> c
-  -> IO ()
+  -> m ()
 startListener rule getProp fromSignal toColor cb client = do
   reply <- getProp client
   displayMaybe cb toColor $ fromSingletonVariant reply
@@ -47,7 +47,8 @@ startListener rule getProp fromSignal toColor cb client = do
   where
     procMatch = procSignalMatch cb toColor
 
-procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
+procSignalMatch
+  :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
 procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
 
 colorText :: Colors -> Bool -> T.Text -> T.Text
@@ -60,11 +61,15 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
 na :: T.Text
 na = "N/A"
 
-displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
-displayMaybe cb f = (cb . T.unpack) <=< 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 $ T.unpack 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
+  :: (MonadUnliftIO m, SafeClient c)
+  => Callback
+  -> (c -> m ())
+  -> m ()
 withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient

lib/Xmobar/Plugins/Device.hs

@@ -12,11 +12,11 @@ module Xmobar.Plugins.Device
   )
 where
 
-import Control.Monad
 import DBus
 import Data.Internal.DBus
 import Data.Internal.Dependency
 import Data.Word
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
@@ -45,7 +45,7 @@ devDep =
   Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
     Method_ getByIP
 
-getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
+getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
 getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
   where
     mc =
@@ -53,7 +53,7 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
         { methodCallBody = [toVariant iface]
         }
 
-getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
+getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 getDeviceConnected path =
   callPropertyGet networkManagerBus path nmDeviceInterface $
     memberName_ $

lib/Xmobar/Plugins/VPN.hs

@@ -14,14 +14,13 @@ module Xmobar.Plugins.VPN
   )
 where
 
-import Control.Concurrent.MVar
-import Control.Monad
 import DBus
 import Data.Internal.DBus
 import Data.Internal.Dependency
 import qualified Data.Map as M
 import Data.Maybe
 import qualified Data.Set as S
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
@@ -35,11 +34,11 @@ instance Exec VPN where
   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
+      let dpy = displayMaybe cb iconFormatter . Just =<< readState state
+      let signalCallback' f = f state dpy
       vpnAddedListener (signalCallback' addedCallback) c
       vpnRemovedListener (signalCallback' removedCallback) c
-      display
+      dpy
     where
       iconFormatter b = return $ colorText colors b text
 
@@ -54,57 +53,59 @@ type VPNState = S.Set ObjectPath
 
 type MutableVPNState = MVar VPNState
 
-initState :: SysClient -> IO MutableVPNState
+initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
 initState client = do
   ot <- getVPNObjectTree client
   newMVar $ findTunnels ot
 
-readState :: MutableVPNState -> IO Bool
+readState :: MonadUnliftIO m => MutableVPNState -> m Bool
 readState = fmap (not . null) . readMVar
 
 updateState
-  :: (ObjectPath -> VPNState -> VPNState)
+  :: MonadUnliftIO m
+  => (ObjectPath -> VPNState -> VPNState)
   -> MutableVPNState
   -> ObjectPath
-  -> IO ()
+  -> m ()
 updateState f state op = modifyMVar_ state $ return . f op
 
 --------------------------------------------------------------------------------
 -- Tunnel Device Detection
 
-getVPNObjectTree :: SysClient -> IO ObjectTree
+getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
 getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
 
 findTunnels :: ObjectTree -> VPNState
 findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
 
-vpnAddedListener :: SignalCallback -> SysClient -> IO ()
+vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
 vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
 
-vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
+vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
 vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
 
-addedCallback :: MutableVPNState -> IO () -> SignalCallback
-addedCallback state display [device, added] = update >> display
+addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+addedCallback state dpy [device, added] = update >> dpy
   where
     added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
     is = M.keys $ fromMaybe M.empty added'
     update = updateDevice S.insert state device is
 addedCallback _ _ _ = return ()
 
-removedCallback :: MutableVPNState -> IO () -> SignalCallback
-removedCallback state display [device, interfaces] = update >> display
+removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+removedCallback state dpy [device, interfaces] = update >> dpy
   where
     is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
     update = updateDevice S.delete state device is
 removedCallback _ _ _ = return ()
 
 updateDevice
-  :: (ObjectPath -> VPNState -> VPNState)
+  :: MonadUnliftIO m
+  => (ObjectPath -> VPNState -> VPNState)
   -> MutableVPNState
   -> Variant
   -> [T.Text]
-  -> IO ()
+  -> m ()
 updateDevice f state device interfaces =
   when (vpnDeviceTun `elem` interfaces) $
     forM_ d $