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 :: IO (MaybeExe CmdSpec)
getEthernet = do getEthernet = do
i <- readInterface isEthernet i <- readInterface isEthernet
maybe (return $ Left []) (runIfInstalled [dep] . ethernetCmd) i evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i
where where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP

View File

@ -9,7 +9,6 @@ module Main (main) where
import Control.Concurrent import Control.Concurrent
import Control.Monad (unless) import Control.Monad (unless)
import Data.Either (fromRight)
import Data.List import Data.List
( isPrefixOf ( isPrefixOf
, sortBy , sortBy
@ -74,7 +73,7 @@ main = do
, dxScreensaverCtrl = sc , dxScreensaverCtrl = sc
} <- startXMonadService } <- startXMonadService
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
depActions <- sequence [runPowermon, runRemovableMon] depActions <- mapM evalFeature [runPowermon, runRemovableMon]
mapM_ (mapM_ forkIO) depActions mapM_ (mapM_ forkIO) depActions
_ <- forkIO $ runWorkspaceMon allDWs _ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
@ -82,7 +81,7 @@ main = do
, childPIDs = [p] , childPIDs = [p]
, childHandles = [h] , childHandles = [h]
} }
lock <- fromRight skip <$> evalFeature runScreenLock lock <- whenInstalled <$> evalFeature runScreenLock
ext <- evalExternal $ externalBindings bc sc ts lock ext <- evalExternal $ externalBindings bc sc ts lock
warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions
-- IDK why this is necessary; nothing prior to this line will print if missing -- IDK why this is necessary; nothing prior to this line will print if missing
@ -472,28 +471,20 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a] , kgBindings :: [KeyBinding a]
} }
evalExternal :: [KeyGroup (IO MaybeX)] -> IO [KeyGroup MaybeX] evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX]
evalExternal = mapM go evalExternal = mapM go
where where
go k@KeyGroup { kgBindings = bs } = go k@KeyGroup { kgBindings = bs } =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a) evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a evalKeyBinding k@KeyBinding { kbAction = a } =
(\f -> k { kbAction = f }) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go filterExternal = fmap go
where where
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs } go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
-- 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 :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
externalToMissing = concatMap go externalToMissing = concatMap go
@ -504,10 +495,9 @@ flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
(Right x) -> Just $ k{ kbAction = x } (Right x) -> Just $ k{ kbAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } (Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
-- _ -> Nothing
externalBindings :: BrightnessControls -> SSControls -> ThreadState -> X () externalBindings :: BrightnessControls -> SSControls -> ThreadState -> X ()
-> [KeyGroup (IO MaybeX)] -> [KeyGroup FeatureX]
externalBindings bc sc ts lock = externalBindings bc sc ts lock =
[ KeyGroup "Launchers" [ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" runAppMenu [ KeyBinding "<XF86Search>" "select/launch app" runAppMenu
@ -525,9 +515,9 @@ externalBindings bc sc ts lock =
] ]
, KeyGroup "Actions" , KeyGroup "Actions"
[ KeyBinding "M-q" "close window" $ noCheck kill1 [ KeyBinding "M-q" "close window" $ ConstFeature kill1
, KeyBinding "M-r" "run program" runCmdMenu , 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" "capture area" runAreaCapture
, KeyBinding "M-C-S-s" "capture screen" runScreenCapture , KeyBinding "M-C-S-s" "capture screen" runScreenCapture
, KeyBinding "M-C-d" "capture desktop" runDesktopCapture , KeyBinding "M-C-d" "capture desktop" runDesktopCapture
@ -553,28 +543,22 @@ externalBindings bc sc ts lock =
] ]
, KeyGroup "System" , KeyGroup "System"
[ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc [ KeyBinding "M-." "backlight up" $ ioFeature $ bctlInc bc
, KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc , KeyBinding "M-," "backlight down" $ ioFeature $ bctlDec bc
, KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc , KeyBinding "M-M1-," "backlight min" $ ioFeature $ bctlMin bc
, KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc , KeyBinding "M-M1-." "backlight max" $ ioFeature $ bctlMax bc
, KeyBinding "M-<End>" "power menu" $ noCheck $ runPowerPrompt lock , KeyBinding "M-<End>" "power menu" $ ConstFeature $ runPowerPrompt lock
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt , KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt
-- TODO this won't be aware of when the lock doesn't exist , KeyBinding "M-<Delete>" "lock screen" runScreenLock
, KeyBinding "M-<Delete>" "lock screen" $ noCheck lock
-- M-<F1> reserved for showing the keymap -- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" $ noCheck (runCleanup ts >> runRestart) , KeyBinding "M-<F2>" "restart xmonad" $ ConstFeature (runCleanup ts >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ noCheck runRecompile , KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile
, KeyBinding "M-<F7>" "start Isync Service" runStartISyncService , KeyBinding "M-<F7>" "start Isync Service" runStartISyncService
, KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer , KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu , KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet , KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth , 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 , 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 -- | Other internal functions
spawnDmenuCmd :: [String] -> IO MaybeX spawnDmenuCmd :: [String] -> FeatureX
spawnDmenuCmd = spawnCmdIfInstalled myDmenuCmd spawnDmenuCmd = featureSpawnCmd myDmenuCmd
themeArgs :: String -> [String] themeArgs :: String -> [String]
themeArgs hexColor = themeArgs hexColor =
@ -62,41 +62,42 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported Commands -- | Exported Commands
runDevMenu :: IO MaybeX runDevMenu :: FeatureX
runDevMenu = runIfInstalled [exe myDmenuDevices] $ do runDevMenu = featureRun [exe myDmenuDevices] $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices
$ ["-c", c] $ ["-c", c]
++ "--" : themeArgs "#999933" ++ "--" : themeArgs "#999933"
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
runBwMenu :: IO MaybeX runBwMenu :: FeatureX
runBwMenu = runIfInstalled [exe myDmenuPasswords] $ runBwMenu = featureRun [exe myDmenuPasswords] $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys x = addName "Show Keybindings" $ do runShowKeys x = addName "Show Keybindings" $ do
s <- io $ runDMenuShowKeys x s <- io $ evalFeature $ runDMenuShowKeys x
ifInstalled s ifInstalled s
$ spawnNotify $ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" } $ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> IO MaybeX runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs = runIfInstalled [exe myDmenuCmd] $ io $ do runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: IO MaybeX runCmdMenu :: FeatureX
runCmdMenu = spawnDmenuCmd ["-show", "run"] runCmdMenu = spawnDmenuCmd ["-show", "run"]
runAppMenu :: IO MaybeX runAppMenu :: FeatureX
runAppMenu = spawnDmenuCmd ["-show", "drun"] runAppMenu = spawnDmenuCmd ["-show", "drun"]
runClipMenu :: IO MaybeX runClipMenu :: FeatureX
runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"] runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
$ spawnCmd myDmenuCmd args $ spawnCmd myDmenuCmd args
where where
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""
@ -104,11 +105,11 @@ runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"]
, "-run-command", "'{cmd}'" , "-run-command", "'{cmd}'"
] ++ themeArgs "#00c44e" ] ++ themeArgs "#00c44e"
runWinMenu :: IO MaybeX runWinMenu :: FeatureX
runWinMenu = spawnDmenuCmd ["-show", "window"] runWinMenu = spawnDmenuCmd ["-show", "window"]
runNetMenu :: IO MaybeX runNetMenu :: FeatureX
runNetMenu = spawnCmdIfInstalled myDmenuNetworks $ themeArgs "#ff3333" runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: IO MaybeX runAutorandrMenu :: FeatureX
runAutorandrMenu = spawnCmdIfInstalled myDmenuMonitors $ themeArgs "#ff0066" runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066"

View File

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

View File

@ -28,6 +28,7 @@ import System.IO.Error
import XMonad.Core import XMonad.Core
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import XMonad.Prompt import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt import XMonad.Prompt.ConfirmPrompt
@ -44,9 +45,6 @@ myOptimusManager = "optimus-manager"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- | Core commands
-- runScreenLock :: IO MaybeX
-- runScreenLock = spawnIfInstalled myScreenlock
runScreenLock :: Feature (X ()) (X ()) runScreenLock :: Feature (X ()) (X ())
runScreenLock = Feature runScreenLock = Feature
{ ftrAction = spawn myScreenlock { ftrAction = spawn myScreenlock
@ -69,6 +67,7 @@ runReboot = spawn "systemctl reboot"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Confirm prompt wrappers -- | Confirm prompt wrappers
-- TODO doesn't this need to also lock the screen?
runSuspendPrompt :: X () runSuspendPrompt :: X ()
runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend
@ -88,7 +87,6 @@ hasBattery :: IO (Maybe String)
hasBattery = do hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath) ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps ts <- mapM readType ps
-- TODO this is obviously stupid
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found" return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
where where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type") readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
@ -106,14 +104,8 @@ runOptimusPrompt' = do
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: IO MaybeX runOptimusPrompt :: FeatureX
runOptimusPrompt = runIfInstalled [exe myOptimusManager] runOptimusPrompt' runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt'
-- runOptimusPrompt :: Feature (X ()) (X ())
-- runOptimusPrompt = Feature
-- { ftrAction = runOptimusPrompt'
-- , ftrSilent = False
-- , ftrChildren = [exe myOptimusManager]
-- }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Universal power prompt -- | Universal power prompt
@ -159,36 +151,6 @@ runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction
sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeAction a = case toEnum $ read a of executeAction a = case toEnum $ read a of
Poweroff -> runPowerOff 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 Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate Hibernate -> lock >> runHibernate
Reboot -> runReboot 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 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them -- and send ClientMessage events when it receives them
runPowermon :: IO (MaybeExe (IO ())) runPowermon :: FeatureIO
runPowermon = runIfInstalled [pathR acpiPath] listenACPI runPowermon = featureRun [pathR acpiPath] listenACPI
-- | Handle ClientMessage event containing and ACPI event (to be used in -- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook) -- Xmonad's event hook)
@ -109,6 +109,5 @@ handleACPI lock tag = do
status <- io isDischarging status <- io isDischarging
-- only run suspend if battery exists and is discharging -- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend forM_ status $ flip when runSuspend
-- io runScreenLock >>= whenInstalled
lock lock

View File

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

View File

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

View File

@ -58,37 +58,6 @@ incBrightness = incPercent steps curFile
decBrightness :: RawBrightness -> IO Brightness decBrightness :: RawBrightness -> IO Brightness
decBrightness = decPercent steps curFile 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 -- | DBus interface
@ -122,10 +91,6 @@ maxFileDep = pathR maxFile
exportIntelBacklight :: Client -> IO BrightnessControls exportIntelBacklight :: Client -> IO BrightnessControls
exportIntelBacklight = exportIntelBacklight =
exportBrightnessControls [curFileDep, maxFileDep] intelBacklightConfig exportBrightnessControls [curFileDep, maxFileDep] intelBacklightConfig
-- b <- hasBacklightMsg
-- if b
-- then Just <$> exportBrightnessControls intelBacklightConfig client
-- else return Nothing
callGetBrightnessIB :: IO (Maybe Brightness) callGetBrightnessIB :: IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig callGetBrightnessIB = callGetBrightness intelBacklightConfig

View File

@ -40,12 +40,11 @@ addMatchCallback rule cb = do
client <- connectSession client <- connectSession
addMatch client rule $ cb . signalBody addMatch client rule $ cb . signalBody
initControls :: Client -> (Client -> Feature (IO ()) (IO ())) initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
-> (Feature (IO ()) (IO ()) -> IO a) -> IO a
initControls client exporter controls = do initControls client exporter controls = do
let x = exporter client let x = exporter client
e <- evalFeature x e <- evalFeature x
case e of case e of
(Right c) -> c (Right c) -> c
_ -> return () _ -> 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.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
-- import XMonad.Internal.Dependency import XMonad.Internal.Dependency
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -38,14 +38,14 @@ data DBusXMonad = DBusXMonad
blankControls :: BrightnessControls blankControls :: BrightnessControls
blankControls = BrightnessControls blankControls = BrightnessControls
{ bctlMax = Left [] { bctlMax = BlankFeature
, bctlMin = Left [] , bctlMin = BlankFeature
, bctlInc = Left [] , bctlInc = BlankFeature
, bctlDec = Left [] , bctlDec = BlankFeature
} }
blankSSToggle :: SSControls blankSSToggle :: SSControls
blankSSToggle = SSControls { ssToggle = Left [] } blankSSToggle = SSControls { ssToggle = BlankFeature }
startXMonadService :: IO DBusXMonad startXMonadService :: IO DBusXMonad
startXMonadService = do startXMonadService = do

View File

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

View File

@ -8,7 +8,10 @@ module XMonad.Internal.Dependency
, DependencyData(..) , DependencyData(..)
, DBusMember(..) , DBusMember(..)
, MaybeX , MaybeX
, FeatureX
, FeatureIO
, Feature(..) , Feature(..)
, ioFeature
, evalFeature , evalFeature
, exe , exe
, systemUnit , systemUnit
@ -16,25 +19,14 @@ module XMonad.Internal.Dependency
, pathR , pathR
, pathW , pathW
, pathRW , pathRW
-- , checkInstalled , featureRun
, runIfInstalled , featureSpawnCmd
, depInstalled , featureSpawn
, warnMissing , warnMissing
, whenInstalled , whenInstalled
, ifInstalled , ifInstalled
, spawnIfInstalled
, spawnCmdIfInstalled
, noCheck
, fmtCmd , fmtCmd
, spawnCmd , spawnCmd
, doubleQuote
, singleQuote
, (#!&&)
, (#!||)
, (#!|)
, (#!>>)
, playSound
, spawnSound
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -48,9 +40,8 @@ import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable) import System.Directory (findExecutable, readable, writable)
import System.Exit import System.Exit
import System.FilePath
import XMonad.Core (X, getXMonadDir) import XMonad.Core (X)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Process import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
@ -84,44 +75,38 @@ data Feature a b = Feature
{ ftrAction :: a { ftrAction :: a
, ftrSilent :: Bool , ftrSilent :: Bool
, ftrChildren :: [Dependency b] , ftrChildren :: [Dependency b]
} | ConstFeature a }
| ConstFeature a
| BlankFeature
-- data Chain a = Chain type FeatureX = Feature (X ()) (X ())
-- { chainAction :: a
-- , chainChildren :: [Feature a a] type FeatureIO = Feature (IO ()) (IO ())
-- , chainCompose :: a -> a -> a
-- } 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 :: Feature a b -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Right x evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left []
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
es <- mapM go c es <- mapM go c
return $ case concat es of return $ case concat es of
[] -> Right a [] -> Right a
es' -> Left (if s then [] else es') 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 where
go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs
go (SubFeature (ConstFeature _)) = return []
go (Dependency d) = do go (Dependency d) = do
e <- depInstalled d e <- depInstalled d
return $ maybeToList e return $ maybeToList e
-- groupResult (x, y) (True, z) = (z:x, y) go (SubFeature _) = return []
-- 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
exe :: String -> Dependency a exe :: String -> Dependency a
exe = Dependency . Executable exe = Dependency . Executable
@ -149,19 +134,23 @@ userUnit = unit UserUnit
-- TODO this is poorly named. This actually represents an action that has -- TODO this is poorly named. This actually represents an action that has
-- one or more dependencies (where "action" is not necessarily executing an exe) -- 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 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 ()) 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 :: String -> IO (Maybe String)
exeInstalled x = do exeInstalled x = do
r <- findExecutable x r <- findExecutable x
@ -180,34 +169,22 @@ unitInstalled u x = do
unitType SystemUnit = "system" unitType SystemUnit = "system"
unitType UserUnit = "user" unitType UserUnit = "user"
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String) pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do pathAccessible p testread testwrite = do
res <- getPermissionsSafe p res <- getPermissionsSafe p
let msg = permMsg res let msg = permMsg res
return msg return msg
-- return $ fmap (\m -> m ++ ": " ++ p) msg
where where
testPerm False _ _ = Nothing testPerm False _ _ = Nothing
testPerm True f r = Just $ f r testPerm True f r = Just $ f r
permMsg NotFoundError = Just "file not found" permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions" permMsg PermError = Just "could not get permissions"
-- permMsg NotFoundError = False
-- permMsg PermError = False
permMsg (PermResult r) = permMsg (PermResult r) =
case (testPerm testread readable r, testPerm testwrite writable r) of case (testPerm testread readable r, testPerm testwrite writable r) of
(Just False, Just False) -> Just "file not readable or writable" (Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable" (Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable" (_, Just False) -> Just "file not writable"
_ -> Nothing _ -> 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
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -227,7 +204,6 @@ dbusInstalled bus usesystem objpath iface mem = do
return $ case res of return $ case res of
Just _ -> Nothing Just _ -> Nothing
_ -> Just "some random dbus interface not found" _ -> Just "some random dbus interface not found"
-- return $ fromMaybe False res
where where
findMem obj = fmap (matchMem mem) findMem obj = fmap (matchMem mem)
$ find (\i -> I.interfaceName i == iface) $ find (\i -> I.interfaceName i == iface)
@ -248,28 +224,6 @@ depInstalled DBusEndpoint { ddDbusBus = b
, ddDbusMember = m , ddDbusMember = m
} = dbusInstalled b s o i 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 :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip whenInstalled = flip ifInstalled skip
@ -277,62 +231,5 @@ ifInstalled :: MaybeExe a -> a -> a
ifInstalled (Right x) _ = x ifInstalled (Right x) _ = x
ifInstalled _ alt = alt 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 :: [MaybeExe a] -> IO ()
warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ] 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