ENH generalize signal callbacks

lib/Data/Internal/DBus.hs

@@ -137,15 +137,16 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 --------------------------------------------------------------------------------
 -- Signals
 
-type SignalCallback = [Variant] -> IO ()
+type SignalCallback m = [Variant] -> m ()
 
 addMatchCallback
   :: (MonadUnliftIO m, SafeClient c)
   => MatchRule
-  -> SignalCallback
+  -> SignalCallback m
   -> c
   -> m SignalHandler
-addMatchCallback rule cb cl = liftIO . addMatch (toClient cl) rule $ cb . signalBody
+addMatchCallback rule cb cl = withRunInIO $ \run -> do
+  addMatch (toClient cl) rule $ run . cb . signalBody
 
 matchSignal
   :: Maybe BusName
@@ -266,7 +267,7 @@ addInterfaceChangedListener
   => BusName
   -> MemberName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
   -> m (Maybe SignalHandler)
 addInterfaceChangedListener bus prop path sc cl = do
@@ -277,7 +278,7 @@ addInterfaceAddedListener
   :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
   -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
@@ -287,7 +288,7 @@ addInterfaceRemovedListener
   :: (MonadUnliftIO m, SafeClient c)
   => BusName
   -> ObjectPath
-  -> SignalCallback
+  -> SignalCallback m
   -> c
   -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =

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
@@ -73,19 +73,19 @@ startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
 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
+    addDeviceAddedListener state dpy adapter cl
-    addDeviceRemovedListener state display adapter cl
+    addDeviceRemovedListener state dpy adapter cl
-    forM_ devices $ \d -> addAndInitDevice state display d 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
@@ -166,27 +166,27 @@ 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 state dpy adapter client =
   addBtOMListener addDevice client
   where
-    addDevice = pathCallback adapter display $ \d ->
+    addDevice = pathCallback adapter dpy $ \d ->
-      addAndInitDevice state display d client
+      addAndInitDevice state dpy d client
 
 addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceRemovedListener state display adapter sys =
+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
 
-pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
+pathCallback :: MonadUnliftIO m => ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback m
-pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
+pathCallback adapter dpy f [device, _] = liftIO $ forM_ (fromVariant device) $ \d ->
-  when (adaptorHasDevice adapter d) $ f d >> display
+  when (adaptorHasDevice adapter d) $ f d >> dpy
 pathCallback _ _ _ _ = return ()
 
 --------------------------------------------------------------------------------
@@ -206,11 +206,11 @@ addAdaptorListener
   -> ObjectPath
   -> SysClient
   -> IO (Maybe SignalHandler)
-addAdaptorListener state display adaptor sys = do
+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 adapter =
@@ -237,8 +237,8 @@ adaptorPowered = "Powered"
 -- Devices
 
 addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addAndInitDevice state display device client = do
+addAndInitDevice state dpy device client = do
-  sh <- addDeviceListener state display device client
+  sh <- addDeviceListener state dpy device client
   -- TODO add some intelligent error messages here
   forM_ sh $ \s -> initDevice state s device client
 
@@ -258,11 +258,11 @@ addDeviceListener
   -> ObjectPath
   -> SysClient
   -> IO (Maybe SignalHandler)
-addDeviceListener state display device sys = do
+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

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 dpy = displayMaybe cb iconFormatter . Just =<< readState state
-      let signalCallback' f = f state display
+      let signalCallback' f = f state dpy
       vpnAddedListener (signalCallback' addedCallback) c
       vpnRemovedListener (signalCallback' removedCallback) c
-      display
+      dpy
     where
       iconFormatter b = return $ colorText colors b text
 
@@ -63,10 +62,11 @@ readState :: MutableVPNState -> IO 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
 
 --------------------------------------------------------------------------------
@@ -78,33 +78,34 @@ 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 :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
-addedCallback state display [device, added] = update >> display
+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 :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
-removedCallback state display [device, interfaces] = update >> display
+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 $