REF arrange dependency module sanely

This commit is contained in:
Nathan Dwarshuis 2021-11-21 10:26:28 -05:00
parent 31ef889762
commit da1e4a1c79
10 changed files with 193 additions and 164 deletions

View File

@ -40,6 +40,7 @@ import XMonad.Hooks.DynamicLog
) )
import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.Shell
-- import XMonad.Internal.DBus.Common (xmonadBus) -- import XMonad.Internal.DBus.Common (xmonadBus)
-- import XMonad.Internal.DBus.Control (pathExists) -- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.DBus.Screensaver (ssSignalDep)
@ -263,7 +264,7 @@ vpnPresent = do
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
rightPlugins :: [IO (MaybeExe CmdSpec)] rightPlugins :: [IO (MaybeAction CmdSpec)]
rightPlugins = rightPlugins =
[ getWireless [ getWireless
, getEthernet , getEthernet
@ -280,21 +281,21 @@ rightPlugins =
where where
nocheck = return . Right nocheck = return . Right
getWireless :: IO (MaybeExe CmdSpec) getWireless :: IO (MaybeAction CmdSpec)
getWireless = do getWireless = do
i <- readInterface isWireless i <- readInterface isWireless
return $ maybe (Left []) (Right . wirelessCmd) i return $ maybe (Left []) (Right . wirelessCmd) i
getEthernet :: IO (MaybeExe CmdSpec) getEthernet :: IO (MaybeAction CmdSpec)
getEthernet = do getEthernet = do
i <- readInterface isEthernet i <- readInterface isEthernet
evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
where where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
getBattery :: BarFeature getBattery :: BarFeature
getBattery = Feature getBattery = Feature
{ ftrAction = batteryCmd { ftrMaybeAction = batteryCmd
, ftrName = "battery level indicator" , ftrName = "battery level indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [IOTest hasBattery] , ftrChildren = [IOTest hasBattery]
@ -304,7 +305,7 @@ type BarFeature = Feature CmdSpec
getVPN :: BarFeature getVPN :: BarFeature
getVPN = Feature getVPN = Feature
{ ftrAction = vpnCmd { ftrMaybeAction = vpnCmd
, ftrName = "VPN status indicator" , ftrName = "VPN status indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [d, v] , ftrChildren = [d, v]
@ -315,7 +316,7 @@ getVPN = Feature
getBt :: BarFeature getBt :: BarFeature
getBt = Feature getBt = Feature
{ ftrAction = btCmd { ftrMaybeAction = btCmd
, ftrName = "bluetooth status indicator" , ftrName = "bluetooth status indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [dep] , ftrChildren = [dep]
@ -325,7 +326,7 @@ getBt = Feature
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = Feature getAlsa = Feature
{ ftrAction = alsaCmd { ftrMaybeAction = alsaCmd
, ftrName = "volume level indicator" , ftrName = "volume level indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [Executable "alsactl"] , ftrChildren = [Executable "alsactl"]
@ -333,7 +334,7 @@ getAlsa = Feature
getBl :: BarFeature getBl :: BarFeature
getBl = Feature getBl = Feature
{ ftrAction = blCmd { ftrMaybeAction = blCmd
, ftrName = "Intel backlight indicator" , ftrName = "Intel backlight indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [intelBacklightSignalDep] , ftrChildren = [intelBacklightSignalDep]
@ -341,13 +342,13 @@ getBl = Feature
getSs :: BarFeature getSs :: BarFeature
getSs = Feature getSs = Feature
{ ftrAction = ssCmd { ftrMaybeAction = ssCmd
, ftrName = "screensaver indicator" , ftrName = "screensaver indicator"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [ssSignalDep] , ftrChildren = [ssSignalDep]
} }
getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
getAllCommands right = do getAllCommands right = do
let left = let left =
[ CmdSpec [ CmdSpec

View File

@ -86,7 +86,7 @@ main = do
, tsChildHandles = [h] , tsChildHandles = [h]
} }
lockRes <- evalFeature runScreenLock lockRes <- evalFeature runScreenLock
let lock = whenInstalled lockRes let lock = whenSatisfied lockRes
ext <- evalExternal $ externalBindings ts lock ext <- evalExternal $ externalBindings ts lock
warnMissing $ externalToMissing ext warnMissing $ externalToMissing ext
-- IDK why this is necessary; nothing prior to this line will print if missing -- IDK why this is necessary; nothing prior to this line will print if missing
@ -464,13 +464,13 @@ internalBindings c =
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } = mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } =
(subtitle h:) $ mkNamedKeymap c (subtitle h:) $ mkNamedKeymap c
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbAction = a} -> (s, addName d a)) $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b <$> b
data KeyBinding a = KeyBinding data KeyBinding a = KeyBinding
{ kbSyms :: String { kbSyms :: String
, kbDesc :: String , kbDesc :: String
, kbAction :: a , kbMaybeAction :: a
} }
data KeyGroup a = KeyGroup data KeyGroup a = KeyGroup
@ -485,23 +485,23 @@ evalExternal = mapM go
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX) evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbAction = a } = evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbAction = f }) <$> evalFeature a (\f -> k { kbMaybeAction = f }) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go filterExternal = fmap go
where where
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs } go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a] externalToMissing :: [KeyGroup (MaybeAction a)] -> [MaybeAction a]
externalToMissing = concatMap go externalToMissing = concatMap go
where where
go KeyGroup { kgBindings = bs } = fmap kbAction bs go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ())) flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
(Right x) -> Just $ k{ kbAction = x } (Right x) -> Just $ k{ kbMaybeAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } (Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX] externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
externalBindings ts lock = externalBindings ts lock =

View File

@ -24,6 +24,7 @@ import XMonad.Core hiding (spawn)
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Notify import XMonad.Internal.Notify
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -48,7 +49,7 @@ myDmenuNetworks = "networkmanager_dmenu"
-- | Other internal functions -- | Other internal functions
spawnDmenuCmd :: String -> [String] -> FeatureX spawnDmenuCmd :: String -> [String] -> FeatureX
spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd spawnDmenuCmd n = featureExeArgs n myDmenuCmd
themeArgs :: String -> [String] themeArgs :: String -> [String]
themeArgs hexColor = themeArgs hexColor =
@ -63,7 +64,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands -- | Exported Commands
runDevMenu :: FeatureX runDevMenu :: FeatureX
runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices
$ ["-c", c] $ ["-c", c]
@ -71,20 +72,20 @@ runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
runBwMenu :: FeatureX runBwMenu :: FeatureX
runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $ runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted -- TODO this is weirdly inverted
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys x = addName "Show Keybindings" $ do runShowKeys x = addName "Show Keybindings" $ do
s <- io $ evalFeature $ runDMenuShowKeys x s <- io $ evalFeature $ runDMenuShowKeys x
ifInstalled s ifSatisfied s
$ spawnNotify $ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" } $ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs = runDMenuShowKeys kbs =
featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do featureDefault "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where where
@ -99,7 +100,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: FeatureX runClipMenu :: FeatureX
runClipMenu = runClipMenu =
featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"] featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
$ spawnCmd myDmenuCmd args $ spawnCmd myDmenuCmd args
where where
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""
@ -112,8 +113,8 @@ runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: FeatureX runNetMenu :: FeatureX
runNetMenu = runNetMenu =
featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333" featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: FeatureX runAutorandrMenu :: FeatureX
runAutorandrMenu = runAutorandrMenu =
featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"

View File

@ -91,10 +91,10 @@ ethernetIface = "enp7s0f1"
-- | Some nice apps -- | Some nice apps
runTerm :: FeatureX runTerm :: FeatureX
runTerm = featureSpawn "terminal" myTerm runTerm = featureExe "terminal" myTerm
runTMux :: FeatureX runTMux :: FeatureX
runTMux = featureRun "terminal multiplexer" deps cmd runTMux = featureDefault "terminal multiplexer" deps cmd
where where
deps = [Executable myTerm, Executable "tmux", Executable "bash"] deps = [Executable myTerm, Executable "tmux", Executable "bash"]
cmd = spawn cmd = spawn
@ -105,25 +105,25 @@ runTMux = featureRun "terminal multiplexer" deps cmd
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
runCalc :: FeatureX runCalc :: FeatureX
runCalc = featureRun "calculator" [Executable myTerm, Executable "R"] runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"]
$ spawnCmd myTerm ["-e", "R"] $ spawnCmd myTerm ["-e", "R"]
runBrowser :: FeatureX runBrowser :: FeatureX
runBrowser = featureSpawn "web browser" myBrowser runBrowser = featureExe "web browser" myBrowser
runEditor :: FeatureX runEditor :: FeatureX
runEditor = featureSpawnCmd "text editor" myEditor runEditor = featureExeArgs "text editor" myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: FeatureX runFileManager :: FeatureX
runFileManager = featureSpawn "file browser" "pcmanfm" runFileManager = featureExe "file browser" "pcmanfm"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Multimedia Commands -- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> FeatureX runMultimediaIfInstalled :: String -> String -> FeatureX
runMultimediaIfInstalled n cmd = runMultimediaIfInstalled n cmd =
featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd] featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd]
runTogglePlay :: FeatureX runTogglePlay :: FeatureX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -151,7 +151,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> FeatureX featureSound :: String -> FilePath -> X () -> X () -> FeatureX
featureSound n file pre post = featureSound n file pre post =
featureRun ("volume " ++ n ++ " control") [Executable "paplay"] featureDefault ("volume " ++ n ++ " control") [Executable "paplay"]
$ pre >> playSound file >> post $ pre >> playSound file >> post
runVolumeDown :: FeatureX runVolumeDown :: FeatureX
@ -168,7 +168,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
runNotificationCmd :: String -> String -> FeatureX runNotificationCmd :: String -> String -> FeatureX
runNotificationCmd n cmd = runNotificationCmd n cmd =
featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd] featureExeArgs (n ++ " control") myNotificationCtrl [cmd]
runNotificationClose :: FeatureX runNotificationClose :: FeatureX
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
@ -190,7 +190,7 @@ runNotificationContext =
runToggleBluetooth :: FeatureX runToggleBluetooth :: FeatureX
runToggleBluetooth = runToggleBluetooth =
featureRun "bluetooth toggle" [Executable myBluetooth] featureDefault "bluetooth toggle" [Executable myBluetooth]
$ spawn $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -199,7 +199,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: FeatureX runToggleEthernet :: FeatureX
runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"] runToggleEthernet = featureDefault "ethernet toggle" [Executable "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"
@ -208,14 +208,14 @@ runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: FeatureX runStartISyncTimer :: FeatureX
runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"] runStartISyncTimer = featureDefault "isync timer" [userUnit "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 :: FeatureX runStartISyncService :: FeatureX
runStartISyncService = featureRun "isync" [userUnit "mbsync.service"] runStartISyncService = featureDefault "isync" [userUnit "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" }
@ -260,7 +260,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> FeatureX runFlameshot :: String -> String -> FeatureX
runFlameshot n mode = featureRun n [Executable myCapture] $ do runFlameshot n mode = featureDefault n [Executable myCapture] $ do
ssDir <- io getCaptureDir ssDir <- io getCaptureDir
spawnCmd myCapture $ mode : ["-p", ssDir] spawnCmd myCapture $ mode : ["-p", ssDir]
@ -279,6 +279,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: FeatureX runCaptureBrowser :: FeatureX
runCaptureBrowser = runCaptureBrowser =
featureRun "screen capture browser" [Executable myImageBrowser] $ do featureDefault "screen capture browser" [Executable myImageBrowser] $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

View File

@ -46,7 +46,7 @@ myOptimusManager = "optimus-manager"
-- | Core commands -- | Core commands
runScreenLock :: Feature (X ()) runScreenLock :: Feature (X ())
runScreenLock = featureSpawn "screen locker" myScreenlock runScreenLock = featureExe "screen locker" myScreenlock
runPowerOff :: X () runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -101,24 +101,24 @@ runOptimusPrompt' = do
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: FeatureX runOptimusPrompt :: FeatureX
runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager] runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager]
runOptimusPrompt' runOptimusPrompt'
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Universal power prompt -- | Universal power prompt
data PowerAction = Poweroff data PowerMaybeAction = Poweroff
| Shutdown | Shutdown
| Hibernate | Hibernate
| Reboot | Reboot
deriving (Eq) deriving (Eq)
instance Enum PowerAction where instance Enum PowerMaybeAction where
toEnum 0 = Poweroff toEnum 0 = Poweroff
toEnum 1 = Shutdown toEnum 1 = Shutdown
toEnum 2 = Hibernate toEnum 2 = Hibernate
toEnum 3 = Reboot toEnum 3 = Reboot
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument" toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
fromEnum Poweroff = 0 fromEnum Poweroff = 0
fromEnum Shutdown = 1 fromEnum Shutdown = 1
@ -131,22 +131,22 @@ 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 :: X () -> X () runPowerPrompt :: X () -> X ()
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
where where
comp = mkComplFunFromList [] comp = mkComplFunFromList []
theme = T.promptTheme { promptKeymap = keymap } theme = T.promptTheme { promptKeymap = keymap }
keymap = M.fromList keymap = M.fromList
$ ((controlMask, xK_g), quit) : $ ((controlMask, xK_g), quit) :
map (first $ (,) 0) map (first $ (,) 0)
[ (xK_p, sendAction Poweroff) [ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendAction Shutdown) , (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendAction Hibernate) , (xK_h, sendMaybeAction Hibernate)
, (xK_r, sendAction Reboot) , (xK_r, sendMaybeAction Reboot)
, (xK_Return, quit) , (xK_Return, quit)
, (xK_Escape, quit) , (xK_Escape, quit)
] ]
sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeAction a = case toEnum $ read a of executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate Hibernate -> lock >> runHibernate

View File

@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
-- | 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 :: FeatureIO runPowermon :: FeatureIO
runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI runPowermon = featureDefault "ACPI event monitor" [pathR acpiPath] listenACPI
-- | Handle ClientMessage event containing and ACPI event (to be used in -- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook) -- Xmonad's event hook)

View File

@ -86,4 +86,4 @@ listenDevices = do
runRemovableMon :: FeatureIO runRemovableMon :: FeatureIO
runRemovableMon = runRemovableMon =
featureRun "removeable device monitor" [addedDep, removedDep] listenDevices featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices

View File

@ -89,7 +89,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> FeatureIO -> Client -> FeatureIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
{ ftrAction = exportBrightnessControls' bc client { ftrMaybeAction = exportBrightnessControls' bc client
, ftrName = n ++ " exporter" , ftrName = n ++ " exporter"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = DBusBus xmonadBus:deps , ftrChildren = DBusBus xmonadBus:deps
@ -133,7 +133,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
Feature Feature
{ ftrAction = void $ callMethod $ methodCall p i m { ftrMaybeAction = void $ callMethod $ methodCall p i m
, ftrName = unwords [n, controlName] , ftrName = unwords [n, controlName]
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [xDbusDep p i $ Method_ m] , ftrChildren = [xDbusDep p i $ Method_ m]

View File

@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver :: Client -> FeatureIO exportScreensaver :: Client -> FeatureIO
exportScreensaver client = Feature exportScreensaver client = Feature
{ ftrAction = cmd { ftrMaybeAction = cmd
, ftrName = "screensaver interface" , ftrName = "screensaver interface"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [Executable ssExecutable, DBusBus xmonadBus] , ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
@ -122,7 +122,7 @@ exportScreensaver client = Feature
callToggle :: FeatureIO callToggle :: FeatureIO
callToggle = Feature callToggle = Feature
{ ftrAction = cmd { ftrMaybeAction = cmd
, ftrName = "screensaver toggle" , ftrName = "screensaver toggle"
, ftrWarning = Default , ftrWarning = Default
, ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle] , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]

View File

@ -2,17 +2,17 @@
-- | Functions for handling dependencies -- | Functions for handling dependencies
module XMonad.Internal.Dependency module XMonad.Internal.Dependency
( MaybeExe ( MaybeAction
, UnitType(..)
, Dependency(..)
, Bus(..)
, Endpoint(..)
, DBusMember(..)
, Warning(..)
, MaybeX , MaybeX
, FeatureX , FeatureX
, FeatureIO , FeatureIO
, Feature(..) , Feature(..)
, Warning(..)
, Dependency(..)
, UnitType(..)
, Bus(..)
, Endpoint(..)
, DBusMember(..)
, ioFeature , ioFeature
, evalFeature , evalFeature
, systemUnit , systemUnit
@ -20,14 +20,12 @@ module XMonad.Internal.Dependency
, pathR , pathR
, pathW , pathW
, pathRW , pathRW
, featureRun , featureDefault
, featureSpawnCmd , featureExeArgs
, featureSpawn , featureExe
, warnMissing , warnMissing
, whenInstalled , whenSatisfied
, ifInstalled , ifSatisfied
, fmtCmd
, spawnCmd
, executeFeature , executeFeature
, executeFeature_ , executeFeature_
, applyFeature , applyFeature
@ -54,51 +52,71 @@ import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Gracefully handling missing binaries -- | Features
--
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) -- A 'feature' is an 'action' (usually an IO ()) that requires one or more
-- 'dependencies'. Features also have a useful name and an error logging
data DBusMember = Method_ MemberName -- protocol.
| Signal_ MemberName --
| Property_ String -- NOTE: there is no way to make a feature depend on another feature. This is
deriving (Eq, Show) -- very complicated to implement and would only be applicable to a few instances
-- (notable the dbus interfaces). In order to implement a dependency tree, use
data Bus = Bus Bool BusName deriving (Eq, Show) -- dependencies that target the output/state of another feature; this is more
-- robust anyways, at the cost of being a bit slower.
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
data Warning = Silent | Default
data Feature a = Feature data Feature a = Feature
{ ftrAction :: a { ftrMaybeAction :: a
, ftrName :: String , ftrName :: String
, ftrWarning :: Warning , ftrWarning :: Warning
, ftrChildren :: [Dependency] , ftrChildren :: [Dependency]
} }
| ConstFeature a | ConstFeature a
| BlankFeature | BlankFeature
-- TODO this is silly as is, and could be made more useful by representing
-- loglevels
data Warning = Silent | Default
type FeatureX = Feature (X ()) type FeatureX = Feature (X ())
type FeatureIO = Feature (IO ()) type FeatureIO = Feature (IO ())
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a) ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a } ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
ioFeature (ConstFeature f) = ConstFeature $ liftIO f ioFeature (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature ioFeature BlankFeature = BlankFeature
evalFeature :: Feature a -> IO (MaybeExe a) featureDefault :: String -> [Dependency] -> a -> Feature a
featureDefault n ds x = Feature
{ ftrMaybeAction = x
, ftrName = n
, ftrWarning = Default
, ftrChildren = ds
}
featureExe :: MonadIO m => String -> String -> Feature (m ())
featureExe n cmd = featureExeArgs n cmd []
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args =
featureDefault n [Executable cmd] $ spawnCmd cmd args
--------------------------------------------------------------------------------
-- | Feature evaluation
--
-- Evaluate a feature by testing if its dependencies are satisfied, and return
-- either the action of the feature or 0 or more error messages that signify
-- what dependencies are missing and why.
type MaybeAction a = Either [String] a
type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Right x evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left [] evalFeature BlankFeature = return $ Left []
evalFeature Feature evalFeature Feature
{ ftrAction = a { ftrMaybeAction = a
, ftrName = n , ftrName = n
, ftrWarning = w , ftrWarning = w
, ftrChildren = c , ftrChildren = c
@ -113,6 +131,48 @@ evalFeature Feature
Silent -> [] Silent -> []
Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
whenSatisfied = flip ifSatisfied skip
ifSatisfied :: MaybeAction a -> a -> a
ifSatisfied (Right x) _ = x
ifSatisfied _ alt = alt
--------------------------------------------------------------------------------
-- | Dependencies
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
pathR :: String -> Dependency pathR :: String -> Dependency
pathR n = AccessiblePath n True False pathR n = AccessiblePath n True False
@ -128,35 +188,29 @@ systemUnit = Systemd SystemUnit
userUnit :: String -> Dependency userUnit :: String -> Dependency
userUnit = Systemd UserUnit userUnit = Systemd UserUnit
-- TODO this is poorly named. This actually represents an action that has --------------------------------------------------------------------------------
-- one or more dependencies (where "action" is not necessarily executing an exe) -- | Dependency evaluation
type MaybeExe a = Either [String] a --
-- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>.
type MaybeX = MaybeExe (X ()) evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeSatisfied n
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitSatisfied t n
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
evalDependency (DBusEndpoint b e) = endpointSatisfied b e
evalDependency (DBusBus b) = busSatisfied b
featureRun :: String -> [Dependency] -> a -> Feature a exeSatisfied :: String -> IO (Maybe String)
featureRun n ds x = Feature exeSatisfied x = do
{ ftrAction = x
, ftrName = n
, ftrWarning = Default
, ftrChildren = ds
}
featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args
featureSpawn :: MonadIO m => String -> String -> Feature (m ())
featureSpawn n cmd = featureSpawnCmd n cmd []
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
r <- findExecutable x r <- findExecutable x
return $ case r of return $ case r of
(Just _) -> Nothing (Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found" _ -> Just $ "executable '" ++ x ++ "' not found"
unitInstalled :: UnitType -> String -> IO (Maybe String) unitSatisfied :: UnitType -> String -> IO (Maybe String)
unitInstalled u x = do unitSatisfied u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of return $ case rc of
ExitSuccess -> Nothing ExitSuccess -> Nothing
@ -166,8 +220,8 @@ unitInstalled u x = do
unitType SystemUnit = "system" unitType SystemUnit = "system"
unitType UserUnit = "user" unitType UserUnit = "user"
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String) pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do pathSatisfied p testread testwrite = do
res <- getPermissionsSafe p res <- getPermissionsSafe p
let msg = permMsg res let msg = permMsg res
return msg return msg
@ -197,8 +251,8 @@ callMethod (Bus usesys bus) path iface mem = do
disconnect client disconnect client
return $ bimap methodErrorMessage methodReturnBody reply return $ bimap methodErrorMessage methodReturnBody reply
dbusBusExists :: Bus -> IO (Maybe String) busSatisfied :: Bus -> IO (Maybe String)
dbusBusExists (Bus usesystem bus) = do busSatisfied (Bus usesystem bus) = do
ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Just e Left e -> Just e
@ -214,8 +268,8 @@ dbusBusExists (Bus usesystem bus) = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String) endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do endpointSatisfied b@(Bus _ bus) (Endpoint objpath iface mem) = do
ret <- callMethod b objpath introspectInterface introspectMethod ret <- callMethod b objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Just e Left e -> Just e
@ -245,43 +299,16 @@ dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
, formatBusName bus , formatBusName bus
] ]
evalDependency :: Dependency -> IO (Maybe String) --------------------------------------------------------------------------------
evalDependency (Executable n) = exeInstalled n -- | Logging functions
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitInstalled t n
evalDependency (AccessiblePath p r w) = pathAccessible p r w
evalDependency (DBusEndpoint b e) = dbusEndpointExists b e
evalDependency (DBusBus b) = dbusBusExists b
whenInstalled :: Monad m => MaybeExe (m ()) -> m () warnMissing :: [MaybeAction a] -> IO ()
whenInstalled = flip ifInstalled skip
ifInstalled :: MaybeExe a -> a -> a
ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
warnMissing :: [MaybeExe a] -> IO ()
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ] warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
warnMissing' :: [String] -> IO () warnMissing' :: [String] -> IO ()
warnMissing' = mapM_ putStrLn warnMissing' = mapM_ putStrLn
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
fmtMsg :: String -> String -> String -> String fmtMsg :: String -> String -> String -> String
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg] fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
where where
bracket s = "[" ++ s ++ "]" bracket s = "[" ++ s ++ "]"