ENH use dependencies in dbus endpoint tests
This commit is contained in:
parent
6ce38b7ade
commit
5a4c411df5
|
@ -274,7 +274,7 @@ rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
|
||||||
rightPlugins sysClient sesClient = mapM evalFeature
|
rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
[ getWireless
|
[ getWireless
|
||||||
, getEthernet
|
, getEthernet
|
||||||
, getVPN
|
, getVPN sysClient
|
||||||
, getBt sysClient
|
, getBt sysClient
|
||||||
, getAlsa
|
, getAlsa
|
||||||
, getBattery
|
, getBattery
|
||||||
|
@ -291,8 +291,6 @@ getWireless = Feature
|
||||||
, ftrName = "wireless status indicator"
|
, ftrName = "wireless status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
-- i <- readInterface isWireless
|
|
||||||
-- return $ maybe (Left []) (Right . wirelessCmd) i
|
|
||||||
|
|
||||||
-- TODO this needs a dbus interface
|
-- TODO this needs a dbus interface
|
||||||
getEthernet :: BarFeature
|
getEthernet :: BarFeature
|
||||||
|
@ -316,20 +314,19 @@ getBattery = Feature
|
||||||
|
|
||||||
type BarFeature = Feature CmdSpec
|
type BarFeature = Feature CmdSpec
|
||||||
|
|
||||||
getVPN :: BarFeature
|
getVPN :: Maybe Client -> BarFeature
|
||||||
getVPN = Feature
|
getVPN client = Feature
|
||||||
{ ftrMaybeAction = Parent vpnCmd [v]
|
{ ftrMaybeAction = DBusEndpoint_ (const vpnCmd) vpnBus client
|
||||||
|
[Endpoint vpnPath vpnInterface $ Property_ vpnConnType]
|
||||||
|
[IOTest vpnPresent]
|
||||||
, ftrName = "VPN status indicator"
|
, ftrName = "VPN status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
where
|
|
||||||
-- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
|
||||||
v = IOTest vpnPresent
|
|
||||||
|
|
||||||
getBt :: Maybe Client -> BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
getBt client = Feature
|
getBt client = Feature
|
||||||
{ ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client
|
{ ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client
|
||||||
[Endpoint btPath btInterface $ Property_ btPowered]
|
[Endpoint btPath btInterface $ Property_ btPowered] []
|
||||||
, ftrName = "bluetooth status indicator"
|
, ftrName = "bluetooth status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
@ -343,21 +340,21 @@ getAlsa = Feature
|
||||||
|
|
||||||
getBl :: Maybe Client -> BarFeature
|
getBl :: Maybe Client -> BarFeature
|
||||||
getBl client = Feature
|
getBl client = Feature
|
||||||
{ ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep]
|
{ ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep] []
|
||||||
, ftrName = "Intel backlight indicator"
|
, ftrName = "Intel backlight indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
|
||||||
getCk :: Maybe Client -> BarFeature
|
getCk :: Maybe Client -> BarFeature
|
||||||
getCk client = Feature
|
getCk client = Feature
|
||||||
{ ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep]
|
{ ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep] []
|
||||||
, ftrName = "Clevo keyboard indicator"
|
, ftrName = "Clevo keyboard indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
|
||||||
getSs :: Maybe Client -> BarFeature
|
getSs :: Maybe Client -> BarFeature
|
||||||
getSs client = Feature
|
getSs client = Feature
|
||||||
{ ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep]
|
{ ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep] []
|
||||||
, ftrName = "screensaver indicator"
|
, ftrName = "screensaver indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
|
|
@ -90,7 +90,7 @@ listenDevices = do
|
||||||
|
|
||||||
runRemovableMon :: Maybe Client -> FeatureIO
|
runRemovableMon :: Maybe Client -> FeatureIO
|
||||||
runRemovableMon client = Feature
|
runRemovableMon client = Feature
|
||||||
{ ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep]
|
{ ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep] []
|
||||||
, ftrName = "removeable device monitor"
|
, ftrName = "removeable device monitor"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
|
|
@ -9,7 +9,6 @@ module XMonad.Internal.Dependency
|
||||||
( MaybeAction
|
( MaybeAction
|
||||||
, MaybeX
|
, MaybeX
|
||||||
, Parent(..)
|
, Parent(..)
|
||||||
-- , ConstFeature(..)
|
|
||||||
, Chain(..)
|
, Chain(..)
|
||||||
, DBusEndpoint_(..)
|
, DBusEndpoint_(..)
|
||||||
, DBusBus_(..)
|
, DBusBus_(..)
|
||||||
|
@ -80,25 +79,21 @@ data Feature a = forall e. Evaluable e => Feature
|
||||||
{ ftrMaybeAction :: e a
|
{ ftrMaybeAction :: e a
|
||||||
, ftrName :: String
|
, ftrName :: String
|
||||||
, ftrWarning :: Warning
|
, ftrWarning :: Warning
|
||||||
-- , ftrChildren :: [Dependency]
|
|
||||||
}
|
}
|
||||||
| ConstFeature a
|
| ConstFeature a
|
||||||
-- | BlankFeature
|
-- | BlankFeature
|
||||||
|
|
||||||
-- TODO this name sucks
|
|
||||||
data Parent a = Parent a [Dependency] deriving (Functor)
|
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))
|
data Chain a = forall b. Chain (b -> a) (IO (Either [String] b))
|
||||||
|
|
||||||
instance Functor Chain where
|
instance Functor Chain where
|
||||||
fmap f (Chain a b) = Chain (f . a) b
|
fmap f (Chain a b) = Chain (f . a) b
|
||||||
|
|
||||||
data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint]
|
data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] [Dependency]
|
||||||
|
|
||||||
instance Functor DBusEndpoint_ where
|
instance Functor DBusEndpoint_ where
|
||||||
fmap f (DBusEndpoint_ a b c eps) = DBusEndpoint_ (f . a) b c eps
|
fmap f (DBusEndpoint_ a b c es ds) = DBusEndpoint_ (f . a) b c es ds
|
||||||
|
|
||||||
data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
|
data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
|
||||||
|
|
||||||
|
@ -123,11 +118,9 @@ ioFeature Feature {..} =
|
||||||
|
|
||||||
featureDefault :: String -> [Dependency] -> a -> Feature a
|
featureDefault :: String -> [Dependency] -> a -> Feature a
|
||||||
featureDefault n ds x = Feature
|
featureDefault n ds x = Feature
|
||||||
-- { ftrMaybeAction = x
|
|
||||||
{ ftrMaybeAction = Parent x ds
|
{ ftrMaybeAction = Parent x ds
|
||||||
, ftrName = n
|
, ftrName = n
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
-- , ftrChildren = ds
|
|
||||||
}
|
}
|
||||||
|
|
||||||
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
||||||
|
@ -140,11 +133,9 @@ featureExeArgs n cmd args =
|
||||||
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
|
featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
|
||||||
-> Maybe Client -> FeatureIO
|
-> Maybe Client -> FeatureIO
|
||||||
featureEndpoint busname path iface mem client = Feature
|
featureEndpoint busname path iface mem client = Feature
|
||||||
-- { ftrMaybeAction = cmd
|
{ ftrMaybeAction = DBusEndpoint_ cmd busname client deps []
|
||||||
{ ftrMaybeAction = DBusEndpoint_ cmd busname client deps
|
|
||||||
, ftrName = "screensaver toggle"
|
, ftrName = "screensaver toggle"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
-- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
|
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
cmd = \c -> void $ callMethod c busname path iface mem
|
cmd = \c -> void $ callMethod c busname path iface mem
|
||||||
|
@ -171,17 +162,15 @@ instance Evaluable Parent where
|
||||||
[] -> Right a
|
[] -> Right a
|
||||||
es' -> Left es'
|
es' -> Left es'
|
||||||
|
|
||||||
-- instance Evaluable ConstFeature where
|
|
||||||
-- eval (ConstFeature a) = return $ Right a
|
|
||||||
|
|
||||||
instance Evaluable Chain where
|
instance Evaluable Chain where
|
||||||
eval (Chain a b) = second a <$> b
|
eval (Chain a b) = second a <$> b
|
||||||
|
|
||||||
instance Evaluable DBusEndpoint_ where
|
instance Evaluable DBusEndpoint_ where
|
||||||
eval (DBusEndpoint_ _ _ Nothing _) = return $ Left ["client not available"]
|
eval (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"]
|
||||||
eval (DBusEndpoint_ action busname (Just client) deps) = do
|
eval (DBusEndpoint_ action busname (Just client) es ds) = do
|
||||||
es <- catMaybes <$> mapM (endpointSatisfied client busname) deps
|
eperrors <- mapM (endpointSatisfied client busname) es
|
||||||
return $ case es of
|
dperrors <- mapM evalDependency ds
|
||||||
|
return $ case catMaybes (eperrors ++ dperrors) of
|
||||||
[] -> Right $ action client
|
[] -> Right $ action client
|
||||||
es' -> Left es'
|
es' -> Left es'
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue