ENH make showkeys use dep framework

bin/xmonad.hs

@@ -95,11 +95,12 @@ run = do
   lockRes <- evalSometimes runScreenLock
   let lock = fromMaybe skip lockRes
   ext <- evalExternal $ externalBindings ts db lock
+  sk <- evalAlways runShowKeys
   -- IDK why this is necessary; nothing prior to this line will print if missing
   hFlush stdout
   ds <- getDirectories
   let conf = ewmh
-             $ addKeymap (filterExternal ext)
+             $ addKeymap sk (filterExternal ext)
              $ docks
              $ def { terminal = myTerm
                    , modMask = myModMask
@@ -462,8 +463,9 @@ xMsgEventHook _ _ = return (All True)
 myModMask :: KeyMask
 myModMask = mod4Mask
 
-addKeymap :: [KeyGroup (X ())] -> XConfig l -> XConfig l
-addKeymap external = addDescrKeys' ((myModMask, xK_F1), runShowKeys)
+addKeymap :: ([((KeyMask, KeySym), NamedAction)] -> X ())
+  -> [KeyGroup (X ())] -> XConfig l -> XConfig l
+addKeymap showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
   (\c -> concatMap (mkNamedSubmap c) $ internalBindings c ++ external)
 
 internalBindings :: XConfig Layout -> [KeyGroup (X ())]

lib/XMonad/Internal/Command/DMenu.hs

@@ -15,17 +15,17 @@ module XMonad.Internal.Command.DMenu
   , runAutorandrMenu
   ) where
 
--- import           Control.Monad.Reader
+import           Control.Monad.Reader
 
 import           Graphics.X11.Types
 
 import           System.Directory           (XdgDirectory (..), getXdgDirectory)
--- import           System.IO
+import           System.IO
 
 import           XMonad.Core                hiding (spawn)
 import           XMonad.Internal.Dependency
--- import           XMonad.Internal.Notify
--- import           XMonad.Internal.Process
+import           XMonad.Internal.Notify
+import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
 import           XMonad.Util.NamedActions
 
@@ -91,39 +91,27 @@ runVPNMenu :: SometimesX
 runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
   spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
 
--- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
--- runShowKeys x = addName "Show Keybindings" $ do
---   s <- io $ evalFeature $ runDMenuShowKeys x
---   ifSatisfied s
---     $ spawnNotify
---     $ defNoteError { body = Just $ Text "could not display keymap" }
+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" }
 
--- TODO not sure what to do with this yet
-runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
-runShowKeys _ = NamedAction (skip :: (X ()))
-  -- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
+showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
+showKeysDMenu = Subfeature
+  { sfName = "keyboard shortcut menu"
+  , sfData = IORoot_ showKeys $ Only_ $ sysExe myDmenuCmd
+  , sfLevel = Warn
+  }
 
--- runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
--- runDMenuShowKeys kbs =
---   Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
-
--- runNotifyShowKeys :: X ()
--- runNotifyShowKeys = spawnNotify
---   $ defNoteError { body = Just $ Text "could not display keymap" }
-
--- runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
--- runDMenuShowKeys' kbs = Subfeature
---   { sfName = "keyboard shortcut menu"
---   , sfTree = IOTree (Standalone act) deps
---   , sfLevel = Warn
---   }
---   where
---     deps = Only $ Executable True myDmenuCmd
---     act = io $ do
---       (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
---       forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
---     cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
---       ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
+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"]

lib/XMonad/Internal/Dependency.hs

@@ -15,6 +15,7 @@ module XMonad.Internal.Dependency
   , SometimesIO
   , PostPass(..)
   , Subfeature(..)
+  , SubfeatureRoot
   , LogLevel(..)
 
   -- dependency tree types
@@ -176,7 +177,8 @@ data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
 -- needed
 data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
   | IORoot_ a (Tree_ IODependency_)
-  | forall p. DBusRoot (p -> Client -> a) (Tree IODependency DBusDependency_ p) (Maybe Client)
+  | forall p. DBusRoot (p -> Client -> a)
+    (Tree IODependency DBusDependency_ p) (Maybe Client)
   | DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
 
 -- | The dependency tree with rules to merge results
@@ -210,7 +212,8 @@ data DBusDependency_ = Bus BusName
   | DBusIO IODependency_
 
 -- | A dependency that only requires IO to evaluate (no payload)
-data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a)
+data IODependency_ = IOSystem_ SystemDependency
+  | forall a. IOSometimes_ (Sometimes a)
 
 data SystemDependency = Executable Bool FilePath
   | AccessiblePath FilePath Bool Bool