diff --git a/bin/xmobar.hs b/bin/xmobar.hs index c43bcc2..f27de5b 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -46,17 +46,16 @@ main = getArgs >>= parse parse :: [String] -> IO () parse [] = run parse ["--deps"] = withCache printDeps -parse ["--test"] = void $ withCache . evalConfig =<< connectDBus +parse ["--test"] = withCache $ withDBus_ evalConfig parse _ = usage run :: IO () -run = do - db <- connectDBus - c <- withCache $ evalConfig db - disconnectDBus db +run = withCache $ withDBus_ $ \db -> do + c <- evalConfig db -- this is needed to see any printed messages - hFlush stdout - xmobar c + liftIO $ do + hFlush stdout + xmobar c evalConfig :: DBusState -> FIO Config evalConfig db = do @@ -67,11 +66,9 @@ evalConfig db = do return $ config bf ifs ios cs d printDeps :: FIO () -printDeps = do - db <- io connectDBus +printDeps = withDBus_ $ \db -> do let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db io $ mapM_ (putStrLn . T.unpack) ps - io $ disconnectDBus db usage :: IO () usage = diff --git a/bin/xmonad.hs b/bin/xmonad.hs index b9a525a..49c12d9 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -89,7 +89,7 @@ run = do uninstallSignalHandlers hSetBuffering stdout LineBuffering withCache $ do - withDBusX $ \db -> do + withDBusX_ $ \db -> do let sys = dbSysClient db let fs = features sys startDBusInterfaces db fs @@ -204,13 +204,6 @@ startXmobar = do startChildDaemons :: FeatureSet -> FIO [Process () () ()] startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) -withDBusX :: (DBusState -> FIO a) -> FIO a -withDBusX = bracket (io connectDBusX) cleanup - where - cleanup db = do - logInfo "unregistering xmonad from DBus" - io $ disconnectDBus db - withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a withChildDaemons fs = bracket (startChildDaemons fs) cleanup where @@ -226,17 +219,14 @@ withXmobar = bracket startXmobar cleanup io $ killNoWait p printDeps :: FIO () -printDeps = do - db <- io connectDBus +printDeps = withDBus_ $ \db -> do (i, f, d) <- allFeatures db - io $ - mapM_ (putStrLn . T.unpack) $ - fmap showFulfillment $ - sort $ - nub $ - concat $ - fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d - io $ disconnectDBus db + mapM_ (liftIO . putStrLn . T.unpack) $ + fmap showFulfillment $ + sort $ + nub $ + concat $ + fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures db = do diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index f895196..14b7775 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -40,19 +40,30 @@ import qualified RIO.Text as T class SafeClient c where toClient :: c -> Client - getDBusClient :: MonadUnliftIO m => m (Maybe c) + getDBusClient + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => m (Maybe c) disconnectDBusClient :: MonadUnliftIO m => c -> m () disconnectDBusClient = liftIO . disconnect . toClient - withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a) + withDBusClient + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (c -> m a) + -> m (Maybe a) withDBusClient f = bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f - withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m () + withDBusClient_ + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (c -> m ()) + -> m () withDBusClient_ = void . withDBusClient - fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a) + fromDBusClient + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (c -> a) + -> m (Maybe a) fromDBusClient f = withDBusClient (return . f) newtype SysClient = SysClient Client @@ -60,20 +71,25 @@ newtype SysClient = SysClient Client instance SafeClient SysClient where toClient (SysClient cl) = cl - getDBusClient = fmap SysClient <$> getDBusClient' True + getDBusClient = fmap SysClient <$> getSomeDBusClient True newtype SesClient = SesClient Client instance SafeClient SesClient where toClient (SesClient cl) = cl - getDBusClient = fmap SesClient <$> getDBusClient' False + getDBusClient = fmap SesClient <$> getSomeDBusClient False -getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client) -getDBusClient' sys = do +getSomeDBusClient + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => Bool + -> m (Maybe Client) +getSomeDBusClient sys = do res <- try $ liftIO $ if sys then connectSystem else connectSession case res of - Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing + Left e -> do + logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e + return Nothing Right c -> return $ Just c -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 0f43ac4..f139eb4 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- @@ -6,6 +7,10 @@ module XMonad.Internal.DBus.Control ( Client , DBusState (..) + , withDBus + , withDBus_ + , withDBusX + , withDBusX_ , connectDBus , connectDBusX , disconnectDBus @@ -34,8 +39,37 @@ data DBusState = DBusState , dbSysClient :: Maybe SysClient } +withDBusX_ + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (DBusState -> m a) + -> m () +withDBusX_ = void . withDBusX_ + +withDBusX + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (DBusState -> m a) + -> m (Maybe a) +withDBusX f = withDBus $ \db -> + -- TODO log error if this fails + forM (dbSesClient db) $ \ses -> + bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db) + +withDBus_ + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (DBusState -> m a) + -> m () +withDBus_ = void . withDBus + +withDBus + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (DBusState -> m a) + -> m a +withDBus = bracket connectDBus disconnectDBus + -- | Connect to the DBus -connectDBus :: MonadUnliftIO m => m DBusState +connectDBus + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => m DBusState connectDBus = do ses <- getDBusClient sys <- getDBusClient @@ -48,14 +82,17 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient disc f = maybe (return ()) disconnectDBusClient $ f db -- | Connect to the DBus and request the XMonad name -connectDBusX :: MonadUnliftIO m => m DBusState +connectDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => m DBusState connectDBusX = do db <- connectDBus forM_ (dbSesClient db) requestXMonadName return db -- | Disconnect from DBus and release the XMonad name -disconnectDBusX :: MonadUnliftIO m => DBusState -> m () +disconnectDBusX + :: MonadUnliftIO m + => DBusState + -> m () disconnectDBusX db = do forM_ (dbSesClient db) releaseXMonadName disconnectDBus db @@ -64,8 +101,12 @@ disconnectDBusX db = do dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] -releaseXMonadName :: MonadUnliftIO m => SesClient -> m () -releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName +releaseXMonadName + :: MonadUnliftIO m + => SesClient + -> m () +releaseXMonadName ses = do + liftIO $ void $ releaseName (toClient ses) xmonadBusName requestXMonadName :: MonadUnliftIO m => SesClient -> m () requestXMonadName ses = do diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 2fd17b0..7605953 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -13,8 +13,8 @@ import Xmobar.Plugins.Common startBacklight :: (MonadUnliftIO m, RealFrac a) - => ((Maybe a -> m ()) -> SesClient -> m ()) - -> (SesClient -> m (Maybe a)) + => ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ()) + -> (SesClient -> RIO SimpleApp (Maybe a)) -> T.Text -> Callback -> m () diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 98b9acc..1983bba 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -70,6 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na) withDBusClientConnection :: (MonadUnliftIO m, SafeClient c) => Callback - -> (c -> m ()) + -> (c -> RIO SimpleApp ()) -> m () -withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient +withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient