ENH use cleaner type interface

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
   }

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
   }

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

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
   }

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

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

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