ENH generalize bluetooth

lib/Xmobar/Plugins/Bluetooth.hs

@@ -69,7 +69,13 @@ instance Exec Bluetooth where
   start (Bluetooth icons colors) cb =
     withDBusClientConnection cb $ startAdapter icons colors cb
 
-startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
+startAdapter
+  :: MonadUnliftIO m
+  => Icons
+  -> Colors
+  -> Callback
+  -> SysClient
+  -> m ()
 startAdapter is cs cb cl = do
   ot <- getBtObjectTree cl
   state <- newMVar emptyState
@@ -97,9 +103,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
 type Icons = (T.Text, T.Text)
 
-displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
 displayIcon callback formatter =
-  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
@@ -137,7 +143,7 @@ emptyState =
     , btPowered = Nothing
     }
 
-readState :: MutableBtState -> IO (Maybe Bool, Bool)
+readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
 readState state = do
   p <- readPowered state
   c <- readDevices state
@@ -160,7 +166,7 @@ adaptorHasDevice adaptor device = case splitPath device of
 splitPath :: ObjectPath -> [T.Text]
 splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
 
-getBtObjectTree :: SysClient -> IO ObjectTree
+getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
 getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
 
 btOMPath :: ObjectPath
@@ -169,50 +175,72 @@ btOMPath = objectPath_ "/"
 addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
 addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
 
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceAddedListener
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 addDeviceAddedListener state dpy adapter client =
   addBtOMListener addDevice client
   where
     addDevice = pathCallback adapter dpy $ \d ->
       addAndInitDevice state dpy d client
 
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceRemovedListener
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 addDeviceRemovedListener state dpy adapter sys =
   addBtOMListener remDevice sys
   where
     remDevice = pathCallback adapter dpy $ \d -> do
       old <- removeDevice state d
-      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
+      forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
 
-pathCallback :: MonadUnliftIO m => ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback m
+pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
-pathCallback adapter dpy f [device, _] = liftIO $ forM_ (fromVariant device) $ \d ->
+pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
   when (adaptorHasDevice adapter d) $ f d >> dpy
 pathCallback _ _ _ _ = return ()
 
 --------------------------------------------------------------------------------
 -- Adapter
 
-initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
+initAdapter
+  :: (MonadUnliftIO m)
+  => MutableBtState
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 initAdapter state adapter client = do
   reply <- callGetPowered adapter client
   putPowered state $ fromSingletonVariant reply
 
-matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
+matchBTProperty
+  :: (MonadUnliftIO m)
+  => SysClient
+  -> ObjectPath
+  -> m (Maybe MatchRule)
 matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
 
 addAdaptorListener
-  :: MutableBtState
+  :: MonadUnliftIO m
-  -> IO ()
+  => MutableBtState
+  -> m ()
   -> ObjectPath
   -> SysClient
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 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 >> dpy
 
-callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
+callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 callGetPowered adapter =
   callPropertyGet btBus adapter adapterInterface $
     memberName_ $
@@ -221,10 +249,10 @@ callGetPowered adapter =
 matchPowered :: [Variant] -> SignalMatch Bool
 matchPowered = matchPropertyChanged adapterInterface adaptorPowered
 
-putPowered :: MutableBtState -> Maybe Bool -> IO ()
+putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
 putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
 
-readPowered :: MutableBtState -> IO (Maybe Bool)
+readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
 readPowered = fmap btPowered . readMVar
 
 adapterInterface :: InterfaceName
@@ -236,13 +264,25 @@ adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addAndInitDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> m ()
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 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
 
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
+initDevice
+  :: MonadUnliftIO m
+  => MutableBtState
+  -> SignalHandler
+  -> ObjectPath
+  -> SysClient
+  -> m ()
 initDevice state sh device sys = do
   reply <- callGetConnected device sys
   void $
@@ -253,11 +293,12 @@ initDevice state sh device sys = do
         }
 
 addDeviceListener
-  :: MutableBtState
+  :: MonadUnliftIO m
-  -> IO ()
+  => MutableBtState
+  -> m ()
   -> ObjectPath
   -> SysClient
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
 addDeviceListener state dpy device sys = do
   rule <- matchBTProperty sys device
   forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
@@ -267,17 +308,27 @@ addDeviceListener state dpy device sys = do
 matchConnected :: [Variant] -> SignalMatch Bool
 matchConnected = matchPropertyChanged devInterface devConnected
 
-callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
+callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
 callGetConnected p =
   callPropertyGet btBus p devInterface $
     memberName_ (T.unpack devConnected)
 
-insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
+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)
 
-updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
+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)
@@ -285,12 +336,16 @@ updateDevice m device status = modifyMVar m $ \s -> do
 anyDevicesConnected :: ConnectedDevices -> Bool
 anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
 
-removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
+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)
 
-readDevices :: MutableBtState -> IO ConnectedDevices
+readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
 readDevices = fmap btDevices . readMVar
 
 devInterface :: InterfaceName