vanadium/xmonad: break into small bindings

We noticed that this makes error message smaller and easier to
understand.

nix/configurations/vanadium/home/xmonad/leanamonad.cabal

@@ -24,8 +24,9 @@ library
   import: common
   hs-source-dirs: lib
   exposed-modules:
-    Leanamonad.Layouts.ReflectMsg
-    Leanamonad.GreekChar
+    XMonad.Layout.Reflect.Message
+    XMonad.Layout.ResizableTile.FixDescription
+    Data.Char.Greek
 
 executable leanamonad
   import: common

nix/configurations/vanadium/home/xmonad/lib/Data/Char/Greek.hs

@@ -1,4 +1,4 @@
-module Leanamonad.GreekChar where
+module Data.Char.Greek where
 
 import Data.List (find)
 

nix/configurations/vanadium/home/xmonad/lib/XMonad/Layout/Reflect/Message.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 
-module Leanamonad.Layouts.ReflectMsg where
+module XMonad.Layout.Reflect.Message where
 
 import XMonad (
   Resize (Expand, Shrink),

nix/configurations/vanadium/home/xmonad/lib/XMonad/Layout/ResizableTile/FixDescription.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+module XMonad.Layout.ResizableTile.FixDescription
+  ( RTFixDescription(..)
+  ) where
+
+import XMonad
+import qualified XMonad.StackSet as W
+import XMonad.Layout.ResizableTile
+
+newtype RTFixDescription a = RTFixDescription { unwrapRT :: ResizableTall a }
+    deriving (Read, Show)
+
+instance LayoutClass RTFixDescription a where
+  runLayout (W.Workspace t l s) =
+    let ws' = W.Workspace t (unwrapRT l) s
+    in fmap (fmap (fmap RTFixDescription))
+       . runLayout ws'
+
+  handleMessage (RTFixDescription l) m =
+    fmap (fmap RTFixDescription)
+    $ handleMessage l m
+
+  description (RTFixDescription l) =
+    description l <> " " <> show (_nmaster l)

nix/configurations/vanadium/home/xmonad/xmonad.hs

@@ -12,8 +12,10 @@ import XMonad.Hooks.RefocusLast
 import XMonad.Hooks.StatusBar
 import XMonad.Layout.NoBorders
 import XMonad.Layout.Reflect
+import XMonad.Layout.Reflect.Message
 import XMonad.Layout.Renamed
 import XMonad.Layout.ResizableTile
+import XMonad.Layout.ResizableTile.FixDescription
 import XMonad.Layout.Spacing
 import qualified XMonad.StackSet as W
 import XMonad.Util.EZConfig
@@ -26,8 +28,7 @@ import qualified Data.Map.Strict as M
 import System.Posix
 import Graphics.X11.ExtraTypes.XF86
 
-import Leanamonad.Layouts.ReflectMsg
-import Leanamonad.GreekChar
+import Data.Char.Greek
 
 main :: IO ()
 main =
@@ -45,169 +46,175 @@ main =
       , focusFollowsMouse  = True
       , terminal           = myTerm
       , workspaces         = myWorkspaces
-
-      , logHook = refocusLastLogHook
-
-      , startupHook = do
-          spawnOnce "fcitx5 &"                                -- Input method
-
-          spawn "feh --no-fehbg --bg-fill ~/.wallpaper &" -- wallpaper
-
-          -- Needed to make gnome keyring work
-          -- https://wiki.archlinux.org/title/GNOME/Keyring#Using_gnome-keyring-daemon_outside_desktop_environments_(KDE,_GNOME,_XFCE,_...)
-          spawn "dbus-update-activation-environment DISPLAY XAUTHORITY WAYLAND_DISPLAY"
-
-          io $ do
-            -- This is done here because:
-            -- - setting `home.sessionVariable` (home-manager) would only effect shells, probably due to the order of launched processes blah blah
-            -- - setting `environment.sessionVariables` (NixOS) would make my set up less portable
-            putEnv "GLFW_IM_MODULE=ibus"  -- Make sure kitty knows how to talk to fcitx
-            putEnv "MOZ_USE_XINPUT2=1"    -- Force touchpad for firefox
-
-      , layoutHook =
-          let tallr = named "Normal"
-                      $ smartSpacingWithEdge 5
-                      $ reflectMsg . reflectHoriz
-                      $ ResizableTall 1 (1/10) (3/7) []
-              mag = magnifyxy 1.05 1.3 (NoMaster 3) False
-           in avoidStruts . smartBorders $
-                mag tallr ||| Full
-
-      , manageHook =
-          composeAll
-            [ className ~? "NautilusPreviewer"  --> customFloating centeredFloat
-            , className =? "feh"                --> customFloating buttomRightFloat
-            , className =? "Minder"
-                  <&&> not <$> title ~? "Pick a Color" -- ignore the color picker
-                --> customFloating centeredFloat
-            , isFirefoxPIP                      --> doFloat
-
-            , namedScratchpadManageHook myScratchpads
-            ]
-
-          <>
-          composeOne
-            [ className =? "firefox" -?> insertPosition Master Newer
-            , className =? "kitty"   -?> insertPosition Below Newer
-            , className `isOneOf`
-                  [ "sioyek"
-                  , "Nautilus"
-                  ]
-                -?> insertPosition End Older
-            ]
+      , logHook            = refocusLastLogHook
+      , startupHook        = myStartupHook
+      , layoutHook         = myLayout
+      , manageHook         = myManageHook
       }
 
-    -- Only remove mappings that needs pass through (it's a map).
-    `removeKeys`
-      [ (superMask, xK_h)
-      , (superMask, xK_l)
-      , (superMask, xK_p)
+    -- Only remove mappings that needs pass through
+    `removeKeys` removedKeybinds
+    `additionalKeys` keybinds
 
-        -- It has been more than once that I actidently killed xmonad >:(
-      , (superMask .|. shiftMask, xK_q)
-      ]
-      ++ [ (superMask              , n) | n <- [xK_1 .. xK_9] ]
-      ++ [ (superMask .|. shiftMask, n) | n <- [xK_1 .. xK_9] ]
+myLayout =
+  let tallr = renamed [ KeepWordsRight 2 ] {- keep "ResizableTall n" -}
+              $ smartSpacingWithEdge 5
+              $ reflectMsg . reflectHoriz
+              $ RTFixDescription
+              $ ResizableTall 1 (1/10) (3/7) []
+      mag = magnifyxy 1.05 1.3 (NoMaster 3) False
+   in avoidStruts . smartBorders $
+        mag tallr ||| Full
 
-    `additionalKeys`
-      [
-      -- Display
-        ((0,         xF86XK_MonBrightnessDown), spawn "light -U 5")
-      , ((0,         xF86XK_MonBrightnessUp  ), spawn "light -A 5")
-      , ((shiftMask, xF86XK_MonBrightnessDown), spawn "light -U 1")
-      , ((shiftMask, xF86XK_MonBrightnessUp  ), spawn "light -A 1")
-      , ((altMask,   xF86XK_MonBrightnessUp  ), spawn "autorandr --change --ignore-lid")
-      , ((altMask,   xF86XK_MonBrightnessDown), spawn "autorandr --change --ignore-lid")
+isOneOf :: Eq a => Query a -> [a] -> Query Bool
+isOneOf q = fmap or . traverse (q =?)
 
-      -- Volume adjustments
-      -- Don't overload the mute button
-      -- In case of doubt, smashing the button becomes deterministic
-      , ((0,           xF86XK_AudioMute),        spawn "pactl -- set-sink-mute 0 1"    ) -- mute
-      , ((controlMask, xF86XK_AudioMute),        spawn "pactl -- set-sink-mute 0 0"    ) -- unmute
-      , ((0,           xF86XK_AudioLowerVolume), spawn "pactl -- set-sink-volume 0 -5%")
-      , ((0,           xF86XK_AudioRaiseVolume), spawn "pactl -- set-sink-volume 0 +5%")
-      , ((shiftMask,   xF86XK_AudioLowerVolume), spawn "pactl -- set-sink-volume 0 -1%")
-      , ((shiftMask,   xF86XK_AudioRaiseVolume), spawn "pactl -- set-sink-volume 0 +1%")
+myManageHook :: ManageHook
+myManageHook =
+  composeAll
+    [ className ~? "NautilusPreviewer"  --> customFloating centeredFloat
+    , className =? "feh"                --> customFloating buttomRightFloat
+    , className =? "Minder"
+          <&&> not <$> title ~? "Pick a Color" -- ignore the color picker
+        --> customFloating centeredFloat
+    , className =? "firefox"
+          <&&> title =? "Picture-in-Picture"
+        --> doFloat
+    , namedScratchpadManageHook myScratchpads
+    ]
+  <> composeOne
+    [ className =? "firefox" -?> insertPosition Master Newer
+    , className =? "kitty"   -?> insertPosition Below Newer
+    , className `isOneOf`
+          [ "sioyek"
+          , "Nautilus"
+          ]
+        -?> insertPosition End Older
+    ]
 
-      -- Playback control
-      , ((0, xF86XK_AudioPrev), spawn "playerctl previous"  )
-      , ((0, xF86XK_AudioPlay), spawn "playerctl play-pause")
-      , ((0, xF86XK_AudioNext), spawn "playerctl next"      )
+myStartupHook :: X ()
+myStartupHook = do
+  spawnOnce "fcitx5 &"                                -- Input method
 
-      -- Toggle fullscreen
-      , ((superMask, xK_Escape), sendMessage NextLayout)
+  spawn "feh --no-fehbg --bg-fill ~/.wallpaper &" -- wallpaper
 
-      -- Resize windows
-      , ((superMask, xK_equal               ), sendMessage $ IncMasterN  1)
-      , ((superMask, xK_minus               ), sendMessage $ IncMasterN -1)
-      , ((superMask, xK_comma               ), sendMessage Shrink         )
-      , ((superMask, xK_period              ), sendMessage Expand         )
-      , ((superMask .|. shiftMask, xK_comma ), sendMessage MirrorShrink   )
-      , ((superMask .|. shiftMask, xK_period), sendMessage MirrorExpand   )
-      , ((superMask              , xK_apostrophe), sendMessage Toggle     )
+  -- Needed to make gnome keyring work
+  -- https://wiki.archlinux.org/title/GNOME/Keyring#Using_gnome-keyring-daemon_outside_desktop_environments_(KDE,_GNOME,_XFCE,_...)
+  spawn "dbus-update-activation-environment DISPLAY XAUTHORITY WAYLAND_DISPLAY"
 
-      -- [D]o sink and lift
-      , ( (superMask, xK_d)
-        , submap $ M.fromList
-            [ ((0, xK_t), withFocused $ windows . W.sink)
-            , ((0, xK_l), withFocused $ windows . flip W.float centeredFloat)
-            ]
-        )
-      ]
+  io $ do
+    -- This is done here because:
+    -- - setting `home.sessionVariable` (home-manager) would only effect shells, probably due to the order of launched processes blah blah
+    -- - setting `environment.sessionVariables` (NixOS) would make my set up less portable
+    putEnv "GLFW_IM_MODULE=ibus"  -- Make sure kitty knows how to talk to fcitx
+    putEnv "MOZ_USE_XINPUT2=1"    -- Force touchpad for firefox
 
-      -- Screenshots
-      ++ (let
-          fullscreen = "maim -u | xclip -in -selection clipboard -t image/png"
+removedKeybinds :: [(KeyMask, KeySym)]
+removedKeybinds =
+  [ (superMask, xK_h)
+  , (superMask, xK_l)
+  , (superMask, xK_p)
+
+    -- It has been more than once that I actidently killed xmonad >:(
+  , (superMask .|. shiftMask, xK_q)
+  ]
+  ++ [ (superMask              , n) | n <- [xK_1 .. xK_9] ]
+  ++ [ (superMask .|. shiftMask, n) | n <- [xK_1 .. xK_9] ]
+
+keybinds :: [((KeyMask, KeySym), X ())]
+keybinds =
+  [
+    -- Display
+    ((0,         xF86XK_MonBrightnessDown), spawn "light -U 5")
+  , ((0,         xF86XK_MonBrightnessUp  ), spawn "light -A 5")
+  , ((shiftMask, xF86XK_MonBrightnessDown), spawn "light -U 1")
+  , ((shiftMask, xF86XK_MonBrightnessUp  ), spawn "light -A 1")
+  , ((altMask,   xF86XK_MonBrightnessUp  ), spawn "autorandr --change --ignore-lid")
+  , ((altMask,   xF86XK_MonBrightnessDown), spawn "autorandr --change --ignore-lid")
+
+    -- Volume adjustments
+    -- Don't overload the mute button
+    -- In case of doubt, smashing the button becomes deterministic
+  , ((0,           xF86XK_AudioMute),        spawn "pactl -- set-sink-mute 0 1"    ) -- mute
+  , ((controlMask, xF86XK_AudioMute),        spawn "pactl -- set-sink-mute 0 0"    ) -- unmute
+  , ((0,           xF86XK_AudioLowerVolume), spawn "pactl -- set-sink-volume 0 -5%")
+  , ((0,           xF86XK_AudioRaiseVolume), spawn "pactl -- set-sink-volume 0 +5%")
+  , ((shiftMask,   xF86XK_AudioLowerVolume), spawn "pactl -- set-sink-volume 0 -1%")
+  , ((shiftMask,   xF86XK_AudioRaiseVolume), spawn "pactl -- set-sink-volume 0 +1%")
+
+    -- Playback control
+  , ((0, xF86XK_AudioPrev), spawn "playerctl previous"  )
+  , ((0, xF86XK_AudioPlay), spawn "playerctl play-pause")
+  , ((0, xF86XK_AudioNext), spawn "playerctl next"      )
+
+    -- Toggle fullscreen
+  , ((superMask, xK_Escape), sendMessage NextLayout)
+
+    -- Resize windows
+  , ((superMask, xK_equal               ), sendMessage $ IncMasterN  1)
+  , ((superMask, xK_minus               ), sendMessage $ IncMasterN -1)
+  , ((superMask, xK_comma               ), sendMessage Shrink         )
+  , ((superMask, xK_period              ), sendMessage Expand         )
+  , ((superMask .|. shiftMask, xK_comma ), sendMessage MirrorShrink   )
+  , ((superMask .|. shiftMask, xK_period), sendMessage MirrorExpand   )
+  , ((superMask              , xK_apostrophe), sendMessage Toggle     )
+
+    -- [D]o sink and lift
+  , ( (superMask, xK_d)
+    , submap $ M.fromList
+        [ ((0, xK_t), withFocused $ windows . W.sink)
+        , ((0, xK_l), withFocused $ windows . flip W.float centeredFloat)
+        ]
+    )
+  ]
+
+    -- Screenshots
+  ++ (let fullscreen = "maim -u | xclip -in -selection clipboard -t image/png"
           withSelection = "maim -u -s -b 5 -o | xclip -in -selection clipboard -t image/png"
           toFloat = "maim -u -s -b 5 -o | feh --auto-zoom -"
-      in
-      [ ((0,                       xK_Print), spawn fullscreen   )
-      , ((superMask .|. shiftMask, xK_3    ), spawn fullscreen   )
-      , ((superMask .|. shiftMask, xK_4    ), spawn withSelection)
-      , ((superMask .|. shiftMask, xK_5    ), spawn toFloat      )
-      ])
+      in  [ ((0,                       xK_Print), spawn fullscreen   )
+          , ((superMask .|. shiftMask, xK_3    ), spawn fullscreen   )
+          , ((superMask .|. shiftMask, xK_4    ), spawn withSelection)
+          , ((superMask .|. shiftMask, xK_5    ), spawn toFloat      )
+          ]
+     )
 
-      -- Yeet
-      ++ (let
-          workspaceKeys = [xK_h, xK_t, xK_n, xK_s, xK_m, xK_w, xK_v, xK_z]
-      in
-      [ ((superMask, k), windows $ W.greedyView space)
-      | (k, space) <- zip workspaceKeys myWorkspaces
-      ]
-      ++
-      [ ((superMask .|. altMask, k), windows $ W.greedyView space . W.shift space)
-      | (k, space) <- zip workspaceKeys myWorkspaces
-      ]
-      ++
-      [ ((superMask .|. controlMask, k), windows $ swapWithCurrent space)
-      | (k, space) <- zip workspaceKeys myWorkspaces
-      ])
+  -- Yeet
+  ++ (let workspaceKeys = [xK_h, xK_t, xK_n, xK_s, xK_m, xK_w, xK_v, xK_z]
+      in  [ ((superMask, k), windows $ W.greedyView space)
+          | (k, space) <- zip workspaceKeys myWorkspaces
+          ]
+          ++ [ ((superMask .|. altMask, k), windows $ W.greedyView space . W.shift space)
+             | (k, space) <- zip workspaceKeys myWorkspaces
+             ]
+          ++ [ ((superMask .|. controlMask, k), windows $ swapWithCurrent space)
+             | (k, space) <- zip workspaceKeys myWorkspaces
+             ]
+     )
 
-      -- Launcher
-      ++ (let
-          launchFirefox = "if type firefox; then firefox; else firefox-esr; fi"
+  -- Launcher
+  ++ (let launchFirefox = "if type firefox; then firefox; else firefox-esr; fi"
           launchDmenu = "dmenu_run -i -fn \"Iosevka-14\" -nb \"#36363a\" -nf \"#e2e2e4\" -sb \"#f7f7f8\" -sf \"#36363a\" -l 10"
           lock = "xscreensaver-command -lock"
-      in
-      [ ((controlMask .|. altMask, xK_m), namedScratchpadAction myScratchpads "cmus"  )
-      , ((controlMask .|. altMask, xK_t), namedScratchpadAction myScratchpads "btop"  )
-      , ((controlMask .|. altMask, xK_p), namedScratchpadAction myScratchpads "pass"  )
-      , ((controlMask .|. altMask, xK_e), namedScratchpadAction myScratchpads "emoji-picker")
-      , ((controlMask .|. altMask, xK_b), spawn launchFirefox                         )
-      , ((superMask,               xK_o), spawn launchDmenu                           )
-      , ((superMask,               xK_l), spawn lock                                  )
-      ])
+      in  [ ((controlMask .|. altMask, xK_m), namedScratchpadAction myScratchpads "cmus"  )
+          , ((controlMask .|. altMask, xK_t), namedScratchpadAction myScratchpads "btop"  )
+          , ((controlMask .|. altMask, xK_p), namedScratchpadAction myScratchpads "pass"  )
+          , ((controlMask .|. altMask, xK_e), namedScratchpadAction myScratchpads "emoji-picker")
+          , ((controlMask .|. altMask, xK_b), spawn launchFirefox                         )
+          , ((superMask,               xK_o), spawn launchDmenu                           )
+          , ((superMask,               xK_l), spawn lock                                  )
+          ]
+     )
 
-      ++ (let
-          powerprofile p = (p, spawn $ "powerprofilesctl set " ++ p)
-      in
-      [ ( (superMask, xK_p), visualSubmap def $ M.fromList
-            [ ((0, xK_1), powerprofile "power-saver")
-            , ((0, xK_2), powerprofile "balanced"   )
-            , ((0, xK_3), powerprofile "performance")
-            ]
-        )
-      ])
+  ++ (let powerprofile p = (p, spawn $ "powerprofilesctl set " ++ p)
+      in  [ ( (superMask, xK_p), visualSubmap def $ M.fromList
+                [ ((0, xK_1), powerprofile "power-saver")
+                , ((0, xK_2), powerprofile "balanced"   )
+                , ((0, xK_3), powerprofile "performance")
+                ]
+            )
+          ]
+     )
 
 myTerm :: String
 myTerm = "kitty"
@@ -217,13 +224,13 @@ superMask = mod4Mask
 altMask = mod1Mask
 
 myWorkspaces :: [String]
-myWorkspaces = take 8 . fmap (:[]) $ greekLower
+myWorkspaces = map (:[]) $ take 8 greekLower
 
 centeredFloat, smallFloat, fullFloat, buttomRightFloat :: W.RationalRect
-centeredFloat = W.RationalRect (1/9) (1/9) (7/9) (7/9)
-smallFloat    = W.RationalRect (3/5) (3/5) (2/7) (2/7)
-fullFloat     = W.RationalRect     0     0     1     1
-buttomRightFloat = W.RationalRect  (1/2) (1/2) (1/2) (1/2)
+centeredFloat    = W.RationalRect (1/9) (1/9) (7/9) (7/9)
+smallFloat       = W.RationalRect (3/5) (3/5) (2/7) (2/7)
+fullFloat        = W.RationalRect     0     0     1     1
+buttomRightFloat = W.RationalRect (1/2) (1/2) (1/2) (1/2)
 
 xmobarConfig :: StatusBarConfig
 xmobarConfig = statusBarProp "xmobar -x 0" (pure myPrettyPrinter)
@@ -236,30 +243,25 @@ xmobarConfig = statusBarProp "xmobar -x 0" (pure myPrettyPrinter)
         , ppSep             = " | "
         }
 
-
-isOneOf :: Eq a => Query a -> [a] -> Query Bool
-isOneOf q = fmap or . traverse (q =?)
-
-isFirefoxPIP :: Query Bool
-isFirefoxPIP =
-  className =? "firefox"
-    <&&> title =? "Picture-in-Picture"
-
 myScratchpads :: [NamedScratchpad]
 myScratchpads =
-  [ NS "cmus"
+  [ NS
+      "cmus"
       (myTerm ++ " -T 'cmus' cmus")
       (title =? "cmus")
       (customFloating centeredFloat)
-  , NS "btop"
+  , NS
+      "btop"
       (myTerm ++ " -T 'btop' btop")
       (title =? "btop")
       (customFloating fullFloat)
-  , NS "pass"
+  , NS
+      "pass"
       (myTerm ++ " -T 'pass' -- fish -i -c 'while :; fzf-pass; end'")
       (title =? "pass")
       (customFloating smallFloat)
-  , NS "emoji-picker"
+  , NS
+      "emoji-picker"
       (myTerm ++ " -T 'emoji-picker' -- fish -i -c 'while :; emoji-picker; end'")
       (title =? "emoji-picker")
       (customFloating smallFloat)