ENH use typeclass to make dependency interface more flexible

2021-11-21 22:47:43 -05:00 · 2021-11-21 22:47:43 -05:00 · 6ce38b7ade
parent 7e5a4a57cd
commit 6ce38b7ade
10 changed files with 235 additions and 141 deletions
--- a/bin/xmobar.hs
+++ b/bin/xmobar.hs
@ -16,7 +16,7 @@ import           Data.Either
 import           Data.List
 import           Data.Maybe

-import           DBus
+import           DBus.Client

 import           System.Directory
 import           System.Exit
@ -41,6 +41,8 @@ import           XMonad.Hooks.DynamicLog
 import           XMonad.Internal.Command.Power                  (hasBattery)
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
+import           XMonad.Internal.DBus.Common
+import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.Shell
 -- import           XMonad.Internal.DBus.Common                    (xmonadBus)
 -- import           XMonad.Internal.DBus.Control                   (pathExists)
@ -52,12 +54,15 @@ import           Xmobar

 main :: IO ()
 main = do
-  rs <- sequence rightPlugins
+  sysClient <- getDBusClient True
+  sesClient <- getDBusClient False
+  rs <- rightPlugins sysClient sesClient
  warnMissing rs
  cs <- getAllCommands rs
  d <- getXMonadDir
  -- this is needed to see any printed messages
  hFlush stdout
+  mapM_ (maybe skip disconnect) [sysClient, sesClient]
  xmobar $ config cs d

 config :: BarRegions -> String -> Config
@ -225,8 +230,8 @@ dateCmd = CmdSpec
 -- some commands depend on the presence of interfaces that can only be
 -- determined at runtime; define these checks here

-dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
-dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
+-- dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
+-- dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)

 -- in the case of network interfaces, assume that the system uses systemd in
 -- which case ethernet interfaces always start with "en" and wireless
@ -245,15 +250,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
 sysfsNet :: FilePath
 sysfsNet = "/sys/class/net"

-readInterface :: (String -> Bool) -> IO (Maybe String)
+readInterface :: (String -> Bool) -> IO (Either [String] String)
 readInterface f = do
  ns <- filter f <$> listInterfaces
  case ns of
+    [] -> return $ Left ["no interfaces found"]
    (x:xs) -> do
      unless (null xs) $
        putStrLn $ "WARNING: extra interfaces found, using " ++ x
-      return $ Just x
-    _     -> return Nothing
+      return $ Right x

 vpnPresent :: IO (Maybe String)
 vpnPresent = do
@ -265,96 +270,96 @@ vpnPresent = do
  where
    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]

-rightPlugins :: [IO (MaybeAction CmdSpec)]
-rightPlugins =
+rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
+rightPlugins sysClient sesClient = mapM evalFeature
  [ getWireless
  , getEthernet
-  , evalFeature getVPN
-  , evalFeature getBt
-  , evalFeature getAlsa
-  , evalFeature getBattery
-  , evalFeature getBl
-  , evalFeature getCk
-  , evalFeature getSs
-  , nocheck lockCmd
-  , nocheck dateCmd
+  , getVPN
+  , getBt sysClient
+  , getAlsa
+  , getBattery
+  , getBl sesClient
+  , getCk sesClient
+  , getSs sesClient
+  , ConstFeature lockCmd
+  , ConstFeature dateCmd
  ]
-  where
-    nocheck = return . Right

-getWireless :: IO (MaybeAction CmdSpec)
-getWireless = do
-  i <- readInterface isWireless
-  return $ maybe (Left []) (Right . wirelessCmd) i
+getWireless :: BarFeature
+getWireless = Feature
+  { ftrMaybeAction = Chain wirelessCmd $ readInterface isWireless
+  , ftrName = "wireless status indicator"
+  , ftrWarning = Default
+  }
+  -- i <- readInterface isWireless
+  -- return $ maybe (Left []) (Right . wirelessCmd) i

-getEthernet :: IO (MaybeAction CmdSpec)
-getEthernet = do
-  i <- readInterface isEthernet
-  evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
-  where
-    dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
+-- TODO this needs a dbus interface
+getEthernet :: BarFeature
+getEthernet = Feature
+  { ftrMaybeAction = Chain ethernetCmd (readInterface isEthernet)
+  , 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

 getBattery :: BarFeature
 getBattery = Feature
-  { ftrMaybeAction = batteryCmd
+  { ftrMaybeAction = Parent batteryCmd [IOTest hasBattery]
  , ftrName = "battery level indicator"
  , ftrWarning = Default
-  , ftrChildren = [IOTest hasBattery]
  }

 type BarFeature = Feature CmdSpec

 getVPN :: BarFeature
 getVPN = Feature
-  { ftrMaybeAction = vpnCmd
+  { ftrMaybeAction = Parent vpnCmd [v]
  , ftrName = "VPN status indicator"
  , ftrWarning = Default
-  , ftrChildren = [d, v]
  }
  where
-    d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
+    -- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
    v = IOTest vpnPresent

-getBt :: BarFeature
-getBt = Feature
-  { ftrMaybeAction = btCmd
+getBt :: Maybe Client -> BarFeature
+getBt client = Feature
+  { ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client
+                     [Endpoint btPath btInterface $ Property_ btPowered]
  , ftrName = "bluetooth status indicator"
  , ftrWarning = Default
-  , ftrChildren = [dep]
  }
-  where
-    dep = dbusDep True btBus btPath btInterface $ Property_ btPowered

 getAlsa :: BarFeature
 getAlsa = Feature
-  { ftrMaybeAction = alsaCmd
+  { ftrMaybeAction = Parent alsaCmd [Executable "alsactl"]
  , ftrName = "volume level indicator"
  , ftrWarning = Default
-  , ftrChildren = [Executable "alsactl"]
  }

-getBl :: BarFeature
-getBl = Feature
-  { ftrMaybeAction = blCmd
+getBl :: Maybe Client -> BarFeature
+getBl client = Feature
+  { ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep]
  , ftrName = "Intel backlight indicator"
  , ftrWarning = Default
-  , ftrChildren = [intelBacklightSignalDep]
  }

-getCk :: BarFeature
-getCk = Feature
-  { ftrMaybeAction = ckCmd
+getCk :: Maybe Client -> BarFeature
+getCk client = Feature
+  { ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep]
  , ftrName = "Clevo keyboard indicator"
  , ftrWarning = Default
-  , ftrChildren = [clevoKeyboardSignalDep]
  }

-getSs :: BarFeature
-getSs = Feature
-  { ftrMaybeAction = ssCmd
+getSs :: Maybe Client -> BarFeature
+getSs client = Feature
+  { ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep]
  , ftrName = "screensaver indicator"
  , ftrWarning = Default
-  , ftrChildren = [ssSignalDep]
  }

 getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@ -76,12 +76,14 @@ import           XMonad.Util.WorkspaceCompare

 main :: IO ()
 main = do
-  cl <- startXMonadService
+  sesClient <- startXMonadService
+  sysClient <- getDBusClient True
  (h, p) <- spawnPipe "xmobar"
-  mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon]
+  mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient]
  forkIO_ $ runWorkspaceMon allDWs
  let ts = ThreadState
-        { tsClient = cl
+        { tsSessionClient = sesClient
+        , tsSystemClient = sysClient
        , tsChildPIDs = [p]
        , tsChildHandles = [h]
        }
@ -114,7 +116,8 @@ main = do
 -- | Concurrency configuration

 data ThreadState = ThreadState
-    { tsClient       :: Maybe Client
+    { tsSessionClient :: Maybe Client
+    , tsSystemClient  :: Maybe Client
    , tsChildPIDs     :: [ProcessHandle]
    , tsChildHandles  :: [Handle]
    }
@ -123,7 +126,8 @@ data ThreadState = ThreadState
 runCleanup :: ThreadState -> X ()
 runCleanup ts = io $ do
  mapM_ killHandle $ tsChildPIDs ts
-  forM_ (tsClient ts) stopXMonadService
+  forM_ (tsSessionClient ts) stopXMonadService
+  forM_ (tsSystemClient ts) disconnect

 --------------------------------------------------------------------------------
 -- | Startuphook configuration
@ -568,12 +572,12 @@ externalBindings ts lock =
    , KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
    , KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
    , KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
-    , KeyBinding "M-<F11>" "toggle screensaver" $ maybe BlankFeature (ioFeature . callToggle) cl
+    , KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl
    , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
    ]
  ]
  where
-    cl = tsClient ts
-    brightessControls ctl getter = maybe BlankFeature (ioFeature . getter . ctl) cl
+    cl = tsSessionClient ts
+    brightessControls ctl getter = (ioFeature . getter . ctl) cl
    ib = brightessControls intelBacklightControls
    ck = brightessControls clevoKeyboardControls
--- a/lib/XMonad/Internal/Concurrent/Removable.hs
+++ b/lib/XMonad/Internal/Concurrent/Removable.hs
@ -33,13 +33,17 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"

-dbusDep :: MemberName -> Dependency
-dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
+-- dbusDep :: MemberName -> Dependency
+-- dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
+dbusDep :: MemberName -> Endpoint
+dbusDep m = Endpoint path interface $ Signal_ m

-addedDep :: Dependency
+-- addedDep :: Dependency
+addedDep :: Endpoint
 addedDep = dbusDep memAdded

-removedDep :: Dependency
+-- removedDep :: Dependency
+removedDep :: Endpoint
 removedDep = dbusDep memRemoved

 driveInsertedSound :: FilePath
@ -84,6 +88,9 @@ listenDevices = do
    addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
      $ playSoundMaybe p . f . signalBody

-runRemovableMon :: FeatureIO
-runRemovableMon =
-  featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices
+runRemovableMon :: Maybe Client -> FeatureIO
+runRemovableMon client = Feature
+  { ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep]
+  , ftrName = "removeable device monitor"
+  , ftrWarning = Default
+  }
--- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
@ -113,14 +113,15 @@ stateFileDep = pathRW stateFile
 brightnessFileDep :: Dependency
 brightnessFileDep = pathR brightnessFile

-clevoKeyboardSignalDep :: Dependency
+-- clevoKeyboardSignalDep :: Dependency
+clevoKeyboardSignalDep :: Endpoint
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig

-exportClevoKeyboard :: Client -> FeatureIO
+exportClevoKeyboard :: Maybe Client -> FeatureIO
 exportClevoKeyboard =
  brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig

-clevoKeyboardControls :: Client -> BrightnessControls
+clevoKeyboardControls :: Maybe Client -> BrightnessControls
 clevoKeyboardControls = brightnessControls clevoKeyboardConfig

 callGetBrightnessCK :: Client -> IO (Maybe Brightness)
--- a/lib/XMonad/Internal/DBus/Brightness/Common.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs
@ -50,7 +50,7 @@ data BrightnessControls = BrightnessControls
  , bctlDec :: FeatureIO
  }

-brightnessControls :: BrightnessConfig a b -> Client -> BrightnessControls
+brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
 brightnessControls bc client =
  BrightnessControls
  { bctlMax = cb "max brightness" memMax
@ -67,9 +67,10 @@ 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 -> Dependency
+-- signalDep :: BrightnessConfig a b -> Dependency
+signalDep :: BrightnessConfig a b -> Endpoint
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
-  DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur
+  Endpoint p i $ Signal_ memCur

 matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
 matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
@ -88,12 +89,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
 -- | Internal DBus Crap

 brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-  -> Client -> FeatureIO
+  -> Maybe Client -> FeatureIO
 brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
-  { ftrMaybeAction = exportBrightnessControls' bc client
+  { ftrMaybeAction = DBusBus_ (exportBrightnessControls' bc) xmonadBusName client deps
  , ftrName = n ++ " exporter"
  , ftrWarning = Default
-  , ftrChildren = DBusBus xmonadBus:deps
  }

 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
@ -131,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
  where
    sig = signal p i memCur

-callBacklight :: Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
+callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
 callBacklight client BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
  (featureEndpoint xmonadBusName p i m client)
  { ftrName = unwords [n, controlName] }
--- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
@ -95,14 +95,15 @@ curFileDep = pathRW curFile
 maxFileDep :: Dependency
 maxFileDep = pathR maxFile

-intelBacklightSignalDep :: Dependency
+-- intelBacklightSignalDep :: Dependency
+intelBacklightSignalDep :: Endpoint
 intelBacklightSignalDep = signalDep intelBacklightConfig

-exportIntelBacklight :: Client -> FeatureIO
+exportIntelBacklight :: Maybe Client -> FeatureIO
 exportIntelBacklight =
  brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig

-intelBacklightControls :: Client -> BrightnessControls
+intelBacklightControls :: Maybe Client -> BrightnessControls
 intelBacklightControls = brightnessControls intelBacklightConfig

 callGetBrightnessIB :: Client -> IO (Maybe Brightness)
--- a/lib/XMonad/Internal/DBus/Common.hs
+++ b/lib/XMonad/Internal/DBus/Common.hs
@ -7,7 +7,7 @@ module XMonad.Internal.DBus.Common
  ( addMatchCallback
  , xmonadBus
  , xmonadBusName
-  , xDbusDep
+  -- , xDbusDep
  -- , initControls
  ) where

@ -22,8 +22,8 @@ xmonadBusName = busName_ "org.xmonad"
 xmonadBus :: Bus
 xmonadBus = Bus False xmonadBusName

-xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
-xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
+-- xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
+-- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m

 -- -- | Call a method and return its result if successful
 -- callMethod :: MethodCall -> IO (Maybe [Variant])
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@ -6,9 +6,11 @@
 module XMonad.Internal.DBus.Control
  ( Client
  , startXMonadService
+  , getDBusClient
  , stopXMonadService
  , pathExists
  , xmonadBus
+  , disconnect
  ) where

 import           Control.Exception
@ -33,21 +35,21 @@ introspectMethod = memberName_ "Introspect"

 startXMonadService :: IO (Maybe Client)
 startXMonadService = do
-  client <- getDBusClient
-  forM_ client $ \c -> do
-    requestXMonadName c
-    mapM_ (\f -> executeFeature_ $ f c)
-      [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
+  client <- getDBusClient False
+  forM_ client requestXMonadName
+  mapM_ (\f -> executeFeature_ $ f client) exporters
  return client
+  where
+    exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

 stopXMonadService :: Client -> IO ()
 stopXMonadService client = do
  void $ releaseName client xmonadBusName
  disconnect client

-getDBusClient :: IO (Maybe Client)
-getDBusClient = do
-  res <- try connectSession
+getDBusClient :: Bool -> IO (Maybe Client)
+getDBusClient sys = do
+  res <- try $ if sys then connectSystem else connectSession
  case res of
    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
    Right c -> return $ Just c
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/lib/XMonad/Internal/DBus/Screensaver.hs
@ -93,18 +93,17 @@ bodyGetCurrentState _   = Nothing
 --------------------------------------------------------------------------------
 -- | Exported haskell API

-exportScreensaver :: Client -> FeatureIO
+exportScreensaver :: Maybe Client -> FeatureIO
 exportScreensaver client = Feature
-  { ftrMaybeAction = cmd
+  { ftrMaybeAction = DBusBus_ cmd xmonadBusName client [Executable ssExecutable]
  , ftrName = "screensaver interface"
  , ftrWarning = Default
-  , ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
  }
  where
-    cmd = export client ssPath defaultInterface
+    cmd cl = export cl ssPath defaultInterface
      { interfaceName = interface
      , interfaceMethods =
-        [ autoMethod memToggle $ emitState client =<< toggle
+        [ autoMethod memToggle $ emitState cl =<< toggle
        , autoMethod memQuery query
        ]
      , interfaceSignals = [sig]
@ -120,7 +119,7 @@ exportScreensaver client = Feature
        ]
      }

-callToggle :: Client -> FeatureIO
+callToggle :: Maybe Client -> FeatureIO
 callToggle client =
  (featureEndpoint xmonadBusName ssPath interface memToggle client)
  { ftrName = "screensaver toggle" }
@ -141,6 +140,8 @@ callQuery client = do
 matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
 matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState

-ssSignalDep :: Dependency
-ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
-  $ Signal_ memState
+-- ssSignalDep :: Dependency
+ssSignalDep :: Endpoint
+-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
+--   $ Signal_ memState
+ssSignalDep = Endpoint ssPath interface $ Signal_ memState
--- a/lib/XMonad/Internal/Dependency.hs
+++ b/lib/XMonad/Internal/Dependency.hs
@ -1,9 +1,18 @@
+{-# LANGUAGE DeriveFunctor   #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE RecordWildCards #-}
+
 --------------------------------------------------------------------------------
 -- | Functions for handling dependencies

 module XMonad.Internal.Dependency
  ( MaybeAction
  , MaybeX
+  , Parent(..)
+  -- , ConstFeature(..)
+  , Chain(..)
+  , DBusEndpoint_(..)
+  , DBusBus_(..)
  , FeatureX
  , FeatureIO
  , Feature(..)
@ -37,7 +46,7 @@ module XMonad.Internal.Dependency
 import           Control.Monad           (void)
 import           Control.Monad.IO.Class

-import           Data.Bifunctor          (bimap)
+import           Data.Bifunctor          (bimap, first, second)
 import           Data.List               (find)
 import           Data.Maybe              (catMaybes, fromMaybe, listToMaybe)

@ -67,14 +76,34 @@ import           XMonad.Internal.Shell
 -- dependencies that target the output/state of another feature; this is more
 -- robust anyways, at the cost of being a bit slower.

-data Feature a = Feature
-  { ftrMaybeAction :: a
+data Feature a = forall e. Evaluable e => Feature
+  { ftrMaybeAction :: e a
  , ftrName        :: String
  , ftrWarning     :: Warning
-  , ftrChildren    :: [Dependency]
+  -- , ftrChildren    :: [Dependency]
  }
  | ConstFeature a
-  | BlankFeature
+  -- | 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]
+
+instance Functor DBusEndpoint_ where
+  fmap f (DBusEndpoint_ a b c eps) = DBusEndpoint_ (f . a) b c eps
+
+data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
+
+instance Functor DBusBus_ where
+  fmap f (DBusBus_ a b c eps) = DBusBus_ (f . a) b c eps

 -- TODO this is silly as is, and could be made more useful by representing
 -- loglevels
@ -84,17 +113,21 @@ type FeatureX = Feature (X ())

 type FeatureIO = Feature (IO ())

-ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
-ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
-ioFeature (ConstFeature f)                 = ConstFeature $ liftIO f
-ioFeature BlankFeature                     = BlankFeature
+ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
+ioFeature (ConstFeature a) = ConstFeature $ liftIO a
+ioFeature Feature {..} =
+  -- HACK just doing a normal record update here will make GHC complain about
+  -- an 'insufficiently polymorphic record update' ...I guess because my
+  -- GADT isn't polymorphic enough (which is obviously BS)
+  Feature {ftrMaybeAction = liftIO <$> ftrMaybeAction, ..}

 featureDefault :: String -> [Dependency] -> a -> Feature a
 featureDefault n ds x = Feature
-  { ftrMaybeAction = x
+  -- { ftrMaybeAction = x
+  { ftrMaybeAction = Parent x ds
  , ftrName = n
  , ftrWarning = Default
-  , ftrChildren = ds
+  -- , ftrChildren = ds
  }

 featureExe :: MonadIO m => String -> String -> Feature (m ())
@ -104,17 +137,18 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
 featureExeArgs n cmd args =
  featureDefault n [Executable cmd] $ spawnCmd cmd args

-- TODO the bus and client might refer to different things
 featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName
-  -> Client -> FeatureIO
+  -> Maybe Client -> FeatureIO
 featureEndpoint busname path iface mem client = Feature
-  { ftrMaybeAction = cmd
+  -- { ftrMaybeAction = cmd
+  { ftrMaybeAction = DBusEndpoint_ cmd busname client deps
  , ftrName = "screensaver toggle"
  , ftrWarning = Default
-  , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
+  -- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem]
  }
  where
-    cmd = void $ callMethod client busname path iface mem
+    cmd = \c -> void $ callMethod c busname path iface mem
+    deps = [Endpoint path iface $ Method_ mem]

 --------------------------------------------------------------------------------
 -- | Feature evaluation
@ -123,24 +157,62 @@ featureEndpoint busname path iface mem client = Feature
 -- either the action of the feature or 0 or more error messages that signify
 -- what dependencies are missing and why.

+class Functor e => Evaluable e where
+  eval :: e a -> IO (MaybeAction a)
+
 type MaybeAction a = Either [String] a

 type MaybeX = MaybeAction (X ())

+instance Evaluable Parent where
+  eval (Parent a ds) = do
+    es <- catMaybes <$> mapM evalDependency ds
+    return $ case es of
+      []  -> 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
+      []  -> Right $ action client
+      es' -> Left es'
+
+instance Evaluable DBusBus_ where
+  eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
+  eval (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'
+
+-- instance Evaluable BlankFeature where
+--   eval (BlankFeature a) = Left ["hopefully a useful error message"]
+
 evalFeature :: Feature a -> IO (MaybeAction a)
 evalFeature (ConstFeature x) = return $ Right x
-evalFeature BlankFeature = return $ Left []
+-- evalFeature BlankFeature = return $ Left []
 evalFeature Feature
  { ftrMaybeAction = a
  , ftrName = n
  , ftrWarning = w
-  , ftrChildren = c
+  -- , ftrChildren = c
  } = do
  procName <- getProgName
-  es <- catMaybes <$> mapM evalDependency c
-  return $ case es of
-    []  -> Right a
-    es' -> Left $ fmtWarnings procName es'
+  res <- eval a
+  return $ first (fmtWarnings procName) res
+  -- es <- catMaybes <$> mapM evalDependency c
+  -- return $ case res of
+  --   []  -> Right a
+  --   es' -> Left $ fmtWarnings procName es'
  where
    fmtWarnings procName es = case w of
      Silent  -> []
@ -173,10 +245,11 @@ ifSatisfied _ alt       = alt
 data Dependency = Executable String
  | AccessiblePath FilePath Bool Bool
  | IOTest (IO (Maybe String))
-  | DBusEndpoint Bus Endpoint
-  | DBusBus Bus
+  -- | DBusEndpoint Bus Endpoint
+  -- | DBusBus Bus
  | Systemd UnitType String

+
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)

 data DBusMember = Method_ MemberName
@ -214,8 +287,8 @@ evalDependency (Executable n)         = exeSatisfied n
 evalDependency (IOTest t)             = t
 evalDependency (Systemd t n)          = unitSatisfied t n
 evalDependency (AccessiblePath p r w) = pathSatisfied p r w
-evalDependency (DBusEndpoint b e)     = endpointSatisfied b e
-evalDependency (DBusBus b)            = busSatisfied b
+-- evalDependency (DBusEndpoint b e)     = endpointSatisfied b e
+-- evalDependency (DBusBus b)            = busSatisfied b

 exeSatisfied :: String -> IO (Maybe String)
 exeSatisfied x = do
@ -266,11 +339,11 @@ callMethod client bus path iface mem = do
           { methodCallDestination = Just bus }
  return $ bimap methodErrorMessage methodReturnBody reply

-busSatisfied :: Bus -> IO (Maybe String)
-busSatisfied (Bus usesystem bus) = do
-  client <- if usesystem then connectSystem else connectSession
+busSatisfied :: Client -> BusName -> IO (Maybe String)
+busSatisfied client bus = do
+  -- client <- if usesystem then connectSystem else connectSession
  ret <- callMethod client queryBus queryPath queryIface queryMem
-  disconnect client
+  -- disconnect client
  return $ case ret of
        Left e    -> Just e
        Right b -> let ns = bodyGetNames b in
@ -285,11 +358,11 @@ busSatisfied (Bus usesystem bus) = do
    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
    bodyGetNames _   = []

-endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
-endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
-  client <- if u then connectSystem else connectSession
-  ret <- callMethod client bus objpath introspectInterface introspectMethod
-  disconnect client
+endpointSatisfied :: Client -> BusName -> Endpoint -> IO (Maybe String)
+endpointSatisfied client busname (Endpoint objpath iface mem) = do
+  -- client <- if u then connectSystem else connectSession
+  ret <- callMethod client busname objpath introspectInterface introspectMethod
+  -- disconnect client
  return $ case ret of
        Left e     -> Just e
        Right body -> procBody body
@ -315,7 +388,7 @@ endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
      , "on interface"
      , singleQuote $ formatInterfaceName iface
      , "on bus"
-      , formatBusName bus
+      , formatBusName busname
      ]

 --------------------------------------------------------------------------------