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

WIP use unliftio everywhere-ish

This commit is contained in:
Nathan Dwarshuis 2022-12-30 10:38:21 -05:00
parent 017d13d80c
commit 769df2fb00
26 changed files with 282 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
bin/xmobar.hs
View File

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

9
bin/xmonad.hs
View File

@ -8,12 +8,8 @@
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)
@ -23,6 +19,7 @@ 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
@ -204,7 +201,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 (io connectDBusX) cleanup withDBusX = bracket connectDBusX cleanup
where where
cleanup db = do cleanup db = do
logInfo "unregistering xmonad from DBus" logInfo "unregistering xmonad from DBus"
@ -226,7 +223,7 @@ withXmobar = bracket startXmobar cleanup
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = do
db <- io connectDBus db <- 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,14 +27,9 @@ module Data.Internal.DBus
, bodyToMaybe , bodyToMaybe
) where ) where
import Control.Exception import RIO
import Control.Monad import qualified RIO.Map as M
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
@ -45,23 +40,38 @@ import DBus.Client
class SafeClient c where class SafeClient c where
toClient :: c -> Client toClient :: c -> Client
getDBusClient :: IO (Maybe c) getDBusClient
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> m (Maybe c)
disconnectDBusClient :: c -> IO () disconnectDBusClient
disconnectDBusClient = disconnect . toClient :: (MonadUnliftIO m)
=> c
-> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient :: (c -> IO a) -> IO (Maybe a) withDBusClient
:: (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
disconnect (toClient c) liftIO $ disconnect (toClient c)
return r return r
withDBusClient_ :: (c -> IO ()) -> IO () withDBusClient_
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> (c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a) fromDBusClient
:: (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
@ -69,20 +79,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 <$> 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' :: Bool -> IO (Maybe Client) getDBusClient_
getDBusClient' sys = do :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
res <- try $ if sys then connectSystem else connectSession => Bool
-> m (Maybe Client)
getDBusClient_ sys = do
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of case res of
Left e -> 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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -90,12 +105,14 @@ getDBusClient' sys = do
type MethodBody = Either T.Text [Variant] type MethodBody = Either T.Text [Variant]
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) callMethod' cl =
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl) . call (toClient cl)
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName callMethod :: (MonadIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> IO MethodBody -> MemberName -> m 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
@ -108,7 +125,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 :: SafeClient c => c -> BusName -> IO (Maybe BusName) callGetNameOwner :: (MonadIO m, SafeClient c) => c -> BusName -> m (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)
@ -129,9 +146,14 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
type SignalCallback = [Variant] -> IO () type SignalCallback = [Variant] -> IO ()
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c addMatchCallback
-> IO SignalHandler :: (MonadIO m, SafeClient c)
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody => MatchRule
-> 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
@ -142,8 +164,14 @@ matchSignal b p i m = matchAny
, matchMember = m , matchMember = m
} }
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath matchSignalFull
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule) :: (MonadIO m, SafeClient c)
=> 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
@ -156,23 +184,29 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged" propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName
-> MemberName -> c -> IO [Variant] -> MemberName -> c -> m [Variant]
callPropertyGet bus path iface property cl = fmap (either (const []) (:[])) callPropertyGet bus path iface property cl =
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 :: SafeClient c => c -> BusName -> Maybe ObjectPath matchPropertyFull
-> IO (Maybe MatchRule) :: (MonadIO m, SafeClient c)
=> 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 :: (Maybe a -> IO ()) -> SignalMatch a -> IO () withSignalMatch :: Monad m => (Maybe a -> m ()) -> SignalMatch a -> m ()
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 ()
@ -208,24 +242,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved" omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath callGetManagedObjects
-> IO ObjectTree :: (MonadIO m, SafeClient c)
=> 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 :: SafeClient c => BusName -> MemberName addInterfaceChangedListener
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler) :: (MonadIO m, SafeClient c)
=> 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 :: SafeClient c => BusName -> ObjectPath addInterfaceAddedListener
-> SignalCallback -> c -> IO (Maybe SignalHandler) :: (MonadIO m, SafeClient c)
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus = addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath addInterfaceRemovedListener
-> SignalCallback -> c -> IO (Maybe SignalHandler) :: (MonadIO m, SafeClient c)
=> 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,38 +106,31 @@ module Data.Internal.Dependency
, shellTest , shellTest
) where ) where
import Control.Monad.IO.Class import Data.Aeson hiding (Error, Result)
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.Process hiding (findExecutable) import RIO.List
import qualified RIO.Text as T import RIO.Process hiding (findExecutable)
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,12 +24,9 @@ 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,17 +29,15 @@ 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,6 +19,7 @@ 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,17 +33,7 @@ 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
@ -55,6 +45,8 @@ 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
@ -106,9 +98,6 @@ 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,14 +12,12 @@ 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,9 +13,6 @@ 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
@ -23,6 +20,7 @@ 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 @@
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus -- | High-level interface for managing XMonad's DBus
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module XMonad.Internal.DBus.Control module XMonad.Internal.DBus.Control
( Client ( Client
, DBusState(..) , DBusState(..)
@ -17,14 +17,15 @@ 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
@ -37,27 +38,36 @@ data DBusState = DBusState
} }
-- | Connect to the DBus -- | Connect to the DBus
connectDBus :: IO DBusState connectDBus
:: (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 :: DBusState -> IO () disconnectDBus
:: (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 :: IO DBusState connectDBusX
:: (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 :: DBusState -> IO () disconnectDBusX
:: (MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBusX db = do disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db disconnectDBus db
@ -66,18 +76,25 @@ disconnectDBusX db = do
dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: SesClient -> IO () releaseXMonadName
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName :: (MonadUnliftIO m)
=> SesClient
-> m ()
releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName
requestXMonadName :: SesClient -> IO () requestXMonadName
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
=> SesClient
-> m ()
requestXMonadName ses = do requestXMonadName ses = do
res <- requestName (toClient ses) xmonadBusName [] res <- liftIO $ 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 " ++ xn | res == NameAlreadyOwner = Just "this process already owns bus name"
| res == NameInQueue | res == NameInQueue
|| res == NameExists = Just $ "another process owns " ++ xn || res == NameExists = Just "another process owns bus name"
| otherwise = Just $ "unknown error when requesting " ++ xn | otherwise = Just "unknown error when requesting bus name"
forM_ msg putStrLn forM_ msg $ \m ->
logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
where where
xn = "'" ++ formatBusName xmonadBusName ++ "'" xn = T.pack $ 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 (member driveFlag) addedHasDrive [_, a] = maybe False (M.member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant))) (fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False addedHasDrive _ = False

13
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 RIO
import DBus import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import Graphics.X11.XScreenSaver import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
import RIO
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell import XMonad.Internal.Shell
@ -45,10 +45,7 @@ toggle = do
query :: IO SSState query :: IO SSState
query = do query = do
-- TODO bracket the display xssi <- withOpenDisplay xScreenSaverQueryInfo
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,12 +25,11 @@ 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
@ -38,7 +37,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 . takeWhile isDigit . unpack) . T.readFile readInt = fmap (read . T.unpack . T.takeWhile isDigit) . readFileUtf8
readBool :: FilePath -> IO Bool readBool :: FilePath -> IO Bool
readBool = fmap (==(1 :: Int)) . readInt readBool = fmap (==(1 :: Int)) . readInt
@ -47,7 +46,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 = T.writeFile f . pack . show writeInt f = writeFileUtf8 f . T.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
View File

@ -1,17 +0,0 @@
--------------------------------------------------------------------------------
-- | 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,6 +10,7 @@ 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
@ -17,9 +18,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 -> do withDBusClientConnection cb $ \c -> liftIO $ do
matchSignal display c matchSignal dpy c
display =<< callGetBrightness c dpy =<< 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), "%"]
display = displayMaybe cb formatBrightness dpy = displayMaybe cb formatBrightness

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

@ -38,19 +38,16 @@ 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
@ -71,23 +68,24 @@ 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 :: Icons -> Colors -> Callback -> SysClient -> IO () startAdapter :: MonadIO m => Icons -> Colors -> Callback -> SysClient -> m ()
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 display = displayIcon cb (iconFormatter is cs) state let dpy = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> do forM_ (findAdapter ot) $ \adapter -> liftIO $ 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 display adapter cl void $ addAdaptorListener state dpy 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 display adapter cl addDeviceAddedListener state dpy adapter cl
addDeviceRemovedListener state display adapter cl addDeviceRemovedListener state dpy adapter cl
forM_ devices $ \d -> addAndInitDevice state display d cl forM_ devices $ \d -> addAndInitDevice state dpy 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
display dpy
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Icon Display -- | Icon Display
@ -99,9 +97,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text) type Icons = (T.Text, T.Text)
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO () displayIcon :: MonadIO m => Callback -> IconFormatter -> MutableBtState -> m ()
displayIcon callback formatter = 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 -- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter iconFormatter :: Icons -> Colors -> IconFormatter
@ -138,7 +136,7 @@ emptyState = BtState
, btPowered = Nothing , btPowered = Nothing
} }
readState :: MutableBtState -> IO (Maybe Bool, Bool) readState :: MonadIO m => MutableBtState -> m (Maybe Bool, Bool)
readState state = do readState state = do
p <- readPowered state p <- readPowered state
c <- readDevices state c <- readDevices state
@ -161,55 +159,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 :: SysClient -> IO ObjectTree getBtObjectTree :: MonadIO m => SysClient -> m ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
btOMPath :: ObjectPath btOMPath :: ObjectPath
btOMPath = objectPath_ "/" btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> SysClient -> IO () addBtOMListener :: MonadIO m => SignalCallback -> SysClient -> m ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc addBtOMListener sc = liftIO . void . addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () addDeviceAddedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
addDeviceAddedListener state display adapter client = addDeviceAddedListener state dpy adapter client =
addBtOMListener addDevice client addBtOMListener addDevice client
where where
addDevice = pathCallback adapter display $ \d -> addDevice = pathCallback adapter dpy $ \d ->
addAndInitDevice state display d client addAndInitDevice state dpy d client
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () addDeviceRemovedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
addDeviceRemovedListener state display adapter sys = addDeviceRemovedListener state dpy adapter sys =
addBtOMListener remDevice sys addBtOMListener remDevice sys
where where
remDevice = pathCallback adapter display $ \d -> do remDevice = pathCallback adapter dpy $ \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 display f [device, _] = forM_ (fromVariant device) $ \d -> pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> display when (adaptorHasDevice adapter d) $ f d >> dpy
pathCallback _ _ _ _ = return () pathCallback _ _ _ _ = return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Adapter -- | Adapter
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO () initAdapter :: MonadIO m => MutableBtState -> ObjectPath -> SysClient -> m ()
initAdapter state adapter client = do initAdapter state adapter client = do
reply <- callGetPowered adapter client reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply liftIO $ putPowered state $ fromSingletonVariant reply
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule) matchBTProperty :: MonadIO m => SysClient -> ObjectPath -> m (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p) matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient addAdaptorListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler) -> m (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do addAdaptorListener state dpy 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 -> putPowered state b >> display procMatch = withSignalMatch $ \b -> liftIO $ putPowered state b >> dpy
callGetPowered :: ObjectPath -> SysClient -> IO [Variant] callGetPowered :: MonadIO m => ObjectPath -> SysClient -> m [Variant]
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ $ T.unpack adaptorPowered $ memberName_ $ T.unpack adaptorPowered
@ -219,7 +217,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 :: MutableBtState -> IO (Maybe Bool) readPowered :: MonadIO m => MutableBtState -> m (Maybe Bool)
readPowered = fmap btPowered . readMVar readPowered = fmap btPowered . readMVar
adapterInterface :: InterfaceName adapterInterface :: InterfaceName
@ -231,13 +229,13 @@ adaptorPowered = "Powered"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Devices -- | Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () addAndInitDevice :: MonadUnliftIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
addAndInitDevice state display device client = do addAndInitDevice state dpy device client = do
sh <- addDeviceListener state display device client sh <- addDeviceListener state dpy 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 :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO () initDevice :: MonadUnliftIO m => MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> m ()
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 $
@ -245,22 +243,22 @@ initDevice state sh device sys = do
, btDevSigHandler = sh , btDevSigHandler = sh
} }
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient addDeviceListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler) -> m (Maybe SignalHandler)
addDeviceListener state display device sys = do addDeviceListener state dpy 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 >> display procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
matchConnected :: [Variant] -> SignalMatch Bool matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> SysClient -> IO [Variant] callGetConnected :: MonadIO m => ObjectPath -> SysClient -> m [Variant]
callGetConnected p = callPropertyGet btBus p devInterface callGetConnected p = callPropertyGet btBus p devInterface
$ memberName_ (T.unpack devConnected) $ 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 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)
@ -278,7 +276,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 :: MutableBtState -> IO ConnectedDevices readDevices :: MonadIO m => MutableBtState -> m ConnectedDevices
readDevices = fmap btDevices . readMVar readDevices = fmap btDevices . readMVar
devInterface :: InterfaceName devInterface :: InterfaceName

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

@ -14,7 +14,6 @@ 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,18 +10,17 @@ 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)
@ -35,17 +34,21 @@ data Colors = Colors
} }
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant]) startListener :: (MonadIO m, SafeClient c, IsVariant a) => MatchRule -> (c -> m [Variant])
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
-> c -> IO () -> c -> m ()
startListener rule getProp fromSignal toColor cb client = do startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client reply <- getProp client
displayMaybe cb toColor $ fromSingletonVariant reply displayMaybe cb (liftIO . 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 :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO () procSignalMatch
:: 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
@ -58,11 +61,17 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
na :: T.Text na :: T.Text
na = "N/A" na = "N/A"
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO () displayMaybe :: (MonadIO m) => Callback -> (a -> m T.Text) -> Maybe a -> m ()
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO () displayMaybe_ :: MonadIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
displayMaybe' cb = maybe (cb $ T.unpack na) displayMaybe_ cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO () withDBusClientConnection
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient :: (SafeClient c)
=> 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,14 +11,12 @@ 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
@ -64,9 +62,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 -> do withDBusClientConnection cb $ \sys -> liftIO $ 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,7 +14,6 @@ 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,6 +11,7 @@ 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
@ -26,9 +27,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 -> do withDBusClientConnection cb $ \sys -> liftIO $ do
matchSignal display sys matchSignal dpy sys
display =<< callQuery sys dpy =<< callQuery sys
where where
display = displayMaybe cb $ return . (\s -> colorText colors s text) dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

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

@ -13,17 +13,15 @@ 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
@ -38,11 +36,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 display = displayMaybe cb iconFormatter . Just =<< readState state let dpy = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state display let signalCallback' f = f state dpy
vpnAddedListener (signalCallback' addedCallback) c vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c vpnRemovedListener (signalCallback' removedCallback) c
display liftIO dpy
where where
iconFormatter b = return $ colorText colors b text iconFormatter b = return $ colorText colors b text
@ -57,7 +55,7 @@ type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState type MutableVPNState = MVar VPNState
initState :: SysClient -> IO MutableVPNState initState :: MonadIO m => SysClient -> m MutableVPNState
initState client = do initState client = do
ot <- getVPNObjectTree client ot <- getVPNObjectTree client
newMVar $ findTunnels ot newMVar $ findTunnels ot
@ -65,28 +63,28 @@ initState client = do
readState :: MutableVPNState -> IO Bool readState :: MutableVPNState -> IO Bool
readState = fmap (not . null) . readMVar readState = fmap (not . null) . readMVar
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState updateState :: MonadUnliftIO m => (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-> ObjectPath -> IO () -> ObjectPath -> m ()
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 :: SysClient -> IO ObjectTree getVPNObjectTree :: MonadIO m => SysClient -> m 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 :: SignalCallback -> SysClient -> IO () vpnAddedListener :: MonadIO m => SignalCallback -> SysClient -> m ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: SignalCallback -> SysClient -> IO () vpnRemovedListener :: MonadIO m => SignalCallback -> SysClient -> m ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MutableVPNState -> IO () -> SignalCallback addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state display [device, added] = update >> display addedCallback state dpy [device, added] = update >> dpy
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'
@ -94,7 +92,7 @@ addedCallback state display [device, added] = update >> display
addedCallback _ _ _ = return () addedCallback _ _ _ = return ()
removedCallback :: MutableVPNState -> IO () -> SignalCallback removedCallback :: MutableVPNState -> IO () -> SignalCallback
removedCallback state display [device, interfaces] = update >> display removedCallback state dpy [device, interfaces] = update >> dpy
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