From 37f607d817abe03299fb04bfc2d99124145527cb Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 1 Jan 2023 23:03:31 -0500 Subject: [PATCH] REF use submonad for bluetooth state --- lib/Xmobar/Plugins/Bluetooth.hs | 201 +++++++++++++------------------- 1 file changed, 84 insertions(+), 117 deletions(-) diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 6f3c0c2..0436b61 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -68,28 +68,30 @@ instance Exec Bluetooth where withDBusClientConnection cb "bluetooth" $ startAdapter icons colors cb startAdapter - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => Icons + :: Icons -> Colors -> Callback -> SysClient - -> m () + -> RIO SimpleApp () startAdapter is cs cb cl = do - ot <- getBtObjectTree cl state <- newMVar emptyState - let dpy = displayIcon cb (iconFormatter is cs) state - -- TODO if this fails it won't be logged - forM_ (findAdapter ot) $ \adapter -> do - -- set up adapter - initAdapter state 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 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 - dpy + let dpy = displayIcon cb (iconFormatter is cs) + mapRIO (wrap state) $ do + ot <- getBtObjectTree cl + -- TODO if this fails it won't be logged + forM_ (findAdapter ot) $ \adapter -> do + -- set up adapter + initAdapter adapter cl + void $ addAdaptorListener dpy adapter cl + -- set up devices on the adapter (and listeners for adding/removing devices) + let devices = findDevices adapter ot + addDeviceAddedListener dpy adapter cl + addDeviceRemovedListener dpy adapter cl + forM_ devices $ \d -> addAndInitDevice dpy d cl + -- after setting things up, show the icon based on the initialized state + dpy + where + wrap s env = BTEnv {btEnv = env, btState = s} -------------------------------------------------------------------------------- -- Icon Display @@ -101,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text) type Icons = (T.Text, T.Text) -displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m () +displayIcon :: Callback -> IconFormatter -> BTIO () displayIcon callback formatter = - liftIO . 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 @@ -120,6 +122,16 @@ iconFormatter (iconConn, iconDisc) cs powered connected = -- is to track the shared state of the bluetooth adaptor and its devices using -- an MVar. +data BTEnv = BTEnv + { btEnv :: !SimpleApp + , btState :: !(MVar BtState) + } + +instance HasLogFunc BTEnv where + logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL + +type BTIO = RIO BTEnv + data BTDevice = BTDevice { btDevConnected :: Maybe Bool , btDevSigHandler :: SignalHandler @@ -132,8 +144,6 @@ data BtState = BtState , btPowered :: Maybe Bool } -type MutableBtState = MVar BtState - emptyState :: BtState emptyState = BtState @@ -141,10 +151,10 @@ emptyState = , btPowered = Nothing } -readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool) -readState state = do - p <- readPowered state - c <- readDevices state +readState :: BTIO (Maybe Bool, Bool) +readState = do + p <- readPowered + c <- readDevices return (p, anyDevicesConnected c) -------------------------------------------------------------------------------- @@ -180,31 +190,19 @@ addBtOMListener -> m () addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc -addDeviceAddedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> m () - -> ObjectPath - -> SysClient - -> m () -addDeviceAddedListener state dpy adapter client = +addDeviceAddedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO () +addDeviceAddedListener dpy adapter client = addBtOMListener addDevice client where addDevice = pathCallback adapter dpy $ \d -> - addAndInitDevice state dpy d client + addAndInitDevice dpy d client -addDeviceRemovedListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> m () - -> ObjectPath - -> SysClient - -> m () -addDeviceRemovedListener state dpy adapter sys = +addDeviceRemovedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO () +addDeviceRemovedListener dpy adapter sys = addBtOMListener remDevice sys where remDevice = pathCallback adapter dpy $ \d -> do - old <- removeDevice state d + old <- removeDevice d forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler pathCallback @@ -220,18 +218,13 @@ pathCallback _ _ _ _ = return () -------------------------------------------------------------------------------- -- Adapter -initAdapter - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> ObjectPath - -> SysClient - -> m () -initAdapter state adapter client = do +initAdapter :: ObjectPath -> SysClient -> BTIO () +initAdapter adapter client = do reply <- callGetPowered adapter client logInfo $ "initializing adapter at path " <> adapter_ -- TODO this could fail if the variant is something weird; the only -- indication I will get is "NA" - putPowered state $ fromSingletonVariant reply + putPowered $ fromSingletonVariant reply where adapter_ = displayWrapQuote $ displayObjectPath adapter @@ -268,16 +261,14 @@ withBTPropertyRule cl path update iface prop = do matchConnected = matchPropertyChanged iface prop addAdaptorListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> m () + :: BTIO () -> ObjectPath -> SysClient - -> m (Maybe SignalHandler) -addAdaptorListener state dpy adaptor sys = do + -> BTIO (Maybe SignalHandler) +addAdaptorListener dpy adaptor sys = do withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered where - procMatch b = putPowered state b >> dpy + procMatch b = putPowered b >> dpy callGetPowered :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -289,11 +280,13 @@ callGetPowered adapter = memberName_ $ T.unpack adaptorPowered -putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m () -putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds}) +putPowered :: Maybe Bool -> BTIO () +putPowered ds = do + m <- asks btState + modifyMVar_ m (\s -> return s {btPowered = ds}) -readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool) -readPowered = fmap btPowered . readMVar +readPowered :: BTIO (Maybe Bool) +readPowered = fmap btPowered $ readMVar =<< asks btState adapterInterface :: InterfaceName adapterInterface = interfaceName_ "org.bluez.Adapter1" @@ -304,50 +297,32 @@ adaptorPowered = "Powered" -------------------------------------------------------------------------------- -- Devices -addAndInitDevice - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> m () - -> ObjectPath - -> SysClient - -> m () -addAndInitDevice state dpy device client = do - res <- addDeviceListener state dpy device client +addAndInitDevice :: BTIO () -> ObjectPath -> SysClient -> BTIO () +addAndInitDevice dpy device client = do + res <- addDeviceListener dpy device client case res of Just handler -> do logInfo $ "initializing device at path " <> device_ - initDevice state handler device client + initDevice handler device client Nothing -> logError $ "could not initialize device at path " <> device_ where device_ = displayWrapQuote $ displayObjectPath device -initDevice - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> SignalHandler - -> ObjectPath - -> SysClient - -> m () -initDevice state sh device sys = do +initDevice :: SignalHandler -> ObjectPath -> SysClient -> BTIO () +initDevice sh device sys = do reply <- callGetConnected device sys void $ - insertDevice state device $ + insertDevice device $ BTDevice { btDevConnected = fromVariant =<< listToMaybe reply , btDevSigHandler = sh } -addDeviceListener - :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) - => MutableBtState - -> m () - -> ObjectPath - -> SysClient - -> m (Maybe SignalHandler) -addDeviceListener state dpy device sys = do +addDeviceListener :: BTIO () -> ObjectPath -> SysClient -> BTIO (Maybe SignalHandler) +addDeviceListener dpy device sys = do withBTPropertyRule sys device procMatch devInterface devConnected where - procMatch c = updateDevice state device c >> dpy + procMatch c = updateDevice device c >> dpy callGetConnected :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) @@ -358,40 +333,32 @@ callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ (T.unpack devConnected) -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) +insertDevice :: ObjectPath -> BTDevice -> BTIO Bool +insertDevice device dev = do + m <- asks btState + modifyMVar m $ \s -> do + let new = M.insert device dev $ btDevices s + return (s {btDevices = new}, anyDevicesConnected new) -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) +updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool +updateDevice device status = do + m <- asks btState + 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 - :: 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) +removeDevice :: ObjectPath -> BTIO (Maybe BTDevice) +removeDevice device = do + m <- asks btState + modifyMVar m $ \s -> do + let devs = btDevices s + return (s {btDevices = M.delete device devs}, M.lookup device devs) -readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices -readDevices = fmap btDevices . readMVar +readDevices :: BTIO ConnectedDevices +readDevices = fmap btDevices $ readMVar =<< asks btState devInterface :: InterfaceName devInterface = interfaceName_ "org.bluez.Device1"