REF use submonad for bluetooth state

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
+  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 state adapter cl
+      initAdapter adapter cl
-    void $ addAdaptorListener state dpy 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 state dpy adapter cl
+      addDeviceAddedListener dpy adapter cl
-    addDeviceRemovedListener state dpy adapter cl
+      addDeviceRemovedListener dpy adapter cl
-    forM_ devices $ \d -> addAndInitDevice state dpy d 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 :: BTIO (Maybe Bool, Bool)
-readState state = do
+readState = do
-  p <- readPowered state
+  p <- readPowered
-  c <- readDevices state
+  c <- readDevices
   return (p, anyDevicesConnected c)
 
 --------------------------------------------------------------------------------
@@ -180,31 +190,19 @@ addBtOMListener
   -> m ()
 addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
 
-addDeviceAddedListener
+addDeviceAddedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+addDeviceAddedListener dpy adapter client =
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addDeviceAddedListener state dpy adapter client =
   addBtOMListener addDevice client
   where
     addDevice = pathCallback adapter dpy $ \d ->
-      addAndInitDevice state dpy d client
+      addAndInitDevice dpy d client
 
-addDeviceRemovedListener
+addDeviceRemovedListener :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+addDeviceRemovedListener dpy adapter sys =
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addDeviceRemovedListener state 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
+initAdapter :: ObjectPath -> SysClient -> BTIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+initAdapter adapter client = do
-  => MutableBtState
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-initAdapter state 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)
+  :: BTIO ()
-  => MutableBtState
-  -> m ()
   -> ObjectPath
   -> SysClient
-  -> m (Maybe SignalHandler)
+  -> BTIO (Maybe SignalHandler)
-addAdaptorListener state dpy adaptor sys = do
+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 :: Maybe Bool -> BTIO ()
-putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
+putPowered ds = do
+  m <- asks btState
+  modifyMVar_ m (\s -> return s {btPowered = ds})
 
-readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
+readPowered :: BTIO (Maybe Bool)
-readPowered = fmap btPowered . readMVar
+readPowered = fmap btPowered $ readMVar =<< asks btState
 
 adapterInterface :: InterfaceName
 adapterInterface = interfaceName_ "org.bluez.Adapter1"
@@ -304,50 +297,32 @@ adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice
+addAndInitDevice :: BTIO () -> ObjectPath -> SysClient -> BTIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+addAndInitDevice dpy device client = do
-  => MutableBtState
+  res <- addDeviceListener dpy device client
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addAndInitDevice state dpy device client = do
-  res <- addDeviceListener state 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
+initDevice :: SignalHandler -> ObjectPath -> SysClient -> BTIO ()
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+initDevice sh device sys = do
-  => MutableBtState
-  -> SignalHandler
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-initDevice state sh device sys = do
   reply <- callGetConnected device sys
   void $
-    insertDevice state device $
+    insertDevice device $
       BTDevice
         { btDevConnected = fromVariant =<< listToMaybe reply
         , btDevSigHandler = sh
         }
 
-addDeviceListener
+addDeviceListener :: BTIO () -> ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+addDeviceListener dpy device sys = do
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m (Maybe SignalHandler)
-addDeviceListener state 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
+insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
-  :: MonadUnliftIO m
+insertDevice device dev = do
-  => MutableBtState
+  m <- asks btState
-  -> ObjectPath
+  modifyMVar m $ \s -> do
-  -> 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
+updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
-  :: MonadUnliftIO m
+updateDevice device status = do
-  => MutableBtState
+  m <- asks btState
-  -> ObjectPath
+  modifyMVar m $ \s -> do
-  -> 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)
 
 anyDevicesConnected :: ConnectedDevices -> Bool
 anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
 
-removeDevice
+removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
-  :: MonadUnliftIO m
+removeDevice device = do
-  => MutableBtState
+  m <- asks btState
-  -> ObjectPath
+  modifyMVar m $ \s -> do
-  -> 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 :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
+readDevices :: BTIO ConnectedDevices
-readDevices = fmap btDevices . readMVar
+readDevices = fmap btDevices $ readMVar =<< asks btState
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"