ENH use features in external keymap

This commit is contained in:
Nathan Dwarshuis 2021-11-20 01:15:04 -05:00
parent 5c30d513eb
commit 7ec86d04c4
13 changed files with 175 additions and 365 deletions

View File

@ -306,7 +306,7 @@ getWireless = do
getEthernet :: IO (MaybeExe CmdSpec)
getEthernet = do
i <- readInterface isEthernet
maybe (return $ Left []) (runIfInstalled [dep] . ethernetCmd) i
evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i
where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP

View File

@ -9,7 +9,6 @@ module Main (main) where
import Control.Concurrent
import Control.Monad (unless)
import Data.Either (fromRight)
import Data.List
( isPrefixOf
, sortBy
@ -74,7 +73,7 @@ main = do
, dxScreensaverCtrl = sc
} <- startXMonadService
(h, p) <- spawnPipe "xmobar"
depActions <- sequence [runPowermon, runRemovableMon]
depActions <- mapM evalFeature [runPowermon, runRemovableMon]
mapM_ (mapM_ forkIO) depActions
_ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState
@ -82,7 +81,7 @@ main = do
, childPIDs = [p]
, childHandles = [h]
}
lock <- fromRight skip <$> evalFeature runScreenLock
lock <- whenInstalled <$> evalFeature runScreenLock
ext <- evalExternal $ externalBindings bc sc ts lock
warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions
-- IDK why this is necessary; nothing prior to this line will print if missing
@ -472,28 +471,20 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup (IO MaybeX)] -> IO [KeyGroup MaybeX]
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup { kgBindings = bs } =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbAction = a } =
(\f -> k { kbAction = f }) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
-- go k@KeyGroup { kgBindings = bs } =
-- ( k { kgBindings = mapMaybe flagKeyBinding bs }
-- , concatMap go' bs
-- )
-- go' KeyBinding{ kbAction = a } = case a of
-- Installed _ opt -> opt
-- -- TODO this will mash together the optional and required deps
-- Missing req opt -> req ++ opt
-- Ignore -> []
externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
externalToMissing = concatMap go
@ -504,10 +495,9 @@ 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 }
-- _ -> Nothing
externalBindings :: BrightnessControls -> SSControls -> ThreadState -> X ()
-> [KeyGroup (IO MaybeX)]
-> [KeyGroup FeatureX]
externalBindings bc sc ts lock =
[ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" runAppMenu
@ -525,9 +515,9 @@ externalBindings bc sc ts lock =
]
, KeyGroup "Actions"
[ KeyBinding "M-q" "close window" $ noCheck kill1
[ KeyBinding "M-q" "close window" $ ConstFeature kill1
, KeyBinding "M-r" "run program" runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ noCheck $ warpToWindow 0.5 0.5
, KeyBinding "M-<Space>" "warp pointer" $ ConstFeature $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" runAreaCapture
, KeyBinding "M-C-S-s" "capture screen" runScreenCapture
, KeyBinding "M-C-d" "capture desktop" runDesktopCapture
@ -553,28 +543,22 @@ externalBindings bc sc ts lock =
]
, KeyGroup "System"
[ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc
, KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc
, KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc
, KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc
, KeyBinding "M-<End>" "power menu" $ noCheck $ runPowerPrompt lock
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
-- TODO this won't be aware of when the lock doesn't exist
, KeyBinding "M-<Delete>" "lock screen" $ noCheck lock
[ KeyBinding "M-." "backlight up" $ ioFeature $ bctlInc bc
, KeyBinding "M-," "backlight down" $ ioFeature $ bctlDec bc
, KeyBinding "M-M1-," "backlight min" $ ioFeature $ bctlMin bc
, KeyBinding "M-M1-." "backlight max" $ ioFeature $ bctlMax bc
, KeyBinding "M-<End>" "power menu" $ ConstFeature $ runPowerPrompt lock
, KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
-- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" $ noCheck (runCleanup ts >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ noCheck runRecompile
, KeyBinding "M-<F2>" "restart xmonad" $ ConstFeature (runCleanup ts >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile
, KeyBinding "M-<F7>" "start Isync Service" runStartISyncService
, KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
, KeyBinding "M-<F11>" "toggle screensaver" $ return $ io <$> ssToggle sc
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ ssToggle sc
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
]
]
-- where
-- TODO this is hacky, I shouldn't really need this data structure for
-- something that doesn't depend on executables
-- runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c

View File

@ -47,8 +47,8 @@ myDmenuNetworks = "networkmanager_dmenu"
--------------------------------------------------------------------------------
-- | Other internal functions
spawnDmenuCmd :: [String] -> IO MaybeX
spawnDmenuCmd = spawnCmdIfInstalled myDmenuCmd
spawnDmenuCmd :: [String] -> FeatureX
spawnDmenuCmd = featureSpawnCmd myDmenuCmd
themeArgs :: String -> [String]
themeArgs hexColor =
@ -62,41 +62,42 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
--------------------------------------------------------------------------------
-- | Exported Commands
runDevMenu :: IO MaybeX
runDevMenu = runIfInstalled [exe myDmenuDevices] $ do
runDevMenu :: FeatureX
runDevMenu = featureRun [exe myDmenuDevices] $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices
$ ["-c", c]
++ "--" : themeArgs "#999933"
++ myDmenuMatchingArgs
runBwMenu :: IO MaybeX
runBwMenu = runIfInstalled [exe myDmenuPasswords] $
runBwMenu :: FeatureX
runBwMenu = featureRun [exe 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 $ runDMenuShowKeys x
s <- io $ evalFeature $ runDMenuShowKeys x
ifInstalled s
$ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> IO MaybeX
runDMenuShowKeys kbs = runIfInstalled [exe myDmenuCmd] $ io $ do
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: IO MaybeX
runCmdMenu :: FeatureX
runCmdMenu = spawnDmenuCmd ["-show", "run"]
runAppMenu :: IO MaybeX
runAppMenu :: FeatureX
runAppMenu = spawnDmenuCmd ["-show", "drun"]
runClipMenu :: IO MaybeX
runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"]
runClipMenu :: FeatureX
runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
$ spawnCmd myDmenuCmd args
where
args = [ "-modi", "\"clipboard:greenclip print\""
@ -104,11 +105,11 @@ runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"]
, "-run-command", "'{cmd}'"
] ++ themeArgs "#00c44e"
runWinMenu :: IO MaybeX
runWinMenu :: FeatureX
runWinMenu = spawnDmenuCmd ["-show", "window"]
runNetMenu :: IO MaybeX
runNetMenu = spawnCmdIfInstalled myDmenuNetworks $ themeArgs "#ff3333"
runNetMenu :: FeatureX
runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: IO MaybeX
runAutorandrMenu = spawnCmdIfInstalled myDmenuMonitors $ themeArgs "#ff0066"
runAutorandrMenu :: FeatureX
runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066"

View File

@ -17,7 +17,6 @@ module XMonad.Internal.Command.Desktop
, runVolumeUp
, runVolumeMute
, runToggleBluetooth
-- , runToggleDPMS
, runToggleEthernet
, runRestart
, runRecompile
@ -31,9 +30,11 @@ module XMonad.Internal.Command.Desktop
, runNotificationCloseAll
, runNotificationHistory
, runNotificationContext
, playSound
) where
import Control.Monad (void)
import Control.Monad.IO.Class
import System.Directory
( createDirectoryIfMissing
@ -44,10 +45,10 @@ import System.FilePath
import XMonad.Actions.Volume
import XMonad.Core hiding (spawn)
-- import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Operations
--------------------------------------------------------------------------------
@ -89,15 +90,11 @@ ethernetIface = "enp7s0f1"
--------------------------------------------------------------------------------
-- | Some nice apps
runTerm :: IO MaybeX
runTerm = spawnIfInstalled myTerm
runTerm :: FeatureX
runTerm = featureSpawn myTerm
runTMux :: IO MaybeX
runTMux = evalFeature $ Feature
{ ftrAction = cmd
, ftrSilent = False
, ftrChildren = [exe myTerm, exe "tmux", exe "bash"]
}
runTMux :: FeatureX
runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
where
cmd = spawn
$ "tmux has-session"
@ -106,95 +103,108 @@ runTMux = evalFeature $ Feature
c = "exec tmux attach-session -d"
msg = "could not connect to tmux session"
runCalc :: IO MaybeX
runCalc = runIfInstalled [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
runCalc :: FeatureX
runCalc = featureRun [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
runBrowser :: IO MaybeX
runBrowser = spawnIfInstalled myBrowser
runBrowser :: FeatureX
runBrowser = featureSpawn myBrowser
runEditor :: IO MaybeX
runEditor = spawnCmdIfInstalled myEditor
runEditor :: FeatureX
runEditor = featureSpawnCmd myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: IO MaybeX
runFileManager = spawnIfInstalled "pcmanfm"
runFileManager :: FeatureX
runFileManager = featureSpawn "pcmanfm"
--------------------------------------------------------------------------------
-- | Multimedia Commands
runMultimediaIfInstalled :: String -> IO MaybeX
runMultimediaIfInstalled cmd = spawnCmdIfInstalled myMultimediaCtl [cmd]
runMultimediaIfInstalled :: String -> FeatureX
runMultimediaIfInstalled cmd = featureSpawnCmd myMultimediaCtl [cmd]
runTogglePlay :: IO MaybeX
runTogglePlay :: FeatureX
runTogglePlay = runMultimediaIfInstalled "play-pause"
runPrevTrack :: IO MaybeX
runPrevTrack :: FeatureX
runPrevTrack = runMultimediaIfInstalled "previous"
runNextTrack :: IO MaybeX
runNextTrack :: FeatureX
runNextTrack = runMultimediaIfInstalled "next"
runStopPlay :: IO MaybeX
runStopPlay :: FeatureX
runStopPlay = runMultimediaIfInstalled "stop"
runVolumeDown :: IO MaybeX
runVolumeDown = spawnSound volumeChangeSound (return ()) $ void (lowerVolume 2)
--------------------------------------------------------------------------------
-- | Volume Commands
runVolumeUp :: IO MaybeX
runVolumeUp = spawnSound volumeChangeSound (return ()) $ void (raiseVolume 2)
soundDir :: FilePath
soundDir = "sound"
runVolumeMute :: IO MaybeX
runVolumeMute = spawnSound volumeChangeSound (void toggleMute) $ return ()
playSound :: MonadIO m => FilePath -> m ()
playSound file = do
p <- (</> soundDir </> file) <$> getXMonadDir
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [p]
featureSound :: FilePath -> X () -> X () -> FeatureX
featureSound file pre post = featureRun [exe "paplay"]
$ pre >> playSound file >> post
runVolumeDown :: FeatureX
runVolumeDown = featureSound volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeUp :: FeatureX
runVolumeUp = featureSound volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeMute :: FeatureX
runVolumeMute = featureSound volumeChangeSound (void toggleMute) $ return ()
--------------------------------------------------------------------------------
-- | Notification control
runNotificationCmd :: String -> IO MaybeX
runNotificationCmd cmd = spawnCmdIfInstalled myNotificationCtrl [cmd]
runNotificationCmd :: String -> FeatureX
runNotificationCmd cmd = featureSpawnCmd myNotificationCtrl [cmd]
runNotificationClose :: IO MaybeX
runNotificationClose :: FeatureX
runNotificationClose = runNotificationCmd "close"
runNotificationCloseAll :: IO MaybeX
runNotificationCloseAll :: FeatureX
runNotificationCloseAll = runNotificationCmd "close-all"
runNotificationHistory :: IO MaybeX
runNotificationHistory :: FeatureX
runNotificationHistory = runNotificationCmd "history-pop"
runNotificationContext :: IO MaybeX
runNotificationContext :: FeatureX
runNotificationContext = runNotificationCmd "context"
--------------------------------------------------------------------------------
-- | System commands
runToggleBluetooth :: IO MaybeX
runToggleBluetooth = runIfInstalled [exe myBluetooth] $ spawn
runToggleBluetooth :: FeatureX
runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on"
#!|| "a=off"
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
-- runToggleDPMS :: IO MaybeX
-- runToggleDPMS = io <$> evalFeature callToggle
runToggleEthernet :: IO MaybeX
runToggleEthernet = runIfInstalled [exe "nmcli"] $ spawn
runToggleEthernet :: FeatureX
runToggleEthernet = featureRun [exe "nmcli"] $ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect"
#!|| "a=disconnect"
#!>> fmtCmd "nmcli" ["device", "$a", ethernetIface]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: IO MaybeX
runStartISyncTimer = runIfInstalled [userUnit "mbsync.timer"]
runStartISyncTimer :: FeatureX
runStartISyncTimer = featureRun [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 :: IO MaybeX
runStartISyncService = runIfInstalled [userUnit "mbsync.service"]
runStartISyncService :: FeatureX
runStartISyncService = featureRun [userUnit "mbsync.service"]
$ spawn
$ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -238,25 +248,25 @@ getCaptureDir = do
where
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> IO MaybeX
runFlameshot mode = runIfInstalled [exe myCapture] $ do
runFlameshot :: String -> FeatureX
runFlameshot mode = featureRun [exe myCapture] $ do
ssDir <- io getCaptureDir
spawnCmd myCapture $ mode : ["-p", ssDir]
-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: IO MaybeX
runAreaCapture :: FeatureX
runAreaCapture = runFlameshot "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: IO MaybeX
runDesktopCapture :: FeatureX
runDesktopCapture = runFlameshot "full"
runScreenCapture :: IO MaybeX
runScreenCapture :: FeatureX
runScreenCapture = runFlameshot "screen"
runCaptureBrowser :: IO MaybeX
runCaptureBrowser = runIfInstalled [exe myImageBrowser] $ do
runCaptureBrowser :: FeatureX
runCaptureBrowser = featureRun [exe myImageBrowser] $ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [dir]

View File

@ -28,6 +28,7 @@ import System.IO.Error
import XMonad.Core
import XMonad.Internal.Dependency
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
@ -44,9 +45,6 @@ myOptimusManager = "optimus-manager"
--------------------------------------------------------------------------------
-- | Core commands
-- runScreenLock :: IO MaybeX
-- runScreenLock = spawnIfInstalled myScreenlock
runScreenLock :: Feature (X ()) (X ())
runScreenLock = Feature
{ ftrAction = spawn myScreenlock
@ -69,6 +67,7 @@ runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- | Confirm prompt wrappers
-- TODO doesn't this need to also lock the screen?
runSuspendPrompt :: X ()
runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend
@ -88,7 +87,6 @@ hasBattery :: IO (Maybe String)
hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps
-- TODO this is obviously stupid
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
@ -106,14 +104,8 @@ runOptimusPrompt' = do
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
runOptimusPrompt :: IO MaybeX
runOptimusPrompt = runIfInstalled [exe myOptimusManager] runOptimusPrompt'
-- runOptimusPrompt :: Feature (X ()) (X ())
-- runOptimusPrompt = Feature
-- { ftrAction = runOptimusPrompt'
-- , ftrSilent = False
-- , ftrChildren = [exe myOptimusManager]
-- }
runOptimusPrompt :: FeatureX
runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt'
--------------------------------------------------------------------------------
-- | Universal power prompt
@ -159,36 +151,6 @@ runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction
sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeAction a = case toEnum $ read a of
Poweroff -> runPowerOff
-- TODO these dependency functions need to be assembled elsewhere and fed
-- to this function
-- Shutdown -> (io runScreenLock >>= whenInstalled) >> runSuspend
-- Hibernate -> (io runScreenLock >>= whenInstalled) >> runHibernate
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate
Reboot -> runReboot
-- runPowerPrompt :: Feature (X ()) (X ()) -> IO (X ())
-- runPowerPrompt lock = do
-- lock' <- evalFeature lock
-- return $ mkXPrompt PowerPrompt theme comp $ executeAction $ fromRight (return ()) lock'
-- 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_Return, quit)
-- , (xK_Escape, quit)
-- ]
-- sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
-- executeAction l a = case toEnum $ read a of
-- Poweroff -> runPowerOff
-- -- TODO these dependency functions need to be assembled elsewhere and fed
-- -- to this function
-- Shutdown -> l >> runSuspend
-- Hibernate -> l >> runHibernate
-- Reboot -> runReboot

View File

@ -94,8 +94,8 @@ 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 :: IO (MaybeExe (IO ()))
runPowermon = runIfInstalled [pathR acpiPath] listenACPI
runPowermon :: FeatureIO
runPowermon = featureRun [pathR acpiPath] listenACPI
-- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook)
@ -109,6 +109,5 @@ handleACPI lock tag = do
status <- io isDischarging
-- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend
-- io runScreenLock >>= whenInstalled
lock

View File

@ -15,6 +15,7 @@ import DBus
import DBus.Client
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Dependency
bus :: BusName
@ -91,5 +92,5 @@ listenDevices = do
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
$ playSoundMaybe p . f . signalBody
runRemovableMon :: IO (MaybeExe (IO ()))
runRemovableMon = runIfInstalled [addedDep, removedDep] listenDevices
runRemovableMon :: FeatureIO
runRemovableMon = featureRun [addedDep, removedDep] listenDevices

View File

@ -39,10 +39,10 @@ data BrightnessConfig a b = BrightnessConfig
}
data BrightnessControls = BrightnessControls
{ bctlMax :: MaybeExe (IO ())
, bctlMin :: MaybeExe (IO ())
, bctlInc :: MaybeExe (IO ())
, bctlDec :: MaybeExe (IO ())
{ bctlMax :: FeatureIO
, bctlMin :: FeatureIO
, bctlInc :: FeatureIO
, bctlDec :: FeatureIO
}
exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b
@ -50,17 +50,12 @@ exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConf
exportBrightnessControls deps bc client =
initControls client (brightnessExporter deps bc) controls
where
controls exporter = do
let callBacklight' = evalFeature . callBacklight bc exporter
mx <- callBacklight' memMax
mn <- callBacklight' memMin
ic <- callBacklight' memInc
dc <- callBacklight' memDec
return $ BrightnessControls
{ bctlMax = mx
, bctlMin = mn
, bctlInc = ic
, bctlDec = dc
controls exporter = let callBacklight' = callBacklight bc exporter in
BrightnessControls
{ bctlMax = callBacklight' memMax
, bctlMin = callBacklight' memMin
, bctlInc = callBacklight' memInc
, bctlDec = callBacklight' memDec
}
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
@ -99,7 +94,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
-- }
brightnessExporter :: RealFrac b => [Dependency (IO ())]
-> BrightnessConfig a b -> Client -> Feature (IO ()) (IO ())
-> BrightnessConfig a b -> Client -> FeatureIO
brightnessExporter deps bc client = Feature
{ ftrAction = exportBrightnessControls' bc client
, ftrSilent = False
@ -132,8 +127,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
-- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
-- void $ callMethod $ methodCall p i mem
callBacklight :: BrightnessConfig a b -> Feature (IO ()) (IO ()) -> MemberName
-> Feature (IO ()) (IO ())
callBacklight :: BrightnessConfig a b -> FeatureIO -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem =
Feature
{ ftrAction = void $ callMethod $ methodCall p i mem

View File

@ -58,37 +58,6 @@ incBrightness = incPercent steps curFile
decBrightness :: RawBrightness -> IO Brightness
decBrightness = decPercent steps curFile
--------------------------------------------------------------------------------
-- | Access checks
-- | determine if backlight is accessible/present
-- Right True -> backlight accessible and present
-- Right False -> backlight not present
-- Left x -> backlight present but could not access (x explaining why)
-- hasBacklight' :: IO (Either String Bool)
-- hasBacklight' = do
-- mx <- isReadable maxFile
-- cx <- isWritable curFile
-- return $ case (mx, cx) of
-- (NotFoundError, NotFoundError) -> Right False
-- (PermResult True, PermResult True) -> Right True
-- (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
-- _ -> Left "Could not determine permissions for backlight files"
-- msg :: Either String Bool -> IO ()
-- msg (Right True) = return ()
-- msg (Right False) = putStrLn "No backlight detected. Controls disabled"
-- msg (Left m) = putStrLn $ "WARNING: " ++ m
-- hasBacklightMsg :: IO Bool
-- hasBacklightMsg = do
-- b <- hasBacklight'
-- msg b
-- return $ fromRight False b
-- hasBacklight :: IO Bool
-- hasBacklight = fromRight False <$> hasBacklight'
--------------------------------------------------------------------------------
-- | DBus interface
@ -122,10 +91,6 @@ maxFileDep = pathR maxFile
exportIntelBacklight :: Client -> IO BrightnessControls
exportIntelBacklight =
exportBrightnessControls [curFileDep, maxFileDep] intelBacklightConfig
-- b <- hasBacklightMsg
-- if b
-- then Just <$> exportBrightnessControls intelBacklightConfig client
-- else return Nothing
callGetBrightnessIB :: IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig

View File

@ -40,12 +40,11 @@ addMatchCallback rule cb = do
client <- connectSession
addMatch client rule $ cb . signalBody
initControls :: Client -> (Client -> Feature (IO ()) (IO ()))
-> (Feature (IO ()) (IO ()) -> IO a) -> IO a
initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
initControls client exporter controls = do
let x = exporter client
e <- evalFeature x
case e of
(Right c) -> c
_ -> return ()
controls x
return $ controls x

View File

@ -21,7 +21,7 @@ import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver
-- import XMonad.Internal.Dependency
import XMonad.Internal.Dependency
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -38,14 +38,14 @@ data DBusXMonad = DBusXMonad
blankControls :: BrightnessControls
blankControls = BrightnessControls
{ bctlMax = Left []
, bctlMin = Left []
, bctlInc = Left []
, bctlDec = Left []
{ bctlMax = BlankFeature
, bctlMin = BlankFeature
, bctlInc = BlankFeature
, bctlDec = BlankFeature
}
blankSSToggle :: SSControls
blankSSToggle = SSControls { ssToggle = Left [] }
blankSSToggle = SSControls { ssToggle = BlankFeature }
startXMonadService :: IO DBusXMonad
startXMonadService = do

View File

@ -97,16 +97,14 @@ bodyGetCurrentState _ = Nothing
--------------------------------------------------------------------------------
-- | Exported haskell API
newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) }
newtype SSControls = SSControls { ssToggle :: FeatureIO }
exportScreensaver :: Client -> IO SSControls
exportScreensaver client = initControls client exportScreensaver' controls
where
controls exporter = do
t <- evalFeature $ callToggle exporter
return $ SSControls { ssToggle = t }
controls exporter = SSControls { ssToggle = callToggle exporter }
exportScreensaver' :: Client -> Feature (IO ()) (IO ())
exportScreensaver' :: Client -> FeatureIO
exportScreensaver' client = Feature
{ ftrAction = cmd
, ftrSilent = False
@ -121,7 +119,7 @@ exportScreensaver' client = Feature
]
}
callToggle :: Feature (IO ()) (IO ()) -> Feature (IO ()) (IO ())
callToggle :: FeatureIO -> FeatureIO
callToggle exporter = Feature
{ ftrAction = cmd
, ftrSilent = False

View File

@ -8,7 +8,10 @@ module XMonad.Internal.Dependency
, DependencyData(..)
, DBusMember(..)
, MaybeX
, FeatureX
, FeatureIO
, Feature(..)
, ioFeature
, evalFeature
, exe
, systemUnit
@ -16,25 +19,14 @@ module XMonad.Internal.Dependency
, pathR
, pathW
, pathRW
-- , checkInstalled
, runIfInstalled
, depInstalled
, featureRun
, featureSpawnCmd
, featureSpawn
, warnMissing
, whenInstalled
, ifInstalled
, spawnIfInstalled
, spawnCmdIfInstalled
, noCheck
, fmtCmd
, spawnCmd
, doubleQuote
, singleQuote
, (#!&&)
, (#!||)
, (#!|)
, (#!>>)
, playSound
, spawnSound
) where
import Control.Monad.IO.Class
@ -48,9 +40,8 @@ import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Exit
import System.FilePath
import XMonad.Core (X, getXMonadDir)
import XMonad.Core (X)
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
@ -84,44 +75,38 @@ data Feature a b = Feature
{ ftrAction :: a
, ftrSilent :: Bool
, ftrChildren :: [Dependency b]
} | ConstFeature a
}
| ConstFeature a
| BlankFeature
-- data Chain a = Chain
-- { chainAction :: a
-- , chainChildren :: [Feature a a]
-- , chainCompose :: a -> a -> a
-- }
type FeatureX = Feature (X ()) (X ())
type FeatureIO = Feature (IO ()) (IO ())
ioFeature :: (MonadIO m, MonadIO n) => Feature (IO a) (IO b) -> Feature (m a) (n b)
ioFeature f@Feature { ftrAction = a, ftrChildren = ds } =
f { ftrAction = liftIO a, ftrChildren = fmap go ds }
where
go :: MonadIO o => Dependency (IO b) -> Dependency (o b)
go (SubFeature s) = SubFeature $ ioFeature s
go (Dependency d) = Dependency d
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature
evalFeature :: Feature a b -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left []
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
es <- mapM go c
return $ case concat es of
[] -> Right a
es' -> Left (if s then [] else es')
-- return $ case foldl groupResult ([], []) c' of
-- ([], opt) -> Installed a opt
-- (req, opt) -> if s then Ignore else Missing req opt
where
go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs
go (SubFeature (ConstFeature _)) = return []
go (Dependency d) = do
e <- depInstalled d
return $ maybeToList e
-- groupResult (x, y) (True, z) = (z:x, y)
-- groupResult (x, y) (False, z) = (x, z:y)
-- evalChain :: Chain a -> IO (MaybeExe a)
-- evalChain Chain { chainAction = a, chainChildren = cs , chainCompose = f } =
-- flip Installed [] <$> foldM go a cs
-- where
-- go acc child = do
-- c <- evalFeature child
-- -- TODO need a way to get error messages out of this for anything
-- -- that's missing
-- return $ case c of
-- (Installed x _) -> f x acc
-- _ -> acc
go (SubFeature _) = return []
exe :: String -> Dependency a
exe = Dependency . Executable
@ -149,19 +134,23 @@ userUnit = unit 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)
-- data MaybeExe a = Installed a [DependencyData]
-- | Missing [DependencyData] [DependencyData]
-- | Ignore
-- deriving (Foldable, Traversable)
-- data MaybeExe a = MaybeExe (Maybe a) [String]
type MaybeExe a = Either [String] a
-- deriving (Foldable, Traversable)
-- instance Functor MaybeExe where
-- fmap f (MaybeExe x m) = MaybeExe (f <$> x) m
type MaybeX = MaybeExe (X ())
featureRun :: [Dependency a] -> b -> Feature b a
featureRun ds x = Feature
{ ftrAction = x
, ftrSilent = False
, ftrChildren = ds
}
featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ()) (m ())
featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args
featureSpawn :: MonadIO m => String -> Feature (m ()) (m ())
featureSpawn cmd = featureSpawnCmd cmd []
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
r <- findExecutable x
@ -180,34 +169,22 @@ unitInstalled u x = do
unitType SystemUnit = "system"
unitType UserUnit = "user"
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
-- return $ fmap (\m -> m ++ ": " ++ p) msg
where
testPerm False _ _ = Nothing
testPerm True f r = Just $ f r
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
-- permMsg NotFoundError = False
-- permMsg PermError = False
permMsg (PermResult r) =
case (testPerm testread readable r, testPerm testwrite writable r) of
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
-- (Just True, Just True) -> True
-- (Just True, Nothing) -> True
-- (Nothing, Just True) -> True
-- _ -> False
-- (Just False, Just False) -> Just "file not readable or writable"
-- (Just False, _) -> Just "file not readable"
-- (_, Just False) -> Just "file not writable"
-- _ -> Nothing
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -227,7 +204,6 @@ dbusInstalled bus usesystem objpath iface mem = do
return $ case res of
Just _ -> Nothing
_ -> Just "some random dbus interface not found"
-- return $ fromMaybe False res
where
findMem obj = fmap (matchMem mem)
$ find (\i -> I.interfaceName i == iface)
@ -248,28 +224,6 @@ depInstalled DBusEndpoint { ddDbusBus = b
, ddDbusMember = m
} = dbusInstalled b s o i m
-- checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData])
-- checkInstalled = fmap go . filterMissing
-- where
-- go = join (***) (fmap depData) . partition depRequired
-- filterMissing :: [Dependency a] -> IO [Dependency a]
-- filterMissing = filterM (fmap not . depInstalled . depData)
runIfInstalled :: [Dependency a] -> b -> IO (MaybeExe b)
runIfInstalled ds x = evalFeature $
Feature
{ ftrAction = x
, ftrSilent = False
, ftrChildren = ds
}
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
spawnCmdIfInstalled :: MonadIO m => String -> [String] -> IO (MaybeExe (m ()))
spawnCmdIfInstalled n args = runIfInstalled [exe n] $ spawnCmd n args
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip
@ -277,62 +231,5 @@ ifInstalled :: MaybeExe a -> a -> a
ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
noCheck :: Monad m => a () -> m (MaybeExe (a ()))
noCheck = return . Right
-- not sure what to do with these
soundDir :: FilePath
soundDir = "sound"
spawnSound :: MonadIO m => FilePath -> m () -> m () -> IO (MaybeExe (m ()))
spawnSound file pre post = runIfInstalled [exe "paplay"]
$ pre >> playSound file >> post
playSound :: MonadIO m => FilePath -> m ()
playSound file = do
p <- (</> soundDir </> file) <$> getXMonadDir
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [p]
-- partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
-- partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
-- where
-- go (Installed _ opt) = ([], opt)
-- go (Missing req opt) = (req, opt)
-- go Ignore = ([], [])
-- fmtMissing :: DependencyData -> String
-- -- TODO this error message is lame
-- fmtMissing (IOTest _) = "some random test failed"
-- fmtMissing DBusEndpoint {} = "some random dbus path is missing"
-- fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
-- fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
-- fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
-- fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
-- fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
-- fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
-- ++ n ++ "' not found"
-- where
-- unitType SystemUnit = "system"
-- unitType UserUnit = "user"
-- fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
-- fmtMsgs req opt = ("[WARNING] "++)
-- <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
-- ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
-- warnMsg ::
-- warnMsg xs = mapM_ putStrLn
-- $ [ "[WARNING] " ++ m | (MaybeExe _ (Just m)) <- xs ]
warnMissing :: [MaybeExe a] -> IO ()
warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
-- fmtType (AccessiblePath _ _ _) = undefined
-- splitDeps :: [MaybeExe a] -> ([a], [String])
-- splitDeps xs = undefined
-- splitDeps' :: [m (MaybeExe a)] -> ([m a], [String])
-- splitDeps' xs = undefined