From 5a4c411df5d94fb42e9f55dbe2890e5dbd1bc367 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 21 Nov 2021 23:07:33 -0500 Subject: [PATCH] ENH use dependencies in dbus endpoint tests --- bin/xmobar.hs | 23 ++++++++---------- lib/XMonad/Internal/Concurrent/Removable.hs | 2 +- lib/XMonad/Internal/Dependency.hs | 27 ++++++--------------- 3 files changed, 19 insertions(+), 33 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index c0eb163..9ebe90f 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -274,7 +274,7 @@ rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec] rightPlugins sysClient sesClient = mapM evalFeature [ getWireless , getEthernet - , getVPN + , getVPN sysClient , getBt sysClient , getAlsa , getBattery @@ -291,8 +291,6 @@ getWireless = Feature , ftrName = "wireless status indicator" , ftrWarning = Default } - -- i <- readInterface isWireless - -- return $ maybe (Left []) (Right . wirelessCmd) i -- TODO this needs a dbus interface getEthernet :: BarFeature @@ -316,20 +314,19 @@ getBattery = Feature type BarFeature = Feature CmdSpec -getVPN :: BarFeature -getVPN = Feature - { ftrMaybeAction = Parent vpnCmd [v] +getVPN :: Maybe Client -> BarFeature +getVPN client = Feature + { ftrMaybeAction = DBusEndpoint_ (const vpnCmd) vpnBus client + [Endpoint vpnPath vpnInterface $ Property_ vpnConnType] + [IOTest vpnPresent] , ftrName = "VPN status indicator" , ftrWarning = Default } - where - -- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType - v = IOTest vpnPresent getBt :: Maybe Client -> BarFeature getBt client = Feature { ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client - [Endpoint btPath btInterface $ Property_ btPowered] + [Endpoint btPath btInterface $ Property_ btPowered] [] , ftrName = "bluetooth status indicator" , ftrWarning = Default } @@ -343,21 +340,21 @@ getAlsa = Feature getBl :: Maybe Client -> BarFeature getBl client = Feature - { ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep] + { ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep] [] , ftrName = "Intel backlight indicator" , ftrWarning = Default } getCk :: Maybe Client -> BarFeature getCk client = Feature - { ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep] + { ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep] [] , ftrName = "Clevo keyboard indicator" , ftrWarning = Default } getSs :: Maybe Client -> BarFeature getSs client = Feature - { ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep] + { ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep] [] , ftrName = "screensaver indicator" , ftrWarning = Default } diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index aa14ab9..bdcc5e2 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -90,7 +90,7 @@ listenDevices = do runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon client = Feature - { ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep] + { ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep] [] , ftrName = "removeable device monitor" , ftrWarning = Default } diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 6c4db28..433c9c3 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -9,7 +9,6 @@ module XMonad.Internal.Dependency ( MaybeAction , MaybeX , Parent(..) - -- , ConstFeature(..) , Chain(..) , DBusEndpoint_(..) , DBusBus_(..) @@ -80,25 +79,21 @@ data Feature a = forall e. Evaluable e => Feature { ftrMaybeAction :: e a , ftrName :: String , ftrWarning :: Warning - -- , ftrChildren :: [Dependency] } | ConstFeature a -- | 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] +data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] [Dependency] 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] @@ -123,11 +118,9 @@ ioFeature Feature {..} = featureDefault :: String -> [Dependency] -> a -> Feature a featureDefault n ds x = Feature - -- { ftrMaybeAction = x { ftrMaybeAction = Parent x ds , ftrName = n , ftrWarning = Default - -- , ftrChildren = ds } featureExe :: MonadIO m => String -> String -> Feature (m ()) @@ -140,11 +133,9 @@ featureExeArgs n cmd args = featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client -> FeatureIO featureEndpoint busname path iface mem client = Feature - -- { ftrMaybeAction = cmd - { ftrMaybeAction = DBusEndpoint_ cmd busname client deps + { ftrMaybeAction = DBusEndpoint_ cmd busname client deps [] , ftrName = "screensaver toggle" , ftrWarning = Default - -- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem] } where cmd = \c -> void $ callMethod c busname path iface mem @@ -171,17 +162,15 @@ instance Evaluable Parent where [] -> 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 + eval (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"] + eval (DBusEndpoint_ action busname (Just client) es ds) = do + eperrors <- mapM (endpointSatisfied client busname) es + dperrors <- mapM evalDependency ds + return $ case catMaybes (eperrors ++ dperrors) of [] -> Right $ action client es' -> Left es'