From 53a537960e91fdcc98d9162e1a19ca8701b4a231 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 26 Jun 2022 19:27:04 -0400 Subject: [PATCH] ENH make showkeys use dep framework --- bin/xmonad.hs | 8 ++-- lib/XMonad/Internal/Command/DMenu.hs | 58 +++++++++++----------------- lib/XMonad/Internal/Dependency.hs | 7 +++- 3 files changed, 33 insertions(+), 40 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index cf16fbf..d7e3bd2 100644 --- a/bin/xmonad.hs +++ b/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 ())] diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 22ec784..e884cf7 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/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"] diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 0ba7a91..a753475 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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