ENH use all parameters where appropriate

bin/xmobar.hs

@@ -178,43 +178,46 @@ type BarFeature = Sometimes CmdSpec
 
 -- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
-getWireless = sometimes1 "wireless status indicator" "sysfs path"
-  $ IORoot wirelessCmd $ Only readWireless
+getWireless = Sometimes "wireless status indicator" xpfWireless
+  [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
 getEthernet :: Maybe Client -> BarFeature
-getEthernet cl = iconDBus "ethernet status indicator" root tree
+getEthernet cl = iconDBus "ethernet status indicator" (const True) root tree
   where
     root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
     tree = And1 (Only readEthernet) (Only_ devDep)
 
 getBattery :: BarFeature
-getBattery = iconIO_ "battery level indicator" root tree
+getBattery = iconIO_ "battery level indicator" xpfBattery root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
     tree = Only_ $ IOTest_ "Test if battery is present" $ fmap (Msg Error) <$> hasBattery
 
 getVPN :: Maybe Client -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test
+getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
     test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent
 
 getBt :: Maybe Client -> BarFeature
-getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
+getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
-getAlsa = iconIO_ "volume level indicator" root $ Only_ $ sysExe "alsactl"
+getAlsa = iconIO_ "volume level indicator" (const True) root
+  $ Only_ $ sysExe "alsactl"
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
 getBl :: Maybe Client -> BarFeature
-getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
+getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
+  intelBacklightSignalDep blCmd
 
 getCk :: Maybe Client -> BarFeature
-getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
+getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
+  clevoKeyboardSignalDep ckCmd
 
 getSs :: Maybe Client -> BarFeature
-getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
+getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
 getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
@@ -224,27 +227,27 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
 --------------------------------------------------------------------------------
 -- | bar feature constructors
 
-xmobarDBus :: String -> DBusDependency_ -> (Fontifier -> CmdSpec)
+xmobarDBus :: String -> XPQuery -> DBusDependency_ -> (Fontifier -> CmdSpec)
   -> Maybe Client -> BarFeature
-xmobarDBus n dep cmd cl = iconDBus_ n root (Only_ dep)
+xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
   where
     root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
 
-iconIO_ :: String -> (Fontifier -> IOTree_ -> Root CmdSpec) -> IOTree_
-  -> BarFeature
+iconIO_ :: String -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
+  -> IOTree_ -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus :: String -> (Fontifier -> DBusTree p -> Root CmdSpec)
+iconDBus :: String -> XPQuery -> (Fontifier -> DBusTree p -> Root CmdSpec)
   -> DBusTree p -> BarFeature
 iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
-iconDBus_ :: String -> (Fontifier -> DBusTree_ -> Root CmdSpec) -> DBusTree_
-  -> BarFeature
+iconDBus_ :: String -> XPQuery -> (Fontifier -> DBusTree_ -> Root CmdSpec)
+  -> DBusTree_ -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
 
-iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String
+iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> XPQuery
   -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
-iconSometimes' c d n r t = Sometimes n (const True)
+iconSometimes' c d n q r t = Sometimes n q
   [ Subfeature icon "icon indicator"
   , Subfeature text "text indicator"
   ]

bin/xmonad.hs

@@ -255,10 +255,11 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
     c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
 
 vmDynamicWorkspace :: Sometimes DynWorkspace
-vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root
+vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
+  [Subfeature root "windows 8 VM"]
   where
-    root = IORoot_ dw $ And_ (Only_ $ sysExe "VBoxManage")
-      $ Only_ $ IOTest_ name $ vmExists vm
+    root = IORoot_ dw $ toAnd_ (sysExe "VBoxManage")
+      $ IOTest_ name $ vmExists vm
     name = unwords ["test if", vm, "exists"]
     c = "VirtualBoxVM"
     vm = "win8raw"
@@ -271,18 +272,9 @@ vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root
          , dwCmd = Just $ spawnCmd "vbox-start" [vm]
          }
 
--- -- TODO this shell command is hilariously slow and kills my fast startup time
--- vmExists :: String -> IO (Maybe String)
--- vmExists vm =
---   go <$> tryIOError (readCreateProcessWithExitCode' pr "")
---   where
---     pr = proc' "VBoxManage" ["showvminfo", vm]
---     go (Right (ExitSuccess, _, _))   = Nothing
---     go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm
---     go (Left e)                      = Just $ show e
-
 xsaneDynamicWorkspace :: Sometimes DynWorkspace
-xsaneDynamicWorkspace = sometimesIO_ "scanner workspace" "xsane" tree dw
+xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
+  [Subfeature (IORoot_ dw tree) "xsane"]
   where
     tree = Only_ $ sysExe "xsane"
     dw = DynWorkspace

lib/XMonad/Internal/Command/DMenu.hs

@@ -95,13 +95,18 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
 
 -- TODO test that bluetooth interface exists
 runBTMenu :: SometimesX
-runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
-  myDmenuBluetooth $ "-c":themeArgs "#0044bb"
+runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
+  [Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
+  where
+    cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
+    tree = Only_ $ sysExe myDmenuBluetooth
 
 runVPNMenu :: SometimesX
-runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN" tree $ spawnCmd myDmenuVPN
-  $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
+runVPNMenu = Sometimes "VPN selector" xpfVPN
+  [Subfeature (IORoot_ cmd tree) "rofi VPN"]
   where
+    cmd = spawnCmd myDmenuVPN
+      $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
     tree = toAnd_ (localExe myDmenuVPN) $ socketExists "expressVPN"
       $ return "/var/lib/expressvpn/expressvpnd.socket"
 

lib/XMonad/Internal/Command/Desktop.hs

@@ -216,14 +216,15 @@ runNotificationContext =
 
 -- this is required for some vpn's to work properly with network-manager
 runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
-runNetAppDaemon cl = sometimesDBus cl "network applet" "NM-applet" tree cmd
+runNetAppDaemon cl = Sometimes "network applet" xpfVPN
+  [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
   where
     tree = toAnd_ (DBusIO $ localExe "nm-applet") $ Bus networkManagerBus
     cmd _ = snd <$> spawnPipe "nm-applet"
 
 runToggleBluetooth :: Maybe Client -> SometimesX
-runToggleBluetooth cl =
-  sometimesDBus cl "bluetooth toggle" "bluetoothctl" tree cmd
+runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
+  [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
   where
     tree = And_ (Only_ $ DBusIO $ sysExe myBluetooth) (Only_ $ Bus btBus)
     cmd _ = spawn

lib/XMonad/Internal/Command/Power.hs

@@ -136,7 +136,8 @@ runOptimusPrompt' fb = do
       #!&& "killall xmonad"
 
 runOptimusPrompt :: SometimesX
-runOptimusPrompt = Sometimes "graphics switcher" xpfOptimus [s]
+runOptimusPrompt = Sometimes "graphics switcher"
+  (\x -> xpfOptimus x && xpfBattery x) [s]
   where
     s = Subfeature { sfData = r, sfName = "optimus manager" }
     r = IORoot runOptimusPrompt' t

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

@@ -117,11 +117,11 @@ clevoKeyboardSignalDep :: DBusDependency_
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
 
 exportClevoKeyboard :: Maybe Client -> SometimesIO
-exportClevoKeyboard =
-  brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig
+exportClevoKeyboard = brightnessExporter xpfClevoBacklight
+  [stateFileDep, brightnessFileDep] clevoKeyboardConfig
 
 clevoKeyboardControls :: Maybe Client -> BrightnessControls
-clevoKeyboardControls = brightnessControls clevoKeyboardConfig
+clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
 callGetBrightnessCK :: Client -> IO (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig

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

@@ -20,6 +20,7 @@ import           DBus.Client
 import           DBus.Internal
 import qualified DBus.Introspection          as I
 
+import           XMonad.Core                 (io)
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 
@@ -51,8 +52,9 @@ data BrightnessControls = BrightnessControls
   , bctlDec :: SometimesIO
   }
 
-brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
-brightnessControls bc client =
+brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe Client
+  -> BrightnessControls
+brightnessControls q bc client =
   BrightnessControls
   { bctlMax = cb "max brightness" memMax
   , bctlMin = cb "min brightness" memMin
@@ -60,7 +62,7 @@ brightnessControls bc client =
   , bctlDec = cb "decrease brightness" memDec
   }
   where
-    cb = callBacklight client bc
+    cb = callBacklight q client bc
 
 callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
@@ -85,12 +87,13 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
 --------------------------------------------------------------------------------
 -- | Internal DBus Crap
 
-brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
-  -> Maybe Client -> SometimesIO
-brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
-  sometimesDBus client n (n ++ " exporter") ds (exportBrightnessControls' bc)
+brightnessExporter :: RealFrac b => XPQuery -> [IODependency_]
+  -> BrightnessConfig a b -> Maybe Client -> SometimesIO
+brightnessExporter q deps bc@BrightnessConfig { bcName = n } cl =
+  Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
   where
-    ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
+    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
+    tree = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
 
 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
 exportBrightnessControls' bc client = do
@@ -127,12 +130,15 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
   where
     sig = signal p i memCur
 
-callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
-  -> SometimesIO
-callBacklight client BrightnessConfig { bcPath = p
-                                      , bcInterface = i
-                                      , bcName = n } controlName m =
-  sometimesEndpoint n (unwords [n, controlName]) xmonadBusName p i m client
+callBacklight :: XPQuery -> Maybe Client -> BrightnessConfig a b -> String
+  -> MemberName -> SometimesIO
+callBacklight q cl BrightnessConfig { bcPath = p
+                                    , bcInterface = i
+                                    , bcName = n } controlName m =
+  Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
+  where
+    root = DBusRoot_ cmd (Only_ $ Endpoint xmonadBusName p i $ Method_ m) cl
+    cmd c = io $ void $ callMethod c xmonadBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -99,11 +99,11 @@ intelBacklightSignalDep :: DBusDependency_
 intelBacklightSignalDep = signalDep intelBacklightConfig
 
 exportIntelBacklight :: Maybe Client -> SometimesIO
-exportIntelBacklight =
-  brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig
+exportIntelBacklight = brightnessExporter xpfIntelBacklight
+  [curFileDep, maxFileDep] intelBacklightConfig
 
 intelBacklightControls :: Maybe Client -> BrightnessControls
-intelBacklightControls = brightnessControls intelBacklightConfig
+intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
 callGetBrightnessIB :: Client -> IO (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig

lib/XMonad/Internal/Dependency.hs

@@ -30,6 +30,7 @@ module XMonad.Internal.Dependency
   -- configuration
   , XParams(..)
   , XPFeatures(..)
+  , XPQuery
 
   -- dependency tree types
   , Root(..)
@@ -187,12 +188,14 @@ printMsg :: FMsg -> FIO ()
 printMsg (FMsg fn n (Msg ll m)) = do
   xl <- asks xpLogLevel
   p <- io getProgName
-  io $ when (ll <= xl) $ putStrLn $ unwords [ bracket p
-                                            , bracket $ show ll
-                                            , bracket fn
-                                            , bracket $ fromMaybe "<toplevel>" n
-                                            , m
-                                            ]
+  io $ when (ll <= xl) $ putStrLn $ unwords $ s p
+  where
+    s p = [ bracket p
+          , bracket $ show ll
+          , bracket fn
+          ]
+          ++ maybe [] ((:[]) . bracket) n
+          ++ [m]
 
 --------------------------------------------------------------------------------
 -- | Feature status
@@ -263,7 +266,7 @@ data FallbackStack p = FallbackBottom (Always p)
 -- | Feature that might not be present
 -- This is like an Always except it doesn't fall back on a guaranteed monadic
 -- action
-data Sometimes a = Sometimes String (XPFeatures -> Bool) (Sometimes_ a)
+data Sometimes a = Sometimes String XPQuery (Sometimes_ a)
 
 -- | Feature that might not be present (inner data)
 type Sometimes_ a = [SubfeatureRoot a]
@@ -485,6 +488,7 @@ data XPFeatures = XPFeatures
   , xpfBluetooth      :: Bool
   , xpfIntelBacklight :: Bool
   , xpfClevoBacklight :: Bool
+  , xpfBattery        :: Bool
   }
 
 instance FromJSON XPFeatures where
@@ -497,6 +501,7 @@ instance FromJSON XPFeatures where
     <*> o .:+ "bluetooth"
     <*> o .:+ "intel_backlight"
     <*> o .:+ "clevo_backlight"
+    <*> o .:+ "battery"
 
 defParams :: XParams
 defParams = XParams
@@ -510,12 +515,16 @@ defXPFeatures = XPFeatures
   , xpfVirtualBox = False
   , xpfXSANE = False
   , xpfWireless = False
+  -- TODO this might be broken down into different flags (expressvpn, etc)
   , xpfVPN = False
   , xpfBluetooth = False
   , xpfIntelBacklight = False
   , xpfClevoBacklight = False
+  , xpfBattery = False
   }
 
+type XPQuery = XPFeatures -> Bool
+
 data Cache = Cache
   { --cIO    :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
     cIO_   :: H.HashMap IODependency_ Result_
@@ -555,12 +564,14 @@ infix .:+
 evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n u xs) = do
   r <- asks (u . xpFeatures)
-  if not r then return $ Left [FMsg n Nothing (Msg Debug "disabled")] else do
+  if not r then return $ Left [dis n] else do
     PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
     let fs' = failedMsgs n fs
     return $ case s of
       (Just p) -> Right $ second (++ fs') $ passActMsg n p
       _        -> Left fs'
+  where
+    dis name = FMsg name Nothing (Msg Debug "feature disabled")
 
 evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
@@ -932,7 +943,7 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
 --------------------------------------------------------------------------------
 -- | Feature constructors
 
-sometimes1_ :: (XPFeatures -> Bool) -> String -> String -> Root a -> Sometimes a
+sometimes1_ :: XPQuery -> String -> String -> Root a -> Sometimes a
 sometimes1_ x fn n t = Sometimes fn x
   [Subfeature{ sfData = t, sfName = n }]