ENH use typeclass to make dependency interface more flexible

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 :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
-dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
+-- 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 $ Right x
-    _     -> return Nothing
 
 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 :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
-rightPlugins =
+rightPlugins sysClient sesClient = mapM evalFeature
   [ getWireless
   , getEthernet
-  , evalFeature getVPN
+  , getVPN
-  , evalFeature getBt
+  , getBt sysClient
-  , evalFeature getAlsa
+  , getAlsa
-  , evalFeature getBattery
+  , getBattery
-  , evalFeature getBl
+  , getBl sesClient
-  , evalFeature getCk
+  , getCk sesClient
-  , evalFeature getSs
+  , getSs sesClient
-  , nocheck lockCmd
+  , ConstFeature lockCmd
-  , nocheck dateCmd
+  , ConstFeature dateCmd
   ]
-  where
-    nocheck = return . Right
 
-getWireless :: IO (MaybeAction CmdSpec)
+getWireless :: BarFeature
-getWireless = do
+getWireless = Feature
-  i <- readInterface isWireless
+  { ftrMaybeAction = Chain wirelessCmd $ readInterface isWireless
-  return $ maybe (Left []) (Right . wirelessCmd) i
+  , ftrName = "wireless status indicator"
+  , ftrWarning = Default
+  }
+  -- i <- readInterface isWireless
+  -- return $ maybe (Left []) (Right . wirelessCmd) i
 
-getEthernet :: IO (MaybeAction CmdSpec)
+-- TODO this needs a dbus interface
-getEthernet = do
+getEthernet :: BarFeature
-  i <- readInterface isEthernet
+getEthernet = Feature
-  evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
+  { ftrMaybeAction = Chain ethernetCmd (readInterface isEthernet)
-  where
+  , ftrName = "ethernet status indicator"
-    dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
+  , 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 :: Maybe Client -> BarFeature
-getBt = Feature
+getBt client = Feature
-  { ftrMaybeAction = btCmd
+  { 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 :: Maybe Client -> BarFeature
-getBl = Feature
+getBl client = Feature
-  { ftrMaybeAction = blCmd
+  { ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep]
   , ftrName = "Intel backlight indicator"
   , ftrWarning = Default
-  , ftrChildren = [intelBacklightSignalDep]
   }
 
-getCk :: BarFeature
+getCk :: Maybe Client -> BarFeature
-getCk = Feature
+getCk client = Feature
-  { ftrMaybeAction = ckCmd
+  { ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep]
   , ftrName = "Clevo keyboard indicator"
   , ftrWarning = Default
-  , ftrChildren = [clevoKeyboardSignalDep]
   }
 
-getSs :: BarFeature
+getSs :: Maybe Client -> BarFeature
-getSs = Feature
+getSs client = Feature
-  { ftrMaybeAction = ssCmd
+  { ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep]
   , ftrName = "screensaver indicator"
   , ftrWarning = Default
-  , ftrChildren = [ssSignalDep]
   }
 
 getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions

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,16 +116,18 @@ main = do
 -- | Concurrency configuration
 
 data ThreadState = ThreadState
-    { tsClient       :: Maybe Client
+    { tsSessionClient :: Maybe Client
-    , tsChildPIDs    :: [ProcessHandle]
+    , tsSystemClient  :: Maybe Client
-    , tsChildHandles :: [Handle]
+    , tsChildPIDs     :: [ProcessHandle]
+    , tsChildHandles  :: [Handle]
     }
 
 -- TODO shouldn't this be run by a signal handler?
 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
+    cl = tsSessionClient ts
-    brightessControls ctl getter = maybe BlankFeature (ioFeature . getter . ctl) cl
+    brightessControls ctl getter = (ioFeature . getter . ctl) cl
     ib = brightessControls intelBacklightControls
     ck = brightessControls clevoKeyboardControls

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -33,13 +33,17 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
-dbusDep :: MemberName -> Dependency
+-- dbusDep :: MemberName -> Dependency
-dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
+-- 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 :: Maybe Client -> FeatureIO
-runRemovableMon =
+runRemovableMon client = Feature
-  featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices
+  { ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep]
+  , ftrName = "removeable device monitor"
+  , ftrWarning = Default
+  }

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)

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] }

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)

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 :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
-xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
+-- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
 
 -- -- | Call a method and return its result if successful
 -- callMethod :: MethodCall -> IO (Maybe [Variant])

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
+  client <- getDBusClient False
-  forM_ client $ \c -> do
+  forM_ client requestXMonadName
-    requestXMonadName c
+  mapM_ (\f -> executeFeature_ $ f client) exporters
-    mapM_ (\f -> executeFeature_ $ f c)
-      [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
   return client
+  where
+    exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 stopXMonadService :: Client -> IO ()
 stopXMonadService client = do
   void $ releaseName client xmonadBusName
   disconnect client
 
-getDBusClient :: IO (Maybe Client)
+getDBusClient :: Bool -> IO (Maybe Client)
-getDBusClient = do
+getDBusClient sys = do
-  res <- try connectSession
+  res <- try $ if sys then connectSystem else connectSession
   case res of
     Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
     Right c -> return $ Just c

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 :: Dependency
-ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
+ssSignalDep :: Endpoint
-  $ Signal_ memState
+-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
+--   $ Signal_ memState
+ssSignalDep = Endpoint ssPath interface $ Signal_ memState

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
+data Feature a = forall e. Evaluable e => Feature
-  { ftrMaybeAction :: a
+  { 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 :: MonadIO m => Feature (IO b) -> Feature (m b)
-ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
+ioFeature (ConstFeature a) = ConstFeature $ liftIO a
-ioFeature (ConstFeature f)                 = ConstFeature $ liftIO f
+ioFeature Feature {..} =
-ioFeature BlankFeature                     = BlankFeature
+  -- 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
+  res <- eval a
-  return $ case es of
+  return $ first (fmtWarnings procName) res
-    []  -> Right a
+  -- es <- catMaybes <$> mapM evalDependency c
-    es' -> Left $ fmtWarnings procName es'
+  -- 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
+  -- | DBusEndpoint Bus Endpoint
-  | DBusBus Bus
+  -- | 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 (DBusEndpoint b e)     = endpointSatisfied b e
-evalDependency (DBusBus b)            = busSatisfied b
+-- 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 :: Client -> BusName -> IO (Maybe String)
-busSatisfied (Bus usesystem bus) = do
+busSatisfied client bus = do
-  client <- if usesystem then connectSystem else connectSession
+  -- 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 :: Client -> BusName -> Endpoint -> IO (Maybe String)
-endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do
+endpointSatisfied client busname (Endpoint objpath iface mem) = do
-  client <- if u then connectSystem else connectSession
+  -- client <- if u then connectSystem else connectSession
-  ret <- callMethod client bus objpath introspectInterface introspectMethod
+  ret <- callMethod client busname objpath introspectInterface introspectMethod
-  disconnect client
+  -- 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
       ]
 
 --------------------------------------------------------------------------------