ENH give all features an overall name

This commit is contained in:
Nathan Dwarshuis 2022-06-28 23:27:55 -04:00
parent 98a8da5168
commit 3e6f4c7e27
10 changed files with 156 additions and 131 deletions

View File

@ -273,6 +273,10 @@ vpnPresent = do
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] 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 :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
rightPlugins sysClient sesClient = mapM evalFeature rightPlugins sysClient sesClient = mapM evalFeature
[ Left getWireless [ Left getWireless
@ -284,53 +288,50 @@ rightPlugins sysClient sesClient = mapM evalFeature
, Left $ getBl sesClient , Left $ getBl sesClient
, Left $ getCk sesClient , Left $ getCk sesClient
, Left $ getSs sesClient , Left $ getSs sesClient
, Right $ Always lockCmd , always' "lock indicator" lockCmd
, Right $ Always dateCmd , always' "date indicator" dateCmd
] ]
where
always' n = Right . Always n . Always_
getWireless :: BarFeature getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd
$ Only $ readInterface "get wifi interface" isWireless $ Only $ readInterface "get wifi interface" isWireless
getEthernet :: Maybe Client -> BarFeature getEthernet :: Maybe Client -> BarFeature
getEthernet client = sometimes1 "ethernet status indicator" $ getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
DBusRoot (const . ethernetCmd) tree client $ DBusRoot (const . ethernetCmd) tree client
where where
tree = And1 (Only readEth) (Only_ devDep) tree = And1 (Only readEth) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature getBattery :: BarFeature
getBattery = sometimesIO "battery level indicator" getBattery = sometimesIO "battery level indicator" "sysfs path"
(Only_ $ sysTest "Test if battery is present" hasBattery) (Only_ $ sysTest "Test if battery is present" hasBattery)
batteryCmd batteryCmd
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN client = sometimesDBus client "VPN status indicator" getVPN client = sometimesDBus client "VPN status indicator"
(toAnd vpnDep test) (const vpnCmd) "xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
where where
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = sometimesDBus client "bluetooth status indicator" getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
(Only_ btDep)
(const btCmd)
getAlsa :: BarFeature 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 :: Maybe Client -> BarFeature
getBl client = sometimesDBus client "Intel backlight indicator" getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
(Only_ intelBacklightSignalDep)
(const blCmd)
getCk :: Maybe Client -> BarFeature getCk :: Maybe Client -> BarFeature
getCk client = sometimesDBus client "Clevo keyboard indicator" getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
(Only_ clevoKeyboardSignalDep)
(const ckCmd)
getSs :: Maybe Client -> BarFeature getSs :: Maybe Client -> BarFeature
getSs client = sometimesDBus client "screensaver indicator" getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
(Only_ ssSignalDep) $ const ssCmd
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do getAllCommands right = do

View File

@ -573,9 +573,9 @@ externalBindings ts db =
] ]
, KeyGroup "Actions" , 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-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" "capture area" $ Left runAreaCapture
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture , KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture , 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 min" $ ck bctlMin
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt , 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 , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-- M-<F1> reserved for showing the keymap -- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart) , KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile , KeyBinding "M-<F3>" "recompile xmonad" recompilef
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService , KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
, KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer , KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
@ -629,7 +629,10 @@ externalBindings ts db =
brightessControls ctl getter = (ioSometimes . getter . ctl) cl brightessControls ctl getter = (ioSometimes . getter . ctl) cl
ib = Left . brightessControls intelBacklightControls ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls 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 ()) type MaybeX = Maybe (X ())

View File

@ -57,7 +57,7 @@ myDmenuNetworks = "networkmanager_dmenu"
-- | Other internal functions -- | Other internal functions
spawnDmenuCmd :: String -> [String] -> SometimesX spawnDmenuCmd :: String -> [String] -> SometimesX
spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd spawnDmenuCmd n = sometimesExeArgs n "rofi preset" True myDmenuCmd
themeArgs :: String -> [String] themeArgs :: String -> [String]
themeArgs hexColor = themeArgs hexColor =
@ -72,24 +72,29 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands -- | Exported Commands
runDevMenu :: SometimesX runDevMenu :: SometimesX
runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do runDevMenu = sometimesIO "device manager" "rofi devices" t x
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" where
spawnCmd myDmenuDevices t = Only_ $ localExe myDmenuDevices
$ ["-c", c] x = do
++ "--" : themeArgs "#999933" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
++ myDmenuMatchingArgs spawnCmd myDmenuDevices
$ ["-c", c]
++ "--" : themeArgs "#999933"
++ myDmenuMatchingArgs
runBTMenu :: SometimesX runBTMenu :: SometimesX
runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
$ "-c":themeArgs "#0044bb" myDmenuBluetooth $ "-c":themeArgs "#0044bb"
runBwMenu :: SometimesX runBwMenu :: SometimesX
runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $ runBwMenu = sometimesIO "password manager" "rofi bitwarden"
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runVPNMenu :: SometimesX runVPNMenu :: SometimesX
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $ runVPNMenu = sometimesIO "VPN selector" "rofi VPN"
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
runCmdMenu :: SometimesX runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
@ -98,7 +103,7 @@ runAppMenu :: SometimesX
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: SometimesX runClipMenu :: SometimesX
runClipMenu = sometimesIO "clipboard manager" deps act runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act
where where
act = spawnCmd myDmenuCmd args act = spawnCmd myDmenuCmd args
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip") deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
@ -111,18 +116,18 @@ runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: SometimesX runNetMenu :: SometimesX
runNetMenu = runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333" True myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: SometimesX runAutorandrMenu :: SometimesX
runAutorandrMenu = runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066" True myDmenuMonitors $ themeArgs "#ff0066"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Shortcut menu -- | Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Option showKeysDMenu (Always fallback) runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback)
where where
-- TODO this should technically depend on dunst -- TODO this should technically depend on dunst
fallback = const $ spawnNotify fallback = const $ spawnNotify

View File

@ -92,10 +92,10 @@ ethernetIface = "enp7s0f1"
-- | Some nice apps -- | Some nice apps
runTerm :: SometimesX runTerm :: SometimesX
runTerm = sometimesExe "terminal" True myTerm runTerm = sometimesExe "terminal" "urxvt" True myTerm
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO "terminal multiplexer" deps act runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
where where
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"] deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
act = spawn act = spawn
@ -106,27 +106,27 @@ runTMux = sometimesIO "terminal multiplexer" deps act
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
runCalc :: SometimesX runCalc :: SometimesX
runCalc = sometimesIO "calculator" deps act runCalc = sometimesIO "calculator" "R" deps act
where where
deps = toAnd (sysExe myTerm) (sysExe "R") deps = toAnd (sysExe myTerm) (sysExe "R")
act = spawnCmd myTerm ["-e", "R"] act = spawnCmd myTerm ["-e", "R"]
runBrowser :: SometimesX runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" False myBrowser runBrowser = sometimesExe "web browser" "brave" False myBrowser
runEditor :: SometimesX 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))"] ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: SometimesX runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" True "pcmanfm" runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Multimedia Commands -- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> SometimesX runMultimediaIfInstalled :: String -> String -> SometimesX
runMultimediaIfInstalled n cmd = runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd] "playerctl" True myMultimediaCtl [cmd]
runTogglePlay :: SometimesX runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -155,7 +155,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> SometimesX featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post = featureSound n file pre post =
sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay") sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
$ pre >> playSound file >> post $ pre >> playSound file >> post
runVolumeDown :: SometimesX runVolumeDown :: SometimesX
@ -172,7 +172,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
runNotificationCmd :: String -> FilePath -> SometimesX runNotificationCmd :: String -> FilePath -> SometimesX
runNotificationCmd n cmd = runNotificationCmd n cmd =
sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd] sometimesExeArgs (n ++ " control") "dunst" True myNotificationCtrl [cmd]
runNotificationClose :: SometimesX runNotificationClose :: SometimesX
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
@ -194,7 +194,7 @@ runNotificationContext =
runToggleBluetooth :: SometimesX runToggleBluetooth :: SometimesX
runToggleBluetooth = runToggleBluetooth =
sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth) sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
$ spawn $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -203,7 +203,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: SometimesX runToggleEthernet :: SometimesX
runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli") runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
$ spawn $ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect" #!&& "a=connect"
@ -212,14 +212,16 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: SometimesX runStartISyncTimer :: SometimesX
runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "mbsync.timer") runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
(Only_ $ sysdUser "mbsync.timer")
$ spawn $ spawn
$ "systemctl --user start mbsync.timer" $ "systemctl --user start mbsync.timer"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: SometimesX runStartISyncService :: SometimesX
runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "mbsync.service") runStartISyncService = sometimesIO "isync" "mbsync service"
(Only_ $ sysdUser "mbsync.service")
$ spawn $ spawn
$ "systemctl --user start mbsync.service" $ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -264,7 +266,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> SometimesX runFlameshot :: String -> String -> SometimesX
runFlameshot n mode = sometimesIO n (Only_ $ sysExe myCapture) runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture)
$ spawnCmd myCapture [mode] $ spawnCmd myCapture [mode]
-- TODO this will steal focus from the current window (and puts it -- TODO this will steal focus from the current window (and puts it
@ -281,7 +283,7 @@ runScreenCapture :: SometimesX
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: SometimesX
runCaptureBrowser = runCaptureBrowser = sometimesIO "screen capture browser" "feh"
sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do (Only_ $ sysExe myImageBrowser) $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

View File

@ -49,7 +49,7 @@ myOptimusManager = "optimus-manager"
-- | Core commands -- | Core commands
runScreenLock :: SometimesX runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" True myScreenlock runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock
runPowerOff :: X () runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -104,8 +104,8 @@ runOptimusPrompt' = do
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: SometimesX runOptimusPrompt :: SometimesX
runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager) runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager"
runOptimusPrompt' (Only_ $ localExe myOptimusManager) runOptimusPrompt'
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Universal power prompt -- | Universal power prompt
@ -134,7 +134,7 @@ instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: AlwaysX runPowerPrompt :: AlwaysX
runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock
where where
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id) withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)

View File

@ -113,9 +113,9 @@ handleACPI lock tag = do
-- | Spawn a new thread that will listen for ACPI events on the acpid socket -- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them -- and send ClientMessage events when it receives them
runPowermon :: SometimesIO runPowermon :: SometimesIO
runPowermon = sometimesIO "ACPI event monitor" socketDep listenACPI runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI
runHandleACPI :: Always (String -> X ()) runHandleACPI :: Always (String -> X ())
runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip
where where
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id) withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)

View File

@ -88,7 +88,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
-> Maybe Client -> SometimesIO -> Maybe Client -> SometimesIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc) sometimesDBus client n (n ++ " exporter") ds (exportBrightnessControls' bc)
where where
ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
@ -132,7 +132,7 @@ callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
callBacklight client BrightnessConfig { bcPath = p callBacklight client BrightnessConfig { bcPath = p
, bcInterface = i , bcInterface = i
, bcName = n } controlName m = , 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 :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -83,6 +83,6 @@ listenDevices client = do
runRemovableMon :: Maybe Client -> SometimesIO runRemovableMon :: Maybe Client -> SometimesIO
runRemovableMon cl = runRemovableMon cl =
sometimesDBus cl "removeable device monitor" deps listenDevices sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where where
deps = toAnd addedDep removedDep deps = toAnd addedDep removedDep

View File

@ -96,7 +96,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver :: Maybe Client -> SometimesIO exportScreensaver :: Maybe Client -> SometimesIO
exportScreensaver client = exportScreensaver client =
sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd sometimesDBus client "screensaver toggle" "xset" (toAnd bus ssx) cmd
where where
cmd cl = export cl ssPath defaultInterface cmd cl = export cl ssPath defaultInterface
{ interfaceName = interface { interfaceName = interface
@ -117,11 +117,11 @@ exportScreensaver client =
] ]
} }
bus = Bus xmonadBusName bus = Bus xmonadBusName
ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable ssx = DBusIO $ sysExe ssExecutable
callToggle :: Maybe Client -> SometimesIO callToggle :: Maybe Client -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName
interface memToggle ssPath interface memToggle
callQuery :: Client -> IO (Maybe SSState) callQuery :: Client -> IO (Maybe SSState)
callQuery client = do callQuery client = do

View File

@ -9,7 +9,9 @@ module XMonad.Internal.Dependency
-- feature types -- feature types
( Feature ( Feature
, Always(..) , Always(..)
, Sometimes , Always_(..)
, Sometimes(..)
, Sometimes_
, AlwaysX , AlwaysX
, AlwaysIO , AlwaysIO
, SometimesX , SometimesX
@ -137,26 +139,26 @@ dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout -- | Dump the status of an Always to stdout
dumpAlways :: Always a -> IO JSONUnquotable dumpAlways :: Always a -> IO JSONUnquotable
dumpAlways = go [] dumpAlways (Always n x) = go [] x
where where
go failed (Option o os) = do go failed (Option o os) = do
(s, r) <- dumpSubfeatureRoot o (s, r) <- dumpSubfeatureRoot o
if r 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 else go (s:failed) os
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed [] go failed (Always_ _) = return $ jsonAlways (Q n) (Just (UQ "true")) failed []
untested acc (Always _) = acc untested acc (Always_ _) = acc
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
-- | Dump the status of a Sometimes to stdout -- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> IO JSONUnquotable dumpSometimes :: Sometimes a -> IO JSONUnquotable
dumpSometimes = go [] dumpSometimes (Sometimes n a) = go [] a
where where
go failed [] = return $ jsonSometimes Nothing failed [] go failed [] = return $ jsonSometimes (Q n) Nothing failed []
go failed (x:xs) = do go failed (x:xs) = do
(s, r) <- dumpSubfeatureRoot x (s, r) <- dumpSubfeatureRoot x
if r 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 else go (s:failed) xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -178,12 +180,18 @@ type Feature a = Either (Sometimes a) (Always a)
-- | Feature that is guaranteed to work -- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail -- 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) -- 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 -- | Feature that might not be present
-- This is like an Always except it doesn't fall back on a guaranteed monadic -- This is like an Always except it doesn't fall back on a guaranteed monadic
-- action -- 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 -- | Individually tested sub-feature data for Always/sometimes
-- The polymorphism allows representing tested and untested states. Includes -- 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) -- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
-- | Tested Always feature -- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a) data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail] | Fallback a [SubfeatureFail]
-- | Tested Sometimes feature -- | Tested Sometimes feature
@ -287,20 +295,20 @@ data PostFail = PostFail [String] | PostMissing String
-- | Testing pipeline -- | Testing pipeline
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a) evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
evalSometimesMsg x = io $ do evalSometimesMsg (Sometimes n xs) = io $ do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of case s of
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs (Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs
_ -> Left <$> failedMsgs True fs _ -> Left <$> failedMsgs True n fs
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a) evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
evalAlwaysMsg x = io $ do evalAlwaysMsg (Always n x) = io $ do
r <- testAlways x r <- testAlways x
case r of case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs (Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs
(Fallback act fs) -> PostPass act <$> failedMsgs False fs (Fallback act fs) -> PostPass act <$> failedMsgs False n fs
testAlways :: Always a -> IO (PostAlways a) testAlways :: Always_ a -> IO (PostAlways a)
testAlways = go [] testAlways = go []
where where
go failed (Option fd next) = do go failed (Option fd next) = do
@ -308,9 +316,9 @@ testAlways = go []
case r of case r of
(Left l) -> go (l:failed) next (Left l) -> go (l:failed) next
(Right pass) -> return $ Primary pass 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 []) testSometimes = go (PostSometimes Nothing [])
where where
go ts [] = return ts go ts [] = return ts
@ -486,11 +494,14 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i
-- | IO Lifting functions -- | IO Lifting functions
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) 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 :: MonadIO m => Always (IO a) -> Always (m a)
ioAlways (Always x) = Always $ io x ioAlways (Always n x) = Always n $ ioAlways' x
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
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 :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf } ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
@ -504,37 +515,39 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature constructors -- | Feature constructors
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }] sometimes1_ l fn n t = Sometimes fn
[Subfeature{ sfData = t, sfName = n, sfLevel = l }]
always1_ :: LogLevel -> String -> Root a -> a -> Always a always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a
always1_ l n t x = always1_ l fn n t x = Always fn
Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x) $ 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 sometimes1 = sometimes1_ Error
always1 :: String -> Root a -> a -> Always a always1 :: String -> String -> Root a -> a -> Always a
always1 = always1_ Error always1 = always1_ Error
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a
sometimesIO n t x = sometimes1 n $ IORoot_ x t sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ()) sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
sometimesExe n sys path = sometimesExeArgs n sys path [] sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ()) sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
sometimesExeArgs n sys path args = -> [String] -> Sometimes (m ())
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args 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 -> (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 ()) -> MemberName -> Maybe Client -> Sometimes (m ())
sometimesEndpoint name busname path iface mem client = sometimesEndpoint fn name busname path iface mem client =
sometimesDBus client name deps cmd sometimesDBus client fn name deps cmd
where where
deps = Only_ $ Endpoint busname path iface $ Method_ mem deps = Only_ $ Endpoint busname path iface $ Method_ mem
cmd c = io $ void $ callMethod c busname path iface 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 data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable] jsonAlways :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> JSONUnquotable -> [JSONUnquotable] -> JSONUnquotable
jsonAlways = jsonFeature True jsonAlways = jsonFeature True
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable] jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> JSONUnquotable -> [JSONUnquotable] -> JSONUnquotable
jsonSometimes = jsonFeature False jsonSometimes = jsonFeature False
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable] jsonFeature :: Bool -> JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [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") [ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
, ("name", JSON_Q name)
, ("success", JSON_UQ $ fromMaybe (UQ "null") success) , ("success", JSON_UQ $ fromMaybe (UQ "null") success)
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed) , ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested) , ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
@ -826,16 +840,16 @@ curly s = "{" ++ s ++ "}"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other random formatting -- | Other random formatting
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String] failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
failedMsgs err = fmap concat . mapM (failedMsg err) failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
failedMsg :: Bool -> SubfeatureFail -> IO [String] failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
failedMsg err Subfeature { sfData = d, sfName = n } = do failedMsg err fn Subfeature { sfData = d, sfName = n } = do
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
fmtMsg :: Bool -> String -> String -> IO String fmtMsg :: Bool -> String -> String -> String -> IO String
fmtMsg err n msg = do fmtMsg err fn n msg = do
let e = if err then "ERROR" else "WARNING" let e = if err then "ERROR" else "WARNING"
p <- getProgName p <- getProgName
return $ unwords [bracket p, bracket e, bracket n, msg] return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]