From edd905971d9f0b7b7b09d65fe8ee9cc8337f4172 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 31 Mar 2022 17:28:23 -0600 Subject: Add a bunch more documentation and ability to see that documentation --- src/Internal/Keys.hs | 275 +++++++++++++++++++++++++++++++++----------------- src/Internal/KeysM.hs | 58 ++++++++--- 2 files changed, 226 insertions(+), 107 deletions(-) (limited to 'src') diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index 88ec8cf..fcf233e 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE RankNTypes, FlexibleContexts #-} +{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} module Internal.Keys (applyKeys) where +import XMonad.Util.Run (safeSpawn) import Data.Monoid (Endo(..)) import Control.Monad.Trans.Class import Control.Monad.Reader @@ -70,6 +71,12 @@ playPause = spawnX "spotify-control play" mediaPrev = spawnX "spotify-control prev" mediaNext = spawnX "spotify-control next" +decreaseVolumeDoc = doc "Decrease volume" decreaseVolume +increaseVolumeDoc = doc "Increase volume" increaseVolume +playPauseDoc = doc "Play/Pause current media" playPause +mediaPrevDoc = doc "Previous media" mediaPrev +mediaNextDoc = doc "Next media" mediaNext + button6 :: Button button6 = 6 @@ -131,19 +138,28 @@ keymap = runKeys $ do jumpToLast mapAlpha 0 jumpToMark - shiftMod $ subkeys $ do + shiftMod $ + doc "Swap the current window with a mark." $ + subkeys $ do bind xK_apostrophe $ - (noMod -|- shiftMod -|- rawMask shiftMask) swapWithLastMark + (noMod -|- shiftMod -|- rawMask shiftMask) $ + doc "Swap the current window with the last mark." + swapWithLastMark + mapAlpha shiftMask swapWithMark bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if -- something goes wrong with the keyboard layout and for first-time boots -- where dmenu/alacritty may not be installed. - rawMask mod4Mask $ spawnX "xterm" + rawMask mod4Mask $ + doc "Spawns XTerm as a fallback if xkb is messed up." $ + spawnX "xterm" -- Moves xmobar to different monitors. - justMod $ spawnX "pkill -SIGUSR1 xmobar" + justMod $ + doc "Move XMobar to another screen." $ + spawnX "pkill -SIGUSR1 xmobar" bind xK_F1 $ do -- Experimental. Sends 'a' to all windows. @@ -157,9 +173,11 @@ keymap = runKeys $ do logs $ "Try send to " ++ show w sendKey (0, xK_a) w - -- Experimental. Sends 'A' 10 times to the focused window. justMod $ - replicateM_ 10 $ withFocused (sendKey (shiftMask, xK_a)) + doc "Print this documentation" $ + (safeSpawn "gxmessage" [ + "-fn", "Source Code Pro", + documentation (keymap config)] :: X ()) bind xK_F7 $ @@ -168,13 +186,13 @@ keymap = runKeys $ do logs (documentation (keymap config)) bind xK_F10 $ do - justMod playPause + justMod playPauseDoc bind xK_F11 $ do - justMod mediaPrev + justMod mediaPrevDoc bind xK_F12 $ do - justMod mediaNext + justMod mediaNextDoc bind xK_Return $ do justMod swapMaster @@ -188,28 +206,48 @@ keymap = runKeys $ do forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) -> bind key $ do -- Move focus to that screen. - justMod $ withScreen W.view idx + justMod $ + doc ("Switch focus to screen " ++ show idx) $ + withScreen W.view idx -- Swap the current screen with the one given - altMod $ withScreen W.greedyView idx + altMod $ + doc ("Swap the current screen with screen " ++ show idx) $ + withScreen W.greedyView idx -- Move the current window to the select screen. - shiftMod $ withScreen W.shift idx + shiftMod $ + doc ("Move the current window to screne " ++ show idx) $ + withScreen W.shift idx - bind xK_bracketright $ do - justMod $ sendMessage $ modifyWindowBorder 5 + altgrMod $ + logs "Test altgr" + bind xK_bracketright $ do + justMod $ + doc "Increase the gaps between windows." $ + sendMessage $ modifyWindowBorder 5 + bind xK_bracketleft $ do - justMod $ sendMessage $ modifyWindowBorder (-5) + justMod $ + doc "Decrease the gaps between windows." $ + sendMessage $ modifyWindowBorder (-5) bind xK_b $ do justMod $ spawnX "bluetooth-select.sh" bind xK_c $ do - justMod runPassMenu - shiftMod CopyWindow.kill1 + justMod $ + doc "Run PassMenu" runPassMenu + + shiftMod $ + doc "Kill the current window" CopyWindow.kill1 bind xK_f $ do - justMod $ sendMessage FlipLayout - shiftMod $ sendMessage HFlipLayout + justMod $ + doc "Flip the current layout vertically" $ + sendMessage FlipLayout + shiftMod $ + doc "Flip the current layout horizontally" $ + sendMessage HFlipLayout bind xK_g $ do justMod $ @@ -312,22 +350,46 @@ keymap = runKeys $ do doc "Recompile and restart XMonad" $ spawnX "xmonad --recompile && xmonad --restart" - justMod $ subkeys $ do + justMod $ + doc "Experimental Bindings" $ + subkeys $ do bind xK_q $ - (justMod -|- noMod) $ do + (justMod -|- noMod) $ + let fi = fromIntegral + mag (fi -> x₁, fi -> y₁) (fi -> x₂, fi -> y₂) = + sqrt ((x₂ - x₁) ^ 2 + (y₂ - y₁) ^ 2) in + + doc "EXPERIMENTAL: Move mouse to control media." $ fix $ \recur -> do + + -- Moving the mouse 100+ pixels to the right will go to the next song + -- Moving the mouse 100+ pixel to the left will go to the prior song + -- Moving the mouse vertically 100+ pixels will stop the loop + -- + -- May mess up the mouse, requiring an XMonad reboot, which is why + -- this is experimental. It's not the most practical bindings in the + -- world, but it shows that it's theoretically possible to program + -- some neat mouse moptions to do cool things. firstMotion@(x, y) <- nextMotion - (x', y') <- iterateWhile (==firstMotion) nextMotion + (x', y') <- iterateWhile ((<100) . mag firstMotion) nextMotion - logs $ printf "Motion: (%d, %d) (%d, %d)" x y x' y' - if (x' - x) < 0 - then mediaPrev - else mediaNext + if abs (y' - y) > abs (x' - x) + then + if (y' - y) < 0 + then logs "up" + else logs "down" + else do + if (x' - x) < 0 + then mediaPrev + else mediaNext + recur bind xK_r $ do - justMod runDMenu - shiftMod $ sendMessage DoRotate + justMod $ doc "Run a command via Rofi" runDMenu + shiftMod $ + doc "Rotate the current layout. (flips x, y coordinates)" $ + sendMessage DoRotate bind xK_s $ do altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" @@ -350,106 +412,137 @@ keymap = runKeys $ do bind xK_h $ justMod $ doc "Decrease volume." $ - decreaseVolume + decreaseVolumeDoc bind xK_l $ justMod $ doc "Increase volume." $ - increaseVolume + increaseVolumeDoc bind xK_v $ justMod $ (return () :: X ()) bind xK_w $ do - justMod windowJump + justMod $ doc "Jump to a window (via rofi)" windowJump bind xK_x $ do - justMod $ sendMessage ToggleStruts + justMod $ + doc "Toggles respect for struts." $ + sendMessage ToggleStruts bind xK_z $ do - justMod $ subkeys $ do - - bind xK_g $ do - (justMod -|- noMod) $ mapNextString $ \_ s -> - case s of - [ch] | isAlphaNum ch -> windows (CopyWindow.copy s) - _ -> return () - - bind xK_p $ do - (justMod -|- noMod) $ mapNextString $ \_ str -> - spawnX $ printf "gxmessage 'typed: \"%s\"\ncodes: \"%s\"\nunicode: á\n'" - str - (show (map ord str)) - - bind xK_t $ do - (justMod -|- noMod) $ logs "Test Log" - - bind xK_n $ do - (justMod -|- noMod) $ spawnX (terminal config ++ " -t Notes -e notes new") - - bind xK_c $ do - shiftMod CopyWindow.killAllOtherCopies - - bind xK_e $ do - (justMod -|- noMod) $ spawnX "emoji-select.sh" - (shiftMod -|- rawMask shiftMask) $ spawnX "emoticon-select.sh" - - bind xK_a $ - (justMod -|- noMod) $ spawnX "set-sink.sh" - - bind xK_w $ - (justMod -|- noMod) $ spawnX "networkmanager_dmenu" - - bind xK_o $ - (justMod -|- noMod) $ spawnX "library-view.sh" - - bind xK_s $ - (justMod -|- noMod) toggleSwallowEnabled - - bind xK_v $ do - (justMod -|- noMod) $ spawnX "set-volume.sh" - (shiftMod -|- rawMask shiftMask) $ spawnX "set-volume.sh -a" - - -- Double-tap Z to toggle zoom. - bind xK_z $ do - noMod -|- justMod $ sendMessage ToggleZoom + justMod $ + doc "Less often used keybindings." $ + subkeys $ do - -- Z is reserved to create sub keybindings to do various things. - -- I don't really use these at the moment. - bind xK_h $ noMod mediaPrev - bind xK_j $ noMod playPause - bind xK_l $ noMod mediaNext + bind xK_g $ do + (justMod -|- noMod) $ + doc "Copy a window to the given workspace" $ + mapNextString $ \_ s -> + case s of + [ch] | isAlphaNum ch -> windows (CopyWindow.copy s) + _ -> return () + + bind xK_p $ do + (justMod -|- noMod) $ mapNextString $ \_ str -> + spawnX $ printf "gxmessage 'typed: \"%s\"\ncodes: \"%s\"\nunicode: á\n'" + str + (show (map ord str)) + + bind xK_t $ do + (justMod -|- noMod) $ logs "Test Log" + + bind xK_n $ do + (justMod -|- noMod) $ + doc "Take a note" $ + spawnX (terminal config ++ " -t Notes -e notes new") + + bind xK_c $ do + shiftMod $ + doc "Kill all other copies of a window." + CopyWindow.killAllOtherCopies + + bind xK_e $ do + (justMod -|- noMod) $ + doc "Select an emoji" $ + spawnX "emoji-select.sh" + + (shiftMod -|- rawMask shiftMask) $ + doc "Select an emoticon" $ + spawnX "emoticon-select.sh" + + bind xK_a $ + (justMod -|- noMod) $ + doc "Move the audio sink for an application." $ + spawnX "set-sink.sh" + + bind xK_w $ + (justMod -|- noMod) $ + doc "Select a network to connect to." $ + spawnX "networkmanager_dmenu" + + bind xK_o $ + (justMod -|- noMod) $ + doc "Open a file from the library" $ + spawnX "library-view.sh" + + bind xK_s $ + (justMod -|- noMod) $ + doc "Toggle the ability for terminals to swallow child windows." $ + toggleSwallowEnabled + + bind xK_v $ do + (justMod -|- noMod) $ + doc "Set the volume via rofi." $ + spawnX "set-volume.sh" + (shiftMod -|- rawMask shiftMask) $ + doc "Set the volume of an application via rofi." $ + spawnX "set-volume.sh -a" + + -- Double-tap Z to toggle zoom. + bind xK_z $ do + noMod -|- justMod $ + doc "Toggle zoom on the current window." $ + sendMessage ToggleZoom + + -- Z is reserved to create sub keybindings to do various things. + -- I don't really use these at the moment. + bind xK_h $ noMod mediaPrevDoc + bind xK_j $ noMod playPauseDoc + bind xK_l $ noMod mediaNextDoc -- Centers the current focused window. i.e. toggles the Zoom layout -- modifier. - shiftMod $ sendMessage ToggleZoom + shiftMod $ + doc "Toggle zoom on the current window." $ + sendMessage ToggleZoom bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" bind xF86XK_AudioLowerVolume $ do noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%" - justMod mediaPrev + justMod mediaPrevDoc bind xF86XK_AudioRaiseVolume $ do noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ +1%" - justMod mediaNext + justMod mediaNextDoc bind xF86XK_AudioMute $ do noMod $ spawnX "pactl set-sink-mute @DEFAULT_SINK@ toggle" bind xF86XK_AudioPlay $ do - noMod playPause + noMod playPauseDoc bind xF86XK_AudioNext $ do - noMod mediaNext + noMod mediaNextDoc bind xF86XK_AudioPrev $ do - noMod mediaPrev + noMod mediaPrevDoc bind xF86XK_AudioPrev $ do - noMod mediaPrev + noMod mediaPrevDoc bind xF86XK_MonBrightnessUp $ do noMod $ spawnX "set-backlight.sh +0.05" diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs index f33d9d0..fa9b49f 100644 --- a/src/Internal/KeysM.hs +++ b/src/Internal/KeysM.hs @@ -3,9 +3,10 @@ module Internal.KeysM where import Data.List +import Data.Bits ((.&.)) import Control.Monad.Writer import Text.Printf -import Control.Arrow (second) +import Control.Arrow (second, first) import Control.Monad (void) import Control.Monad.State (State(..), modify', get, execState) import XMonad @@ -42,6 +43,7 @@ class Bindable k where type BindableMonad k :: (* -> *) -> * -> * bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l () + -- section :: String -> BindableMonad k l () -> BindableMonad k l () class Binding k b where toB :: k -> b @@ -64,13 +66,6 @@ instance Binding a a where doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding doc str k = let (Documented _ t) = toB k in Documented str t -instance Semigroup (KeysM l ()) where - (<>) = mappend - -instance Monoid (KeysM l ()) where - mempty = return () - mappend = (>>) - runKeys :: KeysM l a -> XConfig l -> KeyBindings runKeys (KeysM stateM) config = snd $ execState stateM (config, Map.empty) @@ -101,7 +96,7 @@ hyperMask :: KeyMask hyperMask = mod3Mask altgrMask :: KeyMask -altgrMask = mod2Mask +altgrMask = 0x80 superMask :: KeyMask superMask = mod4Mask @@ -121,6 +116,7 @@ instance Bindable KeySym where KeysM $ modify' $ second $ flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) + instance Bindable Button where type BindableValue Button = ButtonBinding type BindableMonad Button = ButtonsM @@ -456,16 +452,46 @@ mapAlpha km fn = documentation :: KeyBindings -> String -documentation = execWriter . document' "" [] +documentation = execWriter . document' "" where - document' pref priorKeys keybindings = - forM_ (Map.toList keybindings) $ \(key, Documented doc thing) -> do - when (not $ null doc) $ - tell $ printf "%s%s%s: %s\n" pref (intercalate " " $ map show priorKeys) (show key) doc + document' pref keybindings = + forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do + when ((not $ null doc) || hasSubmap thing) $ + tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc case thing of Action _ -> return () - Submap submap -> document' (pref ++ " ") (priorKeys ++ [key]) submap + Submap submap -> document' (pref ++ " ") submap Repeat submap -> do tell pref tell " (repeatable):\n" - document' (pref ++ " ") (priorKeys ++ [key]) submap + document' (pref ++ " ") submap + + keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)]) + keyBindingsToList b = + fmap (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) $ + group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) + + prettyShow :: (KeyMask, KeySym) -> String + prettyShow (mask, key) = printf "<%s%s>" (showMask mask) (keysymToString key) + + hasSubmap b = case b of + Action _ -> False + _ -> True + + + showMask :: KeyMask -> String + showMask mask = + let masks = [(shiftMask, "S"), + (altMask, "A"), + (mod3Mask, "H"), + (mod4Mask, "M"), + (altgrMask, "AGr"), + (controlMask, "C")] in + + concatMap ((++"-") . snd) $ filter ((/=0) . (.&.mask) . fst) masks + + + group :: (Ord b) => (a -> b) -> [a] -> (Map b [a]) + group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) + + -- cgit