From 010b612b93191cac6aa5f3d9d0c8c9bb6995ae6a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 22 Nov 2021 23:02:23 -0500 Subject: [PATCH] ENH use cleaner type interface --- bin/xmobar.hs | 32 +++---- lib/XMonad/Internal/Concurrent/Removable.hs | 8 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 2 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- .../DBus/Brightness/IntelBacklight.hs | 2 +- lib/XMonad/Internal/DBus/Screensaver.hs | 4 +- lib/XMonad/Internal/Dependency.hs | 91 ++++++++++--------- 7 files changed, 71 insertions(+), 72 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 8a2d2b7..84858b5 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -269,7 +269,7 @@ vpnPresent = do rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec] rightPlugins sysClient sesClient = mapM evalFeature [ getWireless - , getEthernet + , getEthernet sysClient , getVPN sysClient , getBt sysClient , getAlsa @@ -283,27 +283,23 @@ rightPlugins sysClient sesClient = mapM evalFeature getWireless :: BarFeature getWireless = Feature - { ftrAction = Chain wirelessCmd $ readInterface isWireless + { ftrAction = GenTree (Double wirelessCmd $ readInterface isWireless) [] , ftrName = "wireless status indicator" , ftrWarning = Default } --- TODO this needs a dbus interface -getEthernet :: BarFeature -getEthernet = Feature - { ftrAction = Chain ethernetCmd (readInterface isEthernet) +getEthernet :: Maybe Client -> BarFeature +getEthernet client = Feature + { ftrAction = DBusTree (Double (\i _ -> ethernetCmd i) (readInterface isEthernet)) client [dep] [] , 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 + where + dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP getBattery :: BarFeature getBattery = Feature - { ftrAction = Parent batteryCmd [IOTest hasBattery] + { ftrAction = GenTree (Single batteryCmd) [IOTest hasBattery] , ftrName = "battery level indicator" , ftrWarning = Default } @@ -312,7 +308,7 @@ type BarFeature = Feature CmdSpec getVPN :: Maybe Client -> BarFeature getVPN client = Feature - { ftrAction = DBusEndpoint (const vpnCmd) client [ep] [dp] + { ftrAction = DBusTree (Single (const vpnCmd)) client [ep] [dp] , ftrName = "VPN status indicator" , ftrWarning = Default } @@ -322,7 +318,7 @@ getVPN client = Feature getBt :: Maybe Client -> BarFeature getBt client = Feature - { ftrAction = DBusEndpoint (const btCmd) client [ep] [] + { ftrAction = DBusTree (Single (const btCmd)) client [ep] [] , ftrName = "bluetooth status indicator" , ftrWarning = Default } @@ -331,28 +327,28 @@ getBt client = Feature getAlsa :: BarFeature getAlsa = Feature - { ftrAction = Parent alsaCmd [Executable "alsactl"] + { ftrAction = GenTree (Single alsaCmd) [Executable "alsactl"] , ftrName = "volume level indicator" , ftrWarning = Default } getBl :: Maybe Client -> BarFeature getBl client = Feature - { ftrAction = DBusEndpoint (const blCmd) client [intelBacklightSignalDep] [] + { ftrAction = DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] [] , ftrName = "Intel backlight indicator" , ftrWarning = Default } getCk :: Maybe Client -> BarFeature getCk client = Feature - { ftrAction = DBusEndpoint (const ckCmd) client [clevoKeyboardSignalDep] [] + { ftrAction = DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] [] , ftrName = "Clevo keyboard indicator" , ftrWarning = Default } getSs :: Maybe Client -> BarFeature getSs client = Feature - { ftrAction = DBusEndpoint (const ssCmd) client [ssSignalDep] [] + { ftrAction = DBusTree (Single (const ssCmd)) client [ssSignalDep] [] , ftrName = "screensaver indicator" , ftrWarning = Default } diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 3fea91e..cf97c5c 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -33,13 +33,13 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> Endpoint +dbusDep :: MemberName -> DBusDep dbusDep m = Endpoint bus path interface $ Signal_ m -addedDep :: Endpoint +addedDep :: DBusDep addedDep = dbusDep memAdded -removedDep :: Endpoint +removedDep :: DBusDep removedDep = dbusDep memRemoved driveInsertedSound :: FilePath @@ -86,7 +86,7 @@ listenDevices = do runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon client = Feature - { ftrAction = DBusEndpoint (const listenDevices) client [addedDep, removedDep] [] + { ftrAction = DBusTree (Single (const listenDevices)) client [addedDep, removedDep] [] , ftrName = "removeable device monitor" , ftrWarning = Default } diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index f9336fd..57eb954 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -113,7 +113,7 @@ stateFileDep = pathRW stateFile brightnessFileDep :: Dependency brightnessFileDep = pathR brightnessFile -clevoKeyboardSignalDep :: Endpoint +clevoKeyboardSignalDep :: DBusDep clevoKeyboardSignalDep = signalDep clevoKeyboardConfig exportClevoKeyboard :: Maybe Client -> FeatureIO diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index db4d241..5c18a49 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -67,7 +67,7 @@ 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 -> Endpoint +signalDep :: BrightnessConfig a b -> DBusDep signalDep BrightnessConfig { bcPath = p, bcInterface = i } = Endpoint xmonadBusName p i $ Signal_ memCur @@ -90,7 +90,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Maybe Client -> FeatureIO brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature - { ftrAction = DBusBus (exportBrightnessControls' bc) xmonadBusName client deps + { ftrAction = DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps , ftrName = n ++ " exporter" , ftrWarning = Default } diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 066bd77..2b855bc 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -95,7 +95,7 @@ curFileDep = pathRW curFile maxFileDep :: Dependency maxFileDep = pathR maxFile -intelBacklightSignalDep :: Endpoint +intelBacklightSignalDep :: DBusDep intelBacklightSignalDep = signalDep intelBacklightConfig exportIntelBacklight :: Maybe Client -> FeatureIO diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index d564eb7..46fca2d 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing exportScreensaver :: Maybe Client -> FeatureIO exportScreensaver client = Feature - { ftrAction = DBusBus cmd xmonadBusName client [Executable ssExecutable] + { ftrAction = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable] , ftrName = "screensaver interface" , ftrWarning = Default } @@ -132,5 +132,5 @@ callQuery client = do matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState -ssSignalDep :: Endpoint +ssSignalDep :: DBusDep ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index add10a6..a698fb4 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -7,14 +7,15 @@ module XMonad.Internal.Dependency ( MaybeAction , MaybeX + , DepTree(..) , Action(..) + , DBusDep(..) , FeatureX , FeatureIO , Feature(..) , Warning(..) , Dependency(..) , UnitType(..) - , Endpoint(..) , DBusMember(..) , ioFeature , evalFeature @@ -37,10 +38,10 @@ module XMonad.Internal.Dependency , callMethod ) where -import Control.Monad (void) import Control.Monad.IO.Class +import Control.Monad.Identity -import Data.Bifunctor (bimap, first, second) +import Data.Bifunctor (bimap, first) import Data.List (find) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) @@ -71,22 +72,24 @@ import XMonad.Internal.Shell -- robust anyways, at the cost of being a bit slower. data Feature a = Feature - { ftrAction :: Action a + { ftrAction :: DepTree a , ftrName :: String , ftrWarning :: Warning } | ConstFeature a -data Action a = Parent a [Dependency] - | forall b. Chain (b -> a) (IO (Either [String] b)) - | DBusEndpoint (Client -> a) (Maybe Client) [Endpoint] [Dependency] - | DBusBus (Client -> a) BusName (Maybe Client) [Dependency] +data DepTree a = GenTree (Action a) [Dependency] + | DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency] + +data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b)) instance Functor Action where - fmap f (Parent a ds) = Parent (f a) ds - fmap f (Chain a b) = Chain (f . a) b - fmap f (DBusEndpoint a c es ds) = DBusEndpoint (f . a) c es ds - fmap f (DBusBus a b c eps) = DBusBus (f . a) b c eps + fmap f (Single a) = Single (f a) + fmap f (Double a b) = Double (f . a) b + +instance Functor DepTree where + fmap f (GenTree a ds) = GenTree (f <$> a) ds + fmap f (DBusTree a c es ds) = DBusTree (fmap (fmap f) a) c es ds -- TODO this is silly as is, and could be made more useful by representing -- loglevels @@ -106,7 +109,7 @@ ioFeature Feature {..} = featureDefault :: String -> [Dependency] -> a -> Feature a featureDefault n ds x = Feature - { ftrAction = Parent x ds + { ftrAction = GenTree (Single x) ds , ftrName = n , ftrWarning = Default } @@ -121,7 +124,7 @@ featureExeArgs n cmd args = featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client -> FeatureIO featureEndpoint busname path iface mem client = Feature - { ftrAction = DBusEndpoint cmd client deps [] + { ftrAction = DBusTree (Single cmd) client deps [] , ftrName = "screensaver toggle" , ftrWarning = Default } @@ -140,31 +143,33 @@ type MaybeAction a = Either [String] a type MaybeX = MaybeAction (X ()) -evalAction :: Action a -> IO (MaybeAction a) +evalTree :: DepTree a -> IO (MaybeAction a) -evalAction (Parent a ds) = do +evalTree (GenTree action ds) = do es <- catMaybes <$> mapM evalDependency ds - return $ case es of - [] -> Right a - es' -> Left es' + case es of + [] -> do + action' <- evalAction action + return $ case action' of + Right f -> Right f + Left es' -> Left es' + es' -> return $ Left es' -evalAction (Chain a b) = second a <$> b - -evalAction (DBusEndpoint _ Nothing _ _) = return $ Left ["client not available"] -evalAction (DBusEndpoint action (Just client) es ds) = do - eperrors <- mapM (endpointSatisfied client) es +evalTree (DBusTree _ Nothing _ _) = return $ Left ["client not available"] +evalTree (DBusTree action (Just client) es ds) = do + eperrors <- mapM (dbusDepSatisfied client) es dperrors <- mapM evalDependency ds - return $ case catMaybes (eperrors ++ dperrors) of - [] -> Right $ action client - es' -> Left es' + case catMaybes (eperrors ++ dperrors) of + [] -> do + action' <- evalAction action + return $ case action' of + Right f -> Right $ f client + Left es' -> Left es' + es' -> return $ Left es' -evalAction (DBusBus _ _ Nothing _) = return $ Left ["client not available"] -evalAction (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' +evalAction :: Action a -> IO (Either [String] a) +evalAction (Single a) = return $ Right a +evalAction (Double a b) = fmap a <$> b evalFeature :: Feature a -> IO (MaybeAction a) evalFeature (ConstFeature x) = return $ Right x @@ -174,7 +179,7 @@ evalFeature Feature , ftrWarning = w } = do procName <- getProgName - res <- evalAction a + res <- evalTree a return $ first (fmtWarnings procName) res where fmtWarnings procName es = case w of @@ -217,7 +222,10 @@ data DBusMember = Method_ MemberName | Property_ String deriving (Eq, Show) -data Endpoint = Endpoint BusName ObjectPath InterfaceName DBusMember deriving (Eq, Show) +data DBusDep = + Bus BusName + | Endpoint BusName ObjectPath InterfaceName DBusMember + deriving (Eq, Show) pathR :: String -> Dependency pathR n = AccessiblePath n True False @@ -295,11 +303,9 @@ callMethod client bus path iface mem = do { methodCallDestination = Just bus } return $ bimap methodErrorMessage methodReturnBody reply -busSatisfied :: Client -> BusName -> IO (Maybe String) -busSatisfied client bus = do - -- client <- if usesystem then connectSystem else connectSession +dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String) +dbusDepSatisfied client (Bus bus) = do ret <- callMethod client queryBus queryPath queryIface queryMem - -- disconnect client return $ case ret of Left e -> Just e Right b -> let ns = bodyGetNames b in @@ -314,11 +320,8 @@ busSatisfied client bus = do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -endpointSatisfied :: Client -> Endpoint -> IO (Maybe String) -endpointSatisfied client (Endpoint busname objpath iface mem) = do - -- client <- if u then connectSystem else connectSession +dbusDepSatisfied client (Endpoint busname objpath iface mem) = do ret <- callMethod client busname objpath introspectInterface introspectMethod - -- disconnect client return $ case ret of Left e -> Just e Right body -> procBody body