From 4aae54b90e70bb51a2f8259ca54d96865ac56a4e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 30 Dec 2022 16:37:52 -0500 Subject: [PATCH] ENH generalize signal callbacks --- lib/Data/Internal/DBus.hs | 13 +++++----- lib/Xmobar/Plugins/Bluetooth.hs | 44 ++++++++++++++++----------------- lib/Xmobar/Plugins/VPN.hs | 31 ++++++++++++----------- 3 files changed, 45 insertions(+), 43 deletions(-) diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 51b2698..16fcc7b 100644 --- a/lib/Data/Internal/DBus.hs +++ b/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 = diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 0ae39e0..488f533 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/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 - 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 @@ -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 -> - 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 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 adapter display f [device, _] = forM_ (fromVariant device) $ \d -> - when (adaptorHasDevice adapter d) $ f d >> display +pathCallback :: MonadUnliftIO m => ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback m +pathCallback adapter dpy f [device, _] = liftIO $ forM_ (fromVariant device) $ \d -> + 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 - sh <- addDeviceListener state display device client +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 @@ -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 diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index a742134..3ccf837 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/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 @@ -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 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 $