ENH use all parameters where appropriate
This commit is contained in:
parent
bdab449be7
commit
7ad7b8960e
|
|
@ -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"
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 }]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue