From 7ad7b8960e7dda266d35940fed1c2ff0d9744a5c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 8 Jul 2022 20:01:35 -0400 Subject: [PATCH] ENH use all parameters where appropriate --- bin/xmobar.hs | 41 ++++++++++--------- bin/xmonad.hs | 20 +++------ lib/XMonad/Internal/Command/DMenu.hs | 13 ++++-- lib/XMonad/Internal/Command/Desktop.hs | 7 ++-- lib/XMonad/Internal/Command/Power.hs | 3 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 6 +-- lib/XMonad/Internal/DBus/Brightness/Common.hs | 34 ++++++++------- .../DBus/Brightness/IntelBacklight.hs | 6 +-- lib/XMonad/Internal/Dependency.hs | 29 +++++++++---- 9 files changed, 89 insertions(+), 70 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index aee91fe..01074d9 100644 --- a/bin/xmobar.hs +++ b/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" ] diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 4d372b9..05f69b3 100644 --- a/bin/xmonad.hs +++ b/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 diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 2e30f2a..59aea00 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/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" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index c0c908d..599e23d 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/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 diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 7c2bb8f..9160226 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/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 diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index fc5bc25..d6f69eb 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index f1e4c97..27a6b4d 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/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) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 7a2ab13..539cd95 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 08b8bb7..2a611d5 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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 "" 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 }]