ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Revert "WIP use unliftio everywhere-ish" 

This reverts commit 769df2fb00.
This commit is contained in:
Nathan Dwarshuis 2022-12-30 10:56:09 -05:00
parent 769df2fb00
commit d560db1548
26 changed files with 258 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
bin/xmobar.hs
View File

@ -56,20 +56,17 @@ main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse [] = run parse [] = run
parse ["--deps"] = withCache printDeps parse ["--deps"] = withCache printDeps
parse ["--test"] = withCache $ do parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
db <- connectDBus
void $ evalConfig db
parse _ = usage parse _ = usage
run :: IO () run :: IO ()
run = run = do
withCache $ do db <- connectDBus
db <- connectDBus c <- withCache $ evalConfig db
c <- evalConfig db disconnectDBus db
disconnectDBus db -- this is needed to see any printed messages
-- this is needed to see any printed messages hFlush stdout
liftIO $ hFlush stdout xmobar c
liftIO $ xmobar c
evalConfig :: DBusState -> FIO Config evalConfig :: DBusState -> FIO Config
evalConfig db = do evalConfig db = do
@ -81,10 +78,10 @@ evalConfig db = do
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = do
db <- connectDBus 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
disconnectDBus db io $ disconnectDBus db
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage = putStrLn $ intercalate "\n"

9
bin/xmonad.hs
View File

@ -8,8 +8,12 @@
module Main (main) where module Main (main) where
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.List
import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Text.IO (hPutStrLn) import Data.Text.IO (hPutStrLn)
@ -19,7 +23,6 @@ import Graphics.X11.Xlib.Extras
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.List
import RIO.Process import RIO.Process
import qualified RIO.Text as T import qualified RIO.Text as T
@ -201,7 +204,7 @@ 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 :: (DBusState -> FIO a) -> FIO a
withDBusX = bracket connectDBusX cleanup withDBusX = bracket (io connectDBusX) cleanup
where where
cleanup db = do cleanup db = do
logInfo "unregistering xmonad from DBus" logInfo "unregistering xmonad from DBus"
@ -223,7 +226,7 @@ withXmobar = bracket startXmobar cleanup
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = do
db <- connectDBus db <- io connectDBus
(i, f, d) <- allFeatures db (i, f, d) <- allFeatures db
io $ mapM_ (putStrLn . T.unpack) io $ mapM_ (putStrLn . T.unpack)
$ fmap showFulfillment $ fmap showFulfillment

144
lib/Data/Internal/DBus.hs
View File

@ -27,9 +27,14 @@ module Data.Internal.DBus
, bodyToMaybe , bodyToMaybe
) where ) where
import RIO import Control.Exception
import qualified RIO.Map as M import Control.Monad
import qualified RIO.Text as T
import Data.Bifunctor
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified RIO.Text as T
import DBus import DBus
import DBus.Client import DBus.Client
@ -40,38 +45,23 @@ import DBus.Client
class SafeClient c where class SafeClient c where
toClient :: c -> Client toClient :: c -> Client
getDBusClient getDBusClient :: IO (Maybe c)
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> m (Maybe c)
disconnectDBusClient disconnectDBusClient :: c -> IO ()
:: (MonadUnliftIO m) disconnectDBusClient = disconnect . toClient
=> c
-> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient withDBusClient :: (c -> IO a) -> IO (Maybe a)
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> (c -> m a)
-> m (Maybe a)
-- TODO bracket
withDBusClient f = do withDBusClient f = do
client <- getDBusClient client <- getDBusClient
forM client $ \c -> do forM client $ \c -> do
r <- f c r <- f c
liftIO $ disconnect (toClient c) disconnect (toClient c)
return r return r
withDBusClient_ withDBusClient_ :: (c -> IO ()) -> IO ()
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> (c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient withDBusClient_ = void . withDBusClient
fromDBusClient fromDBusClient :: (c -> a) -> IO (Maybe a)
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> (c -> a)
-> m (Maybe a)
fromDBusClient f = withDBusClient (return . f) fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client newtype SysClient = SysClient Client
@ -79,25 +69,20 @@ 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 <$> getDBusClient' 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 <$> getDBusClient' False
getDBusClient_ getDBusClient' :: Bool -> IO (Maybe Client)
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) getDBusClient' sys = do
=> Bool res <- try $ if sys then connectSystem else connectSession
-> m (Maybe Client)
getDBusClient_ sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of case res of
Left e -> do Left e -> putStrLn (clientErrorMessage e) >> return Nothing
logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
return Nothing
Right c -> return $ Just c Right c -> return $ Just c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -105,14 +90,12 @@ getDBusClient_ sys = do
type MethodBody = Either T.Text [Variant] type MethodBody = Either T.Text [Variant]
callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' cl = callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl) . call (toClient cl)
callMethod :: (MonadIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> m MethodBody -> MemberName -> IO MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@ -125,7 +108,7 @@ methodCallBus b p i m = (methodCall p i m)
dbusInterface :: InterfaceName dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus" dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: (MonadIO m, SafeClient c) => c -> BusName -> m (Maybe BusName) callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
where where
mc = (methodCallBus dbusName dbusPath dbusInterface mem) mc = (methodCallBus dbusName dbusPath dbusInterface mem)
@ -146,14 +129,9 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback = [Variant] -> IO () type SignalCallback = [Variant] -> IO ()
addMatchCallback addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
:: (MonadIO m, SafeClient c) -> IO SignalHandler
=> MatchRule addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
-> SignalCallback
-> c
-> m SignalHandler
addMatchCallback rule cb cl =
liftIO $ addMatch (toClient cl) rule $ cb . signalBody
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> MatchRule -> Maybe MemberName -> MatchRule
@ -164,14 +142,8 @@ matchSignal b p i m = matchAny
, matchMember = m , matchMember = m
} }
matchSignalFull matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
:: (MonadIO m, SafeClient c) -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
matchSignalFull client b p i m = matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
@ -184,29 +156,23 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged" propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
-> MemberName -> c -> m [Variant] -> MemberName -> c -> IO [Variant]
callPropertyGet bus path iface property cl = callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
liftIO
$ fmap (either (const []) (:[]))
$ getProperty (toClient cl) $ methodCallBus bus path iface property $ getProperty (toClient cl) $ methodCallBus bus path iface property
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p = matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal) matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
:: (MonadIO m, SafeClient c) -> IO (Maybe MatchRule)
=> c
-> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull cl b p = matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
withSignalMatch :: Monad m => (Maybe a -> m ()) -> SignalMatch a -> m () withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
withSignalMatch f (Match x) = f (Just x) withSignalMatch f (Match x) = f (Just x)
withSignalMatch f Failure = f Nothing withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return () withSignalMatch _ NoMatch = return ()
@ -242,44 +208,24 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved" omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
:: (MonadIO m, SafeClient c) -> IO ObjectTree
=> c
-> BusName
-> ObjectPath
-> m ObjectTree
callGetManagedObjects cl bus path = callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod cl bus path omInterface getManagedObjects <$> callMethod cl bus path omInterface getManagedObjects
addInterfaceChangedListener addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
:: (MonadIO m, SafeClient c) -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback
-> c
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl forM rule $ \r -> addMatchCallback r sc cl
addInterfaceAddedListener addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
:: (MonadIO m, SafeClient c) -> SignalCallback -> c -> IO (Maybe SignalHandler)
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus = addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
:: (MonadIO m, SafeClient c) -> SignalCallback -> c -> IO (Maybe SignalHandler)
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus = addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved addInterfaceChangedListener bus omInterfacesRemoved

31
lib/Data/Internal/Dependency.hs
View File

@ -106,31 +106,38 @@ module Data.Internal.Dependency
, shellTest , shellTest
) where ) where
import Data.Aeson hiding (Error, Result) import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Bifunctor
import Data.Either
import Data.Internal.DBus import Data.Internal.DBus
import Data.List
import Data.Maybe
import Data.Yaml import Data.Yaml
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf) import DBus hiding (typeOf)
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import RIO hiding (bracket, fromString) import RIO hiding (bracket, fromString)
import RIO.Directory
import RIO.FilePath import RIO.FilePath
import RIO.List import RIO.Process hiding (findExecutable)
import RIO.Process hiding (findExecutable) import qualified RIO.Text as T
import qualified RIO.Text as T
import System.Directory
import System.Environment import System.Environment
import System.IO.Error import System.IO.Error
import System.Posix.Files import System.Posix.Files
import System.Process.Typed (nullStream) import System.Process.Typed (nullStream)
import XMonad.Core (X, io) import XMonad.Core (X, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess) import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme import XMonad.Internal.Theme
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

5
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -24,9 +24,12 @@ import DBus
import Graphics.X11.Types import Graphics.X11.Types
import RIO.Directory
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory
( XdgDirectory (..)
, getXdgDirectory
)
import System.IO import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)

2
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -47,11 +47,11 @@ import Data.Internal.Dependency
import DBus import DBus
import RIO import RIO
import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Process as P import qualified RIO.Process as P
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory
import System.Environment import System.Environment
import System.Posix.User import System.Posix.User

6
lib/XMonad/Internal/Command/Power.hs
View File

@ -29,15 +29,17 @@ module XMonad.Internal.Command.Power
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.Either
import qualified Data.Map as M
import Graphics.X11.Types import Graphics.X11.Types
import RIO import RIO
import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Map as M
import qualified RIO.Process as P import qualified RIO.Process as P
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory
import System.IO.Error import System.IO.Error
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)

1
lib/XMonad/Internal/Concurrent/ClientMessage.hs
View File

@ -19,7 +19,6 @@ module XMonad.Internal.Concurrent.ClientMessage
( XMsgType(..) ( XMsgType(..)
, sendXMsg , sendXMsg
, splitXMsg , splitXMsg
, withOpenDisplay
) where ) where
import Data.Char import Data.Char

15
lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
View File

@ -33,7 +33,17 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
, doSink , doSink
) where ) where
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
-- import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Event
@ -45,8 +55,6 @@ import RIO hiding
( Display ( Display
, display , display
) )
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Set as S import qualified RIO.Set as S
import System.Process import System.Process
@ -98,6 +106,9 @@ data WConf = WConf
type W a = RIO WConf () type W a = RIO WConf ()
withOpenDisplay :: (Display -> IO a) -> IO a
withOpenDisplay = bracket (openDisplay "") closeDisplay
runWorkspaceMon :: [DynWorkspace] -> IO () runWorkspaceMon :: [DynWorkspace] -> IO ()
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy

4
lib/XMonad/Internal/Concurrent/VirtualBox.hs
View File

@ -12,13 +12,13 @@ module XMonad.Internal.Concurrent.VirtualBox
import Data.Internal.Dependency import Data.Internal.Dependency
import Text.XML.Light
import RIO hiding (try) import RIO hiding (try)
import RIO.Directory import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Text as T import qualified RIO.Text as T
import Text.XML.Light
import XMonad.Internal.Shell import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg) vmExists :: T.Text -> IO (Maybe Msg)

4
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -12,12 +12,14 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
, blPath , blPath
) where ) where
import Control.Monad (when)
import Data.Int (Int32)
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import DBus import DBus
import RIO
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common

4
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -13,6 +13,9 @@ module XMonad.Internal.DBus.Brightness.Common
, signalDep , signalDep
) where ) where
import Control.Monad (void)
import Data.Int (Int32)
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
@ -20,7 +23,6 @@ import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Core (io) import XMonad.Core (io)

2
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -12,12 +12,12 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
, blPath , blPath
) where ) where
import Data.Int (Int32)
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import DBus import DBus
import RIO
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common

53
lib/XMonad/Internal/DBus/Control.hs
View File

@ -1,8 +1,8 @@
-- | High-level interface for managing XMonad's DBus
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control module XMonad.Internal.DBus.Control
( Client ( Client
, DBusState(..) , DBusState(..)
@ -17,15 +17,14 @@ module XMonad.Internal.DBus.Control
, dbusExporters , dbusExporters
) where ) where
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import DBus import DBus
import DBus.Client import DBus.Client
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -38,36 +37,27 @@ data DBusState = DBusState
} }
-- | Connect to the DBus -- | Connect to the DBus
connectDBus connectDBus :: IO DBusState
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> m DBusState
connectDBus = do connectDBus = do
ses <- getDBusClient ses <- getDBusClient
sys <- getDBusClient sys <- getDBusClient
return DBusState { dbSesClient = ses, dbSysClient = sys } return DBusState { dbSesClient = ses, dbSysClient = sys }
-- | Disconnect from the DBus -- | Disconnect from the DBus
disconnectDBus disconnectDBus :: DBusState -> IO ()
:: (MonadUnliftIO m)
=> DBusState -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient disconnectDBus db = disc dbSesClient >> disc dbSysClient
where where
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 connectDBusX :: IO DBusState
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> 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 disconnectDBusX :: DBusState -> IO ()
:: (MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBusX db = do disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db disconnectDBus db
@ -76,25 +66,18 @@ disconnectDBusX db = do
dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName releaseXMonadName :: SesClient -> IO ()
:: (MonadUnliftIO m) releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
=> SesClient
-> m ()
releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName
requestXMonadName requestXMonadName :: SesClient -> IO ()
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> SesClient
-> m ()
requestXMonadName ses = do requestXMonadName ses = do
res <- liftIO $ requestName (toClient ses) xmonadBusName [] res <- requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different -- TODO if the client is not released on shutdown the owner will be different
let msg | res == NamePrimaryOwner = Nothing let msg | res == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just "this process already owns bus name" | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
| res == NameInQueue | res == NameInQueue
|| res == NameExists = Just "another process owns bus name" || res == NameExists = Just $ "another process owns " ++ xn
| otherwise = Just "unknown error when requesting bus name" | otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg $ \m -> forM_ msg putStrLn
logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
where where
xn = T.pack $ formatBusName xmonadBusName xn = "'" ++ formatBusName xmonadBusName ++ "'"

8
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -8,15 +8,15 @@
module XMonad.Internal.DBus.Removable (runRemovableMon) where module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.Map.Strict (Map, member)
import DBus import DBus
import DBus.Client import DBus.Client
import RIO
import qualified RIO.Map as M
import XMonad.Core (io) import XMonad.Core (io)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
@ -60,7 +60,7 @@ driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive" driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool addedHasDrive :: [Variant] -> Bool
addedHasDrive [_, a] = maybe False (M.member driveFlag) addedHasDrive [_, a] = maybe False (member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant))) (fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False addedHasDrive _ = False

19
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -14,15 +14,15 @@ module XMonad.Internal.DBus.Screensaver
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver
import RIO import RIO
import XMonad.Internal.Concurrent.ClientMessage import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell import XMonad.Internal.Shell
@ -45,7 +45,10 @@ toggle = do
query :: IO SSState query :: IO SSState
query = do query = do
xssi <- withOpenDisplay xScreenSaverQueryInfo -- TODO bracket the display
dpy <- openDisplay ""
xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy
return $ case xssi of return $ case xssi of
Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
Just XScreenSaverInfo { xssi_state = _ } -> True Just XScreenSaverInfo { xssi_state = _ } -> True

7
lib/XMonad/Internal/IO.hs
View File

@ -25,11 +25,12 @@ module XMonad.Internal.IO
) where ) where
import Data.Char import Data.Char
import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile)
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Text as T
import System.IO.Error import System.IO.Error
@ -37,7 +38,7 @@ import System.IO.Error
-- | read -- | read
readInt :: (Read a, Integral a) => FilePath -> IO a readInt :: (Read a, Integral a) => FilePath -> IO a
readInt = fmap (read . T.unpack . T.takeWhile isDigit) . readFileUtf8 readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
readBool :: FilePath -> IO Bool readBool :: FilePath -> IO Bool
readBool = fmap (==(1 :: Int)) . readInt readBool = fmap (==(1 :: Int)) . readInt
@ -46,7 +47,7 @@ readBool = fmap (==(1 :: Int)) . readInt
-- | write -- | write
writeInt :: (Show a, Integral a) => FilePath -> a -> IO () writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
writeInt f = writeFileUtf8 f . T.pack . show writeInt f = T.writeFile f . pack . show
writeBool :: FilePath -> Bool -> IO () writeBool :: FilePath -> Bool -> IO ()
writeBool f b = writeInt f ((if b then 1 else 0) :: Int) writeBool f b = writeInt f ((if b then 1 else 0) :: Int)

17
lib/XMonad/Internal/Process.hs Normal file
View File

@ -0,0 +1,17 @@
--------------------------------------------------------------------------------
-- | Functions for managing processes
module XMonad.Internal.Process where
-- import Control.Exception
-- import Control.Monad
-- import Control.Monad.IO.Class
-- import qualified RIO.Text as T
-- import System.Exit
-- import System.IO
-- import System.Process
-- import XMonad.Core hiding (spawn)

9
lib/Xmobar/Plugins/BacklightCommon.hs
View File

@ -10,7 +10,6 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
import Data.Internal.DBus import Data.Internal.DBus
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
@ -18,9 +17,9 @@ import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ()) startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO () -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
startBacklight matchSignal callGetBrightness icon cb = do startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> liftIO $ do withDBusClientConnection cb $ \c -> do
matchSignal dpy c matchSignal display c
dpy =<< callGetBrightness c display =<< callGetBrightness c
where where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
dpy = displayMaybe cb formatBrightness display = displayMaybe cb formatBrightness

96
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -38,16 +38,19 @@ module Xmobar.Plugins.Bluetooth
, btDep , btDep
) where ) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.List
import Data.List.Split import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import DBus import DBus
import DBus.Client import DBus.Client
import RIO
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -68,24 +71,23 @@ instance Exec Bluetooth where
start (Bluetooth icons colors) cb = start (Bluetooth icons colors) cb =
withDBusClientConnection cb $ startAdapter icons colors cb withDBusClientConnection cb $ startAdapter icons colors cb
startAdapter :: MonadIO m => Icons -> Colors -> Callback -> SysClient -> m () startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
startAdapter is cs cb cl = do startAdapter is cs cb cl = do
ot <- getBtObjectTree cl ot <- getBtObjectTree cl
-- TODO use RIO for this?
state <- newMVar emptyState state <- newMVar emptyState
let dpy = displayIcon cb (iconFormatter is cs) state let display = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> liftIO $ do forM_ (findAdapter ot) $ \adapter -> do
-- set up adapter -- set up adapter
initAdapter state adapter cl initAdapter state adapter cl
-- TODO this step could fail; at least warn the user... -- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state dpy adapter cl void $ addAdaptorListener state display adapter cl
-- set up devices on the adapter (and listeners for adding/removing devices) -- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot let devices = findDevices adapter ot
addDeviceAddedListener state dpy adapter cl addDeviceAddedListener state display adapter cl
addDeviceRemovedListener state dpy adapter cl addDeviceRemovedListener state display adapter cl
forM_ devices $ \d -> addAndInitDevice state dpy d cl forM_ devices $ \d -> addAndInitDevice state display d cl
-- after setting things up, show the icon based on the initialized state -- after setting things up, show the icon based on the initialized state
dpy display
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Icon Display -- | Icon Display
@ -97,9 +99,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text) type Icons = (T.Text, T.Text)
displayIcon :: MonadIO m => Callback -> IconFormatter -> MutableBtState -> m () displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
displayIcon callback formatter = displayIcon callback formatter =
liftIO . callback . T.unpack . uncurry formatter <=< readState callback . T.unpack . uncurry formatter <=< readState
-- TODO maybe I want this to fail when any of the device statuses are Nothing -- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter iconFormatter :: Icons -> Colors -> IconFormatter
@ -136,7 +138,7 @@ emptyState = BtState
, btPowered = Nothing , btPowered = Nothing
} }
readState :: MonadIO m => MutableBtState -> m (Maybe Bool, Bool) readState :: MutableBtState -> IO (Maybe Bool, Bool)
readState state = do readState state = do
p <- readPowered state p <- readPowered state
c <- readDevices state c <- readDevices state
@ -159,55 +161,55 @@ adaptorHasDevice adaptor device = case splitPath device of
splitPath :: ObjectPath -> [T.Text] splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
getBtObjectTree :: MonadIO m => SysClient -> m ObjectTree getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
btOMPath :: ObjectPath btOMPath :: ObjectPath
btOMPath = objectPath_ "/" btOMPath = objectPath_ "/"
addBtOMListener :: MonadIO m => SignalCallback -> SysClient -> m () addBtOMListener :: SignalCallback -> SysClient -> IO ()
addBtOMListener sc = liftIO . void . addInterfaceAddedListener btBus btOMPath sc addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state dpy adapter client = addDeviceAddedListener state display adapter client =
addBtOMListener addDevice client addBtOMListener addDevice client
where where
addDevice = pathCallback adapter dpy $ \d -> addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state dpy d client addAndInitDevice state display d client
addDeviceRemovedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceRemovedListener state dpy adapter sys = addDeviceRemovedListener state display adapter sys =
addBtOMListener remDevice sys addBtOMListener remDevice sys
where where
remDevice = pathCallback adapter dpy $ \d -> do remDevice = pathCallback adapter display $ \d -> do
old <- removeDevice state d old <- removeDevice state d
forM_ old $ removeMatch (toClient sys) . btDevSigHandler forM_ old $ removeMatch (toClient sys) . btDevSigHandler
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d -> pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> dpy when (adaptorHasDevice adapter d) $ f d >> display
pathCallback _ _ _ _ = return () pathCallback _ _ _ _ = return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Adapter -- | Adapter
initAdapter :: MonadIO m => MutableBtState -> ObjectPath -> SysClient -> m () initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do initAdapter state adapter client = do
reply <- callGetPowered adapter client reply <- callGetPowered adapter client
liftIO $ putPowered state $ fromSingletonVariant reply putPowered state $ fromSingletonVariant reply
matchBTProperty :: MonadIO m => SysClient -> ObjectPath -> m (Maybe MatchRule) matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p) matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> m (Maybe SignalHandler) -> IO (Maybe SignalHandler)
addAdaptorListener state dpy adaptor sys = do addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
where where
procMatch = withSignalMatch $ \b -> liftIO $ putPowered state b >> dpy procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: MonadIO m => ObjectPath -> SysClient -> m [Variant] callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ $ T.unpack adaptorPowered $ memberName_ $ T.unpack adaptorPowered
@ -217,7 +219,7 @@ matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: MutableBtState -> Maybe Bool -> IO () putPowered :: MutableBtState -> Maybe Bool -> IO ()
putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds }) putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
readPowered :: MonadIO m => MutableBtState -> m (Maybe Bool) readPowered :: MutableBtState -> IO (Maybe Bool)
readPowered = fmap btPowered . readMVar readPowered = fmap btPowered . readMVar
adapterInterface :: InterfaceName adapterInterface :: InterfaceName
@ -229,13 +231,13 @@ adaptorPowered = "Powered"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Devices -- | Devices
addAndInitDevice :: MonadUnliftIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state dpy device client = do addAndInitDevice state display device client = do
sh <- addDeviceListener state dpy device client sh <- addDeviceListener state display device client
-- TODO add some intelligent error messages here -- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client forM_ sh $ \s -> initDevice state s device client
initDevice :: MonadUnliftIO m => MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> m () initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice state sh device sys = do initDevice state sh device sys = do
reply <- callGetConnected device sys reply <- callGetConnected device sys
void $ insertDevice state device $ void $ insertDevice state device $
@ -243,22 +245,22 @@ initDevice state sh device sys = do
, btDevSigHandler = sh , btDevSigHandler = sh
} }
addDeviceListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> m (Maybe SignalHandler) -> IO (Maybe SignalHandler)
addDeviceListener state dpy device sys = do addDeviceListener state display device sys = do
rule <- matchBTProperty sys device rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
where where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
matchConnected :: [Variant] -> SignalMatch Bool matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: MonadIO m => ObjectPath -> SysClient -> m [Variant] callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface callGetConnected p = callPropertyGet btBus p devInterface
$ memberName_ (T.unpack devConnected) $ memberName_ (T.unpack devConnected)
insertDevice :: MonadUnliftIO m => MutableBtState -> ObjectPath -> BTDevice -> m Bool insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s let new = M.insert device dev $ btDevices s
return (s { btDevices = new }, anyDevicesConnected new) return (s { btDevices = new }, anyDevicesConnected new)
@ -276,7 +278,7 @@ removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s let devs = btDevices s
return (s { btDevices = M.delete device devs }, M.lookup device devs) return (s { btDevices = M.delete device devs }, M.lookup device devs)
readDevices :: MonadIO m => MutableBtState -> m ConnectedDevices readDevices :: MutableBtState -> IO ConnectedDevices
readDevices = fmap btDevices . readMVar readDevices = fmap btDevices . readMVar
devInterface :: InterfaceName devInterface :: InterfaceName

1
lib/Xmobar/Plugins/ClevoKeyboard.hs
View File

@ -14,6 +14,7 @@ module Xmobar.Plugins.ClevoKeyboard
import qualified RIO.Text as T import qualified RIO.Text as T
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard

35
lib/Xmobar/Plugins/Common.hs
View File

@ -10,17 +10,18 @@ module Xmobar.Plugins.Common
, Callback , Callback
, Colors(..) , Colors(..)
, displayMaybe , displayMaybe
, displayMaybe_ , displayMaybe'
, xmobarFGColor , xmobarFGColor
) )
where where
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import DBus import DBus
import DBus.Client import DBus.Client
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
@ -34,21 +35,17 @@ data Colors = Colors
} }
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
startListener :: (MonadIO m, SafeClient c, IsVariant a) => MatchRule -> (c -> m [Variant]) startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
-> c -> m () -> c -> IO ()
startListener rule getProp fromSignal toColor cb client = do startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client reply <- getProp client
displayMaybe cb (liftIO . toColor) $ fromSingletonVariant reply displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client void $ addMatchCallback rule (procMatch . fromSignal) client
where where
procMatch = procSignalMatch cb toColor procMatch = procSignalMatch cb toColor
procSignalMatch procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
:: Callback
-> (a -> IO T.Text)
-> SignalMatch a
-> IO ()
procSignalMatch cb f = withSignalMatch (displayMaybe cb f) procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
colorText :: Colors -> Bool -> T.Text -> T.Text colorText :: Colors -> Bool -> T.Text -> T.Text
@ -61,17 +58,11 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
na :: T.Text na :: T.Text
na = "N/A" na = "N/A"
displayMaybe :: (MonadIO m) => Callback -> (a -> m T.Text) -> Maybe a -> m () displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
displayMaybe_ :: MonadIO m => Callback -> (a -> m ()) -> Maybe a -> m () displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
displayMaybe_ cb = maybe (liftIO $ cb $ T.unpack na) displayMaybe' cb = maybe (cb $ T.unpack na)
withDBusClientConnection withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
:: (SafeClient c) withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
=> Callback
-> (c -> RIO SimpleApp ())
-> IO ()
withDBusClientConnection cb f = do
-- TODO be more sophisticated
runSimpleApp $ withDBusClient_ $ displayMaybe_ cb f . Just

8
lib/Xmobar/Plugins/Device.hs
View File

@ -11,12 +11,14 @@ module Xmobar.Plugins.Device
, devDep , devDep
) where ) where
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.Word
import DBus import DBus
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
@ -62,9 +64,9 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where instance Exec Device where
alias (Device (iface, _, _)) = T.unpack iface alias (Device (iface, _, _)) = T.unpack iface
start (Device (iface, text, colors)) cb = do start (Device (iface, text, colors)) cb = do
withDBusClientConnection cb $ \sys -> liftIO $ do withDBusClientConnection cb $ \sys -> do
path <- getDevice sys iface path <- getDevice sys iface
displayMaybe_ cb (listener sys) path displayMaybe' cb (listener sys) path
where where
listener sys path = do listener sys path = do
rule <- matchPropertyFull sys networkManagerBus (Just path) rule <- matchPropertyFull sys networkManagerBus (Just path)

1
lib/Xmobar/Plugins/IntelBacklight.hs
View File

@ -14,6 +14,7 @@ module Xmobar.Plugins.IntelBacklight
import qualified RIO.Text as T import qualified RIO.Text as T
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight

9
lib/Xmobar/Plugins/Screensaver.hs
View File

@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver
, ssAlias , ssAlias
) where ) where
import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import Xmobar import Xmobar
@ -27,9 +26,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb = do start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \sys -> liftIO $ do withDBusClientConnection cb $ \sys -> do
matchSignal dpy sys matchSignal display sys
dpy =<< callQuery sys display =<< callQuery sys
where where
dpy = displayMaybe cb $ return . (\s -> colorText colors s text) display = displayMaybe cb $ return . (\s -> colorText colors s text)

30
lib/Xmobar/Plugins/VPN.hs
View File

@ -13,15 +13,17 @@ module Xmobar.Plugins.VPN
, vpnDep , vpnDep
) where ) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import DBus import DBus
import RIO
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
@ -36,11 +38,11 @@ instance Exec VPN where
start (VPN (text, colors)) cb = start (VPN (text, colors)) cb =
withDBusClientConnection cb $ \c -> do withDBusClientConnection cb $ \c -> do
state <- initState c state <- initState c
let dpy = displayMaybe cb iconFormatter . Just =<< readState state let display = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state dpy let signalCallback' f = f state display
vpnAddedListener (signalCallback' addedCallback) c vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c vpnRemovedListener (signalCallback' removedCallback) c
liftIO dpy display
where where
iconFormatter b = return $ colorText colors b text iconFormatter b = return $ colorText colors b text
@ -55,7 +57,7 @@ type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState type MutableVPNState = MVar VPNState
initState :: MonadIO m => SysClient -> m MutableVPNState initState :: SysClient -> IO MutableVPNState
initState client = do initState client = do
ot <- getVPNObjectTree client ot <- getVPNObjectTree client
newMVar $ findTunnels ot newMVar $ findTunnels ot
@ -63,28 +65,28 @@ initState client = do
readState :: MutableVPNState -> IO Bool readState :: MutableVPNState -> IO Bool
readState = fmap (not . null) . readMVar readState = fmap (not . null) . readMVar
updateState :: MonadUnliftIO m => (ObjectPath -> VPNState -> VPNState) -> MutableVPNState updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-> ObjectPath -> m () -> ObjectPath -> IO ()
updateState f state op = modifyMVar_ state $ return . f op updateState f state op = modifyMVar_ state $ return . f op
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Tunnel Device Detection -- | Tunnel Device Detection
-- --
getVPNObjectTree :: MonadIO m => SysClient -> m ObjectTree getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys) findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: MonadIO m => SignalCallback -> SysClient -> m () vpnAddedListener :: SignalCallback -> SysClient -> IO ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: MonadIO m => SignalCallback -> SysClient -> m () vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MutableVPNState -> IO () -> SignalCallback addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state dpy [device, added] = update >> dpy addedCallback state display [device, added] = update >> display
where where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant)) added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added' is = M.keys $ fromMaybe M.empty added'
@ -92,7 +94,7 @@ addedCallback state dpy [device, added] = update >> dpy
addedCallback _ _ _ = return () addedCallback _ _ _ = return ()
removedCallback :: MutableVPNState -> IO () -> SignalCallback removedCallback :: MutableVPNState -> IO () -> SignalCallback
removedCallback state dpy [device, interfaces] = update >> dpy removedCallback state display [device, interfaces] = update >> display
where where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text] is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is update = updateDevice S.delete state device is