ENH use cleaner type interface

This commit is contained in:
Nathan Dwarshuis 2021-11-22 23:02:23 -05:00
parent e3a7191ed9
commit 010b612b93
7 changed files with 71 additions and 72 deletions

View File

@ -269,7 +269,7 @@ vpnPresent = do
rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec] rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
rightPlugins sysClient sesClient = mapM evalFeature rightPlugins sysClient sesClient = mapM evalFeature
[ getWireless [ getWireless
, getEthernet , getEthernet sysClient
, getVPN sysClient , getVPN sysClient
, getBt sysClient , getBt sysClient
, getAlsa , getAlsa
@ -283,27 +283,23 @@ rightPlugins sysClient sesClient = mapM evalFeature
getWireless :: BarFeature getWireless :: BarFeature
getWireless = Feature getWireless = Feature
{ ftrAction = Chain wirelessCmd $ readInterface isWireless { ftrAction = GenTree (Double wirelessCmd $ readInterface isWireless) []
, ftrName = "wireless status indicator" , ftrName = "wireless status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
-- TODO this needs a dbus interface getEthernet :: Maybe Client -> BarFeature
getEthernet :: BarFeature getEthernet client = Feature
getEthernet = Feature { ftrAction = DBusTree (Double (\i _ -> ethernetCmd i) (readInterface isEthernet)) client [dep] []
{ ftrAction = Chain ethernetCmd (readInterface isEthernet)
, ftrName = "ethernet status indicator" , ftrName = "ethernet status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
where
-- i <- readInterface isEthernet dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP
-- evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
-- where
-- dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
getBattery :: BarFeature getBattery :: BarFeature
getBattery = Feature getBattery = Feature
{ ftrAction = Parent batteryCmd [IOTest hasBattery] { ftrAction = GenTree (Single batteryCmd) [IOTest hasBattery]
, ftrName = "battery level indicator" , ftrName = "battery level indicator"
, ftrWarning = Default , ftrWarning = Default
} }
@ -312,7 +308,7 @@ type BarFeature = Feature CmdSpec
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN client = Feature getVPN client = Feature
{ ftrAction = DBusEndpoint (const vpnCmd) client [ep] [dp] { ftrAction = DBusTree (Single (const vpnCmd)) client [ep] [dp]
, ftrName = "VPN status indicator" , ftrName = "VPN status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
@ -322,7 +318,7 @@ getVPN client = Feature
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = Feature getBt client = Feature
{ ftrAction = DBusEndpoint (const btCmd) client [ep] [] { ftrAction = DBusTree (Single (const btCmd)) client [ep] []
, ftrName = "bluetooth status indicator" , ftrName = "bluetooth status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
@ -331,28 +327,28 @@ getBt client = Feature
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = Feature getAlsa = Feature
{ ftrAction = Parent alsaCmd [Executable "alsactl"] { ftrAction = GenTree (Single alsaCmd) [Executable "alsactl"]
, ftrName = "volume level indicator" , ftrName = "volume level indicator"
, ftrWarning = Default , ftrWarning = Default
} }
getBl :: Maybe Client -> BarFeature getBl :: Maybe Client -> BarFeature
getBl client = Feature getBl client = Feature
{ ftrAction = DBusEndpoint (const blCmd) client [intelBacklightSignalDep] [] { ftrAction = DBusTree (Single (const blCmd)) 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
{ ftrAction = DBusEndpoint (const ckCmd) client [clevoKeyboardSignalDep] [] { ftrAction = DBusTree (Single (const ckCmd)) 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
{ ftrAction = DBusEndpoint (const ssCmd) client [ssSignalDep] [] { ftrAction = DBusTree (Single (const ssCmd)) client [ssSignalDep] []
, ftrName = "screensaver indicator" , ftrName = "screensaver indicator"
, ftrWarning = Default , ftrWarning = Default
} }

View File

@ -33,13 +33,13 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> Endpoint dbusDep :: MemberName -> DBusDep
dbusDep m = Endpoint bus path interface $ Signal_ m dbusDep m = Endpoint bus path interface $ Signal_ m
addedDep :: Endpoint addedDep :: DBusDep
addedDep = dbusDep memAdded addedDep = dbusDep memAdded
removedDep :: Endpoint removedDep :: DBusDep
removedDep = dbusDep memRemoved removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath driveInsertedSound :: FilePath
@ -86,7 +86,7 @@ listenDevices = do
runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon :: Maybe Client -> FeatureIO
runRemovableMon client = Feature runRemovableMon client = Feature
{ ftrAction = DBusEndpoint (const listenDevices) client [addedDep, removedDep] [] { ftrAction = DBusTree (Single (const listenDevices)) client [addedDep, removedDep] []
, ftrName = "removeable device monitor" , ftrName = "removeable device monitor"
, ftrWarning = Default , ftrWarning = Default
} }

View File

@ -113,7 +113,7 @@ stateFileDep = pathRW stateFile
brightnessFileDep :: Dependency brightnessFileDep :: Dependency
brightnessFileDep = pathR brightnessFile brightnessFileDep = pathR brightnessFile
clevoKeyboardSignalDep :: Endpoint clevoKeyboardSignalDep :: DBusDep
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe Client -> FeatureIO exportClevoKeyboard :: Maybe Client -> FeatureIO

View File

@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do
reply <- callMethod client xmonadBusName p i memGet reply <- callMethod client xmonadBusName p i memGet
return $ either (const Nothing) bodyGetBrightness reply return $ either (const Nothing) bodyGetBrightness reply
signalDep :: BrightnessConfig a b -> Endpoint signalDep :: BrightnessConfig a b -> DBusDep
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint xmonadBusName p i $ Signal_ memCur 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 brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Maybe Client -> FeatureIO -> Maybe Client -> FeatureIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature 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" , ftrName = n ++ " exporter"
, ftrWarning = Default , ftrWarning = Default
} }

View File

@ -95,7 +95,7 @@ curFileDep = pathRW curFile
maxFileDep :: Dependency maxFileDep :: Dependency
maxFileDep = pathR maxFile maxFileDep = pathR maxFile
intelBacklightSignalDep :: Endpoint intelBacklightSignalDep :: DBusDep
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe Client -> FeatureIO exportIntelBacklight :: Maybe Client -> FeatureIO

View File

@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver :: Maybe Client -> FeatureIO exportScreensaver :: Maybe Client -> FeatureIO
exportScreensaver client = Feature exportScreensaver client = Feature
{ ftrAction = DBusBus cmd xmonadBusName client [Executable ssExecutable] { ftrAction = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable]
, ftrName = "screensaver interface" , ftrName = "screensaver interface"
, ftrWarning = Default , ftrWarning = Default
} }
@ -132,5 +132,5 @@ callQuery client = do
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
ssSignalDep :: Endpoint ssSignalDep :: DBusDep
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

View File

@ -7,14 +7,15 @@
module XMonad.Internal.Dependency module XMonad.Internal.Dependency
( MaybeAction ( MaybeAction
, MaybeX , MaybeX
, DepTree(..)
, Action(..) , Action(..)
, DBusDep(..)
, FeatureX , FeatureX
, FeatureIO , FeatureIO
, Feature(..) , Feature(..)
, Warning(..) , Warning(..)
, Dependency(..) , Dependency(..)
, UnitType(..) , UnitType(..)
, Endpoint(..)
, DBusMember(..) , DBusMember(..)
, ioFeature , ioFeature
, evalFeature , evalFeature
@ -37,10 +38,10 @@ module XMonad.Internal.Dependency
, callMethod , callMethod
) where ) where
import Control.Monad (void)
import Control.Monad.IO.Class 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.List (find)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
@ -71,22 +72,24 @@ import XMonad.Internal.Shell
-- robust anyways, at the cost of being a bit slower. -- robust anyways, at the cost of being a bit slower.
data Feature a = Feature data Feature a = Feature
{ ftrAction :: Action a { ftrAction :: DepTree a
, ftrName :: String , ftrName :: String
, ftrWarning :: Warning , ftrWarning :: Warning
} }
| ConstFeature a | ConstFeature a
data Action a = Parent a [Dependency] data DepTree a = GenTree (Action a) [Dependency]
| forall b. Chain (b -> a) (IO (Either [String] b)) | DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency]
| DBusEndpoint (Client -> a) (Maybe Client) [Endpoint] [Dependency]
| DBusBus (Client -> a) BusName (Maybe Client) [Dependency] data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
instance Functor Action where instance Functor Action where
fmap f (Parent a ds) = Parent (f a) ds fmap f (Single a) = Single (f a)
fmap f (Chain a b) = Chain (f . a) b fmap f (Double a b) = Double (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 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 -- TODO this is silly as is, and could be made more useful by representing
-- loglevels -- loglevels
@ -106,7 +109,7 @@ ioFeature Feature {..} =
featureDefault :: String -> [Dependency] -> a -> Feature a featureDefault :: String -> [Dependency] -> a -> Feature a
featureDefault n ds x = Feature featureDefault n ds x = Feature
{ ftrAction = Parent x ds { ftrAction = GenTree (Single x) ds
, ftrName = n , ftrName = n
, ftrWarning = Default , ftrWarning = Default
} }
@ -121,7 +124,7 @@ 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
{ ftrAction = DBusEndpoint cmd client deps [] { ftrAction = DBusTree (Single cmd) client deps []
, ftrName = "screensaver toggle" , ftrName = "screensaver toggle"
, ftrWarning = Default , ftrWarning = Default
} }
@ -140,31 +143,33 @@ type MaybeAction a = Either [String] a
type MaybeX = MaybeAction (X ()) 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 es <- catMaybes <$> mapM evalDependency ds
return $ case es of case es of
[] -> Right a [] -> do
es' -> Left es' 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 evalTree (DBusTree _ Nothing _ _) = return $ Left ["client not available"]
evalTree (DBusTree action (Just client) es ds) = do
evalAction (DBusEndpoint _ Nothing _ _) = return $ Left ["client not available"] eperrors <- mapM (dbusDepSatisfied client) es
evalAction (DBusEndpoint action (Just client) es ds) = do
eperrors <- mapM (endpointSatisfied client) es
dperrors <- mapM evalDependency ds dperrors <- mapM evalDependency ds
return $ case catMaybes (eperrors ++ dperrors) of case catMaybes (eperrors ++ dperrors) of
[] -> Right $ action client [] -> do
es' -> Left es' 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 :: Action a -> IO (Either [String] a)
evalAction (DBusBus action busname (Just client) deps) = do evalAction (Single a) = return $ Right a
res <- busSatisfied client busname evalAction (Double a b) = fmap a <$> b
es <- catMaybes . (res:) <$> mapM evalDependency deps
return $ case es of
[] -> Right $ action client
es' -> Left es'
evalFeature :: Feature a -> IO (MaybeAction a) evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Right x evalFeature (ConstFeature x) = return $ Right x
@ -174,7 +179,7 @@ evalFeature Feature
, ftrWarning = w , ftrWarning = w
} = do } = do
procName <- getProgName procName <- getProgName
res <- evalAction a res <- evalTree a
return $ first (fmtWarnings procName) res return $ first (fmtWarnings procName) res
where where
fmtWarnings procName es = case w of fmtWarnings procName es = case w of
@ -217,7 +222,10 @@ data DBusMember = Method_ MemberName
| Property_ String | Property_ String
deriving (Eq, Show) 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 :: String -> Dependency
pathR n = AccessiblePath n True False pathR n = AccessiblePath n True False
@ -295,11 +303,9 @@ callMethod client bus path iface mem = do
{ methodCallDestination = Just bus } { methodCallDestination = Just bus }
return $ bimap methodErrorMessage methodReturnBody reply return $ bimap methodErrorMessage methodReturnBody reply
busSatisfied :: Client -> BusName -> IO (Maybe String) dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
busSatisfied client bus = do dbusDepSatisfied client (Bus bus) = do
-- client <- if usesystem then connectSystem else connectSession
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod client queryBus queryPath queryIface queryMem
-- disconnect client
return $ case ret of return $ case ret of
Left e -> Just e Left e -> Just e
Right b -> let ns = bodyGetNames b in Right b -> let ns = bodyGetNames b in
@ -314,11 +320,8 @@ busSatisfied client bus = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
endpointSatisfied :: Client -> Endpoint -> IO (Maybe String) dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
endpointSatisfied client (Endpoint busname objpath iface mem) = do
-- client <- if u then connectSystem else connectSession
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod client busname objpath introspectInterface introspectMethod
-- disconnect client
return $ case ret of return $ case ret of
Left e -> Just e Left e -> Just e
Right body -> procBody body Right body -> procBody body