ENH give all features an overall name
This commit is contained in:
parent
98a8da5168
commit
3e6f4c7e27
|
|
@ -273,6 +273,10 @@ vpnPresent = do
|
|||
where
|
||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||
|
||||
xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature
|
||||
xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface"
|
||||
(Only_ dep) $ const cmd
|
||||
|
||||
rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
|
||||
rightPlugins sysClient sesClient = mapM evalFeature
|
||||
[ Left getWireless
|
||||
|
|
@ -284,53 +288,50 @@ rightPlugins sysClient sesClient = mapM evalFeature
|
|||
, Left $ getBl sesClient
|
||||
, Left $ getCk sesClient
|
||||
, Left $ getSs sesClient
|
||||
, Right $ Always lockCmd
|
||||
, Right $ Always dateCmd
|
||||
, always' "lock indicator" lockCmd
|
||||
, always' "date indicator" dateCmd
|
||||
]
|
||||
where
|
||||
always' n = Right . Always n . Always_
|
||||
|
||||
getWireless :: BarFeature
|
||||
getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd
|
||||
getWireless = sometimes1 "wireless status indicator" "sysfs path"
|
||||
$ IORoot wirelessCmd
|
||||
$ Only $ readInterface "get wifi interface" isWireless
|
||||
|
||||
getEthernet :: Maybe Client -> BarFeature
|
||||
getEthernet client = sometimes1 "ethernet status indicator" $
|
||||
DBusRoot (const . ethernetCmd) tree client
|
||||
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
|
||||
$ DBusRoot (const . ethernetCmd) tree client
|
||||
where
|
||||
tree = And1 (Only readEth) (Only_ devDep)
|
||||
readEth = readInterface "read ethernet interface" isEthernet
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = sometimesIO "battery level indicator"
|
||||
getBattery = sometimesIO "battery level indicator" "sysfs path"
|
||||
(Only_ $ sysTest "Test if battery is present" hasBattery)
|
||||
batteryCmd
|
||||
|
||||
getVPN :: Maybe Client -> BarFeature
|
||||
getVPN client = sometimesDBus client "VPN status indicator"
|
||||
(toAnd vpnDep test) (const vpnCmd)
|
||||
"xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
|
||||
where
|
||||
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
|
||||
|
||||
getBt :: Maybe Client -> BarFeature
|
||||
getBt client = sometimesDBus client "bluetooth status indicator"
|
||||
(Only_ btDep)
|
||||
(const btCmd)
|
||||
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
|
||||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = sometimesIO "volume level indicator" (Only_ $ sysExe "alsactl") alsaCmd
|
||||
getAlsa = sometimesIO "volume level indicator" "alsactl"
|
||||
(Only_ $ sysExe "alsactl") alsaCmd
|
||||
|
||||
getBl :: Maybe Client -> BarFeature
|
||||
getBl client = sometimesDBus client "Intel backlight indicator"
|
||||
(Only_ intelBacklightSignalDep)
|
||||
(const blCmd)
|
||||
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
|
||||
|
||||
getCk :: Maybe Client -> BarFeature
|
||||
getCk client = sometimesDBus client "Clevo keyboard indicator"
|
||||
(Only_ clevoKeyboardSignalDep)
|
||||
(const ckCmd)
|
||||
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
|
||||
|
||||
getSs :: Maybe Client -> BarFeature
|
||||
getSs client = sometimesDBus client "screensaver indicator"
|
||||
(Only_ ssSignalDep) $ const ssCmd
|
||||
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
|
||||
|
||||
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
||||
getAllCommands right = do
|
||||
|
|
|
|||
|
|
@ -573,9 +573,9 @@ externalBindings ts db =
|
|||
]
|
||||
|
||||
, KeyGroup "Actions"
|
||||
[ KeyBinding "M-q" "close window" $ ftrAlways kill1
|
||||
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
||||
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5
|
||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
||||
, KeyBinding "M-C-s" "capture area" $ Left runAreaCapture
|
||||
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
|
||||
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture
|
||||
|
|
@ -610,11 +610,11 @@ externalBindings ts db =
|
|||
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
||||
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
||||
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
|
||||
, KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt
|
||||
, KeyBinding "M-<Home>" "quit xmonad" quitf
|
||||
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
||||
-- M-<F1> reserved for showing the keymap
|
||||
, KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart)
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile
|
||||
, KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
|
||||
, KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
|
||||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||
|
|
@ -629,7 +629,10 @@ externalBindings ts db =
|
|||
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
||||
ib = Left . brightessControls intelBacklightControls
|
||||
ck = Left . brightessControls clevoKeyboardControls
|
||||
ftrAlways = Right . Always
|
||||
ftrAlways n = Right . Always n . Always_
|
||||
quitf = ftrAlways "quit function" runQuitPrompt
|
||||
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
||||
recompilef = ftrAlways "recompile function" runRecompile
|
||||
|
||||
type MaybeX = Maybe (X ())
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ myDmenuNetworks = "networkmanager_dmenu"
|
|||
-- | Other internal functions
|
||||
|
||||
spawnDmenuCmd :: String -> [String] -> SometimesX
|
||||
spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd
|
||||
spawnDmenuCmd n = sometimesExeArgs n "rofi preset" True myDmenuCmd
|
||||
|
||||
themeArgs :: String -> [String]
|
||||
themeArgs hexColor =
|
||||
|
|
@ -72,24 +72,29 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
|||
-- | Exported Commands
|
||||
|
||||
runDevMenu :: SometimesX
|
||||
runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
|
||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||
spawnCmd myDmenuDevices
|
||||
$ ["-c", c]
|
||||
++ "--" : themeArgs "#999933"
|
||||
++ myDmenuMatchingArgs
|
||||
runDevMenu = sometimesIO "device manager" "rofi devices" t x
|
||||
where
|
||||
t = Only_ $ localExe myDmenuDevices
|
||||
x = do
|
||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||
spawnCmd myDmenuDevices
|
||||
$ ["-c", c]
|
||||
++ "--" : themeArgs "#999933"
|
||||
++ myDmenuMatchingArgs
|
||||
|
||||
runBTMenu :: SometimesX
|
||||
runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
|
||||
$ "-c":themeArgs "#0044bb"
|
||||
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
|
||||
myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
||||
|
||||
runBwMenu :: SometimesX
|
||||
runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $
|
||||
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||
runBwMenu = sometimesIO "password manager" "rofi bitwarden"
|
||||
(Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
|
||||
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||
|
||||
runVPNMenu :: SometimesX
|
||||
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
|
||||
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||
runVPNMenu = sometimesIO "VPN selector" "rofi VPN"
|
||||
(Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
|
||||
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||
|
||||
runCmdMenu :: SometimesX
|
||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||
|
|
@ -98,7 +103,7 @@ runAppMenu :: SometimesX
|
|||
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||
|
||||
runClipMenu :: SometimesX
|
||||
runClipMenu = sometimesIO "clipboard manager" deps act
|
||||
runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act
|
||||
where
|
||||
act = spawnCmd myDmenuCmd args
|
||||
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
|
||||
|
|
@ -111,18 +116,18 @@ runWinMenu :: SometimesX
|
|||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||
|
||||
runNetMenu :: SometimesX
|
||||
runNetMenu =
|
||||
sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333"
|
||||
runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
|
||||
True myDmenuNetworks $ themeArgs "#ff3333"
|
||||
|
||||
runAutorandrMenu :: SometimesX
|
||||
runAutorandrMenu =
|
||||
sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"
|
||||
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||
True myDmenuMonitors $ themeArgs "#ff0066"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Shortcut menu
|
||||
|
||||
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||
runShowKeys = Option showKeysDMenu (Always fallback)
|
||||
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback)
|
||||
where
|
||||
-- TODO this should technically depend on dunst
|
||||
fallback = const $ spawnNotify
|
||||
|
|
|
|||
|
|
@ -92,10 +92,10 @@ ethernetIface = "enp7s0f1"
|
|||
-- | Some nice apps
|
||||
|
||||
runTerm :: SometimesX
|
||||
runTerm = sometimesExe "terminal" True myTerm
|
||||
runTerm = sometimesExe "terminal" "urxvt" True myTerm
|
||||
|
||||
runTMux :: SometimesX
|
||||
runTMux = sometimesIO "terminal multiplexer" deps act
|
||||
runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
|
||||
where
|
||||
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
|
||||
act = spawn
|
||||
|
|
@ -106,27 +106,27 @@ runTMux = sometimesIO "terminal multiplexer" deps act
|
|||
msg = "could not connect to tmux session"
|
||||
|
||||
runCalc :: SometimesX
|
||||
runCalc = sometimesIO "calculator" deps act
|
||||
runCalc = sometimesIO "calculator" "R" deps act
|
||||
where
|
||||
deps = toAnd (sysExe myTerm) (sysExe "R")
|
||||
act = spawnCmd myTerm ["-e", "R"]
|
||||
|
||||
runBrowser :: SometimesX
|
||||
runBrowser = sometimesExe "web browser" False myBrowser
|
||||
runBrowser = sometimesExe "web browser" "brave" False myBrowser
|
||||
|
||||
runEditor :: SometimesX
|
||||
runEditor = sometimesExeArgs "text editor" True myEditor
|
||||
runEditor = sometimesExeArgs "text editor" "emacs" True myEditor
|
||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||
|
||||
runFileManager :: SometimesX
|
||||
runFileManager = sometimesExe "file browser" True "pcmanfm"
|
||||
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Multimedia Commands
|
||||
|
||||
runMultimediaIfInstalled :: String -> String -> SometimesX
|
||||
runMultimediaIfInstalled n cmd =
|
||||
sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd]
|
||||
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
|
||||
"playerctl" True myMultimediaCtl [cmd]
|
||||
|
||||
runTogglePlay :: SometimesX
|
||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||
|
|
@ -155,7 +155,7 @@ playSound file = do
|
|||
|
||||
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
||||
featureSound n file pre post =
|
||||
sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay")
|
||||
sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
|
||||
$ pre >> playSound file >> post
|
||||
|
||||
runVolumeDown :: SometimesX
|
||||
|
|
@ -172,7 +172,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
|
|||
|
||||
runNotificationCmd :: String -> FilePath -> SometimesX
|
||||
runNotificationCmd n cmd =
|
||||
sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd]
|
||||
sometimesExeArgs (n ++ " control") "dunst" True myNotificationCtrl [cmd]
|
||||
|
||||
runNotificationClose :: SometimesX
|
||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||
|
|
@ -194,7 +194,7 @@ runNotificationContext =
|
|||
|
||||
runToggleBluetooth :: SometimesX
|
||||
runToggleBluetooth =
|
||||
sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth)
|
||||
sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
|
||||
$ spawn
|
||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||
#!&& "a=on"
|
||||
|
|
@ -203,7 +203,7 @@ runToggleBluetooth =
|
|||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
||||
|
||||
runToggleEthernet :: SometimesX
|
||||
runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
|
||||
runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
|
||||
$ spawn
|
||||
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
|
||||
#!&& "a=connect"
|
||||
|
|
@ -212,14 +212,16 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
|
|||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||
|
||||
runStartISyncTimer :: SometimesX
|
||||
runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "mbsync.timer")
|
||||
runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
|
||||
(Only_ $ sysdUser "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 :: SometimesX
|
||||
runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "mbsync.service")
|
||||
runStartISyncService = sometimesIO "isync" "mbsync service"
|
||||
(Only_ $ sysdUser "mbsync.service")
|
||||
$ spawn
|
||||
$ "systemctl --user start mbsync.service"
|
||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
|
||||
|
|
@ -264,7 +266,7 @@ getCaptureDir = do
|
|||
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||
|
||||
runFlameshot :: String -> String -> SometimesX
|
||||
runFlameshot n mode = sometimesIO n (Only_ $ sysExe myCapture)
|
||||
runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture)
|
||||
$ spawnCmd myCapture [mode]
|
||||
|
||||
-- TODO this will steal focus from the current window (and puts it
|
||||
|
|
@ -281,7 +283,7 @@ runScreenCapture :: SometimesX
|
|||
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||
|
||||
runCaptureBrowser :: SometimesX
|
||||
runCaptureBrowser =
|
||||
sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do
|
||||
runCaptureBrowser = sometimesIO "screen capture browser" "feh"
|
||||
(Only_ $ sysExe myImageBrowser) $ do
|
||||
dir <- io getCaptureDir
|
||||
spawnCmd myImageBrowser [dir]
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ myOptimusManager = "optimus-manager"
|
|||
-- | Core commands
|
||||
|
||||
runScreenLock :: SometimesX
|
||||
runScreenLock = sometimesExe "screen locker" True myScreenlock
|
||||
runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock
|
||||
|
||||
runPowerOff :: X ()
|
||||
runPowerOff = spawn "systemctl poweroff"
|
||||
|
|
@ -104,8 +104,8 @@ runOptimusPrompt' = do
|
|||
#!&& "killall xmonad"
|
||||
|
||||
runOptimusPrompt :: SometimesX
|
||||
runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager)
|
||||
runOptimusPrompt'
|
||||
runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager"
|
||||
(Only_ $ localExe myOptimusManager) runOptimusPrompt'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Universal power prompt
|
||||
|
|
@ -134,7 +134,7 @@ instance XPrompt PowerPrompt where
|
|||
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
||||
|
||||
runPowerPrompt :: AlwaysX
|
||||
runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock
|
||||
runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock
|
||||
where
|
||||
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)
|
||||
|
||||
|
|
|
|||
|
|
@ -113,9 +113,9 @@ handleACPI lock tag = do
|
|||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||
-- and send ClientMessage events when it receives them
|
||||
runPowermon :: SometimesIO
|
||||
runPowermon = sometimesIO "ACPI event monitor" socketDep listenACPI
|
||||
runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI
|
||||
|
||||
runHandleACPI :: Always (String -> X ())
|
||||
runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip
|
||||
runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip
|
||||
where
|
||||
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
|||
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
|
||||
-> Maybe Client -> SometimesIO
|
||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
||||
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
|
||||
sometimesDBus client n (n ++ " exporter") ds (exportBrightnessControls' bc)
|
||||
where
|
||||
ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
|
||||
|
||||
|
|
@ -132,7 +132,7 @@ callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
|
|||
callBacklight client BrightnessConfig { bcPath = p
|
||||
, bcInterface = i
|
||||
, bcName = n } controlName m =
|
||||
sometimesEndpoint (unwords [n, controlName]) xmonadBusName p i m client
|
||||
sometimesEndpoint n (unwords [n, controlName]) xmonadBusName p i m client
|
||||
|
||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||
|
|
|
|||
|
|
@ -83,6 +83,6 @@ listenDevices client = do
|
|||
|
||||
runRemovableMon :: Maybe Client -> SometimesIO
|
||||
runRemovableMon cl =
|
||||
sometimesDBus cl "removeable device monitor" deps listenDevices
|
||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
||||
where
|
||||
deps = toAnd addedDep removedDep
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ bodyGetCurrentState _ = Nothing
|
|||
|
||||
exportScreensaver :: Maybe Client -> SometimesIO
|
||||
exportScreensaver client =
|
||||
sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd
|
||||
sometimesDBus client "screensaver toggle" "xset" (toAnd bus ssx) cmd
|
||||
where
|
||||
cmd cl = export cl ssPath defaultInterface
|
||||
{ interfaceName = interface
|
||||
|
|
@ -117,11 +117,11 @@ exportScreensaver client =
|
|||
]
|
||||
}
|
||||
bus = Bus xmonadBusName
|
||||
ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable
|
||||
ssx = DBusIO $ sysExe ssExecutable
|
||||
|
||||
callToggle :: Maybe Client -> SometimesIO
|
||||
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
|
||||
interface memToggle
|
||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName
|
||||
ssPath interface memToggle
|
||||
|
||||
callQuery :: Client -> IO (Maybe SSState)
|
||||
callQuery client = do
|
||||
|
|
|
|||
|
|
@ -9,7 +9,9 @@ module XMonad.Internal.Dependency
|
|||
-- feature types
|
||||
( Feature
|
||||
, Always(..)
|
||||
, Sometimes
|
||||
, Always_(..)
|
||||
, Sometimes(..)
|
||||
, Sometimes_
|
||||
, AlwaysX
|
||||
, AlwaysIO
|
||||
, SometimesX
|
||||
|
|
@ -137,26 +139,26 @@ dumpFeature = either dumpSometimes dumpAlways
|
|||
|
||||
-- | Dump the status of an Always to stdout
|
||||
dumpAlways :: Always a -> IO JSONUnquotable
|
||||
dumpAlways = go []
|
||||
dumpAlways (Always n x) = go [] x
|
||||
where
|
||||
go failed (Option o os) = do
|
||||
(s, r) <- dumpSubfeatureRoot o
|
||||
if r
|
||||
then return $ jsonAlways (Just s) failed $ untested [] os
|
||||
then return $ jsonAlways (Q n) (Just s) failed $ untested [] os
|
||||
else go (s:failed) os
|
||||
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed []
|
||||
untested acc (Always _) = acc
|
||||
go failed (Always_ _) = return $ jsonAlways (Q n) (Just (UQ "true")) failed []
|
||||
untested acc (Always_ _) = acc
|
||||
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
|
||||
|
||||
-- | Dump the status of a Sometimes to stdout
|
||||
dumpSometimes :: Sometimes a -> IO JSONUnquotable
|
||||
dumpSometimes = go []
|
||||
dumpSometimes (Sometimes n a) = go [] a
|
||||
where
|
||||
go failed [] = return $ jsonSometimes Nothing failed []
|
||||
go failed [] = return $ jsonSometimes (Q n) Nothing failed []
|
||||
go failed (x:xs) = do
|
||||
(s, r) <- dumpSubfeatureRoot x
|
||||
if r
|
||||
then return $ jsonSometimes (Just s) failed $ fmap dataSubfeatureRoot xs
|
||||
then return $ jsonSometimes (Q n) (Just s) failed $ fmap dataSubfeatureRoot xs
|
||||
else go (s:failed) xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -178,12 +180,18 @@ type Feature a = Either (Sometimes a) (Always a)
|
|||
-- | Feature that is guaranteed to work
|
||||
-- This is composed of sub-features that are tested in order, and if all fail
|
||||
-- the fallback is a monadic action (eg a plain haskell function)
|
||||
data Always a = Option (SubfeatureRoot a) (Always a) | Always a
|
||||
data Always a = Always String (Always_ a)
|
||||
|
||||
-- | Feature that is guaranteed to work (inner data)
|
||||
data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ a
|
||||
|
||||
-- | Feature that might not be present
|
||||
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
||||
-- action
|
||||
type Sometimes a = [SubfeatureRoot a]
|
||||
data Sometimes a = Sometimes String (Sometimes_ a)
|
||||
|
||||
-- | Feature that might not be present (inner data)
|
||||
type Sometimes_ a = [SubfeatureRoot a]
|
||||
|
||||
-- | Individually tested sub-feature data for Always/sometimes
|
||||
-- The polymorphism allows representing tested and untested states. Includes
|
||||
|
|
@ -259,7 +267,7 @@ data DBusMember = Method_ MemberName
|
|||
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
||||
|
||||
-- | Tested Always feature
|
||||
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
|
||||
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
||||
| Fallback a [SubfeatureFail]
|
||||
|
||||
-- | Tested Sometimes feature
|
||||
|
|
@ -287,20 +295,20 @@ data PostFail = PostFail [String] | PostMissing String
|
|||
-- | Testing pipeline
|
||||
|
||||
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
|
||||
evalSometimesMsg x = io $ do
|
||||
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
|
||||
evalSometimesMsg (Sometimes n xs) = io $ do
|
||||
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
|
||||
case s of
|
||||
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
|
||||
_ -> Left <$> failedMsgs True fs
|
||||
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs
|
||||
_ -> Left <$> failedMsgs True n fs
|
||||
|
||||
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
|
||||
evalAlwaysMsg x = io $ do
|
||||
evalAlwaysMsg (Always n x) = io $ do
|
||||
r <- testAlways x
|
||||
case r of
|
||||
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
|
||||
(Fallback act fs) -> PostPass act <$> failedMsgs False fs
|
||||
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs
|
||||
(Fallback act fs) -> PostPass act <$> failedMsgs False n fs
|
||||
|
||||
testAlways :: Always a -> IO (PostAlways a)
|
||||
testAlways :: Always_ a -> IO (PostAlways a)
|
||||
testAlways = go []
|
||||
where
|
||||
go failed (Option fd next) = do
|
||||
|
|
@ -308,9 +316,9 @@ testAlways = go []
|
|||
case r of
|
||||
(Left l) -> go (l:failed) next
|
||||
(Right pass) -> return $ Primary pass failed next
|
||||
go failed (Always a) = return $ Fallback a failed
|
||||
go failed (Always_ a) = return $ Fallback a failed
|
||||
|
||||
testSometimes :: Sometimes a -> IO (PostSometimes a)
|
||||
testSometimes :: Sometimes_ a -> IO (PostSometimes a)
|
||||
testSometimes = go (PostSometimes Nothing [])
|
||||
where
|
||||
go ts [] = return ts
|
||||
|
|
@ -486,11 +494,14 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
|||
-- | IO Lifting functions
|
||||
|
||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||
ioSometimes = fmap ioSubfeature
|
||||
ioSometimes (Sometimes n xs) = Sometimes n $ fmap ioSubfeature xs
|
||||
|
||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||
ioAlways (Always x) = Always $ io x
|
||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||
ioAlways (Always n x) = Always n $ ioAlways' x
|
||||
|
||||
ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
|
||||
ioAlways' (Always_ x) = Always_ $ io x
|
||||
ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a
|
||||
|
||||
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||
|
|
@ -504,37 +515,39 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Feature constructors
|
||||
|
||||
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
||||
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||
sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a
|
||||
sometimes1_ l fn n t = Sometimes fn
|
||||
[Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||
|
||||
always1_ :: LogLevel -> String -> Root a -> a -> Always a
|
||||
always1_ l n t x =
|
||||
Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
|
||||
always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a
|
||||
always1_ l fn n t x = Always fn
|
||||
$ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ x)
|
||||
|
||||
sometimes1 :: String -> Root a -> Sometimes a
|
||||
sometimes1 :: String -> String -> Root a -> Sometimes a
|
||||
sometimes1 = sometimes1_ Error
|
||||
|
||||
always1 :: String -> Root a -> a -> Always a
|
||||
always1 :: String -> String -> Root a -> a -> Always a
|
||||
always1 = always1_ Error
|
||||
|
||||
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
||||
sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||
sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t
|
||||
|
||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
||||
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
|
||||
sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
|
||||
|
||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs n sys path args =
|
||||
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
|
||||
-> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs fn n sys path args =
|
||||
sometimesIO fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||
|
||||
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
||||
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
|
||||
-> (Client -> a) -> Sometimes a
|
||||
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||
|
||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
||||
sometimesEndpoint :: MonadIO m => String -> String -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||
sometimesEndpoint name busname path iface mem client =
|
||||
sometimesDBus client name deps cmd
|
||||
sometimesEndpoint fn name busname path iface mem client =
|
||||
sometimesDBus client fn name deps cmd
|
||||
where
|
||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||
cmd c = io $ void $ callMethod c busname path iface mem
|
||||
|
|
@ -734,18 +747,19 @@ newtype JSONUnquotable = UQ String
|
|||
|
||||
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
|
||||
|
||||
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||
-> JSONUnquotable
|
||||
jsonAlways :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||
-> [JSONUnquotable] -> JSONUnquotable
|
||||
jsonAlways = jsonFeature True
|
||||
|
||||
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||
-> JSONUnquotable
|
||||
jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||
-> [JSONUnquotable] -> JSONUnquotable
|
||||
jsonSometimes = jsonFeature False
|
||||
|
||||
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||
jsonFeature :: Bool -> JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||
-> [JSONUnquotable] -> JSONUnquotable
|
||||
jsonFeature isalways success failed untested = jsonObject
|
||||
jsonFeature isalways name success failed untested = jsonObject
|
||||
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
|
||||
, ("name", JSON_Q name)
|
||||
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
|
||||
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
|
||||
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
|
||||
|
|
@ -826,16 +840,16 @@ curly s = "{" ++ s ++ "}"
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Other random formatting
|
||||
|
||||
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
||||
failedMsgs err = fmap concat . mapM (failedMsg err)
|
||||
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
|
||||
failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
|
||||
|
||||
failedMsg :: Bool -> SubfeatureFail -> IO [String]
|
||||
failedMsg err Subfeature { sfData = d, sfName = n } = do
|
||||
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
||||
failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
|
||||
failedMsg err fn Subfeature { sfData = d, sfName = n } = do
|
||||
mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
||||
|
||||
fmtMsg :: Bool -> String -> String -> IO String
|
||||
fmtMsg err n msg = do
|
||||
fmtMsg :: Bool -> String -> String -> String -> IO String
|
||||
fmtMsg err fn n msg = do
|
||||
let e = if err then "ERROR" else "WARNING"
|
||||
p <- getProgName
|
||||
return $ unwords [bracket p, bracket e, bracket n, msg]
|
||||
return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue