REF arrange dependency module sanely
This commit is contained in:
parent
31ef889762
commit
da1e4a1c79
|
|
@ -40,6 +40,7 @@ import XMonad.Hooks.DynamicLog
|
|||
)
|
||||
import XMonad.Internal.Command.Power (hasBattery)
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.Shell
|
||||
-- import XMonad.Internal.DBus.Common (xmonadBus)
|
||||
-- import XMonad.Internal.DBus.Control (pathExists)
|
||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||
|
|
@ -263,7 +264,7 @@ vpnPresent = do
|
|||
where
|
||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||
|
||||
rightPlugins :: [IO (MaybeExe CmdSpec)]
|
||||
rightPlugins :: [IO (MaybeAction CmdSpec)]
|
||||
rightPlugins =
|
||||
[ getWireless
|
||||
, getEthernet
|
||||
|
|
@ -280,21 +281,21 @@ rightPlugins =
|
|||
where
|
||||
nocheck = return . Right
|
||||
|
||||
getWireless :: IO (MaybeExe CmdSpec)
|
||||
getWireless :: IO (MaybeAction CmdSpec)
|
||||
getWireless = do
|
||||
i <- readInterface isWireless
|
||||
return $ maybe (Left []) (Right . wirelessCmd) i
|
||||
|
||||
getEthernet :: IO (MaybeExe CmdSpec)
|
||||
getEthernet :: IO (MaybeAction CmdSpec)
|
||||
getEthernet = do
|
||||
i <- readInterface isEthernet
|
||||
evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i
|
||||
evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
|
||||
where
|
||||
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = Feature
|
||||
{ ftrAction = batteryCmd
|
||||
{ ftrMaybeAction = batteryCmd
|
||||
, ftrName = "battery level indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [IOTest hasBattery]
|
||||
|
|
@ -304,7 +305,7 @@ type BarFeature = Feature CmdSpec
|
|||
|
||||
getVPN :: BarFeature
|
||||
getVPN = Feature
|
||||
{ ftrAction = vpnCmd
|
||||
{ ftrMaybeAction = vpnCmd
|
||||
, ftrName = "VPN status indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [d, v]
|
||||
|
|
@ -315,7 +316,7 @@ getVPN = Feature
|
|||
|
||||
getBt :: BarFeature
|
||||
getBt = Feature
|
||||
{ ftrAction = btCmd
|
||||
{ ftrMaybeAction = btCmd
|
||||
, ftrName = "bluetooth status indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [dep]
|
||||
|
|
@ -325,7 +326,7 @@ getBt = Feature
|
|||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = Feature
|
||||
{ ftrAction = alsaCmd
|
||||
{ ftrMaybeAction = alsaCmd
|
||||
, ftrName = "volume level indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [Executable "alsactl"]
|
||||
|
|
@ -333,7 +334,7 @@ getAlsa = Feature
|
|||
|
||||
getBl :: BarFeature
|
||||
getBl = Feature
|
||||
{ ftrAction = blCmd
|
||||
{ ftrMaybeAction = blCmd
|
||||
, ftrName = "Intel backlight indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [intelBacklightSignalDep]
|
||||
|
|
@ -341,13 +342,13 @@ getBl = Feature
|
|||
|
||||
getSs :: BarFeature
|
||||
getSs = Feature
|
||||
{ ftrAction = ssCmd
|
||||
{ ftrMaybeAction = ssCmd
|
||||
, ftrName = "screensaver indicator"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [ssSignalDep]
|
||||
}
|
||||
|
||||
getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions
|
||||
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
||||
getAllCommands right = do
|
||||
let left =
|
||||
[ CmdSpec
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ main = do
|
|||
, tsChildHandles = [h]
|
||||
}
|
||||
lockRes <- evalFeature runScreenLock
|
||||
let lock = whenInstalled lockRes
|
||||
let lock = whenSatisfied lockRes
|
||||
ext <- evalExternal $ externalBindings ts lock
|
||||
warnMissing $ externalToMissing ext
|
||||
-- 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 c KeyGroup { kgHeader = h, kgBindings = b } =
|
||||
(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
|
||||
|
||||
data KeyBinding a = KeyBinding
|
||||
{ kbSyms :: String
|
||||
, kbDesc :: String
|
||||
, kbAction :: a
|
||||
, kbMaybeAction :: a
|
||||
}
|
||||
|
||||
data KeyGroup a = KeyGroup
|
||||
|
|
@ -485,23 +485,23 @@ evalExternal = mapM go
|
|||
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
|
||||
|
||||
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
|
||||
evalKeyBinding k@KeyBinding { kbAction = a } =
|
||||
(\f -> k { kbAction = f }) <$> evalFeature a
|
||||
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
|
||||
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
|
||||
|
||||
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
|
||||
filterExternal = fmap go
|
||||
where
|
||||
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
|
||||
where
|
||||
go KeyGroup { kgBindings = bs } = fmap kbAction bs
|
||||
go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs
|
||||
|
||||
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
|
||||
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
|
||||
(Right x) -> Just $ k{ kbAction = x }
|
||||
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
|
||||
flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
|
||||
(Right x) -> Just $ k{ kbMaybeAction = x }
|
||||
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
|
||||
|
||||
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
|
||||
externalBindings ts lock =
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import XMonad.Core hiding (spawn)
|
|||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Notify
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Util.NamedActions
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -48,7 +49,7 @@ myDmenuNetworks = "networkmanager_dmenu"
|
|||
-- | Other internal functions
|
||||
|
||||
spawnDmenuCmd :: String -> [String] -> FeatureX
|
||||
spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd
|
||||
spawnDmenuCmd n = featureExeArgs n myDmenuCmd
|
||||
|
||||
themeArgs :: String -> [String]
|
||||
themeArgs hexColor =
|
||||
|
|
@ -63,7 +64,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
|||
-- | Exported Commands
|
||||
|
||||
runDevMenu :: FeatureX
|
||||
runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
|
||||
runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do
|
||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||
spawnCmd myDmenuDevices
|
||||
$ ["-c", c]
|
||||
|
|
@ -71,20 +72,20 @@ runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
|
|||
++ myDmenuMatchingArgs
|
||||
|
||||
runBwMenu :: FeatureX
|
||||
runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $
|
||||
runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $
|
||||
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||
|
||||
-- TODO this is weirdly inverted
|
||||
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
||||
runShowKeys x = addName "Show Keybindings" $ do
|
||||
s <- io $ evalFeature $ runDMenuShowKeys x
|
||||
ifInstalled s
|
||||
ifSatisfied s
|
||||
$ spawnNotify
|
||||
$ defNoteError { body = Just $ Text "could not display keymap" }
|
||||
|
||||
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
|
||||
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 }
|
||||
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||
where
|
||||
|
|
@ -99,7 +100,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
|||
|
||||
runClipMenu :: FeatureX
|
||||
runClipMenu =
|
||||
featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
|
||||
featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
|
||||
$ spawnCmd myDmenuCmd args
|
||||
where
|
||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||
|
|
@ -112,8 +113,8 @@ runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
|||
|
||||
runNetMenu :: FeatureX
|
||||
runNetMenu =
|
||||
featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
|
||||
featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
|
||||
|
||||
runAutorandrMenu :: FeatureX
|
||||
runAutorandrMenu =
|
||||
featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"
|
||||
featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"
|
||||
|
|
|
|||
|
|
@ -91,10 +91,10 @@ ethernetIface = "enp7s0f1"
|
|||
-- | Some nice apps
|
||||
|
||||
runTerm :: FeatureX
|
||||
runTerm = featureSpawn "terminal" myTerm
|
||||
runTerm = featureExe "terminal" myTerm
|
||||
|
||||
runTMux :: FeatureX
|
||||
runTMux = featureRun "terminal multiplexer" deps cmd
|
||||
runTMux = featureDefault "terminal multiplexer" deps cmd
|
||||
where
|
||||
deps = [Executable myTerm, Executable "tmux", Executable "bash"]
|
||||
cmd = spawn
|
||||
|
|
@ -105,25 +105,25 @@ runTMux = featureRun "terminal multiplexer" deps cmd
|
|||
msg = "could not connect to tmux session"
|
||||
|
||||
runCalc :: FeatureX
|
||||
runCalc = featureRun "calculator" [Executable myTerm, Executable "R"]
|
||||
runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"]
|
||||
$ spawnCmd myTerm ["-e", "R"]
|
||||
|
||||
runBrowser :: FeatureX
|
||||
runBrowser = featureSpawn "web browser" myBrowser
|
||||
runBrowser = featureExe "web browser" myBrowser
|
||||
|
||||
runEditor :: FeatureX
|
||||
runEditor = featureSpawnCmd "text editor" myEditor
|
||||
runEditor = featureExeArgs "text editor" myEditor
|
||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||
|
||||
runFileManager :: FeatureX
|
||||
runFileManager = featureSpawn "file browser" "pcmanfm"
|
||||
runFileManager = featureExe "file browser" "pcmanfm"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Multimedia Commands
|
||||
|
||||
runMultimediaIfInstalled :: String -> String -> FeatureX
|
||||
runMultimediaIfInstalled n cmd =
|
||||
featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd]
|
||||
featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd]
|
||||
|
||||
runTogglePlay :: FeatureX
|
||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||
|
|
@ -151,7 +151,7 @@ playSound file = do
|
|||
|
||||
featureSound :: String -> FilePath -> X () -> X () -> FeatureX
|
||||
featureSound n file pre post =
|
||||
featureRun ("volume " ++ n ++ " control") [Executable "paplay"]
|
||||
featureDefault ("volume " ++ n ++ " control") [Executable "paplay"]
|
||||
$ pre >> playSound file >> post
|
||||
|
||||
runVolumeDown :: FeatureX
|
||||
|
|
@ -168,7 +168,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
|
|||
|
||||
runNotificationCmd :: String -> String -> FeatureX
|
||||
runNotificationCmd n cmd =
|
||||
featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd]
|
||||
featureExeArgs (n ++ " control") myNotificationCtrl [cmd]
|
||||
|
||||
runNotificationClose :: FeatureX
|
||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||
|
|
@ -190,7 +190,7 @@ runNotificationContext =
|
|||
|
||||
runToggleBluetooth :: FeatureX
|
||||
runToggleBluetooth =
|
||||
featureRun "bluetooth toggle" [Executable myBluetooth]
|
||||
featureDefault "bluetooth toggle" [Executable myBluetooth]
|
||||
$ spawn
|
||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||
#!&& "a=on"
|
||||
|
|
@ -199,7 +199,7 @@ runToggleBluetooth =
|
|||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
||||
|
||||
runToggleEthernet :: FeatureX
|
||||
runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
|
||||
runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"]
|
||||
$ spawn
|
||||
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
|
||||
#!&& "a=connect"
|
||||
|
|
@ -208,14 +208,14 @@ runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
|
|||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||
|
||||
runStartISyncTimer :: FeatureX
|
||||
runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"]
|
||||
runStartISyncTimer = featureDefault "isync timer" [userUnit "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 :: FeatureX
|
||||
runStartISyncService = featureRun "isync" [userUnit "mbsync.service"]
|
||||
runStartISyncService = featureDefault "isync" [userUnit "mbsync.service"]
|
||||
$ spawn
|
||||
$ "systemctl --user start mbsync.service"
|
||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
|
||||
|
|
@ -260,7 +260,7 @@ getCaptureDir = do
|
|||
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||
|
||||
runFlameshot :: String -> String -> FeatureX
|
||||
runFlameshot n mode = featureRun n [Executable myCapture] $ do
|
||||
runFlameshot n mode = featureDefault n [Executable myCapture] $ do
|
||||
ssDir <- io getCaptureDir
|
||||
spawnCmd myCapture $ mode : ["-p", ssDir]
|
||||
|
||||
|
|
@ -279,6 +279,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
|
|||
|
||||
runCaptureBrowser :: FeatureX
|
||||
runCaptureBrowser =
|
||||
featureRun "screen capture browser" [Executable myImageBrowser] $ do
|
||||
featureDefault "screen capture browser" [Executable myImageBrowser] $ do
|
||||
dir <- io getCaptureDir
|
||||
spawnCmd myImageBrowser [dir]
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ myOptimusManager = "optimus-manager"
|
|||
-- | Core commands
|
||||
|
||||
runScreenLock :: Feature (X ())
|
||||
runScreenLock = featureSpawn "screen locker" myScreenlock
|
||||
runScreenLock = featureExe "screen locker" myScreenlock
|
||||
|
||||
runPowerOff :: X ()
|
||||
runPowerOff = spawn "systemctl poweroff"
|
||||
|
|
@ -101,24 +101,24 @@ runOptimusPrompt' = do
|
|||
#!&& "killall xmonad"
|
||||
|
||||
runOptimusPrompt :: FeatureX
|
||||
runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager]
|
||||
runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager]
|
||||
runOptimusPrompt'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Universal power prompt
|
||||
|
||||
data PowerAction = Poweroff
|
||||
data PowerMaybeAction = Poweroff
|
||||
| Shutdown
|
||||
| Hibernate
|
||||
| Reboot
|
||||
deriving (Eq)
|
||||
|
||||
instance Enum PowerAction where
|
||||
instance Enum PowerMaybeAction where
|
||||
toEnum 0 = Poweroff
|
||||
toEnum 1 = Shutdown
|
||||
toEnum 2 = Hibernate
|
||||
toEnum 3 = Reboot
|
||||
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument"
|
||||
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
|
||||
|
||||
fromEnum Poweroff = 0
|
||||
fromEnum Shutdown = 1
|
||||
|
|
@ -131,22 +131,22 @@ instance XPrompt PowerPrompt where
|
|||
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
||||
|
||||
runPowerPrompt :: X () -> X ()
|
||||
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction
|
||||
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||
where
|
||||
comp = mkComplFunFromList []
|
||||
theme = T.promptTheme { promptKeymap = keymap }
|
||||
keymap = M.fromList
|
||||
$ ((controlMask, xK_g), quit) :
|
||||
map (first $ (,) 0)
|
||||
[ (xK_p, sendAction Poweroff)
|
||||
, (xK_s, sendAction Shutdown)
|
||||
, (xK_h, sendAction Hibernate)
|
||||
, (xK_r, sendAction Reboot)
|
||||
[ (xK_p, sendMaybeAction Poweroff)
|
||||
, (xK_s, sendMaybeAction Shutdown)
|
||||
, (xK_h, sendMaybeAction Hibernate)
|
||||
, (xK_r, sendMaybeAction Reboot)
|
||||
, (xK_Return, quit)
|
||||
, (xK_Escape, quit)
|
||||
]
|
||||
sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
||||
executeAction a = case toEnum $ read a of
|
||||
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
||||
executeMaybeAction a = case toEnum $ read a of
|
||||
Poweroff -> runPowerOff
|
||||
Shutdown -> lock >> runSuspend
|
||||
Hibernate -> lock >> runHibernate
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
|
|||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||
-- and send ClientMessage events when it receives them
|
||||
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
|
||||
-- Xmonad's event hook)
|
||||
|
|
|
|||
|
|
@ -86,4 +86,4 @@ listenDevices = do
|
|||
|
||||
runRemovableMon :: FeatureIO
|
||||
runRemovableMon =
|
||||
featureRun "removeable device monitor" [addedDep, removedDep] listenDevices
|
||||
featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
|
|||
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
||||
-> Client -> FeatureIO
|
||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
|
||||
{ ftrAction = exportBrightnessControls' bc client
|
||||
{ ftrMaybeAction = exportBrightnessControls' bc client
|
||||
, ftrName = n ++ " exporter"
|
||||
, ftrWarning = Default
|
||||
, 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 { bcPath = p, bcInterface = i, bcName = n } controlName m =
|
||||
Feature
|
||||
{ ftrAction = void $ callMethod $ methodCall p i m
|
||||
{ ftrMaybeAction = void $ callMethod $ methodCall p i m
|
||||
, ftrName = unwords [n, controlName]
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [xDbusDep p i $ Method_ m]
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing
|
|||
|
||||
exportScreensaver :: Client -> FeatureIO
|
||||
exportScreensaver client = Feature
|
||||
{ ftrAction = cmd
|
||||
{ ftrMaybeAction = cmd
|
||||
, ftrName = "screensaver interface"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
|
||||
|
|
@ -122,7 +122,7 @@ exportScreensaver client = Feature
|
|||
|
||||
callToggle :: FeatureIO
|
||||
callToggle = Feature
|
||||
{ ftrAction = cmd
|
||||
{ ftrMaybeAction = cmd
|
||||
, ftrName = "screensaver toggle"
|
||||
, ftrWarning = Default
|
||||
, ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
|
||||
|
|
|
|||
|
|
@ -2,17 +2,17 @@
|
|||
-- | Functions for handling dependencies
|
||||
|
||||
module XMonad.Internal.Dependency
|
||||
( MaybeExe
|
||||
, UnitType(..)
|
||||
, Dependency(..)
|
||||
, Bus(..)
|
||||
, Endpoint(..)
|
||||
, DBusMember(..)
|
||||
, Warning(..)
|
||||
( MaybeAction
|
||||
, MaybeX
|
||||
, FeatureX
|
||||
, FeatureIO
|
||||
, Feature(..)
|
||||
, Warning(..)
|
||||
, Dependency(..)
|
||||
, UnitType(..)
|
||||
, Bus(..)
|
||||
, Endpoint(..)
|
||||
, DBusMember(..)
|
||||
, ioFeature
|
||||
, evalFeature
|
||||
, systemUnit
|
||||
|
|
@ -20,14 +20,12 @@ module XMonad.Internal.Dependency
|
|||
, pathR
|
||||
, pathW
|
||||
, pathRW
|
||||
, featureRun
|
||||
, featureSpawnCmd
|
||||
, featureSpawn
|
||||
, featureDefault
|
||||
, featureExeArgs
|
||||
, featureExe
|
||||
, warnMissing
|
||||
, whenInstalled
|
||||
, ifInstalled
|
||||
, fmtCmd
|
||||
, spawnCmd
|
||||
, whenSatisfied
|
||||
, ifSatisfied
|
||||
, executeFeature
|
||||
, executeFeature_
|
||||
, applyFeature
|
||||
|
|
@ -54,51 +52,71 @@ import XMonad.Internal.Process
|
|||
import XMonad.Internal.Shell
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Gracefully handling missing binaries
|
||||
|
||||
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)
|
||||
|
||||
data Dependency = Executable String
|
||||
| AccessiblePath FilePath Bool Bool
|
||||
| IOTest (IO (Maybe String))
|
||||
| DBusEndpoint Bus Endpoint
|
||||
| DBusBus Bus
|
||||
| Systemd UnitType String
|
||||
|
||||
data Warning = Silent | Default
|
||||
-- | Features
|
||||
--
|
||||
-- A 'feature' is an 'action' (usually an IO ()) that requires one or more
|
||||
-- 'dependencies'. Features also have a useful name and an error logging
|
||||
-- protocol.
|
||||
--
|
||||
-- NOTE: there is no way to make a feature depend on another feature. This is
|
||||
-- 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
|
||||
-- dependencies that target the output/state of another feature; this is more
|
||||
-- robust anyways, at the cost of being a bit slower.
|
||||
|
||||
data Feature a = Feature
|
||||
{ ftrAction :: a
|
||||
, ftrName :: String
|
||||
, ftrWarning :: Warning
|
||||
, ftrChildren :: [Dependency]
|
||||
{ ftrMaybeAction :: a
|
||||
, ftrName :: String
|
||||
, ftrWarning :: Warning
|
||||
, ftrChildren :: [Dependency]
|
||||
}
|
||||
| ConstFeature a
|
||||
| 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 FeatureIO = Feature (IO ())
|
||||
|
||||
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
|
||||
ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a }
|
||||
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
|
||||
ioFeature BlankFeature = BlankFeature
|
||||
ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
|
||||
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
|
||||
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 BlankFeature = return $ Left []
|
||||
evalFeature Feature
|
||||
{ ftrAction = a
|
||||
{ ftrMaybeAction = a
|
||||
, ftrName = n
|
||||
, ftrWarning = w
|
||||
, ftrChildren = c
|
||||
|
|
@ -113,6 +131,48 @@ evalFeature Feature
|
|||
Silent -> []
|
||||
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 n = AccessiblePath n True False
|
||||
|
||||
|
|
@ -128,35 +188,29 @@ systemUnit = Systemd SystemUnit
|
|||
userUnit :: String -> Dependency
|
||||
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)
|
||||
type MaybeExe a = Either [String] a
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Dependency evaluation
|
||||
--
|
||||
-- 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
|
||||
featureRun n ds x = Feature
|
||||
{ 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
|
||||
exeSatisfied :: String -> IO (Maybe String)
|
||||
exeSatisfied x = do
|
||||
r <- findExecutable x
|
||||
return $ case r of
|
||||
(Just _) -> Nothing
|
||||
_ -> Just $ "executable '" ++ x ++ "' not found"
|
||||
|
||||
unitInstalled :: UnitType -> String -> IO (Maybe String)
|
||||
unitInstalled u x = do
|
||||
unitSatisfied :: UnitType -> String -> IO (Maybe String)
|
||||
unitSatisfied u x = do
|
||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||
return $ case rc of
|
||||
ExitSuccess -> Nothing
|
||||
|
|
@ -166,8 +220,8 @@ unitInstalled u x = do
|
|||
unitType SystemUnit = "system"
|
||||
unitType UserUnit = "user"
|
||||
|
||||
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
||||
pathAccessible p testread testwrite = do
|
||||
pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
||||
pathSatisfied p testread testwrite = do
|
||||
res <- getPermissionsSafe p
|
||||
let msg = permMsg res
|
||||
return msg
|
||||
|
|
@ -197,8 +251,8 @@ callMethod (Bus usesys bus) path iface mem = do
|
|||
disconnect client
|
||||
return $ bimap methodErrorMessage methodReturnBody reply
|
||||
|
||||
dbusBusExists :: Bus -> IO (Maybe String)
|
||||
dbusBusExists (Bus usesystem bus) = do
|
||||
busSatisfied :: Bus -> IO (Maybe String)
|
||||
busSatisfied (Bus usesystem bus) = do
|
||||
ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
|
||||
return $ case ret of
|
||||
Left e -> Just e
|
||||
|
|
@ -214,8 +268,8 @@ dbusBusExists (Bus usesystem bus) = do
|
|||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
||||
bodyGetNames _ = []
|
||||
|
||||
dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String)
|
||||
dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
|
||||
endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
|
||||
endpointSatisfied b@(Bus _ bus) (Endpoint objpath iface mem) = do
|
||||
ret <- callMethod b objpath introspectInterface introspectMethod
|
||||
return $ case ret of
|
||||
Left e -> Just e
|
||||
|
|
@ -245,43 +299,16 @@ dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
|
|||
, formatBusName bus
|
||||
]
|
||||
|
||||
evalDependency :: Dependency -> IO (Maybe String)
|
||||
evalDependency (Executable n) = exeInstalled n
|
||||
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
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Logging functions
|
||||
|
||||
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
|
||||
whenInstalled = flip ifInstalled skip
|
||||
|
||||
ifInstalled :: MaybeExe a -> a -> a
|
||||
ifInstalled (Right x) _ = x
|
||||
ifInstalled _ alt = alt
|
||||
|
||||
warnMissing :: [MaybeExe a] -> IO ()
|
||||
warnMissing :: [MaybeAction a] -> IO ()
|
||||
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
|
||||
|
||||
warnMissing' :: [String] -> IO ()
|
||||
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 procName level msg = unwords [bracket procName, bracket level, msg]
|
||||
where
|
||||
bracket s = "[" ++ s ++ "]"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue