ENH make better error messages for features

bin/xmobar.hs

@@ -40,12 +40,9 @@ import           XMonad.Hooks.DynamicLog
     )
 import           XMonad.Internal.Command.Power                  (hasBattery)
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
-    ( curFileDep
-    , maxFileDep
-    )
 -- import           XMonad.Internal.DBus.Common                    (xmonadBus)
 -- import           XMonad.Internal.DBus.Control                   (pathExists)
-import           XMonad.Internal.DBus.Screensaver               (ssDep)
+import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
 import           XMonad.Internal.Dependency
 -- import           XMonad.Internal.Shell                          (fmtCmd)
 import qualified XMonad.Internal.Theme                          as T
@@ -226,20 +223,8 @@ dateCmd = CmdSpec
 -- some commands depend on the presence of interfaces that can only be
 -- determined at runtime; define these checks here
 
--- noSetup :: Monad m => a -> m (Maybe a)
--- noSetup = return . Just
-
--- toJust :: a -> Bool -> Maybe a
--- toJust x b = if b then Just x else Nothing
-
 dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
-dbusDep usesys bus obj iface mem = DBusEndpoint
+dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem)
-  { ddDbusBus = bus
-  , ddDbusSystem = usesys
-  , ddDbusObject = obj
-  , ddDbusInterface = iface
-  , ddDbusMember = mem
-  }
 
 -- in the case of network interfaces, assume that the system uses systemd in
 -- which case ethernet interfaces always start with "en" and wireless
@@ -303,14 +288,15 @@ getWireless = do
 getEthernet :: IO (MaybeExe CmdSpec)
 getEthernet = do
   i <- readInterface isEthernet
-  evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i
+  evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i
   where
     dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
 
 getBattery :: BarFeature
 getBattery = Feature
   { ftrAction = batteryCmd
-  , ftrSilent = False
+  , ftrName = "battery level indicator"
+  , ftrWarning = Default
   , ftrChildren = [IOTest hasBattery]
   }
 
@@ -319,7 +305,8 @@ type BarFeature = Feature CmdSpec
 getVPN :: BarFeature
 getVPN = Feature
   { ftrAction = vpnCmd
-  , ftrSilent = False
+  , ftrName = "VPN status indicator"
+  , ftrWarning = Default
   , ftrChildren = [d, v]
   }
   where
@@ -329,7 +316,8 @@ getVPN = Feature
 getBt :: BarFeature
 getBt = Feature
   { ftrAction = btCmd
-  , ftrSilent = False
+  , ftrName = "bluetooth status indicator"
+  , ftrWarning = Default
   , ftrChildren = [dep]
   }
   where
@@ -338,22 +326,25 @@ getBt = Feature
 getAlsa :: BarFeature
 getAlsa = Feature
   { ftrAction = alsaCmd
-  , ftrSilent = False
+  , ftrName = "volume level indicator"
-  , ftrChildren = [exe "alsactl"]
+  , ftrWarning = Default
+  , ftrChildren = [Executable "alsactl"]
   }
 
 getBl :: BarFeature
 getBl = Feature
   { ftrAction = blCmd
-  , ftrSilent = False
+  , ftrName = "Intel backlight indicator"
-  , ftrChildren = [curFileDep, maxFileDep]
+  , ftrWarning = Default
+  , ftrChildren = [intelBacklightSignalDep]
   }
 
 getSs :: BarFeature
 getSs = Feature
   { ftrAction = ssCmd
-  , ftrSilent = False
+  , ftrName = "screensaver indicator"
-  , ftrChildren = [ssDep]
+  , ftrWarning = Default
+  , ftrChildren = [ssSignalDep]
   }
 
 getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions

lib/XMonad/Internal/Command/DMenu.hs

@@ -47,8 +47,8 @@ myDmenuNetworks = "networkmanager_dmenu"
 --------------------------------------------------------------------------------
 -- | Other internal functions
 
-spawnDmenuCmd :: [String] -> FeatureX
+spawnDmenuCmd :: String -> [String] -> FeatureX
-spawnDmenuCmd = featureSpawnCmd myDmenuCmd
+spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd
 
 themeArgs :: String -> [String]
 themeArgs hexColor =
@@ -63,7 +63,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 -- | Exported Commands
 
 runDevMenu :: FeatureX
-runDevMenu = featureRun [exe myDmenuDevices] $ do
+runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
   c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
   spawnCmd myDmenuDevices
     $ ["-c", c]
@@ -71,7 +71,7 @@ runDevMenu = featureRun [exe myDmenuDevices] $ do
     ++ myDmenuMatchingArgs
 
 runBwMenu :: FeatureX
-runBwMenu = featureRun [exe myDmenuPasswords] $
+runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $
   spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
 
 -- TODO this is weirdly inverted
@@ -83,7 +83,8 @@ runShowKeys x = addName "Show Keybindings" $ do
     $ defNoteError { body = Just $ Text "could not display keymap" }
 
 runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
-runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
+runDMenuShowKeys kbs =
+  featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
   (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
   forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
   where
@@ -91,13 +92,14 @@ runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
       ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
 
 runCmdMenu :: FeatureX
-runCmdMenu = spawnDmenuCmd ["-show", "run"]
+runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
 
 runAppMenu :: FeatureX
-runAppMenu = spawnDmenuCmd ["-show", "drun"]
+runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
 runClipMenu :: FeatureX
-runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
+runClipMenu =
+  featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
   $ spawnCmd myDmenuCmd args
   where
     args = [ "-modi", "\"clipboard:greenclip print\""
@@ -106,10 +108,12 @@ runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
            ] ++ themeArgs "#00c44e"
 
 runWinMenu :: FeatureX
-runWinMenu = spawnDmenuCmd ["-show", "window"]
+runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
 runNetMenu :: FeatureX
-runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333"
+runNetMenu =
+  featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
 
 runAutorandrMenu :: FeatureX
-runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066"
+runAutorandrMenu =
+  featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"

lib/XMonad/Internal/Command/Desktop.hs

@@ -91,11 +91,12 @@ ethernetIface = "enp7s0f1"
 -- | Some nice apps
 
 runTerm :: FeatureX
-runTerm = featureSpawn myTerm
+runTerm = featureSpawn "terminal" myTerm
 
 runTMux :: FeatureX
-runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
+runTMux = featureRun "terminal multiplexer" deps cmd
   where
+    deps = [Executable myTerm, Executable "tmux", Executable "bash"]
     cmd = spawn
       $ "tmux has-session"
       #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
@@ -104,35 +105,37 @@ runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
     msg = "could not connect to tmux session"
 
 runCalc :: FeatureX
-runCalc = featureRun [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
+runCalc = featureRun "calculator" [Executable myTerm, Executable "R"]
+  $ spawnCmd myTerm ["-e", "R"]
 
 runBrowser :: FeatureX
-runBrowser = featureSpawn myBrowser
+runBrowser = featureSpawn "web browser" myBrowser
 
 runEditor :: FeatureX
-runEditor = featureSpawnCmd myEditor
+runEditor = featureSpawnCmd "text editor" myEditor
   ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
 
 runFileManager :: FeatureX
-runFileManager = featureSpawn "pcmanfm"
+runFileManager = featureSpawn "file browser" "pcmanfm"
 
 --------------------------------------------------------------------------------
 -- | Multimedia Commands
 
-runMultimediaIfInstalled :: String -> FeatureX
+runMultimediaIfInstalled :: String -> String -> FeatureX
-runMultimediaIfInstalled cmd = featureSpawnCmd myMultimediaCtl [cmd]
+runMultimediaIfInstalled n cmd =
+  featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd]
 
 runTogglePlay :: FeatureX
-runTogglePlay = runMultimediaIfInstalled "play-pause"
+runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
 
 runPrevTrack :: FeatureX
-runPrevTrack = runMultimediaIfInstalled "previous"
+runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
 
 runNextTrack :: FeatureX
-runNextTrack = runMultimediaIfInstalled "next"
+runNextTrack = runMultimediaIfInstalled "next track" "next"
 
 runStopPlay :: FeatureX
-runStopPlay = runMultimediaIfInstalled "stop"
+runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 
 --------------------------------------------------------------------------------
 -- | Volume Commands
@@ -146,42 +149,49 @@ playSound file = do
   -- paplay seems to have less latency than aplay
   spawnCmd "paplay" [p]
 
-featureSound :: FilePath -> X () -> X () -> FeatureX
+featureSound :: String -> FilePath -> X () -> X () -> FeatureX
-featureSound file pre post = featureRun [exe "paplay"]
+featureSound n file pre post =
+  featureRun ("volume " ++ n ++ " control") [Executable "paplay"]
   $ pre >> playSound file >> post
 
 runVolumeDown :: FeatureX
-runVolumeDown = featureSound volumeChangeSound (return ()) $ void (lowerVolume 2)
+runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
 
 runVolumeUp :: FeatureX
-runVolumeUp = featureSound volumeChangeSound (return ()) $ void (raiseVolume 2)
+runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
 
 runVolumeMute :: FeatureX
-runVolumeMute = featureSound volumeChangeSound (void toggleMute) $ return ()
+runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
 -- | Notification control
 
-runNotificationCmd :: String -> FeatureX
+runNotificationCmd :: String -> String -> FeatureX
-runNotificationCmd cmd = featureSpawnCmd myNotificationCtrl [cmd]
+runNotificationCmd n cmd =
+  featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd]
 
 runNotificationClose :: FeatureX
-runNotificationClose = runNotificationCmd "close"
+runNotificationClose = runNotificationCmd "close notification" "close"
 
 runNotificationCloseAll :: FeatureX
-runNotificationCloseAll = runNotificationCmd "close-all"
+runNotificationCloseAll =
+  runNotificationCmd "close all notifications" "close-all"
 
 runNotificationHistory :: FeatureX
-runNotificationHistory = runNotificationCmd "history-pop"
+runNotificationHistory =
+  runNotificationCmd "see notification history" "history-pop"
 
 runNotificationContext :: FeatureX
-runNotificationContext = runNotificationCmd "context"
+runNotificationContext =
+  runNotificationCmd "open notification context" "context"
 
 --------------------------------------------------------------------------------
 -- | System commands
 
 runToggleBluetooth :: FeatureX
-runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
+runToggleBluetooth =
+  featureRun "bluetooth toggle" [Executable myBluetooth]
+  $ spawn
   $ myBluetooth ++ " show | grep -q \"Powered: no\""
   #!&& "a=on"
   #!|| "a=off"
@@ -189,7 +199,8 @@ runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
 runToggleEthernet :: FeatureX
-runToggleEthernet = featureRun [exe "nmcli"] $ spawn
+runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
+  $ spawn
   $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
   #!&& "a=connect"
   #!|| "a=disconnect"
@@ -197,14 +208,14 @@ runToggleEthernet = featureRun [exe "nmcli"] $ spawn
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
 runStartISyncTimer :: FeatureX
-runStartISyncTimer = featureRun [userUnit "mbsync.timer"]
+runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"]
   $ spawn
   $ "systemctl --user start mbsync.timer"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started"  }
   #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
 
 runStartISyncService :: FeatureX
-runStartISyncService = featureRun [userUnit "mbsync.service"]
+runStartISyncService = featureRun "isync" [userUnit "mbsync.service"]
   $ spawn
   $ "systemctl --user start mbsync.service"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@@ -248,25 +259,26 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: String -> FeatureX
+runFlameshot :: String -> String -> FeatureX
-runFlameshot mode = featureRun [exe myCapture] $ do
+runFlameshot n mode = featureRun n [Executable myCapture] $ do
   ssDir <- io getCaptureDir
   spawnCmd myCapture $ mode : ["-p", ssDir]
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
 runAreaCapture :: FeatureX
-runAreaCapture = runFlameshot "gui"
+runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
 runDesktopCapture :: FeatureX
-runDesktopCapture = runFlameshot "full"
+runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
 runScreenCapture :: FeatureX
-runScreenCapture = runFlameshot "screen"
+runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: FeatureX
-runCaptureBrowser = featureRun [exe myImageBrowser] $ do
+runCaptureBrowser =
+  featureRun "screen capture browser" [Executable myImageBrowser] $ do
   dir <- io getCaptureDir
   spawnCmd myImageBrowser [dir]

lib/XMonad/Internal/Command/Power.hs

@@ -46,11 +46,7 @@ myOptimusManager = "optimus-manager"
 -- | Core commands
 
 runScreenLock :: Feature (X ())
-runScreenLock = Feature
+runScreenLock = featureSpawn "screen locker" myScreenlock
-  { ftrAction = spawn myScreenlock
-  , ftrSilent = False
-  , ftrChildren = [exe myScreenlock]
-  }
 
 runPowerOff :: X ()
 runPowerOff = spawn "systemctl poweroff"
@@ -105,7 +101,8 @@ runOptimusPrompt' = do
       #!&& "killall xmonad"
 
 runOptimusPrompt :: FeatureX
-runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt'
+runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager]
+  runOptimusPrompt'
 
 --------------------------------------------------------------------------------
 -- | Universal power prompt

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
 -- and send ClientMessage events when it receives them
 runPowermon :: FeatureIO
-runPowermon = featureRun [pathR acpiPath] listenACPI
+runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI
 
 -- | Handle ClientMessage event containing and ACPI event (to be used in
 -- Xmonad's event hook)

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -34,13 +34,7 @@ memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
 dbusDep :: MemberName -> Dependency
-dbusDep m = DBusEndpoint
+dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m)
-  { ddDbusBus = bus
-  , ddDbusSystem = True
-  , ddDbusObject = path
-  , ddDbusInterface = interface
-  , ddDbusMember = Signal_ m
-  }
 
 addedDep :: Dependency
 addedDep = dbusDep memAdded
@@ -91,4 +85,5 @@ listenDevices = do
       $ playSoundMaybe p . f . signalBody
 
 runRemovableMon :: FeatureIO
-runRemovableMon = featureRun [addedDep, removedDep] listenDevices
+runRemovableMon =
+  featureRun "removeable device monitor" [addedDep, removedDep] listenDevices

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Brightness.Common
   , brightnessExporter
   , callGetBrightness
   , matchSignal
+  , signalDep
   ) where
 
 import           Control.Monad               (void)
@@ -16,6 +17,7 @@ import           Data.Int                    (Int32)
 
 import           DBus
 import           DBus.Client
+import qualified DBus.Introspection          as I
 
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
@@ -37,6 +39,7 @@ data BrightnessConfig a b = BrightnessConfig
   , bcGetMax    :: IO a
   , bcPath      :: ObjectPath
   , bcInterface :: InterfaceName
+  , bcName      :: String
   }
 
 data BrightnessControls = BrightnessControls
@@ -47,25 +50,30 @@ data BrightnessControls = BrightnessControls
   }
 
 brightnessControls :: BrightnessConfig a b -> BrightnessControls
-brightnessControls BrightnessConfig { bcPath = p, bcInterface = i } =
+brightnessControls bc =
   BrightnessControls
-  { bctlMax = cb memMax
+  { bctlMax = cb "max brightness" memMax
-  , bctlMin = cb memMin
+  , bctlMin = cb "min brightness" memMin
-  , bctlInc = cb memInc
+  , bctlInc = cb "increase brightness" memInc
-  , bctlDec = cb memDec
+  , bctlDec = cb "decrease brightness" memDec
   }
   where
-    cb = callBacklight p i
+    cb = callBacklight bc
 
 callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
   reply <- callMethod $ methodCall p i memGet
   return $ reply >>= bodyGetBrightness
 
+signalDep :: BrightnessConfig a b -> Dependency
+signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
+  DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur
+
 matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler
 matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
   client <- connectSession
   addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
+  -- TODO disconnect here?
   where
     brMatcher = matchAny
       { matchPath = Just p
@@ -78,10 +86,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
 
 brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
   -> Client -> FeatureIO
-brightnessExporter deps bc client = Feature
+brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
   { ftrAction = exportBrightnessControls' bc client
-  , ftrSilent = False
+  , ftrName = n ++ " exporter"
-  , ftrChildren = deps
+  , ftrWarning = Default
+  , ftrChildren = DBusBus xmonadBus:deps
   }
 
 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
@@ -98,6 +107,18 @@ exportBrightnessControls' bc client = do
       , autoMethod' memDec bcDec
       , autoMethod memGet (round <$> funget maxval :: IO Int32)
       ]
+    , interfaceSignals = [sig]
+    }
+  where
+    sig = I.Signal
+      { I.signalName = memCur
+      , I.signalArgs =
+        [
+          I.SignalArg
+          { I.signalArgName = "brightness"
+          , I.signalArgType = TypeInt32
+          }
+        ]
       }
 
 emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
@@ -106,11 +127,12 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
   where
     sig = signal p i memCur
 
-callBacklight :: ObjectPath -> InterfaceName -> MemberName -> FeatureIO
+callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO
-callBacklight p  i m =
+callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
   Feature
   { ftrAction = void $ callMethod $ methodCall p i m
-  , ftrSilent = False
+  , ftrName = unwords [n, controlName]
+  , ftrWarning = Default
   , ftrChildren = [xDbusDep p i $ Method_ m]
   }
 

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

@@ -6,8 +6,7 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
   , matchSignalIB
   , exportIntelBacklight
   , intelBacklightControls
-  , curFileDep
+  , intelBacklightSignalDep
-  , maxFileDep
   , blPath
   ) where
 
@@ -78,6 +77,7 @@ intelBacklightConfig = BrightnessConfig
   , bcGetMax = getMaxRawBrightness
   , bcPath = blPath
   , bcInterface = interface
+  , bcName = "Intel backlight"
   }
 
 --------------------------------------------------------------------------------
@@ -89,6 +89,9 @@ curFileDep = pathRW curFile
 maxFileDep :: Dependency
 maxFileDep = pathR maxFile
 
+intelBacklightSignalDep :: Dependency
+intelBacklightSignalDep = signalDep intelBacklightConfig
+
 exportIntelBacklight :: Client -> FeatureIO
 exportIntelBacklight =
   brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig

lib/XMonad/Internal/DBus/Common.hs

@@ -6,8 +6,9 @@ module XMonad.Internal.DBus.Common
   , callMethod'
   , addMatchCallback
   , xmonadBus
+  , xmonadBusName
   , xDbusDep
-  , initControls
+  -- , initControls
   ) where
 
 import           DBus
@@ -15,23 +16,22 @@ import           DBus.Client
 
 import           XMonad.Internal.Dependency
 
-xmonadBus :: BusName
+xmonadBusName :: BusName
-xmonadBus = busName_ "org.xmonad"
+xmonadBusName = busName_ "org.xmonad"
+
+xmonadBus :: Bus
+xmonadBus = Bus False xmonadBusName
 
 xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency
-xDbusDep o i m = DBusEndpoint
+xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m
-  { ddDbusBus = xmonadBus
+
-  , ddDbusSystem = False
+-- connectBus :: Bus -> IO (Maybe Client)
-  , ddDbusObject = o
-  , ddDbusInterface = i
-  , ddDbusMember = m
-  }
 
 -- | Call a method and return its result if successful
 callMethod :: MethodCall -> IO (Maybe [Variant])
 callMethod mc = do
   client <- connectSession
-  r <- callMethod' client (Just xmonadBus) mc
+  r <- callMethod' client (Just xmonadBusName) mc
   disconnect client
   return r
 
@@ -50,11 +50,11 @@ addMatchCallback rule cb = do
   client <- connectSession
   addMatch client rule $ cb . signalBody
 
-initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
+-- initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
-initControls client exporter controls = do
+-- initControls client exporter controls = do
-  let x = exporter client
+--   let x = exporter client
-  e <- evalFeature x
+--   e <- evalFeature x
-  case e of
+--   case e of
-    (Right c) -> c
+--     (Right c) -> c
-    _         -> return ()
+--     _         -> return ()
-  return $ controls x
+--   return $ controls x

lib/XMonad/Internal/DBus/Control.hs

@@ -19,7 +19,6 @@ import           Data.Either
 import           DBus
 import           DBus.Client
 
--- import           XMonad.Internal.DBus.Brightness.Common
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver
@@ -42,7 +41,7 @@ startXMonadService = do
 
 stopXMonadService :: Client -> IO ()
 stopXMonadService client = do
-  void $ releaseName client xmonadBus
+  void $ releaseName client xmonadBusName
   disconnect client
 
 getDBusClient :: IO (Maybe Client)
@@ -54,7 +53,7 @@ getDBusClient = do
 
 requestXMonadName :: Client -> IO ()
 requestXMonadName client = do
-  res <- requestName client xmonadBus []
+  res <- requestName client xmonadBusName []
   -- TODO if the client is not released on shutdown the owner will be
   -- different
   let msg | res == NamePrimaryOwner = Nothing
@@ -64,7 +63,7 @@ requestXMonadName client = do
           | otherwise = Just $ "unknown error when requesting " ++ xn
   forM_ msg putStrLn
   where
-    xn = "'" ++ formatBusName xmonadBus ++ "'"
+    xn = "'" ++ formatBusName xmonadBusName ++ "'"
 
 pathExists :: Bool -> BusName -> ObjectPath -> IO Bool
 pathExists sysbus n p = do

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -8,6 +8,7 @@ module XMonad.Internal.DBus.Screensaver
   , matchSignal
   , ssPath
   , ssDep
+  , ssSignalDep
   , SSControls(..)
   ) where
 
@@ -15,6 +16,7 @@ import           Control.Monad               (void)
 
 import           DBus
 import           DBus.Client
+import qualified DBus.Introspection          as I
 
 import           Graphics.X11.XScreenSaver
 import           Graphics.X11.Xlib.Display
@@ -34,6 +36,10 @@ ssExecutable = "xset"
 ssDep :: Dependency
 ssDep = Executable ssExecutable
 
+ssSignalDep :: Dependency
+ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
+  $ Signal_ memState
+
 toggle :: IO SSState
 toggle = do
   st <- query
@@ -99,16 +105,12 @@ bodyGetCurrentState _   = Nothing
 
 newtype SSControls = SSControls { ssToggle :: FeatureIO }
 
--- exportScreensaver :: Client -> IO SSControls
--- exportScreensaver client = initControls client exportScreensaver' controls
---   where
---     controls _ = SSControls { ssToggle = callToggle }
-
 exportScreensaver :: Client -> FeatureIO
 exportScreensaver client = Feature
   { ftrAction = cmd
-  , ftrSilent = False
+  , ftrName = "screensaver interface"
-  , ftrChildren = [ssDep]
+  , ftrWarning = Default
+  , ftrChildren = [ssDep, DBusBus xmonadBus]
   }
   where
     cmd = export client ssPath defaultInterface
@@ -117,12 +119,24 @@ exportScreensaver client = Feature
         [ autoMethod memToggle $ emitState client =<< toggle
         , autoMethod memQuery query
         ]
+      , interfaceSignals = [sig]
+      }
+    sig = I.Signal
+      { I.signalName = memState
+      , I.signalArgs =
+        [
+          I.SignalArg
+          { I.signalArgName = "enabled"
+          , I.signalArgType = TypeBoolean
+          }
+        ]
       }
 
 callToggle :: FeatureIO
 callToggle = Feature
   { ftrAction = cmd
-  , ftrSilent = False
+  , ftrName = "screensaver toggle"
+  , ftrWarning = Default
   , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
   }
   where

lib/XMonad/Internal/Dependency.hs

@@ -5,14 +5,16 @@ module XMonad.Internal.Dependency
   ( MaybeExe
   , UnitType(..)
   , Dependency(..)
+  , Bus(..)
+  , Endpoint(..)
   , DBusMember(..)
+  , Warning(..)
   , MaybeX
   , FeatureX
   , FeatureIO
   , Feature(..)
   , ioFeature
   , evalFeature
-  , exe
   , systemUnit
   , userUnit
   , pathR
@@ -34,14 +36,16 @@ module XMonad.Internal.Dependency
 
 import           Control.Monad.IO.Class
 
+import           Data.Bifunctor          (bimap)
 import           Data.List               (find)
-import           Data.Maybe              (listToMaybe, maybeToList)
+import           Data.Maybe              (catMaybes, fromMaybe, listToMaybe)
 
 import           DBus
 import           DBus.Client
 import qualified DBus.Introspection      as I
 
 import           System.Directory        (findExecutable, readable, writable)
+import           System.Environment
 import           System.Exit
 
 import           XMonad.Core             (X, io)
@@ -59,21 +63,23 @@ data DBusMember = Method_ MemberName
   | Property_ String
   deriving (Eq, Show)
 
+data Bus = Bus Bool BusName deriving (Eq, Show)
+
+data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
+
 data Dependency = Executable String
   | AccessiblePath FilePath Bool Bool
   | IOTest (IO (Maybe String))
-  | DBusEndpoint
+  | DBusEndpoint Bus Endpoint
-    { ddDbusBus       :: BusName
+  | DBusBus Bus
-    , ddDbusSystem    :: Bool
-    , ddDbusObject    :: ObjectPath
-    , ddDbusInterface :: InterfaceName
-    , ddDbusMember    :: DBusMember
-    }
   | Systemd UnitType String
 
+data Warning = Silent | Default
+
 data Feature a = Feature
   { ftrAction   :: a
-  , ftrSilent   :: Bool
+  , ftrName     :: String
+  , ftrWarning  :: Warning
   , ftrChildren :: [Dependency]
   }
   | ConstFeature a
@@ -91,16 +97,21 @@ ioFeature BlankFeature                = BlankFeature
 evalFeature :: Feature a -> IO (MaybeExe a)
 evalFeature (ConstFeature x) = return $ Right x
 evalFeature BlankFeature = return $ Left []
-evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
+evalFeature Feature
-  es <- mapM go c
+  { ftrAction = a
-  return $ case concat es of
+  , ftrName = n
+  , ftrWarning = w
+  , ftrChildren = c
+  } = do
+  procName <- getProgName
+  es <- catMaybes <$> mapM evalDependency c
+  return $ case es of
     []  -> Right a
-    es' -> Left (if s then [] else es')
+    es' -> Left $ fmtWarnings procName es'
   where
-    go = fmap maybeToList . depInstalled
+    fmtWarnings procName es = case w of
-
+      Silent  -> []
-exe :: String -> Dependency
+      Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
-exe = Executable
 
 pathR :: String -> Dependency
 pathR n = AccessiblePath n True False
@@ -123,18 +134,19 @@ type MaybeExe a = Either [String] a
 
 type MaybeX = MaybeExe (X ())
 
-featureRun :: [Dependency] -> a -> Feature a
+featureRun :: String -> [Dependency] -> a -> Feature a
-featureRun ds x = Feature
+featureRun n ds x = Feature
   { ftrAction = x
-  , ftrSilent = False
+  , ftrName = n
+  , ftrWarning = Default
   , ftrChildren = ds
   }
 
-featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ())
+featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ())
-featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args
+featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args
 
-featureSpawn :: MonadIO m => String -> Feature (m ())
+featureSpawn :: MonadIO m => String -> String -> Feature (m ())
-featureSpawn cmd = featureSpawnCmd cmd []
+featureSpawn n cmd = featureSpawnCmd n cmd []
 
 exeInstalled :: String -> IO (Maybe String)
 exeInstalled x = do
@@ -177,37 +189,69 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
+callMethod :: Bus -> ObjectPath -> InterfaceName -> MemberName -> IO (Either String [Variant])
-  -> IO (Maybe String)
+callMethod (Bus usesys bus) path iface mem = do
-dbusInstalled bus usesystem objpath iface mem = do
+  client <- if usesys then connectSystem else connectSession
-  client <- if usesystem then connectSystem else connectSession
+  reply <- call client (methodCall path iface mem)
-  reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
            { methodCallDestination = Just bus }
-  let res = findMem =<< I.parseXML objpath =<< fromVariant
-        =<< listToMaybe (methodReturnBody reply)
   disconnect client
-  return $ case res of
+  return $ bimap methodErrorMessage methodReturnBody reply
-    Just _ -> Nothing
-    _      -> Just "some random dbus interface not found"
-  where
-    findMem obj = fmap (matchMem mem)
-      $ find (\i -> I.interfaceName i == iface)
-      $ I.objectInterfaces obj
-    matchMem (Method_ n) = elem n . fmap I.methodName . I.interfaceMethods
-    matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals
-    matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties
 
-depInstalled :: Dependency -> IO (Maybe String)
+dbusBusExists :: Bus -> IO (Maybe String)
-depInstalled (Executable n)         = exeInstalled n
+dbusBusExists (Bus usesystem bus) = do
-depInstalled (IOTest t)             = t
+  ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
-depInstalled (Systemd t n)          = unitInstalled t n
+  return $ case ret of
-depInstalled (AccessiblePath p r w) = pathAccessible p r w
+        Left e    -> Just e
-depInstalled DBusEndpoint { ddDbusBus = b
+        Right b -> let ns = bodyGetNames b in
-                          , ddDbusSystem = s
+          if bus' `elem` ns then Nothing
-                          , ddDbusObject = o
+          else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
-                          , ddDbusInterface = i
+  where
-                          , ddDbusMember = m
+    bus' = formatBusName bus
-                          } = dbusInstalled b s o i m
+    queryBus = busName_ "org.freedesktop.DBus"
+    queryIface = interfaceName_ "org.freedesktop.DBus"
+    queryPath = objectPath_ "/"
+    queryMem = memberName_ "ListNames"
+    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
+    bodyGetNames _   = []
+
+dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String)
+dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
+  ret <- callMethod b objpath introspectInterface introspectMethod
+  return $ case ret of
+        Left e     -> Just e
+        Right body -> procBody body
+  where
+    procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
+                          =<< listToMaybe body in
+      case res of
+        Just True -> Nothing
+        _         -> Just $ fmtMsg' mem
+    findMem = fmap (matchMem mem)
+      . find (\i -> I.interfaceName i == iface)
+      . I.objectInterfaces
+    matchMem (Method_ n)   = elemMember n I.methodName I.interfaceMethods
+    matchMem (Signal_ n)   = elemMember n I.signalName I.interfaceSignals
+    matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
+    elemMember n fname fmember = elem n . fmap fname . fmember
+    fmtMem (Method_ n)   = "method " ++ singleQuote (formatMemberName n)
+    fmtMem (Signal_ n)   = "signal " ++ singleQuote (formatMemberName n)
+    fmtMem (Property_ n) = "property " ++ singleQuote n
+    fmtMsg' m = unwords
+      [ "could not find"
+      , fmtMem m
+      , "on interface"
+      , singleQuote $ formatInterfaceName iface
+      , "on bus"
+      , formatBusName bus
+      ]
+
+evalDependency :: Dependency -> IO (Maybe String)
+evalDependency (Executable n)         = exeInstalled n
+evalDependency (IOTest t)             = t
+evalDependency (Systemd t n)          = unitInstalled t n
+evalDependency (AccessiblePath p r w) = pathAccessible p r w
+evalDependency (DBusEndpoint b e)     = dbusEndpointExists b e
+evalDependency (DBusBus b)            = dbusBusExists b
 
 whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
 whenInstalled = flip ifInstalled skip
@@ -217,7 +261,7 @@ ifInstalled (Right x) _ = x
 ifInstalled _ alt       = alt
 
 warnMissing :: [MaybeExe a] -> IO ()
-warnMissing xs = warnMissing' $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
+warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
 
 warnMissing' :: [String] -> IO ()
 warnMissing' = mapM_ putStrLn
@@ -235,3 +279,9 @@ executeFeature = applyFeature id
 
 executeFeature_ :: Feature (IO ()) -> IO ()
 executeFeature_ = executeFeature ()
+
+fmtMsg :: String -> String -> String -> String
+fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
+  where
+    bracket s = "[" ++ s ++ "]"
+