From 505577b7551957750987526e67aaa8e26b6aceca Mon Sep 17 00:00:00 2001
From: slotThe <soliditsallgood@mailbox.org>
Date: Fri, 14 Jan 2022 11:53:58 +0100
Subject: [PATCH 1/3] X.Prelude: Add keymaskToString, keyToString
This technically introduces a regression with regards to the way that
modifier masks are printed in X.U.NamedActions and X.H.DebugEvents.
However, since this way of printing masks is move in line with
X.U.EZConfig, I personally don't think that this is noteworthy.
---
CHANGES.md | 5 +++++
XMonad/Hooks/DebugEvents.hs | 24 +----------------------
XMonad/Prelude.hs | 38 ++++++++++++++++++++++++++++++++++++-
XMonad/Util/NamedActions.hs | 21 ++------------------
4 files changed, 45 insertions(+), 43 deletions(-)
diff --git a/CHANGES.md b/CHANGES.md
index 88a27404..3b08d1e5 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -116,6 +116,11 @@
resetting borders back in layouts where you want borders after calling
`voidBorders`.
+ * `XMonad.Prelude`
+
+ - Added `keymaskToString` and `keyToString` to show a key mask and a
+ key in the style of `XMonad.Util.EZConfig`.
+
## 0.17.0 (October 27, 2021)
### Breaking Changes
diff --git a/XMonad/Hooks/DebugEvents.hs b/XMonad/Hooks/DebugEvents.hs
index cef8fb71..2873082f 100644
--- a/XMonad/Hooks/DebugEvents.hs
+++ b/XMonad/Hooks/DebugEvents.hs
@@ -111,7 +111,7 @@ debugEventsHook' ButtonEvent {ev_window = w
windowEvent "Button" w
nl <- gets numberlockMask
let msk | s == 0 = ""
- | otherwise = "modifiers " ++ vmask nl s
+ | otherwise = "modifiers " ++ keymaskToString nl s
say " button" $ show b ++ msk
debugEventsHook' DestroyWindowEvent {ev_window = w
@@ -218,28 +218,6 @@ clientMessages = [("_NET_ACTIVE_WINDOW",("_NET_ACTIVE_WINDOW",32,1))
,("WM_SAVE_YOURSELF" ,("STRING" , 8,0))
]
--- | Convert a modifier mask into a useful string
-vmask :: KeyMask -> KeyMask -> String
-vmask numLockMask msk = unwords $
- reverse $
- fst $
- foldr vmask' ([],msk) masks
- where
- masks = map (\m -> (m,show m)) [0..toEnum (finiteBitSize msk - 1)] ++
- [(numLockMask,"num" )
- ,( lockMask,"lock" )
- ,(controlMask,"ctrl" )
- ,( shiftMask,"shift")
- ,( mod5Mask,"mod5" )
- ,( mod4Mask,"mod4" )
- ,( mod3Mask,"mod3" )
- ,( mod2Mask,"mod2" )
- ,( mod1Mask,"mod1" )
- ]
- vmask' _ a@( _,0) = a
- vmask' (m,s) (ss,v) | v .&. m == m = (s : ss,v .&. complement m)
- vmask' _ r = r
-
-- formatting properties. ick. --
-- @@@ Document the parser. Someday.
diff --git a/XMonad/Prelude.hs b/XMonad/Prelude.hs
index b04d6460..de2a83cf 100644
--- a/XMonad/Prelude.hs
+++ b/XMonad/Prelude.hs
@@ -22,6 +22,8 @@ module XMonad.Prelude (
NonEmpty((:|)),
notEmpty,
safeGetWindowAttributes,
+ keyToString,
+ keymaskToString,
) where
import Foreign (alloca, peek)
@@ -39,7 +41,9 @@ import Data.Maybe as Exports
import Data.Monoid as Exports
import Data.Traversable as Exports
-import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Bifunctor (bimap)
+import Data.Bits
+import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Stack
-- | Short for 'fromIntegral'.
@@ -80,3 +84,35 @@ safeGetWindowAttributes w = withDisplay $ \dpy -> io . alloca $ \p ->
xGetWindowAttributes dpy w p >>= \case
0 -> pure Nothing
_ -> Just <$> peek p
+
+-- | Convert a modifier mask into a useful string.
+keymaskToString :: KeyMask -- ^ Num lock mask
+ -> KeyMask -- ^ Modifier mask
+ -> String
+keymaskToString numLockMask msk =
+ unwords . reverse . fst . foldr go ([], msk) $ masks
+ where
+ masks :: [(KeyMask, String)]
+ masks = map (\m -> (m, show m))
+ [0 .. toEnum (finiteBitSize msk - 1)]
+ ++ [ (numLockMask, "num-" )
+ , (lockMask, "lock-")
+ , (controlMask, "C-" )
+ , (shiftMask, "S-" )
+ , (mod5Mask, "M5-" )
+ , (mod4Mask, "M4-" )
+ , (mod3Mask, "M3-" )
+ , (mod2Mask, "M2-" )
+ , (mod1Mask, "M1-" )
+ ]
+
+ go :: (KeyMask, String) -> ([String], KeyMask) -> ([String], KeyMask)
+ go (m, s) a@(ss, v)
+ | v == 0 = a
+ | v .&. m == m = (s : ss, v .&. complement m)
+ | otherwise = a
+
+-- | Convert a full key combination; i.e., a 'KeyMask' and 'KeySym'
+-- pair, into a string.
+keyToString :: (KeyMask, KeySym) -> [Char]
+keyToString = uncurry (++) . bimap (keymaskToString 0) keysymToString
diff --git a/XMonad/Util/NamedActions.hs b/XMonad/Util/NamedActions.hs
index 5b815c4a..d12aabe0 100644
--- a/XMonad/Util/NamedActions.hs
+++ b/XMonad/Util/NamedActions.hs
@@ -47,10 +47,9 @@ module XMonad.Util.NamedActions (
import XMonad.Actions.Submap(submap)
-import XMonad.Prelude (groupBy)
+import XMonad.Prelude (groupBy, keyToString)
import XMonad
-import Control.Arrow(Arrow((&&&), second, (***)))
-import Data.Bits(Bits((.&.), complement))
+import Control.Arrow(Arrow((&&&), second))
import System.Exit(exitSuccess)
import qualified Data.Map as M
@@ -166,22 +165,6 @@ submapName = NamedAction . (submap . M.map getAction . M.fromList &&& showKm)
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
a ^++^ b = map (second NamedAction) a ++ map (second NamedAction) b
--- | Or allow another lookup table?
-modToString :: KeyMask -> String
-modToString mask = concatMap (++"-") $ filter (not . null)
- $ map (uncurry pick)
- [(mod1Mask, "M1")
- ,(mod2Mask, "M2")
- ,(mod3Mask, "M3")
- ,(mod4Mask, "M4")
- ,(mod5Mask, "M5")
- ,(controlMask, "C")
- ,(shiftMask,"Shift")]
- where pick m str = if m .&. complement mask == 0 then str else ""
-
-keyToString :: (KeyMask, KeySym) -> [Char]
-keyToString = uncurry (++) . (modToString *** keysymToString)
-
showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]]
showKmSimple = concatMap (\(k,e) -> if snd k == 0 then "":showName e else map ((keyToString k ++) . smartSpace) $ showName e)
From 86b816ec5046ec09b911d48df282b7039a201dfc Mon Sep 17 00:00:00 2001
From: slotThe <soliditsallgood@mailbox.org>
Date: Fri, 14 Jan 2022 11:54:28 +0100
Subject: [PATCH 2/3] X.U.XUtils: Add framework for manipulating simple windows
Adds several new functions and type for manipulating "simple windows".
There are several ways to draw windows in X.U.XUtils and other places
already, but they are all quite manual. Most of the time one does not
want to think about dimensions much and assumes that the code is smart
enough to "figure it out"; this is an attempt to do exactly that.
There is a less-managed version `showSimpleWindow`, which just creates
and shows the windows, as well as a wrapper-like `withSimpleWindow` that
also destroys the window once some action finishes executing.
With these functions it should be possible to refactor some contrib
modules that currently draw windows manually, like X.U.EasyMotion.
---
CHANGES.md | 6 +++
XMonad/Util/XUtils.hs | 91 ++++++++++++++++++++++++++++++++++++++++++-
2 files changed, 96 insertions(+), 1 deletion(-)
diff --git a/CHANGES.md b/CHANGES.md
index 3b08d1e5..3d8664fd 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -121,6 +121,12 @@
- Added `keymaskToString` and `keyToString` to show a key mask and a
key in the style of `XMonad.Util.EZConfig`.
+ * `XMonad.Util.XUtils`
+
+ - Added `withSimpleWindow`, `showSimpleWindow`, `WindowConfig`, and
+ `WindowRect` in order to simplify the handling of simply popup
+ windows.
+
## 0.17.0 (October 27, 2021)
### Breaking Changes
diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs
index 3e9fbe1e..bf012665 100644
--- a/XMonad/Util/XUtils.hs
+++ b/XMonad/Util/XUtils.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Util.XUtils
@@ -17,7 +21,11 @@
module XMonad.Util.XUtils
( -- * Usage:
-- $usage
- averagePixels
+ withSimpleWindow
+ , showSimpleWindow
+ , WindowConfig(..)
+ , WindowRect(..)
+ , averagePixels
, createNewWindow
, showWindow
, showWindows
@@ -37,6 +45,7 @@ import XMonad.Prelude
import XMonad
import XMonad.Util.Font
import XMonad.Util.Image
+import qualified XMonad.StackSet as W
-- $usage
-- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or
@@ -157,6 +166,86 @@ paintTextAndIcons w fs wh ht bw bc borc ffc fbc als strs i_als icons = do
is = Just (ffc, fbc, zip iconPositions icons)
paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is
+-- | The config for a window, as interpreted by 'showSimpleWindow'.
+--
+-- The font @winFont@ can either be specified in the TODO format or as an
+-- xft font. For example:
+--
+-- > winFont = "xft:monospace-20"
+--
+-- or
+--
+-- > winFont = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
+data WindowConfig = WindowConfig
+ { winFont :: !String -- ^ Font to use.
+ , winBg :: !String -- ^ Background color.
+ , winFg :: !String -- ^ Foreground color.
+ , winRect :: !WindowRect -- ^ Position and size of the rectangle.
+ }
+
+instance Default WindowConfig where
+ def = WindowConfig
+ {
+#ifdef XFT
+ winFont = "xft:monospace-20"
+#else
+ winFont = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
+#endif
+ , winBg = "black"
+ , winFg = "white"
+ , winRect = CenterWindow
+ }
+
+-- | What kind of window we should be.
+data WindowRect
+ = CenterWindow -- ^ Centered, big enough to fit all the text.
+ | CustomRect Rectangle -- ^ Completely custom dimensions.
+
+-- | Create a window, then fill and show it with the given text. If you
+-- are looking for a version of this function that also takes care of
+-- destroying the window, refer to 'withSimpleWindow'.
+showSimpleWindow :: WindowConfig -- ^ Window config.
+ -> [String] -- ^ Lines of text to show.
+ -> X Window
+showSimpleWindow WindowConfig{..} strs = do
+ let pad = 20
+ font <- initXMF winFont
+ dpy <- asks display
+ Rectangle sx sy sw sh <- getRectangle winRect
+
+ -- Text extents for centering all fonts
+ extends <- maximum . map (uncurry (+)) <$> traverse (textExtentsXMF font) strs
+ -- Height and width of entire window
+ height <- pure . fi $ (1 + length strs) * fi extends
+ width <- (+ pad) . fi . maximum <$> traverse (textWidthXMF dpy font) strs
+
+ let -- x and y coordinates that specify the upper left corner of the window
+ x = sx + (fi sw - width + 2) `div` 2
+ y = sy + (fi sh - height + 2) `div` 2
+ -- y position of first string
+ yFirst = (height + extends) `div` fi (1 + length strs)
+ -- (x starting, y starting) for all strings
+ strPositions = map (pad `div` 2, ) [yFirst, yFirst + extends ..]
+
+ w <- createNewWindow (Rectangle x y (fi width) (fi height)) Nothing "" True
+ let ms = Just (font, winFg, winBg, zip strs strPositions)
+ showWindow w
+ paintWindow' w (Rectangle 0 0 (fi width) (fi height)) 0 winBg "" ms Nothing
+ releaseXMF font
+ pure w
+ where
+ getRectangle :: WindowRect -> X Rectangle
+ getRectangle = \case
+ CenterWindow -> gets $ screenRect . W.screenDetail . W.current . windowset
+ CustomRect r -> pure r
+
+-- | Like 'showSimpleWindow', but fully manage the window; i.e., destroy
+-- it after the given function finishes its execution.
+withSimpleWindow :: WindowConfig -> [String] -> X a -> X a
+withSimpleWindow wc strs doStuff = do
+ w <- showSimpleWindow wc strs
+ doStuff <* withDisplay (io . (`destroyWindow` w))
+
-- This stuff is not exported
-- | Paints a titlebar with some strings and icons
From cf1d966ee6cc3d57684b4358d4e9d2602397de2c Mon Sep 17 00:00:00 2001
From: slotThe <soliditsallgood@mailbox.org>
Date: Fri, 14 Jan 2022 11:59:03 +0100
Subject: [PATCH 3/3] X.A.Submap: Add visualSubmap
Add a `visualSubmap` function, which works much like the regular
`submap` one, except that it visualises the available choices in a
pop-up window.
Related: https://github.com/xmonad/xmonad-contrib/issues/472
---
CHANGES.md | 7 +++-
XMonad/Actions/Submap.hs | 80 ++++++++++++++++++++++++++++++++--------
2 files changed, 70 insertions(+), 17 deletions(-)
diff --git a/CHANGES.md b/CHANGES.md
index 3d8664fd..134755bf 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -124,9 +124,14 @@
* `XMonad.Util.XUtils`
- Added `withSimpleWindow`, `showSimpleWindow`, `WindowConfig`, and
- `WindowRect` in order to simplify the handling of simply popup
+ `WindowRect` in order to simplify the handling of simple popup
windows.
+ * `XMonad.Actions.Submap`
+
+ - Added `visualSubmap` to visualise the available keys and their
+ actions when inside a submap.
+
## 0.17.0 (October 27, 2021)
### Breaking Changes
diff --git a/XMonad/Actions/Submap.hs b/XMonad/Actions/Submap.hs
index f4088139..06c8c7e4 100644
--- a/XMonad/Actions/Submap.hs
+++ b/XMonad/Actions/Submap.hs
@@ -17,13 +17,18 @@ module XMonad.Actions.Submap (
-- * Usage
-- $usage
submap,
+ visualSubmap,
submapDefault,
- submapDefaultWithKey
+ submapDefaultWithKey,
+
+ -- * Utilities
+ subName,
) where
import Data.Bits
-import XMonad.Prelude (fix, fromMaybe)
-import XMonad hiding (keys)
import qualified Data.Map as M
+import XMonad hiding (keys)
+import XMonad.Prelude (fix, fromMaybe, keyToString)
+import XMonad.Util.XUtils
{- $usage
@@ -62,6 +67,44 @@ For detailed instructions on editing your key bindings, see
submap :: M.Map (KeyMask, KeySym) (X ()) -> X ()
submap = submapDefault (return ())
+-- | Like 'submap', but visualise the relevant options.
+--
+-- ==== __Example__
+--
+-- > import qualified Data.Map as Map
+-- > import XMonad.Actions.Submap
+-- >
+-- > gotoLayout :: [(String, X ())] -- for use with EZConfig
+-- > gotoLayout = -- assumes you have a layout named "Tall" and one named "Full".
+-- > ["M-l", visualSubmap def $ Map.fromList $ map (\(k, s, a) -> ((0, k), (s, a)))
+-- > [ (xK_t, "Tall", switchToLayout "Tall") -- "M-l t" switches to "Tall"
+-- > , (xK_r, "Full", switchToLayout "Full") -- "M-l r" switches to "full"
+-- > ]]
+--
+-- One could alternatively also write @gotoLayout@ as
+--
+-- > gotoLayout = ["M-l", visualSubmap def $ Map.fromList $
+-- > [ ((0, xK_t), subName "Tall" $ switchToLayout "Tall")
+-- > , ((0, xK_r), subName "Full" $ switchToLayout "Full")
+-- > ]]
+visualSubmap :: WindowConfig -- ^ The config for the spawned window.
+ -> M.Map (KeyMask, KeySym) (String, X ())
+ -- ^ A map @keybinding -> (description, action)@.
+ -> X ()
+visualSubmap wc keys =
+ withSimpleWindow wc descriptions waitForKeyPress >>= \(m', s) ->
+ maybe (pure ()) snd (M.lookup (m', s) keys)
+ where
+ descriptions :: [String]
+ descriptions =
+ zipWith (\key desc -> keyToString key <> ": " <> desc)
+ (M.keys keys)
+ (map fst (M.elems keys))
+
+-- | Give a name to an action.
+subName :: String -> X () -> (String, X ())
+subName = (,)
+
-- | Like 'submap', but executes a default action if the key did not match.
submapDefault :: X () -> M.Map (KeyMask, KeySym) (X ()) -> X ()
submapDefault = submapDefaultWithKey . const
@@ -71,28 +114,33 @@ submapDefault = submapDefaultWithKey . const
submapDefaultWithKey :: ((KeyMask, KeySym) -> X ())
-> M.Map (KeyMask, KeySym) (X ())
-> X ()
-submapDefaultWithKey defAction keys = do
- XConf { theRoot = root, display = d } <- ask
+submapDefaultWithKey defAction keys = waitForKeyPress >>=
+ \(m', s) -> fromMaybe (defAction (m', s)) (M.lookup (m', s) keys)
- io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
- io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync
- none none currentTime
+-----------------------------------------------------------------------
+-- Internal stuff
+
+waitForKeyPress :: X (KeyMask, KeySym)
+waitForKeyPress = do
+ XConf{ theRoot = root, display = dpy } <- ask
+
+ io $ do grabKeyboard dpy root False grabModeAsync grabModeAsync currentTime
+ grabPointer dpy root False buttonPressMask grabModeAsync grabModeAsync
+ none none currentTime
(m, s) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do
- maskEvent d (keyPressMask .|. buttonPressMask) p
+ maskEvent dpy (keyPressMask .|. buttonPressMask) p
ev <- getEvent p
case ev of
KeyEvent { ev_keycode = code, ev_state = m } -> do
- keysym <- keycodeToKeysym d code 0
+ keysym <- keycodeToKeysym dpy code 0
if isModifierKey keysym
then nextkey
else return (m, keysym)
_ -> return (0, 0)
-- Remove num lock mask and Xkb group state bits
m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)
-
- io $ ungrabPointer d currentTime
- io $ ungrabKeyboard d currentTime
- io $ sync d False
-
- fromMaybe (defAction (m', s)) (M.lookup (m', s) keys)
+ io $ do ungrabPointer dpy currentTime
+ ungrabKeyboard dpy currentTime
+ sync dpy False
+ pure (m', s)