ENH use typeclass to make dependency interface more flexible
This commit is contained in:
parent
7e5a4a57cd
commit
6ce38b7ade
115
bin/xmobar.hs
115
bin/xmobar.hs
|
|
@ -16,7 +16,7 @@ import Data.Either
|
|||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import System.Directory
|
||||
import System.Exit
|
||||
|
|
@ -41,6 +41,8 @@ import XMonad.Hooks.DynamicLog
|
|||
import XMonad.Internal.Command.Power (hasBattery)
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.DBus.Control
|
||||
import XMonad.Internal.Shell
|
||||
-- import XMonad.Internal.DBus.Common (xmonadBus)
|
||||
-- import XMonad.Internal.DBus.Control (pathExists)
|
||||
|
|
@ -52,12 +54,15 @@ import Xmobar
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
rs <- sequence rightPlugins
|
||||
sysClient <- getDBusClient True
|
||||
sesClient <- getDBusClient False
|
||||
rs <- rightPlugins sysClient sesClient
|
||||
warnMissing rs
|
||||
cs <- getAllCommands rs
|
||||
d <- getXMonadDir
|
||||
-- this is needed to see any printed messages
|
||||
hFlush stdout
|
||||
mapM_ (maybe skip disconnect) [sysClient, sesClient]
|
||||
xmobar $ config cs d
|
||||
|
||||
config :: BarRegions -> String -> Config
|
||||
|
|
@ -225,8 +230,8 @@ dateCmd = CmdSpec
|
|||
-- some commands depend on the presence of interfaces that can only be
|
||||
-- determined at runtime; define these checks here
|
||||
|
||||
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
|
||||
dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
|
||||
-- dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
|
||||
-- dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
|
||||
|
||||
-- in the case of network interfaces, assume that the system uses systemd in
|
||||
-- which case ethernet interfaces always start with "en" and wireless
|
||||
|
|
@ -245,15 +250,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
|||
sysfsNet :: FilePath
|
||||
sysfsNet = "/sys/class/net"
|
||||
|
||||
readInterface :: (String -> Bool) -> IO (Maybe String)
|
||||
readInterface :: (String -> Bool) -> IO (Either [String] String)
|
||||
readInterface f = do
|
||||
ns <- filter f <$> listInterfaces
|
||||
case ns of
|
||||
[] -> return $ Left ["no interfaces found"]
|
||||
(x:xs) -> do
|
||||
unless (null xs) $
|
||||
putStrLn $ "WARNING: extra interfaces found, using " ++ x
|
||||
return $ Just x
|
||||
_ -> return Nothing
|
||||
return $ Right x
|
||||
|
||||
vpnPresent :: IO (Maybe String)
|
||||
vpnPresent = do
|
||||
|
|
@ -265,96 +270,96 @@ vpnPresent = do
|
|||
where
|
||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||
|
||||
rightPlugins :: [IO (MaybeAction CmdSpec)]
|
||||
rightPlugins =
|
||||
rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
|
||||
rightPlugins sysClient sesClient = mapM evalFeature
|
||||
[ getWireless
|
||||
, getEthernet
|
||||
, evalFeature getVPN
|
||||
, evalFeature getBt
|
||||
, evalFeature getAlsa
|
||||
, evalFeature getBattery
|
||||
, evalFeature getBl
|
||||
, evalFeature getCk
|
||||
, evalFeature getSs
|
||||
, nocheck lockCmd
|
||||
, nocheck dateCmd
|
||||
, getVPN
|
||||
, getBt sysClient
|
||||
, getAlsa
|
||||
, getBattery
|
||||
, getBl sesClient
|
||||
, getCk sesClient
|
||||
, getSs sesClient
|
||||
, ConstFeature lockCmd
|
||||
, ConstFeature dateCmd
|
||||
]
|
||||
where
|
||||
nocheck = return . Right
|
||||
|
||||
getWireless :: IO (MaybeAction CmdSpec)
|
||||
getWireless = do
|
||||
i <- readInterface isWireless
|
||||
return $ maybe (Left []) (Right . wirelessCmd) i
|
||||
getWireless :: BarFeature
|
||||
getWireless = Feature
|
||||
{ ftrMaybeAction = Chain wirelessCmd $ readInterface isWireless
|
||||
, ftrName = "wireless status indicator"
|
||||
, ftrWarning = Default
|
||||
}
|
||||
-- i <- readInterface isWireless
|
||||
-- return $ maybe (Left []) (Right . wirelessCmd) i
|
||||
|
||||
getEthernet :: IO (MaybeAction CmdSpec)
|
||||
getEthernet = do
|
||||
i <- readInterface isEthernet
|
||||
evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
|
||||
where
|
||||
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
|
||||
-- TODO this needs a dbus interface
|
||||
getEthernet :: BarFeature
|
||||
getEthernet = Feature
|
||||
{ ftrMaybeAction = Chain ethernetCmd (readInterface isEthernet)
|
||||
, ftrName = "ethernet status indicator"
|
||||
, ftrWarning = Default
|
||||
}
|
||||
|
||||
-- i <- readInterface isEthernet
|
||||
-- evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
|
||||
-- where
|
||||
-- dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = Feature
|
||||
{ ftrMaybeAction = batteryCmd
|
||||
{ ftrMaybeAction = Parent batteryCmd [IOTest hasBattery]
|
||||
, ftrName = "battery level indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [IOTest hasBattery]
|
||||
}
|
||||
|
||||
type BarFeature = Feature CmdSpec
|
||||
|
||||
getVPN :: BarFeature
|
||||
getVPN = Feature
|
||||
{ ftrMaybeAction = vpnCmd
|
||||
{ ftrMaybeAction = Parent vpnCmd [v]
|
||||
, ftrName = "VPN status indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [d, v]
|
||||
}
|
||||
where
|
||||
d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||
-- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||
v = IOTest vpnPresent
|
||||
|
||||
getBt :: BarFeature
|
||||
getBt = Feature
|
||||
{ ftrMaybeAction = btCmd
|
||||
getBt :: Maybe Client -> BarFeature
|
||||
getBt client = Feature
|
||||
{ ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client
|
||||
[Endpoint btPath btInterface $ Property_ btPowered]
|
||||
, ftrName = "bluetooth status indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [dep]
|
||||
}
|
||||
where
|
||||
dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
|
||||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = Feature
|
||||
{ ftrMaybeAction = alsaCmd
|
||||
{ ftrMaybeAction = Parent alsaCmd [Executable "alsactl"]
|
||||
, ftrName = "volume level indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [Executable "alsactl"]
|
||||
}
|
||||
|
||||
getBl :: BarFeature
|
||||
getBl = Feature
|
||||
{ ftrMaybeAction = blCmd
|
||||
getBl :: Maybe Client -> BarFeature
|
||||
getBl client = Feature
|
||||
{ ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep]
|
||||
, ftrName = "Intel backlight indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [intelBacklightSignalDep]
|
||||
}
|
||||
|
||||
getCk :: BarFeature
|
||||
getCk = Feature
|
||||
{ ftrMaybeAction = ckCmd
|
||||
getCk :: Maybe Client -> BarFeature
|
||||
getCk client = Feature
|
||||
{ ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep]
|
||||
, ftrName = "Clevo keyboard indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [clevoKeyboardSignalDep]
|
||||
}
|
||||
|
||||
getSs :: BarFeature
|
||||
getSs = Feature
|
||||
{ ftrMaybeAction = ssCmd
|
||||
getSs :: Maybe Client -> BarFeature
|
||||
getSs client = Feature
|
||||
{ ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep]
|
||||
, ftrName = "screensaver indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [ssSignalDep]
|
||||
}
|
||||
|
||||
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
||||
|
|
|
|||
|
|
@ -76,12 +76,14 @@ import XMonad.Util.WorkspaceCompare
|
|||
|
||||
main :: IO ()
|
||||
main = do
|
||||
cl <- startXMonadService
|
||||
sesClient <- startXMonadService
|
||||
sysClient <- getDBusClient True
|
||||
(h, p) <- spawnPipe "xmobar"
|
||||
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon]
|
||||
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient]
|
||||
forkIO_ $ runWorkspaceMon allDWs
|
||||
let ts = ThreadState
|
||||
{ tsClient = cl
|
||||
{ tsSessionClient = sesClient
|
||||
, tsSystemClient = sysClient
|
||||
, tsChildPIDs = [p]
|
||||
, tsChildHandles = [h]
|
||||
}
|
||||
|
|
@ -114,16 +116,18 @@ main = do
|
|||
-- | Concurrency configuration
|
||||
|
||||
data ThreadState = ThreadState
|
||||
{ tsClient :: Maybe Client
|
||||
, tsChildPIDs :: [ProcessHandle]
|
||||
, tsChildHandles :: [Handle]
|
||||
{ tsSessionClient :: Maybe Client
|
||||
, tsSystemClient :: Maybe Client
|
||||
, tsChildPIDs :: [ProcessHandle]
|
||||
, tsChildHandles :: [Handle]
|
||||
}
|
||||
|
||||
-- TODO shouldn't this be run by a signal handler?
|
||||
runCleanup :: ThreadState -> X ()
|
||||
runCleanup ts = io $ do
|
||||
mapM_ killHandle $ tsChildPIDs ts
|
||||
forM_ (tsClient ts) stopXMonadService
|
||||
forM_ (tsSessionClient ts) stopXMonadService
|
||||
forM_ (tsSystemClient ts) disconnect
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Startuphook configuration
|
||||
|
|
@ -568,12 +572,12 @@ externalBindings ts lock =
|
|||
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ maybe BlankFeature (ioFeature . callToggle) cl
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl
|
||||
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
||||
]
|
||||
]
|
||||
where
|
||||
cl = tsClient ts
|
||||
brightessControls ctl getter = maybe BlankFeature (ioFeature . getter . ctl) cl
|
||||
cl = tsSessionClient ts
|
||||
brightessControls ctl getter = (ioFeature . getter . ctl) cl
|
||||
ib = brightessControls intelBacklightControls
|
||||
ck = brightessControls clevoKeyboardControls
|
||||
|
|
|
|||
|
|
@ -33,13 +33,17 @@ memAdded = memberName_ "InterfacesAdded"
|
|||
memRemoved :: MemberName
|
||||
memRemoved = memberName_ "InterfacesRemoved"
|
||||
|
||||
dbusDep :: MemberName -> Dependency
|
||||
dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
|
||||
-- dbusDep :: MemberName -> Dependency
|
||||
-- dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
|
||||
dbusDep :: MemberName -> Endpoint
|
||||
dbusDep m = Endpoint path interface $ Signal_ m
|
||||
|
||||
addedDep :: Dependency
|
||||
-- addedDep :: Dependency
|
||||
addedDep :: Endpoint
|
||||
addedDep = dbusDep memAdded
|
||||
|
||||
removedDep :: Dependency
|
||||
-- removedDep :: Dependency
|
||||
removedDep :: Endpoint
|
||||
removedDep = dbusDep memRemoved
|
||||
|
||||
driveInsertedSound :: FilePath
|
||||
|
|
@ -84,6 +88,9 @@ listenDevices = do
|
|||
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
|
||||
$ playSoundMaybe p . f . signalBody
|
||||
|
||||
runRemovableMon :: FeatureIO
|
||||
runRemovableMon =
|
||||
featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices
|
||||
runRemovableMon :: Maybe Client -> FeatureIO
|
||||
runRemovableMon client = Feature
|
||||
{ ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep]
|
||||
, ftrName = "removeable device monitor"
|
||||
, ftrWarning = Default
|
||||
}
|
||||
|
|
|
|||
|
|
@ -113,14 +113,15 @@ stateFileDep = pathRW stateFile
|
|||
brightnessFileDep :: Dependency
|
||||
brightnessFileDep = pathR brightnessFile
|
||||
|
||||
clevoKeyboardSignalDep :: Dependency
|
||||
-- clevoKeyboardSignalDep :: Dependency
|
||||
clevoKeyboardSignalDep :: Endpoint
|
||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||
|
||||
exportClevoKeyboard :: Client -> FeatureIO
|
||||
exportClevoKeyboard :: Maybe Client -> FeatureIO
|
||||
exportClevoKeyboard =
|
||||
brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
||||
|
||||
clevoKeyboardControls :: Client -> BrightnessControls
|
||||
clevoKeyboardControls :: Maybe Client -> BrightnessControls
|
||||
clevoKeyboardControls = brightnessControls clevoKeyboardConfig
|
||||
|
||||
callGetBrightnessCK :: Client -> IO (Maybe Brightness)
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ data BrightnessControls = BrightnessControls
|
|||
, bctlDec :: FeatureIO
|
||||
}
|
||||
|
||||
brightnessControls :: BrightnessConfig a b -> Client -> BrightnessControls
|
||||
brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
|
||||
brightnessControls bc client =
|
||||
BrightnessControls
|
||||
{ bctlMax = cb "max brightness" memMax
|
||||
|
|
@ -67,9 +67,10 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do
|
|||
reply <- callMethod client xmonadBusName p i memGet
|
||||
return $ either (const Nothing) bodyGetBrightness reply
|
||||
|
||||
signalDep :: BrightnessConfig a b -> Dependency
|
||||
-- signalDep :: BrightnessConfig a b -> Dependency
|
||||
signalDep :: BrightnessConfig a b -> Endpoint
|
||||
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
||||
DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur
|
||||
Endpoint p i $ Signal_ memCur
|
||||
|
||||
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
|
||||
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
|
||||
|
|
@ -88,12 +89,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
|
|||
-- | Internal DBus Crap
|
||||
|
||||
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
||||
-> Client -> FeatureIO
|
||||
-> Maybe Client -> FeatureIO
|
||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
|
||||
{ ftrMaybeAction = exportBrightnessControls' bc client
|
||||
{ ftrMaybeAction = DBusBus_ (exportBrightnessControls' bc) xmonadBusName client deps
|
||||
, ftrName = n ++ " exporter"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = DBusBus xmonadBus:deps
|
||||
}
|
||||
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
||||
|
|
@ -131,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
|||
where
|
||||
sig = signal p i memCur
|
||||
|
||||
callBacklight :: Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
|
||||
callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
|
||||
callBacklight client BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
|
||||
(featureEndpoint xmonadBusName p i m client)
|
||||
{ ftrName = unwords [n, controlName] }
|
||||
|
|
|
|||
|
|
@ -95,14 +95,15 @@ curFileDep = pathRW curFile
|
|||
maxFileDep :: Dependency
|
||||
maxFileDep = pathR maxFile
|
||||
|
||||
intelBacklightSignalDep :: Dependency
|
||||
-- intelBacklightSignalDep :: Dependency
|
||||
intelBacklightSignalDep :: Endpoint
|
||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||
|
||||
exportIntelBacklight :: Client -> FeatureIO
|
||||
exportIntelBacklight :: Maybe Client -> FeatureIO
|
||||
exportIntelBacklight =
|
||||
brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig
|
||||
|
||||
intelBacklightControls :: Client -> BrightnessControls
|
||||
intelBacklightControls :: Maybe Client -> BrightnessControls
|
||||
intelBacklightControls = brightnessControls intelBacklightConfig
|
||||
|
||||
callGetBrightnessIB :: Client -> IO (Maybe Brightness)
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ module XMonad.Internal.DBus.Common
|
|||
( addMatchCallback
|
||||
, xmonadBus
|
||||
, xmonadBusName
|
||||
, xDbusDep
|
||||
-- , xDbusDep
|
||||
-- , initControls
|
||||
) where
|
||||
|
||||
|
|
@ -22,8 +22,8 @@ xmonadBusName = busName_ "org.xmonad"
|
|||
xmonadBus :: Bus
|
||||
xmonadBus = Bus False xmonadBusName
|
||||
|
||||
xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
|
||||
xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
|
||||
-- xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
|
||||
-- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
|
||||
|
||||
-- -- | Call a method and return its result if successful
|
||||
-- callMethod :: MethodCall -> IO (Maybe [Variant])
|
||||
|
|
|
|||
|
|
@ -6,9 +6,11 @@
|
|||
module XMonad.Internal.DBus.Control
|
||||
( Client
|
||||
, startXMonadService
|
||||
, getDBusClient
|
||||
, stopXMonadService
|
||||
, pathExists
|
||||
, xmonadBus
|
||||
, disconnect
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
|
|
@ -33,21 +35,21 @@ introspectMethod = memberName_ "Introspect"
|
|||
|
||||
startXMonadService :: IO (Maybe Client)
|
||||
startXMonadService = do
|
||||
client <- getDBusClient
|
||||
forM_ client $ \c -> do
|
||||
requestXMonadName c
|
||||
mapM_ (\f -> executeFeature_ $ f c)
|
||||
[exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
client <- getDBusClient False
|
||||
forM_ client requestXMonadName
|
||||
mapM_ (\f -> executeFeature_ $ f client) exporters
|
||||
return client
|
||||
where
|
||||
exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
|
||||
stopXMonadService :: Client -> IO ()
|
||||
stopXMonadService client = do
|
||||
void $ releaseName client xmonadBusName
|
||||
disconnect client
|
||||
|
||||
getDBusClient :: IO (Maybe Client)
|
||||
getDBusClient = do
|
||||
res <- try connectSession
|
||||
getDBusClient :: Bool -> IO (Maybe Client)
|
||||
getDBusClient sys = do
|
||||
res <- try $ if sys then connectSystem else connectSession
|
||||
case res of
|
||||
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
||||
Right c -> return $ Just c
|
||||
|
|
|
|||
|
|
@ -93,18 +93,17 @@ bodyGetCurrentState _ = Nothing
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Exported haskell API
|
||||
|
||||
exportScreensaver :: Client -> FeatureIO
|
||||
exportScreensaver :: Maybe Client -> FeatureIO
|
||||
exportScreensaver client = Feature
|
||||
{ ftrMaybeAction = cmd
|
||||
{ ftrMaybeAction = DBusBus_ cmd xmonadBusName client [Executable ssExecutable]
|
||||
, ftrName = "screensaver interface"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
|
||||
}
|
||||
where
|
||||
cmd = export client ssPath defaultInterface
|
||||
cmd cl = export cl ssPath defaultInterface
|
||||
{ interfaceName = interface
|
||||
, interfaceMethods =
|
||||
[ autoMethod memToggle $ emitState client =<< toggle
|
||||
[ autoMethod memToggle $ emitState cl =<< toggle
|
||||
, autoMethod memQuery query
|
||||
]
|
||||
, interfaceSignals = [sig]
|
||||
|
|
@ -120,7 +119,7 @@ exportScreensaver client = Feature
|
|||
]
|
||||
}
|
||||
|
||||
callToggle :: Client -> FeatureIO
|
||||
callToggle :: Maybe Client -> FeatureIO
|
||||
callToggle client =
|
||||
(featureEndpoint xmonadBusName ssPath interface memToggle client)
|
||||
{ ftrName = "screensaver toggle" }
|
||||
|
|
@ -141,6 +140,8 @@ callQuery client = do
|
|||
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
|
||||
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
||||
|
||||
ssSignalDep :: Dependency
|
||||
ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
|
||||
$ Signal_ memState
|
||||
-- ssSignalDep :: Dependency
|
||||
ssSignalDep :: Endpoint
|
||||
-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
|
||||
-- $ Signal_ memState
|
||||
ssSignalDep = Endpoint ssPath interface $ Signal_ memState
|
||||
|
|
|
|||
|
|
@ -1,9 +1,18 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Functions for handling dependencies
|
||||
|
||||
module XMonad.Internal.Dependency
|
||||
( MaybeAction
|
||||
, MaybeX
|
||||
, Parent(..)
|
||||
-- , ConstFeature(..)
|
||||
, Chain(..)
|
||||
, DBusEndpoint_(..)
|
||||
, DBusBus_(..)
|
||||
, FeatureX
|
||||
, FeatureIO
|
||||
, Feature(..)
|
||||
|
|
@ -37,7 +46,7 @@ module XMonad.Internal.Dependency
|
|||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Bifunctor (bimap)
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Data.List (find)
|
||||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
||||
|
||||
|
|
@ -67,14 +76,34 @@ import XMonad.Internal.Shell
|
|||
-- dependencies that target the output/state of another feature; this is more
|
||||
-- robust anyways, at the cost of being a bit slower.
|
||||
|
||||
data Feature a = Feature
|
||||
{ ftrMaybeAction :: a
|
||||
data Feature a = forall e. Evaluable e => Feature
|
||||
{ ftrMaybeAction :: e a
|
||||
, ftrName :: String
|
||||
, ftrWarning :: Warning
|
||||
, ftrChildren :: [Dependency]
|
||||
-- , ftrChildren :: [Dependency]
|
||||
}
|
||||
| ConstFeature a
|
||||
| BlankFeature
|
||||
-- | BlankFeature
|
||||
|
||||
-- TODO this name sucks
|
||||
data Parent a = Parent a [Dependency] deriving (Functor)
|
||||
|
||||
-- newtype ConstFeature a = ConstFeature a deriving (Functor)
|
||||
|
||||
data Chain a = forall b. Chain (b -> a) (IO (Either [String] b))
|
||||
|
||||
instance Functor Chain where
|
||||
fmap f (Chain a b) = Chain (f . a) b
|
||||
|
||||
data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint]
|
||||
|
||||
instance Functor DBusEndpoint_ where
|
||||
fmap f (DBusEndpoint_ a b c eps) = DBusEndpoint_ (f . a) b c eps
|
||||
|
||||
data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
|
||||
|
||||
instance Functor DBusBus_ where
|
||||
fmap f (DBusBus_ a b c eps) = DBusBus_ (f . a) b c eps
|
||||
|
||||
-- TODO this is silly as is, and could be made more useful by representing
|
||||
-- loglevels
|
||||
|
|
@ -84,17 +113,21 @@ type FeatureX = Feature (X ())
|
|||
|
||||
type FeatureIO = Feature (IO ())
|
||||
|
||||
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
|
||||
ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
|
||||
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
|
||||
ioFeature BlankFeature = BlankFeature
|
||||
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
|
||||
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
|
||||
ioFeature Feature {..} =
|
||||
-- HACK just doing a normal record update here will make GHC complain about
|
||||
-- an 'insufficiently polymorphic record update' ...I guess because my
|
||||
-- GADT isn't polymorphic enough (which is obviously BS)
|
||||
Feature {ftrMaybeAction = liftIO <$> ftrMaybeAction, ..}
|
||||
|
||||
featureDefault :: String -> [Dependency] -> a -> Feature a
|
||||
featureDefault n ds x = Feature
|
||||
{ ftrMaybeAction = x
|
||||
-- { ftrMaybeAction = x
|
||||
{ ftrMaybeAction = Parent x ds
|
||||
, ftrName = n
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = ds
|
||||
-- , ftrChildren = ds
|
||||
}
|
||||
|
||||
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
||||
|
|
@ -104,17 +137,18 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
|
|||
featureExeArgs n cmd args =
|
||||
featureDefault n [Executable cmd] $ spawnCmd cmd args
|
||||
|
||||
-- TODO the bus and client might refer to different things
|
||||
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
|
||||
-> Client -> FeatureIO
|
||||
-> Maybe Client -> FeatureIO
|
||||
featureEndpoint busname path iface mem client = Feature
|
||||
{ ftrMaybeAction = cmd
|
||||
-- { ftrMaybeAction = cmd
|
||||
{ ftrMaybeAction = DBusEndpoint_ cmd busname client deps
|
||||
, ftrName = "screensaver toggle"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
|
||||
-- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
|
||||
}
|
||||
where
|
||||
cmd = void $ callMethod client busname path iface mem
|
||||
cmd = \c -> void $ callMethod c busname path iface mem
|
||||
deps = [Endpoint path iface $ Method_ mem]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Feature evaluation
|
||||
|
|
@ -123,24 +157,62 @@ featureEndpoint busname path iface mem client = Feature
|
|||
-- either the action of the feature or 0 or more error messages that signify
|
||||
-- what dependencies are missing and why.
|
||||
|
||||
class Functor e => Evaluable e where
|
||||
eval :: e a -> IO (MaybeAction a)
|
||||
|
||||
type MaybeAction a = Either [String] a
|
||||
|
||||
type MaybeX = MaybeAction (X ())
|
||||
|
||||
instance Evaluable Parent where
|
||||
eval (Parent a ds) = do
|
||||
es <- catMaybes <$> mapM evalDependency ds
|
||||
return $ case es of
|
||||
[] -> Right a
|
||||
es' -> Left es'
|
||||
|
||||
-- instance Evaluable ConstFeature where
|
||||
-- eval (ConstFeature a) = return $ Right a
|
||||
|
||||
instance Evaluable Chain where
|
||||
eval (Chain a b) = second a <$> b
|
||||
|
||||
instance Evaluable DBusEndpoint_ where
|
||||
eval (DBusEndpoint_ _ _ Nothing _) = return $ Left ["client not available"]
|
||||
eval (DBusEndpoint_ action busname (Just client) deps) = do
|
||||
es <- catMaybes <$> mapM (endpointSatisfied client busname) deps
|
||||
return $ case es of
|
||||
[] -> Right $ action client
|
||||
es' -> Left es'
|
||||
|
||||
instance Evaluable DBusBus_ where
|
||||
eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
|
||||
eval (DBusBus_ action busname (Just client) deps) = do
|
||||
res <- busSatisfied client busname
|
||||
es <- catMaybes . (res:) <$> mapM evalDependency deps
|
||||
return $ case es of
|
||||
[] -> Right $ action client
|
||||
es' -> Left es'
|
||||
|
||||
-- instance Evaluable BlankFeature where
|
||||
-- eval (BlankFeature a) = Left ["hopefully a useful error message"]
|
||||
|
||||
evalFeature :: Feature a -> IO (MaybeAction a)
|
||||
evalFeature (ConstFeature x) = return $ Right x
|
||||
evalFeature BlankFeature = return $ Left []
|
||||
-- evalFeature BlankFeature = return $ Left []
|
||||
evalFeature Feature
|
||||
{ ftrMaybeAction = a
|
||||
, ftrName = n
|
||||
, ftrWarning = w
|
||||
, ftrChildren = c
|
||||
-- , ftrChildren = c
|
||||
} = do
|
||||
procName <- getProgName
|
||||
es <- catMaybes <$> mapM evalDependency c
|
||||
return $ case es of
|
||||
[] -> Right a
|
||||
es' -> Left $ fmtWarnings procName es'
|
||||
res <- eval a
|
||||
return $ first (fmtWarnings procName) res
|
||||
-- es <- catMaybes <$> mapM evalDependency c
|
||||
-- return $ case res of
|
||||
-- [] -> Right a
|
||||
-- es' -> Left $ fmtWarnings procName es'
|
||||
where
|
||||
fmtWarnings procName es = case w of
|
||||
Silent -> []
|
||||
|
|
@ -173,10 +245,11 @@ ifSatisfied _ alt = alt
|
|||
data Dependency = Executable String
|
||||
| AccessiblePath FilePath Bool Bool
|
||||
| IOTest (IO (Maybe String))
|
||||
| DBusEndpoint Bus Endpoint
|
||||
| DBusBus Bus
|
||||
-- | DBusEndpoint Bus Endpoint
|
||||
-- | DBusBus Bus
|
||||
| Systemd UnitType String
|
||||
|
||||
|
||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||
|
||||
data DBusMember = Method_ MemberName
|
||||
|
|
@ -214,8 +287,8 @@ evalDependency (Executable n) = exeSatisfied n
|
|||
evalDependency (IOTest t) = t
|
||||
evalDependency (Systemd t n) = unitSatisfied t n
|
||||
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
|
||||
evalDependency (DBusEndpoint b e) = endpointSatisfied b e
|
||||
evalDependency (DBusBus b) = busSatisfied b
|
||||
-- evalDependency (DBusEndpoint b e) = endpointSatisfied b e
|
||||
-- evalDependency (DBusBus b) = busSatisfied b
|
||||
|
||||
exeSatisfied :: String -> IO (Maybe String)
|
||||
exeSatisfied x = do
|
||||
|
|
@ -266,11 +339,11 @@ callMethod client bus path iface mem = do
|
|||
{ methodCallDestination = Just bus }
|
||||
return $ bimap methodErrorMessage methodReturnBody reply
|
||||
|
||||
busSatisfied :: Bus -> IO (Maybe String)
|
||||
busSatisfied (Bus usesystem bus) = do
|
||||
client <- if usesystem then connectSystem else connectSession
|
||||
busSatisfied :: Client -> BusName -> IO (Maybe String)
|
||||
busSatisfied client bus = do
|
||||
-- client <- if usesystem then connectSystem else connectSession
|
||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||
disconnect client
|
||||
-- disconnect client
|
||||
return $ case ret of
|
||||
Left e -> Just e
|
||||
Right b -> let ns = bodyGetNames b in
|
||||
|
|
@ -285,11 +358,11 @@ busSatisfied (Bus usesystem bus) = do
|
|||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
||||
bodyGetNames _ = []
|
||||
|
||||
endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
|
||||
endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
|
||||
client <- if u then connectSystem else connectSession
|
||||
ret <- callMethod client bus objpath introspectInterface introspectMethod
|
||||
disconnect client
|
||||
endpointSatisfied :: Client -> BusName -> Endpoint -> IO (Maybe String)
|
||||
endpointSatisfied client busname (Endpoint objpath iface mem) = do
|
||||
-- client <- if u then connectSystem else connectSession
|
||||
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
||||
-- disconnect client
|
||||
return $ case ret of
|
||||
Left e -> Just e
|
||||
Right body -> procBody body
|
||||
|
|
@ -315,7 +388,7 @@ endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
|
|||
, "on interface"
|
||||
, singleQuote $ formatInterfaceName iface
|
||||
, "on bus"
|
||||
, formatBusName bus
|
||||
, formatBusName busname
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue