diff --git a/bin/xmonad.hs b/bin/xmonad.hs index d7e3bd2..c4c2198 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -92,10 +92,9 @@ run = do { tsChildPIDs = [p] , tsChildHandles = [h] } - lockRes <- evalSometimes runScreenLock - let lock = fromMaybe skip lockRes - ext <- evalExternal $ externalBindings ts db lock + ext <- evalExternal $ externalBindings ts db sk <- evalAlways runShowKeys + ha <- evalAlways runHandleACPI -- IDK why this is necessary; nothing prior to this line will print if missing hFlush stdout ds <- getDirectories @@ -106,7 +105,7 @@ run = do , modMask = myModMask , layoutHook = myLayouts , manageHook = myManageHook - , handleEventHook = myEventHook lock + , handleEventHook = myEventHook ha , startupHook = myStartupHook , workspaces = myWorkspaces , logHook = myLoghook h @@ -442,17 +441,17 @@ manageApps = composeOne $ concatMap dwHook allDWs ++ -------------------------------------------------------------------------------- -- | Eventhook configuration -myEventHook :: X () -> Event -> X All -myEventHook lock = xMsgEventHook lock <+> handleEventHook def +myEventHook :: (String -> X ()) -> Event -> X All +myEventHook handler = xMsgEventHook handler <+> handleEventHook def -- | React to ClientMessage events from concurrent threads -xMsgEventHook :: X () -> Event -> X All -xMsgEventHook lock ClientMessageEvent { ev_message_type = t, ev_data = d } +xMsgEventHook :: (String -> X ()) -> Event -> X All +xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d } | t == bITMAP = do let (xtype, tag) = splitXMsg d case xtype of Workspace -> removeDynamicWorkspace tag - ACPI -> handleACPI lock tag + ACPI -> handler tag Unknown -> io $ print "WARNING: unknown concurrent message" return (All True) xMsgEventHook _ _ = return (All True) @@ -559,8 +558,8 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of (Just x) -> Just $ k{ kbMaybeAction = x } Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip } -externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup (FeatureX)] -externalBindings ts db lock = +externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] +externalBindings ts db = [ KeyGroup "Launchers" [ KeyBinding "" "select/launch app" $ Left runAppMenu , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu @@ -615,7 +614,7 @@ externalBindings ts db lock = , KeyBinding "M-S-," "keyboard down" $ ck bctlDec , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax - , KeyBinding "M-" "power menu" $ ftrAlways $ runPowerPrompt lock + , KeyBinding "M-" "power menu" $ Right runPowerPrompt , KeyBinding "M-" "quit xmonad" $ ftrAlways runQuitPrompt , KeyBinding "M-" "lock screen" $ Left runScreenLock -- M- reserved for showing the keymap diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index e884cf7..8428b5c 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -91,28 +91,6 @@ runVPNMenu :: SometimesX runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs -runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) -runShowKeys = Option showKeysDMenu (Always fallback) - where - -- TODO this should technically depend on dunst - fallback = const $ spawnNotify - $ defNoteError { body = Just $ Text "could not display keymap" } - -showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) -showKeysDMenu = Subfeature - { sfName = "keyboard shortcut menu" - , sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd - , sfLevel = Warn - } - -showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () -showKeys kbs = 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 :: SometimesX runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] @@ -139,3 +117,28 @@ runNetMenu = runAutorandrMenu :: SometimesX runAutorandrMenu = sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066" + +-------------------------------------------------------------------------------- +-- | Shortcut menu + +runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) +runShowKeys = Option showKeysDMenu (Always fallback) + where + -- TODO this should technically depend on dunst + fallback = const $ spawnNotify + $ defNoteError { body = Just $ Text "could not display keymap" } + +showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) +showKeysDMenu = Subfeature + { sfName = "keyboard shortcut menu" + , sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd + , sfLevel = Warn + } + +showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () +showKeys kbs = 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 diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 5e93ab6..366f1f5 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -12,6 +12,9 @@ module XMonad.Internal.Command.Power , runSuspendPrompt , runQuitPrompt , hasBattery + + + , powerPrompt ) where import Control.Arrow (first) @@ -130,8 +133,16 @@ data PowerPrompt = PowerPrompt instance XPrompt PowerPrompt where showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" -runPowerPrompt :: X () -> X () -runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction +runPowerPrompt :: AlwaysX +runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock + where + withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id) + +powerPromptNoLock :: X () +powerPromptNoLock = powerPrompt skip + +powerPrompt :: X () -> X () +powerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction where comp = mkComplFunFromList theme [] theme = T.promptTheme { promptKeymap = keymap } diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index c8f4d7f..51d0a9b 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -6,7 +6,7 @@ module XMonad.Internal.Concurrent.ACPIEvent ( runPowermon - , handleACPI + , runHandleACPI ) where import Control.Exception @@ -26,6 +26,7 @@ import XMonad.Core import XMonad.Internal.Command.Power import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Dependency +import XMonad.Internal.Shell -------------------------------------------------------------------------------- -- | Data structure to hold the ACPI events I care about @@ -97,13 +98,18 @@ acpiPath = "/var/run/acpid.socket" runPowermon :: SometimesIO runPowermon = sometimesIO "ACPI event monitor" (Only_ $ pathR acpiPath) listenACPI +runHandleACPI :: Always (String -> X ()) +runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip + where + withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id) + -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) handleACPI :: X () -> String -> X () handleACPI lock tag = do let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent forM_ acpiTag $ \case - Power -> runPowerPrompt lock + Power -> powerPrompt lock Sleep -> runSuspendPrompt LidClose -> do status <- io isDischarging diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index a753475..75c7f9f 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -42,6 +42,7 @@ module XMonad.Internal.Dependency , ioAlways -- feature construction + , always1 , sometimes1 , sometimesIO , sometimesDBus @@ -460,13 +461,16 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }] --- always1_ :: LogLevel -> String -> Root a Tree -> a -> Always a --- always1_ l n t x = --- Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x) +always1_ :: LogLevel -> String -> Root a -> a -> Always a +always1_ l n t x = + Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x) sometimes1 :: String -> Root a -> Sometimes a sometimes1 = sometimes1_ Error +always1 :: String -> Root a -> a -> Always a +always1 = always1_ Error + sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a sometimesIO n t x = sometimes1 n $ IORoot_ x t