REF use submonad for bluetooth state

2023-01-01 23:03:31 -05:00 · 2023-01-01 23:03:31 -05:00 · 37f607d817
parent 9d7ca49357
commit 37f607d817
1 changed files with 84 additions and 117 deletions
--- 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"