Compare commits

...

1 Commits

Author SHA1 Message Date
Nathan Dwarshuis 73ed6b9734 ENH run xmonad and xmobar totally in rio 2022-12-31 21:03:58 -05:00
6 changed files with 90 additions and 46 deletions

View File

@ -46,15 +46,14 @@ main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse [] = run parse [] = run
parse ["--deps"] = withCache printDeps parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus parse ["--test"] = withCache $ withDBus_ evalConfig
parse _ = usage parse _ = usage
run :: IO () run :: IO ()
run = do run = withCache $ withDBus_ $ \db -> do
db <- connectDBus c <- evalConfig db
c <- withCache $ evalConfig db
disconnectDBus db
-- this is needed to see any printed messages -- this is needed to see any printed messages
liftIO $ do
hFlush stdout hFlush stdout
xmobar c xmobar c
@ -67,11 +66,9 @@ evalConfig db = do
return $ config bf ifs ios cs d return $ config bf ifs ios cs d
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = withDBus_ $ \db -> do
db <- io connectDBus
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
io $ mapM_ (putStrLn . T.unpack) ps io $ mapM_ (putStrLn . T.unpack) ps
io $ disconnectDBus db
usage :: IO () usage :: IO ()
usage = usage =

View File

@ -89,7 +89,7 @@ run = do
uninstallSignalHandlers uninstallSignalHandlers
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
withCache $ do withCache $ do
withDBusX $ \db -> do withDBusX_ $ \db -> do
let sys = dbSysClient db let sys = dbSysClient db
let fs = features sys let fs = features sys
startDBusInterfaces db fs startDBusInterfaces db fs
@ -204,13 +204,6 @@ startXmobar = do
startChildDaemons :: FeatureSet -> FIO [Process () () ()] startChildDaemons :: FeatureSet -> FIO [Process () () ()]
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) 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 :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
withChildDaemons fs = bracket (startChildDaemons fs) cleanup withChildDaemons fs = bracket (startChildDaemons fs) cleanup
where where
@ -226,17 +219,14 @@ withXmobar = bracket startXmobar cleanup
io $ killNoWait p io $ killNoWait p
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = withDBus_ $ \db -> do
db <- io connectDBus
(i, f, d) <- allFeatures db (i, f, d) <- allFeatures db
io $ mapM_ (liftIO . putStrLn . T.unpack) $
mapM_ (putStrLn . T.unpack) $
fmap showFulfillment $ fmap showFulfillment $
sort $ sort $
nub $ nub $
concat $ concat $
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
io $ disconnectDBus db
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = do allFeatures db = do

View File

@ -40,19 +40,30 @@ import qualified RIO.Text as T
class SafeClient c where class SafeClient c where
toClient :: c -> Client 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 :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient 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 = withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM 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 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) fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client newtype SysClient = SysClient Client
@ -60,20 +71,25 @@ newtype SysClient = SysClient Client
instance SafeClient SysClient where instance SafeClient SysClient where
toClient (SysClient cl) = cl toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True getDBusClient = fmap SysClient <$> getSomeDBusClient True
newtype SesClient = SesClient Client newtype SesClient = SesClient Client
instance SafeClient SesClient where instance SafeClient SesClient where
toClient (SesClient cl) = cl toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False getDBusClient = fmap SesClient <$> getSomeDBusClient False
getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client) getSomeDBusClient
getDBusClient' sys = do :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> m (Maybe Client)
getSomeDBusClient sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of 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 Right c -> return $ Just c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -6,6 +7,10 @@
module XMonad.Internal.DBus.Control module XMonad.Internal.DBus.Control
( Client ( Client
, DBusState (..) , DBusState (..)
, withDBus
, withDBus_
, withDBusX
, withDBusX_
, connectDBus , connectDBus
, connectDBusX , connectDBusX
, disconnectDBus , disconnectDBus
@ -34,8 +39,37 @@ data DBusState = DBusState
, dbSysClient :: Maybe SysClient , 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 -- | Connect to the DBus
connectDBus :: MonadUnliftIO m => m DBusState connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBus = do connectDBus = do
ses <- getDBusClient ses <- getDBusClient
sys <- getDBusClient sys <- getDBusClient
@ -48,14 +82,17 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
disc f = maybe (return ()) disconnectDBusClient $ f db disc f = maybe (return ()) disconnectDBusClient $ f db
-- | Connect to the DBus and request the XMonad name -- | 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 connectDBusX = do
db <- connectDBus db <- connectDBus
forM_ (dbSesClient db) requestXMonadName forM_ (dbSesClient db) requestXMonadName
return db return db
-- | Disconnect from DBus and release the XMonad name -- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: MonadUnliftIO m => DBusState -> m () disconnectDBusX
:: MonadUnliftIO m
=> DBusState
-> m ()
disconnectDBusX db = do disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db disconnectDBus db
@ -64,8 +101,12 @@ disconnectDBusX db = do
dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: MonadUnliftIO m => SesClient -> m () releaseXMonadName
releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName :: MonadUnliftIO m
=> SesClient
-> m ()
releaseXMonadName ses = do
liftIO $ void $ releaseName (toClient ses) xmonadBusName
requestXMonadName :: MonadUnliftIO m => SesClient -> m () requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
requestXMonadName ses = do requestXMonadName ses = do

View File

@ -13,8 +13,8 @@ import Xmobar.Plugins.Common
startBacklight startBacklight
:: (MonadUnliftIO m, RealFrac a) :: (MonadUnliftIO m, RealFrac a)
=> ((Maybe a -> m ()) -> SesClient -> m ()) => ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
-> (SesClient -> m (Maybe a)) -> (SesClient -> RIO SimpleApp (Maybe a))
-> T.Text -> T.Text
-> Callback -> Callback
-> m () -> m ()

View File

@ -70,6 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c) :: (MonadUnliftIO m, SafeClient c)
=> Callback => Callback
-> (c -> m ()) -> (c -> RIO SimpleApp ())
-> m () -> m ()
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient