ENH use features in external keymap
This commit is contained in:
parent
5c30d513eb
commit
7ec86d04c4
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -9,12 +9,13 @@ module XMonad.Internal.Concurrent.Removable (runRemovableMon) where
|
|||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
|
||||
import Data.Map.Lazy (Map, member)
|
||||
import Data.Map.Lazy (Map, member)
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue