REF consolidate method call functions

This commit is contained in:
Nathan Dwarshuis 2021-11-21 16:58:01 -05:00
parent da1e4a1c79
commit 81543cbbbc
4 changed files with 28 additions and 35 deletions

View File

@ -61,10 +61,11 @@ brightnessControls bc =
where where
cb = callBacklight bc cb = callBacklight bc
-- TODO not dry
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c) callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
reply <- callMethod $ methodCall p i memGet reply <- callMethod xmonadBus p i memGet
return $ reply >>= bodyGetBrightness return $ either (const Nothing) bodyGetBrightness reply
signalDep :: BrightnessConfig a b -> Dependency signalDep :: BrightnessConfig a b -> Dependency
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
@ -133,7 +134,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
Feature Feature
{ ftrMaybeAction = void $ callMethod $ methodCall p i m { ftrMaybeAction = void $ callMethod xmonadBus p i m
, ftrName = unwords [n, controlName] , ftrName = unwords [n, controlName]
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [xDbusDep p i $ Method_ m] , ftrChildren = [xDbusDep p i $ Method_ m]

View File

@ -2,9 +2,9 @@
-- | Common internal DBus functions -- | Common internal DBus functions
module XMonad.Internal.DBus.Common module XMonad.Internal.DBus.Common
( callMethod -- ( callMethod
, callMethod' -- , callMethod'
, addMatchCallback ( addMatchCallback
, xmonadBus , xmonadBus
, xmonadBusName , xmonadBusName
, xDbusDep , xDbusDep
@ -25,36 +25,25 @@ xmonadBus = Bus False xmonadBusName
xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
-- connectBus :: Bus -> IO (Maybe Client) -- -- | Call a method and return its result if successful
-- callMethod :: MethodCall -> IO (Maybe [Variant])
-- callMethod mc = do
-- client <- connectSession
-- r <- callMethod' client (Just xmonadBusName) mc
-- disconnect client
-- return r
-- | Call a method and return its result if successful -- callMethod' :: Client -> Maybe BusName -> MethodCall -> IO (Maybe [Variant])
callMethod :: MethodCall -> IO (Maybe [Variant]) -- callMethod' client bn mc = do
callMethod mc = do -- -- TODO handle clienterrors here
client <- connectSession -- reply <- call client mc { methodCallDestination = bn }
r <- callMethod' client (Just xmonadBusName) mc -- -- TODO not all methods warrant that we wait for a reply? (see callNoReply)
disconnect client -- return $ case reply of
return r -- Left _ -> Nothing
-- Right ret -> Just $ methodReturnBody ret
callMethod' :: Client -> Maybe BusName -> MethodCall -> IO (Maybe [Variant])
callMethod' client bn mc = do
-- TODO handle clienterrors here
reply <- call client mc { methodCallDestination = bn }
-- TODO not all methods warrant that we wait for a reply? (see callNoReply)
return $ case reply of
Left _ -> Nothing
Right ret -> Just $ methodReturnBody ret
-- | Bind a callback to a signal match rule -- | Bind a callback to a signal match rule
addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
addMatchCallback rule cb = do addMatchCallback rule cb = do
client <- connectSession client <- connectSession
addMatch client rule $ cb . signalBody addMatch client rule $ cb . signalBody
-- initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
-- initControls client exporter controls = do
-- let x = exporter client
-- e <- evalFeature x
-- case e of
-- (Right c) -> c
-- _ -> return ()
-- return $ controls x

View File

@ -128,12 +128,13 @@ callToggle = Feature
, ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle] , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
} }
where where
cmd = void $ callMethod $ methodCall ssPath interface memToggle cmd = void $ callMethod xmonadBus ssPath interface memToggle
callQuery :: IO (Maybe SSState) callQuery :: IO (Maybe SSState)
callQuery = do callQuery = do
reply <- callMethod $ methodCall ssPath interface memQuery reply <- callMethod xmonadBus ssPath interface memQuery
return $ reply >>= bodyGetCurrentState -- return $ reply >>= bodyGetCurrentState
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState

View File

@ -30,6 +30,7 @@ module XMonad.Internal.Dependency
, executeFeature_ , executeFeature_
, applyFeature , applyFeature
, applyFeature_ , applyFeature_
, callMethod
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -243,6 +244,7 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
-- TODO this belongs somewhere else, IDK where tho for now
callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant]) callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant])
callMethod (Bus usesys bus) path iface mem = do callMethod (Bus usesys bus) path iface mem = do
client <- if usesys then connectSystem else connectSession client <- if usesys then connectSystem else connectSession