ENH use dependency framework for power prompt

bin/xmonad.hs

@@ -92,10 +92,9 @@ run = do
            { tsChildPIDs = [p]
            , tsChildHandles = [h]
            }
-  lockRes <- evalSometimes runScreenLock
+  ext <- evalExternal $ externalBindings ts db
-  let lock = fromMaybe skip lockRes
-  ext <- evalExternal $ externalBindings ts db lock
   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 :: (String -> X ()) -> Event -> X All
-myEventHook lock = xMsgEventHook lock <+> handleEventHook def
+myEventHook handler = xMsgEventHook handler <+> handleEventHook def
 
 -- | React to ClientMessage events from concurrent threads
-xMsgEventHook :: X () -> Event -> X All
+xMsgEventHook :: (String -> X ()) -> Event -> X All
-xMsgEventHook lock ClientMessageEvent { ev_message_type = t, ev_data = d }
+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 :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-externalBindings ts db lock =
+externalBindings ts db =
   [ KeyGroup "Launchers"
     [ KeyBinding "<XF86Search>" "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-<End>" "power menu" $ ftrAlways $ runPowerPrompt lock
+    , KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
     , KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt
     , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
     -- M-<F1> reserved for showing the keymap

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

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 :: AlwaysX
-runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
+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 }

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

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_ :: LogLevel -> String -> Root a -> a -> Always a
--- always1_ l n t x =
+always1_ l n t x =
---   Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always 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