Merge pull request #680 from slotThe/visual-submap

X.A.Submap: Add `visualSubmap`

CHANGES.md

@@ -116,6 +116,22 @@
       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`.
+
+  * `XMonad.Util.XUtils`
+
+    - Added `withSimpleWindow`, `showSimpleWindow`, `WindowConfig`, and
+      `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

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
+submapDefaultWithKey defAction keys = waitForKeyPress >>=
-    XConf { theRoot = root, display = d } <- ask
+    \(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
+-- Internal stuff
-                     none none currentTime
+
+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 $ do ungrabPointer dpy currentTime
-    io $ ungrabPointer d currentTime
+            ungrabKeyboard dpy currentTime
-    io $ ungrabKeyboard d currentTime
+            sync dpy False
-    io $ sync d False
+    pure (m', s)
-
-    fromMaybe (defAction (m', s)) (M.lookup (m', s) keys)

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.

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

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 Control.Arrow(Arrow((&&&), second))
-import Data.Bits(Bits((.&.), complement))
 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)
 

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