diff --git a/bin/xmobar.hs b/bin/xmobar.hs index a202e97..3b27b20 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 8872f2d..ab7c10b 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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 "" "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-" "warp pointer" $ noCheck $ warpToWindow 0.5 0.5 + , KeyBinding "M-" "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-" "power menu" $ noCheck $ runPowerPrompt lock - , KeyBinding "M-" "quit xmonad" $ noCheck runQuitPrompt - -- TODO this won't be aware of when the lock doesn't exist - , KeyBinding "M-" "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-" "power menu" $ ConstFeature $ runPowerPrompt lock + , KeyBinding "M-" "quit xmonad" $ ConstFeature runQuitPrompt + , KeyBinding "M-" "lock screen" runScreenLock -- M- reserved for showing the keymap - , KeyBinding "M-" "restart xmonad" $ noCheck (runCleanup ts >> runRestart) - , KeyBinding "M-" "recompile xmonad" $ noCheck runRecompile + , KeyBinding "M-" "restart xmonad" $ ConstFeature (runCleanup ts >> runRestart) + , KeyBinding "M-" "recompile xmonad" $ ConstFeature runRecompile , KeyBinding "M-" "start Isync Service" runStartISyncService , KeyBinding "M-C-" "start Isync Timer" runStartISyncTimer , KeyBinding "M-" "select autorandr profile" runAutorandrMenu , KeyBinding "M-" "toggle ethernet" runToggleEthernet , KeyBinding "M-" "toggle bluetooth" runToggleBluetooth - , KeyBinding "M-" "toggle screensaver" $ return $ io <$> ssToggle sc + , KeyBinding "M-" "toggle screensaver" $ ioFeature $ ssToggle sc , KeyBinding "M-" "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 - diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 7d352eb..2ad8dc3 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 6ff52f5..e2877f3 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 3410676..7d35465 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 1a5cc71..f8b050c 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 7e61c95..30375fb 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 769f78d..ec92230 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index a509ef0..a84eab1 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 7441e2a..b5c30e4 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 42103ef..2d607ad 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 431c589..06ef903 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 8585ecb..2984ba2 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -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