Revert "WIP use unliftio everywhere-ish"
This reverts commit 769df2fb00.
This commit is contained in:
parent
769df2fb00
commit
d560db1548
|
|
@ -56,20 +56,17 @@ main = getArgs >>= parse
|
|||
parse :: [String] -> IO ()
|
||||
parse [] = run
|
||||
parse ["--deps"] = withCache printDeps
|
||||
parse ["--test"] = withCache $ do
|
||||
db <- connectDBus
|
||||
void $ evalConfig db
|
||||
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
|
||||
parse _ = usage
|
||||
|
||||
run :: IO ()
|
||||
run =
|
||||
withCache $ do
|
||||
db <- connectDBus
|
||||
c <- evalConfig db
|
||||
disconnectDBus db
|
||||
-- this is needed to see any printed messages
|
||||
liftIO $ hFlush stdout
|
||||
liftIO $ xmobar c
|
||||
run = do
|
||||
db <- connectDBus
|
||||
c <- withCache $ evalConfig db
|
||||
disconnectDBus db
|
||||
-- this is needed to see any printed messages
|
||||
hFlush stdout
|
||||
xmobar c
|
||||
|
||||
evalConfig :: DBusState -> FIO Config
|
||||
evalConfig db = do
|
||||
|
|
@ -81,10 +78,10 @@ evalConfig db = do
|
|||
|
||||
printDeps :: FIO ()
|
||||
printDeps = do
|
||||
db <- connectDBus
|
||||
db <- io connectDBus
|
||||
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
|
||||
io $ mapM_ (putStrLn . T.unpack) ps
|
||||
disconnectDBus db
|
||||
io $ disconnectDBus db
|
||||
|
||||
usage :: IO ()
|
||||
usage = putStrLn $ intercalate "\n"
|
||||
|
|
|
|||
|
|
@ -8,8 +8,12 @@
|
|||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.Text.IO (hPutStrLn)
|
||||
|
||||
|
|
@ -19,7 +23,6 @@ import Graphics.X11.Xlib.Extras
|
|||
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import RIO.List
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
|
||||
|
|
@ -201,7 +204,7 @@ startChildDaemons :: FeatureSet -> FIO [Process () () ()]
|
|||
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||
|
||||
withDBusX :: (DBusState -> FIO a) -> FIO a
|
||||
withDBusX = bracket connectDBusX cleanup
|
||||
withDBusX = bracket (io connectDBusX) cleanup
|
||||
where
|
||||
cleanup db = do
|
||||
logInfo "unregistering xmonad from DBus"
|
||||
|
|
@ -223,7 +226,7 @@ withXmobar = bracket startXmobar cleanup
|
|||
|
||||
printDeps :: FIO ()
|
||||
printDeps = do
|
||||
db <- connectDBus
|
||||
db <- io connectDBus
|
||||
(i, f, d) <- allFeatures db
|
||||
io $ mapM_ (putStrLn . T.unpack)
|
||||
$ fmap showFulfillment
|
||||
|
|
|
|||
|
|
@ -27,9 +27,14 @@ module Data.Internal.DBus
|
|||
, bodyToMaybe
|
||||
) where
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
|
||||
import Data.Bifunctor
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
|
@ -40,38 +45,23 @@ import DBus.Client
|
|||
class SafeClient c where
|
||||
toClient :: c -> Client
|
||||
|
||||
getDBusClient
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> m (Maybe c)
|
||||
getDBusClient :: IO (Maybe c)
|
||||
|
||||
disconnectDBusClient
|
||||
:: (MonadUnliftIO m)
|
||||
=> c
|
||||
-> m ()
|
||||
disconnectDBusClient = liftIO . disconnect . toClient
|
||||
disconnectDBusClient :: c -> IO ()
|
||||
disconnectDBusClient = disconnect . toClient
|
||||
|
||||
withDBusClient
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> (c -> m a)
|
||||
-> m (Maybe a)
|
||||
-- TODO bracket
|
||||
withDBusClient :: (c -> IO a) -> IO (Maybe a)
|
||||
withDBusClient f = do
|
||||
client <- getDBusClient
|
||||
forM client $ \c -> do
|
||||
r <- f c
|
||||
liftIO $ disconnect (toClient c)
|
||||
disconnect (toClient c)
|
||||
return r
|
||||
|
||||
withDBusClient_
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> (c -> m ())
|
||||
-> m ()
|
||||
withDBusClient_ :: (c -> IO ()) -> IO ()
|
||||
withDBusClient_ = void . withDBusClient
|
||||
|
||||
fromDBusClient
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> (c -> a)
|
||||
-> m (Maybe a)
|
||||
fromDBusClient :: (c -> a) -> IO (Maybe a)
|
||||
fromDBusClient f = withDBusClient (return . f)
|
||||
|
||||
newtype SysClient = SysClient Client
|
||||
|
|
@ -79,25 +69,20 @@ newtype SysClient = SysClient Client
|
|||
instance SafeClient SysClient where
|
||||
toClient (SysClient cl) = cl
|
||||
|
||||
getDBusClient = fmap SysClient <$> getDBusClient_ True
|
||||
getDBusClient = fmap SysClient <$> getDBusClient' True
|
||||
|
||||
newtype SesClient = SesClient Client
|
||||
|
||||
instance SafeClient SesClient where
|
||||
toClient (SesClient cl) = cl
|
||||
|
||||
getDBusClient = fmap SesClient <$> getDBusClient_ False
|
||||
getDBusClient = fmap SesClient <$> getDBusClient' False
|
||||
|
||||
getDBusClient_
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> Bool
|
||||
-> m (Maybe Client)
|
||||
getDBusClient_ sys = do
|
||||
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
||||
getDBusClient' :: Bool -> IO (Maybe Client)
|
||||
getDBusClient' sys = do
|
||||
res <- try $ if sys then connectSystem else connectSession
|
||||
case res of
|
||||
Left e -> do
|
||||
logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
|
||||
return Nothing
|
||||
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
||||
Right c -> return $ Just c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -105,14 +90,12 @@ getDBusClient_ sys = do
|
|||
|
||||
type MethodBody = Either T.Text [Variant]
|
||||
|
||||
callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody
|
||||
callMethod' cl =
|
||||
liftIO
|
||||
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
||||
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||
. call (toClient cl)
|
||||
|
||||
callMethod :: (MonadIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> m MethodBody
|
||||
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> IO MethodBody
|
||||
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
||||
|
||||
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||
|
|
@ -125,7 +108,7 @@ methodCallBus b p i m = (methodCall p i m)
|
|||
dbusInterface :: InterfaceName
|
||||
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
|
||||
where
|
||||
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
|
||||
|
|
@ -146,14 +129,9 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|||
|
||||
type SignalCallback = [Variant] -> IO ()
|
||||
|
||||
addMatchCallback
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> MatchRule
|
||||
-> SignalCallback
|
||||
-> c
|
||||
-> m SignalHandler
|
||||
addMatchCallback rule cb cl =
|
||||
liftIO $ addMatch (toClient cl) rule $ cb . signalBody
|
||||
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
|
||||
-> IO SignalHandler
|
||||
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
||||
|
||||
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
|
||||
-> Maybe MemberName -> MatchRule
|
||||
|
|
@ -164,14 +142,8 @@ matchSignal b p i m = matchAny
|
|||
, matchMember = m
|
||||
}
|
||||
|
||||
matchSignalFull
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> Maybe ObjectPath
|
||||
-> Maybe InterfaceName
|
||||
-> Maybe MemberName
|
||||
-> m (Maybe MatchRule)
|
||||
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
||||
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
|
||||
matchSignalFull client b p i m =
|
||||
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_ "PropertiesChanged"
|
||||
|
||||
callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> c -> m [Variant]
|
||||
callPropertyGet bus path iface property cl =
|
||||
liftIO
|
||||
$ fmap (either (const []) (:[]))
|
||||
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> c -> IO [Variant]
|
||||
callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
|
||||
$ getProperty (toClient cl) $ methodCallBus bus path iface property
|
||||
|
||||
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
||||
matchProperty b p =
|
||||
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
||||
|
||||
matchPropertyFull
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> Maybe ObjectPath
|
||||
-> m (Maybe MatchRule)
|
||||
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
||||
-> IO (Maybe MatchRule)
|
||||
matchPropertyFull cl b p =
|
||||
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
||||
|
||||
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 Failure = f Nothing
|
||||
withSignalMatch _ NoMatch = return ()
|
||||
|
|
@ -242,44 +208,24 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
|
|||
omInterfacesRemoved :: MemberName
|
||||
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
||||
|
||||
callGetManagedObjects
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> c
|
||||
-> BusName
|
||||
-> ObjectPath
|
||||
-> m ObjectTree
|
||||
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
|
||||
-> IO ObjectTree
|
||||
callGetManagedObjects cl bus path =
|
||||
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
||||
<$> callMethod cl bus path omInterface getManagedObjects
|
||||
|
||||
addInterfaceChangedListener
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> MemberName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
|
||||
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
|
||||
addInterfaceChangedListener bus prop path sc cl = do
|
||||
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
||||
forM rule $ \r -> addMatchCallback r sc cl
|
||||
|
||||
addInterfaceAddedListener
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
|
||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
||||
addInterfaceAddedListener bus =
|
||||
addInterfaceChangedListener bus omInterfacesAdded
|
||||
|
||||
addInterfaceRemovedListener
|
||||
:: (MonadIO m, SafeClient c)
|
||||
=> BusName
|
||||
-> ObjectPath
|
||||
-> SignalCallback
|
||||
-> c
|
||||
-> m (Maybe SignalHandler)
|
||||
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
|
||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
||||
addInterfaceRemovedListener bus =
|
||||
addInterfaceChangedListener bus omInterfacesRemoved
|
||||
|
|
|
|||
|
|
@ -106,31 +106,38 @@ module Data.Internal.Dependency
|
|||
, shellTest
|
||||
) 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.Bifunctor
|
||||
import Data.Either
|
||||
import Data.Internal.DBus
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Yaml
|
||||
|
||||
import GHC.IO.Exception (ioe_description)
|
||||
import GHC.IO.Exception (ioe_description)
|
||||
|
||||
import DBus hiding (typeOf)
|
||||
import qualified DBus.Introspection as I
|
||||
import DBus hiding (typeOf)
|
||||
import qualified DBus.Introspection as I
|
||||
|
||||
import RIO hiding (bracket, fromString)
|
||||
import RIO.Directory
|
||||
import RIO hiding (bracket, fromString)
|
||||
import RIO.FilePath
|
||||
import RIO.List
|
||||
import RIO.Process hiding (findExecutable)
|
||||
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.IO.Error
|
||||
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.Shell hiding (proc, runProcess)
|
||||
import XMonad.Internal.Shell hiding (proc, runProcess)
|
||||
import XMonad.Internal.Theme
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -24,9 +24,12 @@ import DBus
|
|||
|
||||
import Graphics.X11.Types
|
||||
|
||||
import RIO.Directory
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
( XdgDirectory (..)
|
||||
, getXdgDirectory
|
||||
)
|
||||
import System.IO
|
||||
|
||||
import XMonad.Core hiding (spawn)
|
||||
|
|
|
|||
|
|
@ -47,11 +47,11 @@ import Data.Internal.Dependency
|
|||
import DBus
|
||||
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Process as P
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Posix.User
|
||||
|
||||
|
|
|
|||
|
|
@ -29,15 +29,17 @@ module XMonad.Internal.Command.Power
|
|||
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import Data.Either
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Graphics.X11.Types
|
||||
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Process as P
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
import System.IO.Error
|
||||
|
||||
import XMonad.Core hiding (spawn)
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@ module XMonad.Internal.Concurrent.ClientMessage
|
|||
( XMsgType(..)
|
||||
, sendXMsg
|
||||
, splitXMsg
|
||||
, withOpenDisplay
|
||||
) where
|
||||
|
||||
import Data.Char
|
||||
|
|
|
|||
|
|
@ -33,7 +33,17 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
|
|||
, doSink
|
||||
) 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.Xlib.Atom
|
||||
import Graphics.X11.Xlib.Display
|
||||
import Graphics.X11.Xlib.Event
|
||||
|
|
@ -45,8 +55,6 @@ import RIO hiding
|
|||
( Display
|
||||
, display
|
||||
)
|
||||
import RIO.List
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Set as S
|
||||
|
||||
import System.Process
|
||||
|
|
@ -98,6 +106,9 @@ data WConf = WConf
|
|||
|
||||
type W a = RIO WConf ()
|
||||
|
||||
withOpenDisplay :: (Display -> IO a) -> IO a
|
||||
withOpenDisplay = bracket (openDisplay "") closeDisplay
|
||||
|
||||
runWorkspaceMon :: [DynWorkspace] -> IO ()
|
||||
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
|
||||
root <- rootWindow dpy $ defaultScreen dpy
|
||||
|
|
|
|||
|
|
@ -12,13 +12,13 @@ module XMonad.Internal.Concurrent.VirtualBox
|
|||
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import Text.XML.Light
|
||||
|
||||
import RIO hiding (try)
|
||||
import RIO.Directory
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import Text.XML.Light
|
||||
|
||||
import XMonad.Internal.Shell
|
||||
|
||||
vmExists :: T.Text -> IO (Maybe Msg)
|
||||
|
|
|
|||
|
|
@ -12,12 +12,14 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
|||
, blPath
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import DBus
|
||||
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
|
|
|
|||
|
|
@ -13,6 +13,9 @@ module XMonad.Internal.DBus.Brightness.Common
|
|||
, signalDep
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
|
|
@ -20,7 +23,6 @@ import DBus
|
|||
import DBus.Client
|
||||
import qualified DBus.Introspection as I
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Core (io)
|
||||
|
|
|
|||
|
|
@ -12,12 +12,12 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
|
|||
, blPath
|
||||
) where
|
||||
|
||||
import Data.Int (Int32)
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import DBus
|
||||
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.Common
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
-- | High-level interface for managing XMonad's DBus
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | High-level interface for managing XMonad's DBus
|
||||
|
||||
module XMonad.Internal.DBus.Control
|
||||
( Client
|
||||
, DBusState(..)
|
||||
|
|
@ -17,15 +17,14 @@ module XMonad.Internal.DBus.Control
|
|||
, dbusExporters
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
|
@ -38,36 +37,27 @@ data DBusState = DBusState
|
|||
}
|
||||
|
||||
-- | Connect to the DBus
|
||||
connectDBus
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> m DBusState
|
||||
connectDBus :: IO DBusState
|
||||
connectDBus = do
|
||||
ses <- getDBusClient
|
||||
sys <- getDBusClient
|
||||
return DBusState { dbSesClient = ses, dbSysClient = sys }
|
||||
|
||||
-- | Disconnect from the DBus
|
||||
disconnectDBus
|
||||
:: (MonadUnliftIO m)
|
||||
=> DBusState -> m ()
|
||||
disconnectDBus :: DBusState -> IO ()
|
||||
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
||||
where
|
||||
disc f = maybe (return ()) disconnectDBusClient $ f db
|
||||
|
||||
-- | Connect to the DBus and request the XMonad name
|
||||
connectDBusX
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> m DBusState
|
||||
connectDBusX :: IO DBusState
|
||||
connectDBusX = do
|
||||
db <- connectDBus
|
||||
forM_ (dbSesClient db) requestXMonadName
|
||||
return db
|
||||
|
||||
-- | Disconnect from DBus and release the XMonad name
|
||||
disconnectDBusX
|
||||
:: (MonadUnliftIO m)
|
||||
=> DBusState
|
||||
-> m ()
|
||||
disconnectDBusX :: DBusState -> IO ()
|
||||
disconnectDBusX db = do
|
||||
forM_ (dbSesClient db) releaseXMonadName
|
||||
disconnectDBus db
|
||||
|
|
@ -76,25 +66,18 @@ disconnectDBusX db = do
|
|||
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
|
||||
releaseXMonadName
|
||||
:: (MonadUnliftIO m)
|
||||
=> SesClient
|
||||
-> m ()
|
||||
releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName
|
||||
releaseXMonadName :: SesClient -> IO ()
|
||||
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
|
||||
|
||||
requestXMonadName
|
||||
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
||||
=> SesClient
|
||||
-> m ()
|
||||
requestXMonadName :: SesClient -> IO ()
|
||||
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
|
||||
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 == NameExists = Just "another process owns bus name"
|
||||
| otherwise = Just "unknown error when requesting bus name"
|
||||
forM_ msg $ \m ->
|
||||
logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
|
||||
|| res == NameExists = Just $ "another process owns " ++ xn
|
||||
| otherwise = Just $ "unknown error when requesting " ++ xn
|
||||
forM_ msg putStrLn
|
||||
where
|
||||
xn = T.pack $ formatBusName xmonadBusName
|
||||
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||
|
|
|
|||
|
|
@ -8,15 +8,15 @@
|
|||
|
||||
module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.Map.Strict (Map, member)
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
|
||||
import XMonad.Core (io)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
|
||||
|
|
@ -60,7 +60,7 @@ driveFlag :: String
|
|||
driveFlag = "org.freedesktop.UDisks2.Drive"
|
||||
|
||||
addedHasDrive :: [Variant] -> Bool
|
||||
addedHasDrive [_, a] = maybe False (M.member driveFlag)
|
||||
addedHasDrive [_, a] = maybe False (member driveFlag)
|
||||
(fromVariant a :: Maybe (Map String (Map String Variant)))
|
||||
addedHasDrive _ = False
|
||||
|
||||
|
|
|
|||
|
|
@ -14,15 +14,15 @@ module XMonad.Internal.DBus.Screensaver
|
|||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import qualified DBus.Introspection as I
|
||||
|
||||
import Graphics.X11.XScreenSaver
|
||||
|
||||
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.Shell
|
||||
|
||||
|
|
@ -45,7 +45,10 @@ toggle = do
|
|||
|
||||
query :: IO SSState
|
||||
query = do
|
||||
xssi <- withOpenDisplay xScreenSaverQueryInfo
|
||||
-- TODO bracket the display
|
||||
dpy <- openDisplay ""
|
||||
xssi <- xScreenSaverQueryInfo dpy
|
||||
closeDisplay dpy
|
||||
return $ case xssi of
|
||||
Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
|
||||
Just XScreenSaverInfo { xssi_state = _ } -> True
|
||||
|
|
|
|||
|
|
@ -25,11 +25,12 @@ module XMonad.Internal.IO
|
|||
) where
|
||||
|
||||
import Data.Char
|
||||
import Data.Text (pack, unpack)
|
||||
import Data.Text.IO as T (readFile, writeFile)
|
||||
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.IO.Error
|
||||
|
||||
|
|
@ -37,7 +38,7 @@ import System.IO.Error
|
|||
-- | read
|
||||
|
||||
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 = fmap (==(1 :: Int)) . readInt
|
||||
|
|
@ -46,7 +47,7 @@ readBool = fmap (==(1 :: Int)) . readInt
|
|||
-- | write
|
||||
|
||||
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 f b = writeInt f ((if b then 1 else 0) :: Int)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -10,7 +10,6 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
|||
|
||||
import Data.Internal.DBus
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import Xmobar.Plugins.Common
|
||||
|
|
@ -18,9 +17,9 @@ import Xmobar.Plugins.Common
|
|||
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
|
||||
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
|
||||
startBacklight matchSignal callGetBrightness icon cb = do
|
||||
withDBusClientConnection cb $ \c -> liftIO $ do
|
||||
matchSignal dpy c
|
||||
dpy =<< callGetBrightness c
|
||||
withDBusClientConnection cb $ \c -> do
|
||||
matchSignal display c
|
||||
display =<< callGetBrightness c
|
||||
where
|
||||
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
||||
dpy = displayMaybe cb formatBrightness
|
||||
display = displayMaybe cb formatBrightness
|
||||
|
|
|
|||
|
|
@ -38,16 +38,19 @@ module Xmobar.Plugins.Bluetooth
|
|||
, btDep
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.List
|
||||
import Data.List.Split
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import RIO
|
||||
import RIO.List
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Internal.DBus.Common
|
||||
|
|
@ -68,24 +71,23 @@ instance Exec Bluetooth where
|
|||
start (Bluetooth 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
|
||||
ot <- getBtObjectTree cl
|
||||
-- TODO use RIO for this?
|
||||
state <- newMVar emptyState
|
||||
let dpy = displayIcon cb (iconFormatter is cs) state
|
||||
forM_ (findAdapter ot) $ \adapter -> liftIO $ do
|
||||
let display = displayIcon cb (iconFormatter is cs) state
|
||||
forM_ (findAdapter ot) $ \adapter -> do
|
||||
-- set up adapter
|
||||
initAdapter state adapter cl
|
||||
-- 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)
|
||||
let devices = findDevices adapter ot
|
||||
addDeviceAddedListener state dpy adapter cl
|
||||
addDeviceRemovedListener state dpy adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state dpy d cl
|
||||
addDeviceAddedListener state display adapter cl
|
||||
addDeviceRemovedListener state display adapter cl
|
||||
forM_ devices $ \d -> addAndInitDevice state display d cl
|
||||
-- after setting things up, show the icon based on the initialized state
|
||||
dpy
|
||||
display
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Icon Display
|
||||
|
|
@ -97,9 +99,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
|||
|
||||
type Icons = (T.Text, T.Text)
|
||||
|
||||
displayIcon :: MonadIO m => Callback -> IconFormatter -> MutableBtState -> m ()
|
||||
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
|
||||
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
|
||||
iconFormatter :: Icons -> Colors -> IconFormatter
|
||||
|
|
@ -136,7 +138,7 @@ emptyState = BtState
|
|||
, btPowered = Nothing
|
||||
}
|
||||
|
||||
readState :: MonadIO m => MutableBtState -> m (Maybe Bool, Bool)
|
||||
readState :: MutableBtState -> IO (Maybe Bool, Bool)
|
||||
readState state = do
|
||||
p <- readPowered state
|
||||
c <- readDevices state
|
||||
|
|
@ -159,55 +161,55 @@ adaptorHasDevice adaptor device = case splitPath device of
|
|||
splitPath :: ObjectPath -> [T.Text]
|
||||
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
|
||||
|
||||
getBtObjectTree :: MonadIO m => SysClient -> m ObjectTree
|
||||
getBtObjectTree :: SysClient -> IO ObjectTree
|
||||
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||
|
||||
btOMPath :: ObjectPath
|
||||
btOMPath = objectPath_ "/"
|
||||
|
||||
addBtOMListener :: MonadIO m => SignalCallback -> SysClient -> m ()
|
||||
addBtOMListener sc = liftIO . void . addInterfaceAddedListener btBus btOMPath sc
|
||||
addBtOMListener :: SignalCallback -> SysClient -> IO ()
|
||||
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
|
||||
|
||||
addDeviceAddedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
|
||||
addDeviceAddedListener state dpy adapter client =
|
||||
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceAddedListener state display adapter client =
|
||||
addBtOMListener addDevice client
|
||||
where
|
||||
addDevice = pathCallback adapter dpy $ \d ->
|
||||
addAndInitDevice state dpy d client
|
||||
addDevice = pathCallback adapter display $ \d ->
|
||||
addAndInitDevice state display d client
|
||||
|
||||
addDeviceRemovedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
|
||||
addDeviceRemovedListener state dpy adapter sys =
|
||||
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addDeviceRemovedListener state display adapter sys =
|
||||
addBtOMListener remDevice sys
|
||||
where
|
||||
remDevice = pathCallback adapter dpy $ \d -> do
|
||||
remDevice = pathCallback adapter display $ \d -> do
|
||||
old <- removeDevice state d
|
||||
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
|
||||
|
||||
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
|
||||
pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> dpy
|
||||
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||
when (adaptorHasDevice adapter d) $ f d >> display
|
||||
pathCallback _ _ _ _ = return ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Adapter
|
||||
|
||||
initAdapter :: MonadIO m => MutableBtState -> ObjectPath -> SysClient -> m ()
|
||||
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
||||
initAdapter state adapter client = do
|
||||
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)
|
||||
|
||||
addAdaptorListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
|
||||
-> m (Maybe SignalHandler)
|
||||
addAdaptorListener state dpy adaptor sys = do
|
||||
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addAdaptorListener state display adaptor sys = do
|
||||
rule <- matchBTProperty sys adaptor
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
|
||||
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
|
||||
$ memberName_ $ T.unpack adaptorPowered
|
||||
|
||||
|
|
@ -217,7 +219,7 @@ matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
|||
putPowered :: MutableBtState -> Maybe Bool -> IO ()
|
||||
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
|
||||
|
||||
adapterInterface :: InterfaceName
|
||||
|
|
@ -229,13 +231,13 @@ adaptorPowered = "Powered"
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Devices
|
||||
|
||||
addAndInitDevice :: MonadUnliftIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
|
||||
addAndInitDevice state dpy device client = do
|
||||
sh <- addDeviceListener state dpy device client
|
||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||
addAndInitDevice state display device client = do
|
||||
sh <- addDeviceListener state display device client
|
||||
-- TODO add some intelligent error messages here
|
||||
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
|
||||
reply <- callGetConnected device sys
|
||||
void $ insertDevice state device $
|
||||
|
|
@ -243,22 +245,22 @@ initDevice state sh device sys = do
|
|||
, btDevSigHandler = sh
|
||||
}
|
||||
|
||||
addDeviceListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
|
||||
-> m (Maybe SignalHandler)
|
||||
addDeviceListener state dpy device sys = do
|
||||
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
||||
-> IO (Maybe SignalHandler)
|
||||
addDeviceListener state display device sys = do
|
||||
rule <- matchBTProperty sys device
|
||||
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
|
||||
where
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
|
||||
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
|
||||
|
||||
matchConnected :: [Variant] -> SignalMatch Bool
|
||||
matchConnected = matchPropertyChanged devInterface devConnected
|
||||
|
||||
callGetConnected :: MonadIO m => ObjectPath -> SysClient -> m [Variant]
|
||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||
callGetConnected p = callPropertyGet btBus p devInterface
|
||||
$ 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
|
||||
let new = M.insert device dev $ btDevices s
|
||||
return (s { btDevices = new }, anyDevicesConnected new)
|
||||
|
|
@ -276,7 +278,7 @@ removeDevice m device = modifyMVar m $ \s -> do
|
|||
let devs = btDevices s
|
||||
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
|
||||
|
||||
devInterface :: InterfaceName
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ module Xmobar.Plugins.ClevoKeyboard
|
|||
import qualified RIO.Text as T
|
||||
|
||||
import Xmobar
|
||||
|
||||
import Xmobar.Plugins.BacklightCommon
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
|
|
|
|||
|
|
@ -10,17 +10,18 @@ module Xmobar.Plugins.Common
|
|||
, Callback
|
||||
, Colors(..)
|
||||
, displayMaybe
|
||||
, displayMaybe_
|
||||
, displayMaybe'
|
||||
, xmobarFGColor
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||
|
|
@ -34,21 +35,17 @@ data Colors = Colors
|
|||
}
|
||||
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
|
||||
-> c -> m ()
|
||||
-> c -> IO ()
|
||||
startListener rule getProp fromSignal toColor cb client = do
|
||||
reply <- getProp client
|
||||
displayMaybe cb (liftIO . toColor) $ fromSingletonVariant reply
|
||||
displayMaybe cb toColor $ fromSingletonVariant reply
|
||||
void $ addMatchCallback rule (procMatch . fromSignal) client
|
||||
where
|
||||
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)
|
||||
|
||||
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 = "N/A"
|
||||
|
||||
displayMaybe :: (MonadIO m) => Callback -> (a -> m T.Text) -> Maybe a -> m ()
|
||||
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
|
||||
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
|
||||
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
|
||||
|
||||
displayMaybe_ :: MonadIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
|
||||
displayMaybe_ cb = maybe (liftIO $ cb $ T.unpack na)
|
||||
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
|
||||
displayMaybe' cb = maybe (cb $ T.unpack na)
|
||||
|
||||
withDBusClientConnection
|
||||
:: (SafeClient c)
|
||||
=> Callback
|
||||
-> (c -> RIO SimpleApp ())
|
||||
-> IO ()
|
||||
withDBusClientConnection cb f = do
|
||||
-- TODO be more sophisticated
|
||||
runSimpleApp $ withDBusClient_ $ displayMaybe_ cb f . Just
|
||||
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
|
||||
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
|
||||
|
|
|
|||
|
|
@ -11,12 +11,14 @@ module Xmobar.Plugins.Device
|
|||
, devDep
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.Word
|
||||
|
||||
import DBus
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Internal.Command.Desktop
|
||||
|
|
@ -62,9 +64,9 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
|||
instance Exec Device where
|
||||
alias (Device (iface, _, _)) = T.unpack iface
|
||||
start (Device (iface, text, colors)) cb = do
|
||||
withDBusClientConnection cb $ \sys -> liftIO $ do
|
||||
withDBusClientConnection cb $ \sys -> do
|
||||
path <- getDevice sys iface
|
||||
displayMaybe_ cb (listener sys) path
|
||||
displayMaybe' cb (listener sys) path
|
||||
where
|
||||
listener sys path = do
|
||||
rule <- matchPropertyFull sys networkManagerBus (Just path)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ module Xmobar.Plugins.IntelBacklight
|
|||
import qualified RIO.Text as T
|
||||
|
||||
import Xmobar
|
||||
|
||||
import Xmobar.Plugins.BacklightCommon
|
||||
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver
|
|||
, ssAlias
|
||||
) where
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import Xmobar
|
||||
|
|
@ -27,9 +26,9 @@ ssAlias = "screensaver"
|
|||
instance Exec Screensaver where
|
||||
alias (Screensaver _) = T.unpack ssAlias
|
||||
start (Screensaver (text, colors)) cb = do
|
||||
withDBusClientConnection cb $ \sys -> liftIO $ do
|
||||
matchSignal dpy sys
|
||||
dpy =<< callQuery sys
|
||||
withDBusClientConnection cb $ \sys -> do
|
||||
matchSignal display sys
|
||||
display =<< callQuery sys
|
||||
where
|
||||
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
|
||||
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
||||
|
||||
|
|
|
|||
|
|
@ -13,15 +13,17 @@ module Xmobar.Plugins.VPN
|
|||
, vpnDep
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
|
||||
import DBus
|
||||
|
||||
import RIO
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Set as S
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import XMonad.Internal.Command.Desktop
|
||||
|
|
@ -36,11 +38,11 @@ instance Exec VPN where
|
|||
start (VPN (text, colors)) cb =
|
||||
withDBusClientConnection cb $ \c -> do
|
||||
state <- initState c
|
||||
let dpy = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state dpy
|
||||
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
||||
let signalCallback' f = f state display
|
||||
vpnAddedListener (signalCallback' addedCallback) c
|
||||
vpnRemovedListener (signalCallback' removedCallback) c
|
||||
liftIO dpy
|
||||
display
|
||||
where
|
||||
iconFormatter b = return $ colorText colors b text
|
||||
|
||||
|
|
@ -55,7 +57,7 @@ type VPNState = S.Set ObjectPath
|
|||
|
||||
type MutableVPNState = MVar VPNState
|
||||
|
||||
initState :: MonadIO m => SysClient -> m MutableVPNState
|
||||
initState :: SysClient -> IO MutableVPNState
|
||||
initState client = do
|
||||
ot <- getVPNObjectTree client
|
||||
newMVar $ findTunnels ot
|
||||
|
|
@ -63,28 +65,28 @@ initState client = do
|
|||
readState :: MutableVPNState -> IO Bool
|
||||
readState = fmap (not . null) . readMVar
|
||||
|
||||
updateState :: MonadUnliftIO m => (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
||||
-> ObjectPath -> m ()
|
||||
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
||||
-> ObjectPath -> IO ()
|
||||
updateState f state op = modifyMVar_ state $ return . f op
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Tunnel Device Detection
|
||||
--
|
||||
|
||||
getVPNObjectTree :: MonadIO m => SysClient -> m ObjectTree
|
||||
getVPNObjectTree :: SysClient -> IO ObjectTree
|
||||
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
||||
|
||||
findTunnels :: ObjectTree -> VPNState
|
||||
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
|
||||
|
||||
vpnRemovedListener :: MonadIO m => SignalCallback -> SysClient -> m ()
|
||||
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
|
||||
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
||||
|
||||
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
addedCallback state dpy [device, added] = update >> dpy
|
||||
addedCallback state display [device, added] = update >> display
|
||||
where
|
||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||
is = M.keys $ fromMaybe M.empty added'
|
||||
|
|
@ -92,7 +94,7 @@ addedCallback state dpy [device, added] = update >> dpy
|
|||
addedCallback _ _ _ = return ()
|
||||
|
||||
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||
removedCallback state dpy [device, interfaces] = update >> dpy
|
||||
removedCallback state display [device, interfaces] = update >> display
|
||||
where
|
||||
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
||||
update = updateDevice S.delete state device is
|
||||
|
|
|
|||
Loading…
Reference in New Issue