From fada61902291aeb29914fff288301a8c487c4ecd Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 10 Apr 2022 13:26:16 -0600 Subject: Rename Internal to Rahm.Desktop --- src/Rahm/Desktop/CornerLayout.hs | 58 +++ src/Rahm/Desktop/DMenu.hs | 45 +++ src/Rahm/Desktop/Hash.hs | 11 + src/Rahm/Desktop/Keys.hs | 820 +++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/KeysM.hs | 497 ++++++++++++++++++++++++ src/Rahm/Desktop/Layout.hs | 326 ++++++++++++++++ src/Rahm/Desktop/LayoutDraw.hs | 155 ++++++++ src/Rahm/Desktop/LayoutList.hs | 297 ++++++++++++++ src/Rahm/Desktop/Lib.hs | 160 ++++++++ src/Rahm/Desktop/Logger.hs | 32 ++ src/Rahm/Desktop/Marking.hs | 204 ++++++++++ src/Rahm/Desktop/MouseMotion.hs | 97 +++++ src/Rahm/Desktop/NoPersist.hs | 23 ++ src/Rahm/Desktop/PassMenu.hs | 13 + src/Rahm/Desktop/PromptConfig.hs | 12 + src/Rahm/Desktop/RebindKeys.hs | 119 ++++++ src/Rahm/Desktop/ScreenRotate.hs | 19 + src/Rahm/Desktop/Submap.hs | 104 +++++ src/Rahm/Desktop/Swallow.hs | 29 ++ src/Rahm/Desktop/SwapMaster.hs | 41 ++ src/Rahm/Desktop/Windows.hs | 86 ++++ src/Rahm/Desktop/XMobarLog.hs | 78 ++++ 22 files changed, 3226 insertions(+) create mode 100644 src/Rahm/Desktop/CornerLayout.hs create mode 100644 src/Rahm/Desktop/DMenu.hs create mode 100644 src/Rahm/Desktop/Hash.hs create mode 100644 src/Rahm/Desktop/Keys.hs create mode 100644 src/Rahm/Desktop/KeysM.hs create mode 100644 src/Rahm/Desktop/Layout.hs create mode 100644 src/Rahm/Desktop/LayoutDraw.hs create mode 100644 src/Rahm/Desktop/LayoutList.hs create mode 100644 src/Rahm/Desktop/Lib.hs create mode 100644 src/Rahm/Desktop/Logger.hs create mode 100644 src/Rahm/Desktop/Marking.hs create mode 100644 src/Rahm/Desktop/MouseMotion.hs create mode 100644 src/Rahm/Desktop/NoPersist.hs create mode 100644 src/Rahm/Desktop/PassMenu.hs create mode 100644 src/Rahm/Desktop/PromptConfig.hs create mode 100644 src/Rahm/Desktop/RebindKeys.hs create mode 100644 src/Rahm/Desktop/ScreenRotate.hs create mode 100644 src/Rahm/Desktop/Submap.hs create mode 100644 src/Rahm/Desktop/Swallow.hs create mode 100644 src/Rahm/Desktop/SwapMaster.hs create mode 100644 src/Rahm/Desktop/Windows.hs create mode 100644 src/Rahm/Desktop/XMobarLog.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/CornerLayout.hs b/src/Rahm/Desktop/CornerLayout.hs new file mode 100644 index 0000000..33f439e --- /dev/null +++ b/src/Rahm/Desktop/CornerLayout.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +-- Creates a layout, the "corner layout" that keeps the master window in the +-- corner and the other windows go around it. +module Rahm.Desktop.CornerLayout where + +import Data.Typeable (Typeable) +import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) +import qualified XMonad.StackSet as S + +data Corner a = Corner Rational Rational + deriving (Show, Typeable, Read) + +instance LayoutClass Corner a where + pureLayout (Corner frac _) screen@(Rectangle x y w h) ss = + let w' = floor $ fromIntegral w * frac + h' = floor $ fromIntegral h * frac + corner = Rectangle 0 0 w' h' + vertRect = Rectangle (fromIntegral w') 0 (w - w') h + horizRect = Rectangle 0 (fromIntegral h') w' (h - h') + ws = S.integrate ss + + vn = (length ws - 1) `div` 2 + hn = (length ws - 1) - vn + in + case ws of + [a] -> [(a, screen)] + [a, b] -> [ + (a, Rectangle x y w' h), + (b, Rectangle (x + fromIntegral w') y (w - w') h)] + _ -> + zip ws $ map ( + \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $ + corner : + splitVert vertRect vn ++ + splitHoriz horizRect hn + + pureMessage (Corner frac delta) m = fmap resize (fromMessage m) + where + resize Shrink = Corner (frac - delta) delta + resize Expand = Corner (frac + delta) delta + +splitVert :: Rectangle -> Int -> [Rectangle] +splitVert (Rectangle x y w h) i' = + map + (\i -> Rectangle x (y + fromIntegral (step * i)) w step) + [0 .. i - 1] + where + i = fromIntegral i' + step = h `div` i + +splitHoriz :: Rectangle -> Int -> [Rectangle] +splitHoriz (Rectangle x y w h) i' = + map + (\i -> Rectangle (x + fromIntegral (step * i)) y step h) + [0 .. i - 1] + where + step = w `div` i + i = fromIntegral i' diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs new file mode 100644 index 0000000..62ecdd3 --- /dev/null +++ b/src/Rahm/Desktop/DMenu.hs @@ -0,0 +1,45 @@ +module Rahm.Desktop.DMenu where + +import XMonad.Util.Dmenu +import XMonad +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import XMonad.Util.Run +import Data.List (intercalate) +import Text.Printf (printf) + +data Colors = + Colors { + fg :: String, + bg :: String + } | DefaultColors + +menuCommand :: [String] +menuCommand = ["rofi", "-monitor", "-4", "-dmenu", "-sort", "-levenshtein-sort"] + +menuCommandString :: String +menuCommandString = unwords menuCommand + +runDMenu :: X () +runDMenu = void $ + safeSpawn + "rofi" + ["-monitor", "-4", "-display-run", "Execute", "-show", "run"] + +runDMenuPrompt :: String -> Maybe String -> [String] -> X String +runDMenuPrompt prompt color select = + let realColor = maybe [] (\c -> ["-sb", c, "-nf", c]) color + in + runProcessWithInput "/home/rahm/.local/bin/dmenu_debug.sh" ([ + "-p", prompt, + "-l", "12", + "-dim", "0.4" ] ++ realColor) (intercalate "\n" select) + + +runDMenuPromptWithMap :: String -> Maybe String -> Map String a -> X (Maybe a) +runDMenuPromptWithMap prompt color map = do + let realColor = maybe [] ( + \c -> ["-theme-str", printf "* {theme-color: %s;}" c]) color + menuMapArgs (head menuCommand) + (tail menuCommand ++ ["-p", prompt] ++ realColor) map diff --git a/src/Rahm/Desktop/Hash.hs b/src/Rahm/Desktop/Hash.hs new file mode 100644 index 0000000..dc58d96 --- /dev/null +++ b/src/Rahm/Desktop/Hash.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Rahm.Desktop.Hash where + +import Numeric (showHex) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Crypto.Hash.SHA1 as SHA1 + +quickHash :: String -> String +quickHash str = + concatMap (`showHex` "") $ BS.unpack (SHA1.hash $ BC.pack str) diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs new file mode 100644 index 0000000..9712f84 --- /dev/null +++ b/src/Rahm/Desktop/Keys.hs @@ -0,0 +1,820 @@ +{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} +module Rahm.Desktop.Keys (applyKeys) where + +import XMonad.Util.Run (safeSpawn) +import Data.Monoid (Endo(..)) +import Control.Monad.Trans.Class +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Loops (iterateWhile) +import Control.Monad.Fix (fix) +import Graphics.X11.ExtraTypes.XF86; +import Rahm.Desktop.KeysM +import Rahm.Desktop.SwapMaster (swapMaster) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.MosaicAlt +import Graphics.X11.ExtraTypes.XorgDefault +import System.Process +import XMonad.Util.Ungrab +import XMonad.Layout.Spacing +import Data.Maybe (isJust, fromMaybe) +import Debug.Trace +import Control.Applicative +import Prelude hiding ((!!)) +import Control.Monad +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Map (Map) +import Rahm.Desktop.Layout +import Rahm.Desktop.Marking +import Rahm.Desktop.PromptConfig +import System.IO +import Text.Printf +import XMonad +import Rahm.Desktop.Submap +import XMonad.Actions.WindowNavigation +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell +import XMonad.Util.CustomKeys +import XMonad.Util.Scratchpad +import XMonad.Actions.RotSlaves +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Actions.SpawnOn as SpawnOn + +import qualified Data.Map as Map +import qualified XMonad.StackSet as W + +import Rahm.Desktop.LayoutList +import Rahm.Desktop.MouseMotion +import Rahm.Desktop.Windows +import Rahm.Desktop.Lib +import Rahm.Desktop.DMenu +import Rahm.Desktop.PassMenu +import Rahm.Desktop.Logger +import Rahm.Desktop.RebindKeys +import Rahm.Desktop.Swallow +import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) + +type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) +type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) + + +spawnX :: String -> X () +spawnX = spawn + +noWindow :: b -> Window -> b +noWindow = const + +decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%" +increaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ +5%" +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 + +button7 :: Button +button7 = 7 + +button8 :: Button +button8 = 8 + +button9 :: Button +button9 = 9 + +button10 :: Button +button10 = 10 + +button11 :: Button +button11 = 11 + +button12 :: Button +button12 = 12 + +button13 :: Button +button13 = 13 + +button14 :: Button +button14 = 14 + +button15 :: Button +button15 = 15 + +keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l +keyBindingToKeymap bindings config = fmap bindingToX (bindings config) + + where + bindingToX b = + case b of + Documented _ (Action x) -> x + Documented _ (Submap mapping) -> + submap (fmap bindingToX mapping) + Documented _ (Repeat mapping) -> + fix $ \recur -> + submap (fmap (\b -> bindingToX b >> recur) mapping) + +keymap :: XConfig l -> KeyBindings +keymap = runKeys $ do + config <- getConfig + + let subkeys keysM = Submap (runKeys keysM config) + repeatable keysM = Repeat (runKeys keysM config) + + bind xK_apostrophe $ do + justMod $ + doc "Jumps between marks." $ + mapNextString $ \_ str -> + case str of + ['\''] -> jumpToLast + [ch] | isAlphaNum ch -> jumpToMark ch + "[" -> historyPrev + "]" -> historyNext + _ -> return () + + shiftMod $ + doc "Swap the current window with a mark." $ + mapNextString $ \_ str -> + case str of + ['\''] -> swapWithLastMark + [ch] | isAlphaNum ch -> swapWithMark ch + _ -> return () + + 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 $ + doc "Spawns XTerm as a fallback if xkb is messed up." $ + spawnX "xterm" + + -- Moves xmobar to different monitors. + justMod $ + doc "Move XMobar to another screen." $ + spawnX "pkill -SIGUSR1 xmobar" + + bind xK_F1 $ do + -- Experimental. Sends 'a' to all windows. + -- + -- I've discovered that many clients ignore such synthetic events, including + -- Spotify, Chrome and Gedit. Some, like Chrome, seem to honor them if it's + -- focused. It's pretty annoying because it keeps me from doing some cool + -- things all for BS security theater, but I guess there might be some way + -- to do this via XTest? + shiftMod $ forAllWindows $ \w -> do + logs $ "Try send to " ++ show w + sendKey (0, xK_a) w + + justMod $ + doc "Print this documentation" + (safeSpawn "gxmessage" [ + "-fn", "Source Code Pro", + documentation (keymap config)] :: X ()) + + bind xK_F7 $ + + justMod $ + doc "Print this documentation." $ + logs (documentation (keymap config)) + + bind xK_F10 $ do + justMod playPauseDoc + + bind xK_F11 $ do + justMod mediaPrevDoc + + bind xK_F12 $ do + justMod mediaNextDoc + + bind xK_Return $ do + justMod swapMaster + + bind xK_Tab $ do + justMod $ windows W.focusDown + shiftMod $ windows W.focusUp + + -- Switch between different screens. These are the leftmost keys on the home + -- row in a Dvorak layout. One might want to switch these to ASD for QWERTY. + forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) -> + bind key $ do + -- Move focus to that screen. + justMod $ + doc ("Switch focus to screen " ++ show idx) $ + withScreen W.view idx + -- Swap the current screen with the one given + altMod $ + doc ("Swap the current screen with screen " ++ show idx) $ + withScreen W.greedyView idx + -- Move the current window to the select screen. + shiftMod $ + doc ("Move the current window to screne " ++ show idx) $ + withScreen W.shift idx + + altgrMod $ + logs "Test altgr" + + bind xK_bracketright $ do + justMod $ + doc "Increase the gaps between windows." $ + sendMessage $ modifyWindowBorder 5 + + bind xK_bracketleft $ do + justMod $ + doc "Decrease the gaps between windows." $ + sendMessage $ modifyWindowBorder (-5) + + bind xK_b $ do + justMod $ spawnX "bluetooth-select.sh" + + bind xK_c $ do + justMod $ + doc "Run PassMenu" runPassMenu + + shiftMod $ + doc "Kill the current window" CopyWindow.kill1 + + bind xK_f $ do + justMod $ + doc "Flip the current layout vertically" $ + sendMessage FlipLayout + shiftMod $ + doc "Flip the current layout horizontally" $ + sendMessage HFlipLayout + + bind xK_g $ do + justMod $ + doc "Goto a workspace\n\n\t\ + + \If the second character typed is alpha-numberic, jump to that\n\t\ + \workspace. The workspace is created on-the-fly if such a workspace\n\t\ + \does not exist.\n\n\t\ + + \If the second character typed is:\n\t\t\ + \]: go to the next workspace\n\t\t\ + \[: go to the previous workspace\n\t\t\ + \}: cycle the workspaces on the screens to the right\n\t\t\ + \{: cycle the workspaces on the screens to the left\n\t\t\ + \: Jump to the accompaning workspace.\n\t\t\ + \F1: display this help.\n" $ + mapNextStringWithKeysym $ \_ keysym str -> + case (keysym, str) of + (_, [ch]) | isAlphaNum ch -> gotoWorkspace ch + (_, "]") -> pushHistory $ withRelativeWorkspace next W.greedyView + (_, "[") -> pushHistory $ withRelativeWorkspace prev W.greedyView + (_, "}") -> windows screenRotateForward + (_, "{") -> windows screenRotateBackward + (_, " ") -> gotoAccompaningWorkspace + + -- Test binding. Tests that I can still submap keysyms alone (keys + -- where XLookupString won't return anything helpful.) + (f, _) | f == xK_F1 -> + (safeSpawn "gxmessage" [ + "-fn", "Source Code Pro", + documentation (keymap config)] :: X ()) + + _ -> return () + shiftMod $ + doc "Move the currently focused window to another workspace" $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> shiftToWorkspace ch + "]" -> withRelativeWorkspace next W.shift + "[" -> withRelativeWorkspace prev W.shift + _ -> return () + shiftAltMod $ + doc "Swap this workspace with another workspace (rename)." $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> swapWorkspace ch + _ -> return () + + bind xK_h $ do + justMod $ + doc "Focus on the next window down in the stack" $ + windows W.focusDown + + shiftMod $ + doc "Swap the current window with the next one down in the stack" $ + windows W.swapDown + + controlMod $ + doc "Rotate all the windows down the stack" + rotAllDown + + bind xK_j $ do + justMod $ + doc "Shrink the size of the zoom region" $ + sendMessage ShrinkZoom + + shiftMod $ + doc "Go to the previous window in history." historyPrev + + bind xK_k $ do + justMod $ + doc "Expand the size of the zoom region" $ + sendMessage ExpandZoom + + shiftMod $ + doc "Go to the next window in history." historyNext + + bind xK_l $ do + justMod $ + doc "Focus the next window in the stack" $ + windows W.focusUp + + shiftMod $ + doc "Swap the currently focused window with the next window in the stack." $ + windows W.swapUp + + controlMod $ + doc "Rotate the windows up." + rotAllUp + + altMod $ + doc "Lock the screen" $ + spawnX "xsecurelock" + + bind xK_minus $ do + justMod $ + doc "Decrease the number of windows in the master region." $ + sendMessage (IncMasterN (-1)) + + shiftMod $ + doc "For mosaic layout, shrink the size-share of the current window" $ + withFocused $ sendMessage . shrinkWindowAlt + + bind xK_m $ do + justMod $ + doc "Mark the current window with the next typed character." $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> markCurrentWindow ch + _ -> return () + + bind xK_n $ do + justMod $ + doc "Shift to the next workspace." $ + withRelativeWorkspace next W.greedyView + + bind xK_p $ do + justMod $ + doc "Shift to the previous workspace." $ + withRelativeWorkspace prev W.greedyView + + bind xK_plus $ do + justMod $ + doc "Increase the number of windows in the master region." $ + sendMessage (IncMasterN 1) + + shiftMod $ + doc "For mosaic layout, increase the size-share of the current window." $ + withFocused $ sendMessage . expandWindowAlt + + bind xK_q $ do + shiftMod $ + doc "Recompile and restart XMonad" $ + spawnX "xmonad --recompile && xmonad --restart" + + justMod $ + doc "Experimental Bindings" $ + subkeys $ do + + bind xK_q $ + (justMod -|- noMod) $ + doc "EXPERIMENTAL: Move mouse to control media." $ + mouseRotateMotion (logs "CW") (logs "CCW") + + bind xK_r $ do + 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" + + bind xK_space $ do + justMod $ + doc "Use the next layout in the layout list." $ sendMessage toNextLayout + + altMod $ + doc "Reset the layout to the default layout." $ sendMessage toFirstLayout + + shiftMod $ + doc "Use the previous layout in the layout list." $ + sendMessage toPreviousLayout + + bind xK_t $ do + justMod $ + doc "Spawn a terminal." $ spawnX (terminal config) + + shiftMod $ + doc "Sink the current window into the tiling." $ withFocused $ windows . W.sink + + altMod $ + doc "Spawn a floating terminal" $ spawnX (terminal config ++ " -t Floating\\ Term") + + bind xK_v $ + -- Allows repeated strokes of M-h and M-l to reduce and increase volume + -- respectively. + justMod $ + doc "Changes the volume." $ + repeatable $ do + bind xK_h $ + justMod $ + doc "Decrease volume." + decreaseVolumeDoc + + bind xK_l $ + justMod $ + doc "Increase volume." + increaseVolumeDoc + + bind xK_v $ + justMod (return () :: X ()) + + bind xK_w $ do + justMod $ doc "Jump to a window (via rofi)" windowJump + + bind xK_x $ do + justMod $ + doc "Toggles respect for struts." $ + sendMessage ToggleStruts + + bind xK_z $ do + + justMod $ + doc "Less often used keybindings." $ + subkeys $ do + + 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) $ + doc "Go to the prior window in the history" historyPrev + + 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_n $ do + (justMod -|- noMod) $ + doc "Go to the next window in the history" historyNext + + 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 $ + 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 mediaPrevDoc + + bind xF86XK_AudioRaiseVolume $ do + noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ +1%" + justMod mediaNextDoc + + bind xF86XK_AudioMute $ do + noMod $ spawnX "pactl set-sink-mute @DEFAULT_SINK@ toggle" + + bind xF86XK_AudioPlay $ do + noMod playPauseDoc + + bind xF86XK_AudioNext $ do + noMod mediaNextDoc + + bind xF86XK_AudioPrev $ do + noMod mediaPrevDoc + + bind xF86XK_AudioPrev $ do + noMod mediaPrevDoc + + bind xF86XK_MonBrightnessUp $ do + noMod $ spawnX "set-backlight.sh +0.05" + justMod $ spawnX "set-backlight.sh 1" + + bind xF86XK_MonBrightnessDown $ do + noMod $ spawnX "set-backlight.sh -0.05" + justMod $ spawnX "set-backlight.sh 0.01" + rawMask shiftMask $ spawnX "set-backlight.sh 0" + +mouseMap :: ButtonsMap l +mouseMap = runButtons $ do + config <- getConfig + + let x button = Map.lookup button (mouseMap config) + + let defaultButtons button = fromMaybe (\w -> return ()) $ + Map.lookup button (mouseMap config) + subMouse = submapButtonsWithKey defaultButtons . flip runButtons config + + + let continuous :: [(Button, X ())] -> Button -> Window -> X () + continuous actions button w = do + case find ((==button) . fst) actions of + Just (_, action) -> action + Nothing -> return () + + (subMouse $ + forM_ (map fst actions) $ \b -> + bind b $ noMod $ \w -> continuous actions b w) w + + bind button1 $ do + justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster + + bind button2 $ do + justMod $ windows . (W.shiftMaster .) . W.focusWindow + + bind button3 $ do + justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster + + bind button6 $ + justMod $ noWindow (withRelativeWorkspace prev W.greedyView) + + bind button7 $ + justMod $ noWindow (withRelativeWorkspace next W.greedyView) + + bind button8 $ + justMod $ noWindow mediaPrev + + bind button9 $ + justMod $ noWindow mediaNext + + bind button14 $ do + noMod $ subMouse $ do + + bind button3 $ + noMod $ noWindow (gotoWorkspace 's') + + bind button13 $ do + noMod $ noWindow $ click >> CopyWindow.kill1 + + bind button14 $ do + noMod $ noWindow $ click >> sendMessage ToggleZoom + + bind button15 $ do + noMod $ noWindow $ spawnX "pavucontrol" + + let mediaButtons = [ + (button4, increaseVolume), + (button5, decreaseVolume), + (button2, playPause), + (button9, historyNext), + (button8, historyPrev), + (button6, mediaPrev), + (button7, mediaNext) + ] + + forM_ (map fst mediaButtons) $ \b -> + bind b $ noMod $ continuous mediaButtons b + + bind button13 $ noMod $ subMouse $ do + bind button1 $ noMod mouseMoveWindow + bind button2 $ noMod $ windows . W.sink + bind button3 $ noMod mouseResizeWindow + + bind button13 $ noMod $ subMouse $ do + bind button13 $ noMod $ subMouse $ do + bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" + bind button1 $ noMod $ noWindow $ + spawnX "sudo -A systemctl suspend && xsecurelock" + + bind button15 $ do + + noMod $ subMouse $ do + bind button13 $ noMod $ noWindow gotoAccompaningWorkspace + + bind button15 $ do + noMod $ noWindow jumpToLast + + + let workspaceButtons = [ + (button2, swapMaster), + + (button9, withRelativeWorkspace next W.greedyView), + (button8, withRelativeWorkspace prev W.greedyView), + + (button4, windows W.focusUp), + (button5, windows W.focusDown), + + (button7, windows screenRotateForward), + (button6, windows screenRotateBackward) + ] + + forM_ (map fst workspaceButtons) $ \b -> + bind b $ noMod $ continuous workspaceButtons b + +-- Bindings specific to a window. These are set similarly to th ekeymap above, +-- but uses a Query monad to tell which windows the keys will apply to. +-- +-- This is useful to create hotkeys in applications where hot keys are not +-- configurable, or to remove keybindings that are irritating (looking at you, +-- ctrl+w in Chrome!!). +windowSpecificBindings :: + XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () +windowSpecificBindings config = do + + w <- lift ask + + let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) + emitKey = flip sendKey w + + configureIf (flip elem browsers <$> className) $ do + + -- if the window is a browser, configure these bindings. Lots of browsers + -- make up their own garbage bindings that are not standard across many + -- other applications. This alleviates the issue. + -- + -- Consistency with terminal: + -- + -- Ctrl+h is backspace + -- Ctrl+w is ctrl+backspace + -- Ctrl+u is ctrl+shift+backspace + -- + -- Consistency with Vim/Emacs-ish: + -- + -- Alt+{Shift,Ctrl,}+{h,j,k,l} -> {Shift,Ctrl,}+{Left,Down,Up,Right} + -- Ctrl+b -> Ctrl+Left + -- Ctrl+e -> Ctrl+Right + -- Ctrl+$ -> End + -- Ctrl+^ -> Home + -- + -- Ctrl+d -> Delete current tab. + + + let mods = permuteMods [shiftMask, controlMask, 0] + + bind xK_h $ do + rawMask controlMask $ emitKey (0, xK_BackSpace) + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Left) + + bind xK_j $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Down) + + bind xK_k $ + forM_ mods $ \mask -> + rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) + + bind xK_l $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) + + bind xK_u $ + rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_BackSpace) + + bind xK_w $ + rawMask controlMask $ emitKey (controlMask, xK_BackSpace) + + bind xK_b $ do + rawMask controlMask $ emitKey (controlMask, xK_Left) + rawMask (controlMask .|. shiftMask) $ + emitKey (controlMask .|. shiftMask, xK_Left) + + bind xK_e $ do + rawMask controlMask $ emitKey (controlMask, xK_Right) + rawMask (controlMask .|. shiftMask) $ + emitKey (controlMask .|. shiftMask, xK_Right) + + bind xK_dollar $ + rawMask controlMask $ emitKey (0, xK_End) + + bind xK_at $ + rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) + + bind xK_d $ + rawMask controlMask $ emitKey (controlMask, xK_w) + + bind xK_F2 $ + -- Experimental. + noMod $ logs "This is a test" + + -- Add a binding to xev as a test. + configureIf (title =? "Event Tester") $ + bind xK_F2 $ + noMod $ emitKey (controlMask, xK_F2) + + where + browsers = ["Google-chrome", "Brave-browser", "firefox-default"] + + -- Create a permutation from a list of modifiers. + -- + -- i.e. permuteMods [C, S, M] will return + -- + -- [C, S, M, C + M, C + S, M + S, C + S + M, 0] + permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False]) + +windowBindings :: XConfig l -> XConfig l +windowBindings xconfig = + xconfig { + startupHook = do + forAllWindows (runQuery doQuery) + startupHook xconfig, + + manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig + } + + where + doQuery :: Query () + doQuery = do + map <- execWriterT $ windowSpecificBindings xconfig + w <- ask + + liftX $ logs $ printf "For Window: %s" (show w) + forM_ (Map.toList map) $ \(key, action) -> do + liftX $ logs $ printf " -- remap: %s" (show key) + remapKey key action + +applyKeys :: XConfig l -> IO (XConfig l) +applyKeys config = + return $ windowBindings $ config { keys = keyBindingToKeymap keymap, mouseBindings = mouseMap } + +click :: X () +click = do + (dpy, root) <- asks $ (,) <$> display <*> theRoot + (_, _, window, _, _, _, _, _) <- io $ queryPointer dpy root + focus window + +modifyWindowBorder :: Integer -> SpacingModifier +modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> + Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) + + where clip i | i < 0 = 0 + clip i = i diff --git a/src/Rahm/Desktop/KeysM.hs b/src/Rahm/Desktop/KeysM.hs new file mode 100644 index 0000000..ef52c24 --- /dev/null +++ b/src/Rahm/Desktop/KeysM.hs @@ -0,0 +1,497 @@ +{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances, TypeFamilies, FlexibleContexts #-} +module Rahm.Desktop.KeysM where + +import Data.List +import Data.Bits ((.&.)) +import Control.Monad.Writer +import Text.Printf +import Control.Arrow (second, first) +import Control.Monad (void) +import Control.Monad.State (State(..), modify', get, execState) +import XMonad +import Data.Map (Map) +import qualified Data.Map as Map + +data Documented t = Documented String t + +data KeyBinding = + Action (X ()) | + Submap KeyBindings | + Repeat KeyBindings + +type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding) + +type ButtonBinding = Window -> X () +type ButtonBindings = Map (KeyMask, Button) ButtonBinding + +{- Module that defines a DSL for binding keys. -} +newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) + deriving (Functor, Applicative, Monad) + +newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a) + deriving (Functor, Applicative, Monad) + +newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a) + deriving (Functor, Applicative, Monad) + +class HasConfig m where + getConfig :: m l (XConfig l) + +class Bindable k where + type BindableValue k :: * + 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 + + rawMask :: KeyMask -> k -> BindingBuilder b () + rawMask m x = BindingBuilder $ modify' (second ((m, toB x):)) + +instance Binding (X ()) (Documented KeyBinding) where + toB = Documented "" . Action + +instance Binding KeyBindings (Documented KeyBinding) where + toB = Documented "" . Submap + +instance Binding a (Documented a) where + toB = Documented "" + +instance Binding a a where + toB = id + +doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding +doc str k = let (Documented _ t) = toB k in Documented str t + +runKeys :: KeysM l a -> XConfig l -> KeyBindings +runKeys (KeysM stateM) config = + snd $ execState stateM (config, Map.empty) + +runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings +runButtons (ButtonsM stateM) config = + snd $ execState stateM (config, Map.empty) + +instance HasConfig KeysM where + getConfig = fst <$> KeysM get + +instance HasConfig ButtonsM where + getConfig = fst <$> ButtonsM get + +{- Generally it is assumed that the mod key shoud be pressed, but not always. -} +noMod :: (Binding k b) => k -> BindingBuilder b () +noMod = rawMask 0 + +maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b () +maskMod mask action = do + modMask <- fst <$> BindingBuilder get + rawMask (modMask .|. mask) action + +altMask :: KeyMask +altMask = mod1Mask + +hyperMask :: KeyMask +hyperMask = mod3Mask + +altgrMask :: KeyMask +altgrMask = 0x80 + +superMask :: KeyMask +superMask = mod4Mask + +justMod :: (Binding k b) => k -> BindingBuilder b () +justMod = maskMod 0 + +instance Bindable KeySym where + type BindableValue KeySym = Documented KeyBinding + type BindableMonad KeySym = KeysM + + -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l () + bind key (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + 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 + + -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () + bind button (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + ButtonsM $ modify' $ second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) + +shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask) + +shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask) + +shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask) + +shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask) + +shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask) + +shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltMod = + maskMod (shiftMask .|. controlMask .|. altMask) + +shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask) + +shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask) + +shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperMod = + maskMod (shiftMask .|. controlMask .|. superMask) + +shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask) + +shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperMod = + maskMod (shiftMask .|. controlMask .|. hyperMask) + +shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltgrMod = + maskMod (shiftMask .|. controlMask .|. altgrMask) + +shiftControlMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlMod = + maskMod (shiftMask .|. controlMask) + +shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask) + +shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask) + +shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperMod = + maskMod (shiftMask .|. altMask .|. superMask) + +shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperMod = + maskMod (shiftMask .|. altMask .|. hyperMask) + +shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltAltgrMod = + maskMod (shiftMask .|. altMask .|. altgrMask) + +shiftAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltMod = + maskMod (shiftMask .|. altMask) + +shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperAltgrMod = + maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperMod = + maskMod (shiftMask .|. superMask .|. hyperMask) + +shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperAltgrMod = + maskMod (shiftMask .|. superMask .|. altgrMask) + +shiftSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperMod = + maskMod (shiftMask .|. superMask) + +shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperAltgrMod = + maskMod (shiftMask .|. hyperMask .|. altgrMask) + +shiftHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperMod = + maskMod (shiftMask .|. hyperMask) + +shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltgrMod = + maskMod (shiftMask .|. altgrMask) + +shiftMod :: (Binding k b) => k -> BindingBuilder b () +shiftMod = maskMod shiftMask + +controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask) + +controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. altgrMask) + +controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperMod = + maskMod (controlMask .|. altMask .|. superMask) + +controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperAltgrMod = + maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask) + +controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperMod = + maskMod (controlMask .|. altMask .|. hyperMask) + +controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltAltgrMod = + maskMod (controlMask .|. altMask .|. altgrMask) + +controlAltMod :: (Binding k b) => k -> BindingBuilder b () +controlAltMod = + maskMod (controlMask .|. altMask) + +controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperAltgrMod = + maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask) + +controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperMod = + maskMod (controlMask .|. superMask .|. hyperMask) + +controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperAltgrMod = + maskMod (controlMask .|. superMask .|. altgrMask) + +controlSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperMod = + maskMod (controlMask .|. superMask) + +controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperAltgrMod = + maskMod (controlMask .|. hyperMask .|. altgrMask) + +controlHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperMod = + maskMod (controlMask .|. hyperMask) + +controlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltgrMod = + maskMod (controlMask .|. altgrMask) + +controlMod :: (Binding k b) => k -> BindingBuilder b () +controlMod = maskMod controlMask + +altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperAltgrMod = + maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask) + +altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperMod = + maskMod (altMask .|. superMask .|. hyperMask) + +altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperAltgrMod = + maskMod (altMask .|. superMask .|. altgrMask) + +altSuperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperMod = + maskMod (altMask .|. superMask) + +altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altHyperAltgrMod = + maskMod (altMask .|. hyperMask .|. altgrMask) + +altHyperMod :: (Binding k b) => k -> BindingBuilder b () +altHyperMod = + maskMod (altMask .|. hyperMask) + +altAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altAltgrMod = + maskMod (altMask .|. altgrMask) + +altMod :: (Binding k b) => k -> BindingBuilder b () +altMod = maskMod altMask + +superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superHyperAltgrMod = + maskMod (superMask .|. hyperMask .|. altgrMask) + +superHyperMod :: (Binding k b) => k -> BindingBuilder b () +superHyperMod = + maskMod (superMask .|. hyperMask) + +superAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superAltgrMod = + maskMod (superMask .|. altgrMask) + +superMod :: (Binding k b) => k -> BindingBuilder b () +superMod = maskMod superMask + +hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +hyperAltgrMod = + maskMod (hyperMask .|. altgrMask) + +hyperMod :: (Binding k b) => k -> BindingBuilder b () +hyperMod = maskMod hyperMask + +altgrMod :: (Binding k b) => k -> BindingBuilder b () +altgrMod = maskMod altgrMask + +{- Can combine two or more of the functions above to apply the same action to + - multiple masks. -} +(-|-) :: (Binding k b) => + (k -> BindingBuilder b ()) -> + (k -> BindingBuilder b ()) -> + k -> BindingBuilder b () +(-|-) fn1 fn2 f = fn1 f >> fn2 f + +{- Meant for submapping, binds all alphanumeric charactes to (fn c). -} +mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbersAndAlpha km fn = do + mapNumbers km fn + mapAlpha km fn + +{- Meant for submapping. This binds all numbers to (fn x) where x is the number + - pressed and fn is the function provided. -} +mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbers km fn = do + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) + [ (xK_0, '0') + , (xK_1, '1') + , (xK_2, '2') + , (xK_3, '3') + , (xK_4, '4') + , (xK_5, '5') + , (xK_6, '6') + , (xK_7, '7') + , (xK_8, '8') + , (xK_9, '9') + -- Programmer Dvorak shifts the numbers so I have to map to their unshifted + -- form. + , (xK_bracketright, '6') + , (xK_exclam, '8') + , (xK_bracketleft, '7') + , (xK_braceleft, '5') + , (xK_braceright, '3') + , (xK_parenleft, '1') + , (xK_equal, '9') + , (xK_asterisk, '0') + , (xK_parenright, '2') + , (xK_plus, '4') ] + +{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the + - character pressed and fn is the function provided. -} +mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapAlpha km fn = + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) [ + (xK_a, 'a') + , (xK_b, 'b') + , (xK_c, 'c') + , (xK_d, 'd') + , (xK_e, 'e') + , (xK_f, 'f') + , (xK_g, 'g') + , (xK_h, 'h') + , (xK_i, 'i') + , (xK_j, 'j') + , (xK_k, 'k') + , (xK_l, 'l') + , (xK_m, 'm') + , (xK_n, 'n') + , (xK_o, 'o') + , (xK_p, 'p') + , (xK_q, 'q') + , (xK_r, 'r') + , (xK_s, 's') + , (xK_t, 't') + , (xK_u, 'u') + , (xK_v, 'v') + , (xK_w, 'w') + , (xK_x, 'x') + , (xK_y, 'y') + , (xK_z, 'z') + ] + + +documentation :: KeyBindings -> String +documentation = execWriter . document' "" + where + 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 ++ " ") submap + Repeat submap -> do + tell pref + tell " (repeatable):\n" + 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]))) + + diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs new file mode 100644 index 0000000..95854b8 --- /dev/null +++ b/src/Rahm/Desktop/Layout.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-} +module Rahm.Desktop.Layout where + +import GHC.TypeLits + +import Data.Proxy (Proxy(..)) +import Rahm.Desktop.CornerLayout (Corner(..)) +import Control.Arrow (second) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Circle +import XMonad.Layout.Accordion +import Control.Applicative +import XMonad.Layout.Spacing +import Data.List +import XMonad.Layout.Spiral +import XMonad.Layout.ThreeColumns +import XMonad.Layout.Grid +import XMonad.Layout.Dishes +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Fullscreen +import qualified XMonad.Layout.Dwindle as D +import XMonad.Layout +import XMonad.Layout.LayoutModifier +import XMonad +import XMonad.Core +import XMonad.Layout.NoBorders (smartBorders, noBorders) + +import Rahm.Desktop.LayoutList +import Rahm.Desktop.Windows + +import qualified Data.Map as M +import qualified XMonad.StackSet as W + +myLayout = + fullscreenFull $ + avoidStruts $ + spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ + layoutZipper $ + mods (reinterpretIncMaster $ spiral (6/7)) |: + mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: + mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: + mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: + mods Grid |: + mods (Dishes 2 (1/6)) |: + mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: + nil + +-- This is a type class that defines how to reinterpret a message. One can think +-- of this as a kind of type-level function. It lets one associate a function +-- (reinterpretMessage) with a type construct, which for the case below is a +-- Symbol. +-- +-- It would be nice to attach this function to the LayoutModifier directly as a +-- value, however LayoutModifiers must be Show-able and Read-able and functions +-- are not. However encoding in the typesystem itsef which function is to be +-- called is the best alternative I have. +class DoReinterpret (k :: t) where + reinterpretMessage :: + Proxy k -> SomeMessage -> X (Maybe SomeMessage) + +-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages +-- intended to modify the master space and instead have those messages expand +-- and shrink the current window. +-- +-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system +-- hacking one can do in Haskell. +instance DoReinterpret "ForMosaic" where + + -- IncMaster message + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do + fmap (SomeMessage . + (if n > 0 + then expandWindowAlt + else shrinkWindowAlt)) <$> getFocusedWindow + + -- ResizeMaster message + reinterpretMessage _ (fromMessage -> Just m) = do + fmap (SomeMessage . + (case m of + Expand -> expandWindowAlt + Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + + -- Messages that don't match the above, just leave it unmodified. + reinterpretMessage _ m = return (Just m) + +instance DoReinterpret "IncMasterToResizeMaster" where + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = + return $ Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink + reinterpretMessage _ m = return (Just m) + +-- Data construct for association a DoReinterpret function with a concrete +-- construct that can be used in the LayoutModifier instance. +-- +-- It wolud be nice to have ReinterpretMessage hold the function as a value +-- rather than delegate to this kind-instance, however, it won't work because +-- LayoutModifiers have to be Read-able and Show-able, and functions are neither +-- of those, so a value-level function may not be a member of a LayoutModifier, +-- thus I have to settle for delegating to a hard-coded instance using +-- type-classes. +data ReinterpretMessage k a = ReinterpretMessage + deriving (Show, Read) + +-- Instance for ReinterpretMessage as a Layout modifier. +instance (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a where + + handleMessOrMaybeModifyIt self message = do + + -- Delegates to the reinterpretMessage function associatied with the + -- type-variable k. + newMessage <- reinterpretMessage (ofProxy self) message + case newMessage of + Just m -> return $ Just $ Right m + Nothing -> return $ Just $ Left self + where + -- ofProxy just provides reifies the phantom type k so the type system can + -- figure out what instance to go to. + ofProxy :: ReinterpretMessage k a -> Proxy k + ofProxy _ = Proxy + +modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a +modifyMosaic = ModifiedLayout ReinterpretMessage + +reinterpretIncMaster :: + l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a +reinterpretIncMaster = ModifiedLayout ReinterpretMessage + +mods = + ModifiedLayout (Zoomable False 0.05 0.05) . + ModifiedLayout (Flippable False) . + ModifiedLayout (HFlippable False) . + ModifiedLayout (Rotateable False) + + +data ModifyDescription m l a = ModifyDescription m (l a) + deriving (Show, Read) + +data TallDescriptionModifier = TallDescriptionModifier + deriving (Show, Read) + +data ThreeColDescMod = ThreeColDescMod + deriving (Show, Read) + +class DescriptionModifier m l where + newDescription :: m -> l a -> String -> String + +instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where + runLayout (W.Workspace t (ModifyDescription m l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + doLayout (ModifyDescription m l) a s = do + (rects, maybeNewLayout) <- doLayout l a s + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + pureLayout (ModifyDescription m l) a s = pureLayout l a s + + emptyLayout (ModifyDescription m l) a = do + (rects, maybeNewLayout) <- emptyLayout l a + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + handleMessage (ModifyDescription m l) a = do + maybeNewLayout <- handleMessage l a + return (ModifyDescription m <$> maybeNewLayout) + + pureMessage (ModifyDescription m l) a = + let maybeNewLayout = pureMessage l a in + ModifyDescription m <$> maybeNewLayout + + description (ModifyDescription m l) = newDescription m l (description l) + +instance DescriptionModifier TallDescriptionModifier Tall where + newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" + +instance DescriptionModifier ThreeColDescMod ThreeCol where + newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" + newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" + +data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable) + +instance Message ResizeZoom where + +newtype Flippable a = Flippable Bool -- True if flipped + deriving (Show, Read) + +newtype HFlippable a = HFlippable Bool -- True if flipped + deriving (Show, Read) + +newtype Rotateable a = Rotateable Bool -- True if rotated + deriving (Show, Read) + +data FlipLayout = FlipLayout deriving (Typeable) + +data HFlipLayout = HFlipLayout deriving (Typeable) + +data DoRotate = DoRotate deriving (Typeable) + +data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window. + deriving (Show, Read) + +-- Toggles if the current window should be zoomed or not. Set the boolean +-- to set the zoom.mhar +data ZoomModifier = + ToggleZoom | + Zoom | + Unzoom + deriving (Typeable) + +instance Message FlipLayout where + +instance Message HFlipLayout where + +instance Message ZoomModifier where + +instance Message DoRotate where + +instance (Eq a) => LayoutModifier Rotateable a where + pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned = + if rotate + then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) + else (returned, Nothing) + where + zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h + unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h + + scaleRect (Rectangle x y w h) = + Rectangle (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) + + fi = fromIntegral + + + pureMess (Rotateable rot) mess = + fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess) + + modifyDescription (Rotateable rot) underlying = + let descr = description underlying in + if rot + then descr ++ " Rotated" + else descr + +instance (Eq a) => LayoutModifier Flippable a where + pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h + + pureMess (Flippable flip) message = + case fromMessage message of + Just FlipLayout -> Just (Flippable (not flip)) + Nothing -> Nothing + + modifyDescription (Flippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " Flipped" + else descr + +instance (Eq a) => LayoutModifier HFlippable a where + pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h + + pureMess (HFlippable flip) message = + case fromMessage message of + Just HFlipLayout -> Just (HFlippable (not flip)) + Nothing -> Nothing + + modifyDescription (HFlippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " HFlipped" + else descr + + +instance (Eq a) => LayoutModifier Zoomable a where + redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned = + if doit + then + let focused = W.focus <$> stack + (zoomed, rest) = partition ((==focused) . Just . fst) returned + in case zoomed of + [] -> return (rest, Nothing) + ((fwin, _):_) -> return ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing) + + else return (returned, Nothing) + where + wp = floor $ fromIntegral w * ws + hp = floor $ fromIntegral h * hs + + handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess = + return $ + (handleResize <$> fromMessage mess) + <|> (Left . handleZoom <$> fromMessage mess) + where + handleResize r = + if showing + then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d) + else Right $ case r of + ShrinkZoom -> SomeMessage Shrink + ExpandZoom -> SomeMessage Expand + + where d = (case r of + ShrinkZoom -> -1 + ExpandZoom -> 1) * 0.02 + + handleZoom ToggleZoom = Zoomable (not showing) sw sh + handleZoom Zoom = Zoomable True sw sh + handleZoom Unzoom = Zoomable False sw sh + + guard f | f > 1 = 1 + | f < 0 = 0 + | otherwise = f diff --git a/src/Rahm/Desktop/LayoutDraw.hs b/src/Rahm/Desktop/LayoutDraw.hs new file mode 100644 index 0000000..c3d8c9e --- /dev/null +++ b/src/Rahm/Desktop/LayoutDraw.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, +ScopedTypeVariables, BangPatterns #-} +module Rahm.Desktop.LayoutDraw (drawLayout) where + +import Control.Monad + +import Control.Arrow (second) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Control.Monad.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Hash (quickHash) +import Rahm.Desktop.Layout (ZoomModifier(..)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (()) +import Text.Printf (printf) +import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) + +import XMonad (X, + Rectangle(..), + Dimension, + LayoutClass, + Message, + Window, + SomeMessage(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +-- Draws and returns an XPM for the current layout. +-- +-- Returns +-- - Bool - true if the xpm has already been written, and is thus cached. +-- - String - description of the current layout +-- - String - the text to send to XMobar +-- +-- This function actually runs the current layout's doLayout function to +-- generate the XPM, so it's completely portable to all layouts. +-- +-- Note this function is impure and running the layout to create the XPM is also +-- impure. While in-practice most layouts are pure, it should be kept in mind. +drawLayout :: X (Bool, String, String) +drawLayout = do + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- foldM (flip ($)) layout [ + handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' Unzoom + ] + + (cached, xpm) <- drawXpmIO layout' + + return (cached , X.description layout, printf "" xpm) + +-- Returns true if a point is inside a rectangle (inclusive). +pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool +pointInRect (x, y) (Rectangle x' y' w h) = + x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce +-- noise from things like AvoidStruts, as there is unfortunately no way to force +-- avoid struts to be off, one can only toggle it. +sf :: (Integral a) => a +sf = 1024 + +handleMessage' :: + (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) +handleMessage' message layout = do + fromMaybe layout <$> X.handleMessage layout (SomeMessage message) + +-- Creates the XPM for the given layout and returns the path to it. +-- +-- This function does run doLayout on the given layout, and that should be +-- accounted for. +drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) +drawXpmIO l = do + dir <- X.getXMonadDir + + let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. + + let (w, h) = (56, 24) + let descr = X.description l + let iconCacheDir = dir "icons" "cache" + let iconPath = iconCacheDir (quickHash descr ++ ".xpm") + + let colors = [ + "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", + "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] + + (rects', _) <- + X.runLayout + (S.Workspace "0" l (S.differentiate [1 .. 5])) + (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) + + let rects = flip map rects' $ \(_, Rectangle x y w h) -> + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) + + X.liftIO $ do + exists <- doesFileExist iconPath + createDirectoryIfMissing True iconCacheDir + + unless exists $ do + let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 + writeFile iconPath xpmText + + return (exists, iconPath) + +-- +-- Create's an XPM, purely. Returns a string with the XPM contents. +-- Takes as arguments +-- +-- - dimensions of the icon. +-- - list of (color, rectangle) pairs. +-- - The amount to shrink the windows by for those pretty gaps. +-- +drawXpm :: + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String +drawXpm (w, h) rects' shrinkAmt = execWriter $ do + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c None\"a,\n" + + forM_ [0 .. h - 1] $ \y -> do + tell "\"" + forM_ [0 .. w - 1] $ \x -> + (case find (matches x y) zipRects of + Nothing -> tell "%" + Just (chr, _) -> tell [chr]) + tell "\"" + when (y /= h - 1 - shrinkAmt) (tell ",") + tell "\n" + tell "};\n" + + where + matches x y (_, (_, r)) = pointInRect (x, y) r + rects = map (second (shrink shrinkAmt)) rects' + guard a b = if a <= shrinkAmt then 1 else b + shrink amt (Rectangle x y w h) = + Rectangle + x + y + (guard w $ w - fromIntegral amt) + (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/LayoutList.hs b/src/Rahm/Desktop/LayoutList.hs new file mode 100644 index 0000000..3bc09d3 --- /dev/null +++ b/src/Rahm/Desktop/LayoutList.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, + FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, + RankNTypes, TupleSections, TypeFamilies #-} + +{- + - This module provides a more powerful version of the "Choose" layout that can + - be bidirectionally navigated. + - + - The indexing uses a type-safe zipper to keep track of the currently-selected + - layout. + -} +module Rahm.Desktop.LayoutList ( + LayoutList, + layoutZipper, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + (|:), + nil + )where + +import Control.Applicative ((<|>)) +import Data.Void +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe, fromJust) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +-- Type-level lists. LNil is the final of the list. LCons contains a layout and a +-- tail. +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +-- Sel - This defines a structure where either this selected, or some +-- other element is selected. +-- +-- These types can be composed to create what is effectively a bounded integer. +-- I.e. there can be a type like +-- +-- Sel (Sel (Sel (Sel End))) +-- +-- Such a type is equivalent to an integer bounded at 4, because this type can +-- exist in no more than 4 states: +-- +-- Sel +-- Skip Sel +-- Skip (Skip Sel) +-- Skip (Skip (Skip Sel)) +-- +-- Note that a type (Sel End) can only be in the Sel as End may not be +-- construted (without using undefined). +data Sel l = + Sel | + (Selector l) => Skip l +deriving instance (Read l, Selector l) => Read (Sel l) +deriving instance (Show l, Selector l) => Show (Sel l) +deriving instance (Eq l, Selector l) => Eq (Sel l) + +-- Reimplement Void as End, just to keep the two separate, but End is for all +-- intents and purposes Void. +data End +deriving instance Read End +deriving instance Show End +deriving instance Eq End + + +-- Types that constitute a selection. Selections can be moved to the next +-- selection, moved to the previous selection, optionally there could be a +-- previous selection and they may be currently selected. +class (Eq c) => Selector c where + -- Increments the selection to the next state + -- + -- Returns Nothing if the selection class is in the final state and cannot be + -- incremented any farther. (This is helpful to facilitate modular + -- arithmatic) + increment :: c -> Maybe c + + -- Decrements the selection to the previous state. Returns Nothing if the + -- state is already in its initial setting. + decrement :: c -> Maybe c + + -- The initial state. + initial :: Maybe c + + -- The final state. + final :: Maybe c + +-- +-- Is selelected can be in two states: +-- +-- 1. The current element is selected +-- 2. The current element is not selected and another element deeper in the +-- structure is selected. +instance (Selector t) => Selector (Sel t) where + -- If the current element is not selected, increment the tail. + increment (Skip l) = Skip <$> increment l + -- If the current element is selected, the increment is just the initial of + -- the tail. + increment Sel = Skip <$> initial + + -- For a selection, the initial is just this in the Sel state. + initial = Just Sel + + -- Looks ahead at the tail, sees if it is selected, if so, select this one + -- instead, if the one ahead isn't selected, then decrement that one. + decrement (Skip t) = Just $ maybe Sel Skip (decrement t) + decrement Sel = Nothing + + -- Navigates to the end of the structure to find the final form. + final = Just $ maybe Sel Skip final + +-- The End structure (which is equivalent to Void) is the "null" selector; the +-- basecase that the Sel selector terminates at. +instance Selector End where + + -- Incrementing the End Selector doesn't do anything. + increment = const Nothing + + -- Decrementing the End Selector doesn't do anythig + decrement = const Nothing + + -- There is no initial value for the End selector. + initial = Nothing + + -- There is not final state for the End selector. + final = Nothing + +-- Increment a selector, but cyclicly +incrementCycle :: (Selector c) => c -> c +incrementCycle c = + case increment c of + Nothing -> fromMaybe c initial + Just x -> x + +-- Add two selectors together, incrementing the first until the second cannot be +-- incremented anymore. +addSelector :: (Selector c) => c -> c -> c +addSelector c1 c2 = addSel c1 (decrement c2) + where + addSel c1 Nothing = c1 + addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) + +-- Turn an int into a selector by repeatably incrementing. +intToSelector :: (Selector c) => Int -> c +intToSelector 0 = fromJust initial +intToSelector n = incrementCycle $ intToSelector (n - 1) + +-- A LayoutList consists of a LayoutSelect type and a corresponding Selector. +data LayoutList l a where + LayoutList :: + (LayoutSelect l a, Selector (SelectorFor l)) => + SelectorFor l -> l a -> LayoutList l a + +deriving instance (LayoutSelect l a) => Show (LayoutList l a) +deriving instance (LayoutSelect l a) => Read (LayoutList l a) + +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons + +infixr 5 |: + +-- Constructs a LayoutList. This function enforces that the SelectorFor l +-- is a 'Sel' type. Essentially this enforces that there must be at least one +-- underlying layout, otherwise a LayoutList cannot be constructed. +layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> LayoutList l a +layoutZipper = LayoutList Sel + +-- The termination of a layout zipper. +nil :: LNil a +nil = LNil + +-- Message to navigate to a layout. +newtype NavigateLayout = + -- Sets the layout based on the given function. + NavigateLayout { + changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) + +-- NavigateLayout instance to move to the next layout, circularly. +toNextLayout :: NavigateLayout +toNextLayout = NavigateLayout $ addSelector (intToSelector 1) + +-- NavigateLayout instance to move to the previous layout, circularly. +toPreviousLayout :: NavigateLayout +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) + +-- NavigateLayotu instance to move to the first layout. +toFirstLayout :: NavigateLayout +toFirstLayout = NavigateLayout (`fromMaybe` initial) + +instance Message NavigateLayout where + +-- LayoutSelect class Describes a type that can be used to select a layout using +-- the associated type SelectorFor. +-- +-- Instances of this class are LCons and LNil. +class (Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l)) => LayoutSelect l a where + + -- The selector that is used to update the layout corresponding to the + -- selector. This selector must be an instance of the Selector class. + type SelectorFor l :: * + + -- Update applies a functor to the selected layout and maybe returns a result + -- and an updated layout. + update :: forall r m. (Monad m) => + -- The selector for this type. Determines which layout the function is + -- applied to. + SelectorFor l -> + -- The LayoutSelect being modified. + l a -> + -- Higher-ordered function to generically apply to the Layout associated + -- with the Selector. Works on all LayoutClass's. + (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> + + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) + +-- Instance for LayoutSelect for cons +instance (Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t)) => + LayoutSelect (LCons l t) a where + + -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure + -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the + -- number of Cons in this structure enforcing safe selection. + type SelectorFor (LCons l t) = Sel (SelectorFor t) + + -- The current layout in this Cons-list is selected. + update Sel (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + -- The current layout is not selected. Move on to another layout. + update (Skip s) (LCons l t) fn = + fmap (second $ \t' -> LCons l t') <$> update s t fn + +-- LNil is a layout select. It doesn't do anything. Indeed update really can't +-- be called on on this because that would require instantiating a End type. +instance LayoutSelect LNil a where + type SelectorFor LNil = End -- LNil cannot be selected. + update _ _ _ = return Nothing + +-- Instance of layout class for LayoutList. The implementation for this +-- just delegates to the underlying LayoutSelect class using the generic +-- update method. +instance (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a where + + runLayout (W.Workspace i (LayoutList idx l) ms) r = do + r <- update idx l $ \layout -> + runLayout (W.Workspace i layout ms) r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + pureLayout (LayoutList idx l) r s = runIdentity $ do + r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) + case r of + Nothing -> return [] + Just (r, a) -> return r + + emptyLayout (LayoutList idx l) r = do + r <- update idx l $ \layout -> emptyLayout layout r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = + return $ Just (LayoutList (fn idx) l) + + handleMessage (LayoutList idx l) m = do + r <- update idx l $ \layout -> ((),) <$> handleMessage layout m + return $ LayoutList idx . snd <$> r + + pureMessage (LayoutList idx l) m = runIdentity $ do + r <- update idx l $ \layout -> return ((), pureMessage layout m) + return $ LayoutList idx . snd <$> r + + description (LayoutList idx l) = runIdentity $ do + r <- update idx l $ \l -> return (description l, Nothing) + return $ + case r of + Nothing -> "No Layout" + Just (descr, _) -> descr diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs new file mode 100644 index 0000000..c90a5d7 --- /dev/null +++ b/src/Rahm/Desktop/Lib.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RankNTypes #-} +module Rahm.Desktop.Lib where + +import Prelude hiding ((!!)) + +import XMonad.Actions.DynamicWorkspaces +import XMonad.Util.Run +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell + +import Rahm.Desktop.PromptConfig + +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Maybe +import Rahm.Desktop.Marking +import Text.Printf +import XMonad hiding (workspaces, Screen) +import XMonad.StackSet hiding (filter, focus) +import qualified Data.Map as Map +import Rahm.Desktop.DMenu +import Data.Ord (comparing) + +import qualified XMonad.StackSet as S +import Rahm.Desktop.Windows + +type WorkspaceName = Char +newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) + +data WinPrompt = WinPrompt + +instance XPrompt WinPrompt where + showXPrompt _ = "[Window] " + commandToComplete _ = id + +data WorkspaceState = Current | Hidden | Visible + deriving (Ord, Eq, Enum) + +-- Returns all the workspaces that are either visible, current or Hidden but +-- have windows and that workspace's state. +-- +-- In other words, filters out workspaces that have no windows and are not +-- visible. +-- +-- This function will sort the result by the workspace tag. +getPopulatedWorkspaces :: + (Ord i) => S.StackSet i l a sid sd -> [(WorkspaceState, S.Workspace i l a)] +getPopulatedWorkspaces (S.StackSet (S.Screen cur _ _) vis hi _) = + sortOn (tag . snd) $ + mapMaybe (\w@(S.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ + map (\(S.Screen w _ _) -> (Visible, w)) vis ++ + [(Current, cur)] + +getHorizontallyOrderedScreens :: + StackSet wid l a ScreenId ScreenDetail -> + [Screen wid l a ScreenId ScreenDetail] +-- ^ Returns a list of screens ordered from leftmost to rightmost. +getHorizontallyOrderedScreens windowSet = + flip sortBy screens $ \sc1 sc2 -> + let (SD (Rectangle x1 _ _ _)) = screenDetail sc1 + (SD (Rectangle x2 _ _ _)) = screenDetail sc2 + in x1 `compare` x2 + where + screens = current windowSet : visible windowSet + +getCurrentWorkspace :: X WorkspaceName +getCurrentWorkspace = withWindowSet $ + \(StackSet (Screen (Workspace t _ _) _ _) _ _ _) -> do + return (head t) + +gotoAccompaningWorkspace :: X () +gotoAccompaningWorkspace = do + cur <- getCurrentWorkspace + if isUpper cur + then gotoWorkspace (toLower cur) + else gotoWorkspace (toUpper cur) + +gotoWorkspace :: WorkspaceName -> X () +gotoWorkspace ch = pushHistory $ do + addHiddenWorkspace [ch] + windows $ greedyView $ return ch + +shiftToWorkspace :: WorkspaceName -> X () +shiftToWorkspace ch = do + addHiddenWorkspace [ch] + (windows . shift . return) ch + +swapWorkspace :: WorkspaceName -> X () +swapWorkspace toWorkspaceName = do + addHiddenWorkspace [toWorkspaceName] + windows $ \ss -> do + let fromWorkspace = tag $ workspace $ current ss + toWorkspace = [toWorkspaceName] in + StackSet (swapSc fromWorkspace toWorkspace $ current ss) + (map (swapSc fromWorkspace toWorkspace) $ visible ss) + (map (swapWs fromWorkspace toWorkspace) $ hidden ss) + (floating ss) + where + swapSc fromWorkspace toWorkspace (Screen ws a b) = + Screen (swapWs fromWorkspace toWorkspace ws) a b + + swapWs fromWorkspace toWorkspace ws@(Workspace t' l s) + | t' == fromWorkspace = Workspace toWorkspace l s + | t' == toWorkspace = Workspace fromWorkspace l s + | otherwise = ws + +fuzzyCompletion :: String -> String -> Bool +fuzzyCompletion str0 str1 = + all (`isInfixOf`l0) ws + where + ws = filter (not . all isSpace) $ words (map toLower str0) + l0 = map toLower str1 + +getString :: Window -> X String +getString = runQuery $ do + t <- title + a <- appName + return $ + if map toLower a `isInfixOf` map toLower t + then t + else printf "%s - %s" t a + +withRelativeWorkspace :: Selector -> (WorkspaceId -> WindowSet -> WindowSet) -> X () +withRelativeWorkspace (Selector selector) fn = + windows $ \ss -> + let tags = sort (tag . snd <$> filter (\x -> fst x /= Visible ) (getPopulatedWorkspaces ss)) + from = tag $ workspace $ current ss + to = selector from tags + in fn to ss + +next :: Selector +next = Selector $ \a l -> select a l l + where select n (x:y:xs) _ | n == x = y + select n [x] (y:_) | n == x = y + select n (x:xs) orig = select n xs orig + select n _ _ = n + +prev :: Selector +prev = Selector $ \a l -> + let (Selector fn) = next in fn a (reverse l) + +withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () +withScreen fn n = do + windows $ \windowSet -> + case getHorizontallyOrderedScreens windowSet !! n of + Nothing -> windowSet + Just screen -> fn (tag $ workspace screen) windowSet + +windowJump :: X () +windowJump = pushHistory $ do + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + + windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId + + case windowId of + Nothing -> return () + Just wid -> focus wid diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs new file mode 100644 index 0000000..c73942f --- /dev/null +++ b/src/Rahm/Desktop/Logger.hs @@ -0,0 +1,32 @@ +module Rahm.Desktop.Logger where + +import XMonad +import qualified XMonad.Util.ExtensibleState as XS +import System.IO + +import Rahm.Desktop.NoPersist + +newtype LoggerState = + LoggerState { + logHandle :: Maybe (NoPersist Handle) + } + +instance ExtensionClass LoggerState where + initialValue = LoggerState Nothing + +logs :: String -> X () +logs s = do + LoggerState handle' <- XS.get + + handle <- + case handle' of + Nothing -> do + handle <- io $ openFile "/tmp/xmonad.log" AppendMode + XS.put $ LoggerState $ Just $ NoPersist handle + return handle + + Just (NoPersist h) -> return h + + io $ do + hPutStrLn handle s + hFlush handle diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs new file mode 100644 index 0000000..8e9867d --- /dev/null +++ b/src/Rahm/Desktop/Marking.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Rahm.Desktop.Marking ( + historyNext, historyPrev, + markCurrentWindow, pushHistory, + jumpToMark, jumpToLast, swapWithLastMark, + swapWithMark + ) where + +import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) +import XMonad +import XMonad.StackSet hiding (focus) +import Data.IORef +import Data.Map (Map) +import Control.Monad (when) + +import System.FilePath +import System.IO +import Control.Exception +import System.Environment +import qualified Data.Sequence as Seq +import Data.Sequence (Seq(..)) + +import qualified XMonad.Util.ExtensibleState as XS + +import qualified Data.Map as Map + +{- Submodule that handles marking windows so they can be jumped back to. -} + +type Mark = Char + +historySize = 100 -- max number of history elements the tail. + +data History a = History [a] (Seq a) + deriving (Read, Show) + +instance Default (History a) where + + def = History [] Seq.empty + +seqPush :: a -> Seq a -> Seq a +seqPush elem s@(seq :|> _) | Seq.length s >= historySize = elem :<| seq +seqPush elem s = elem :<| s + +historyForward :: History a -> History a +historyForward (History (a:as) tail) = History as (seqPush a tail) +historyForward z = z + +historyBackward :: History a -> History a +historyBackward (History head (a :<| as)) = History (a : head) as +historyBackward z = z + +historyCurrent :: History a -> Maybe a +historyCurrent (History (a:_) _) = Just a +historyCurrent _ = Nothing + +historyPush :: (Eq a) => a -> History a -> History a +historyPush a h@(History (w : _) _) | a == w = h +historyPush a (History (w : _) tail) = History [a] (seqPush w tail) +historyPush a (History _ tail) = History [a] tail + +historySwap :: History a -> History a +historySwap (History (a:as) (t :<| ts)) = History (t : as) (seqPush a ts) +historySwap z = z + +historyLast :: History a -> Maybe a +historyLast (History _ (t :<| _)) = Just t +historyLast _ = Nothing + +data Spot = + WindowSpot Window | -- Focus is on a window. + TagSpot String -- Focus is on an (empty) tag + deriving (Read, Show, Eq, Ord) + +greedyFocus :: Spot -> X () +greedyFocus (WindowSpot win) = do + ws <- withWindowSet $ \ss -> + return $ getLocationWorkspace =<< findWindow ss win + + mapM_ (windows . greedyView . tag) ws + focus win +greedyFocus (TagSpot tag) = + windows $ greedyView tag + +data MarkState = + MarkState { + markStateMap :: Map Mark Window + , windowHistory :: History Spot + } deriving (Read, Show) + + +instance ExtensionClass MarkState where + initialValue = MarkState Map.empty def + extensionType = PersistentExtension + +changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState) +changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)} + +withMaybeFocused :: (Maybe Window -> X ()) -> X () +withMaybeFocused f = withWindowSet $ f . peek + +normalizeWindows :: X () +normalizeWindows = do + MarkState { windowHistory = h } <- XS.get + mapM_ greedyFocus (historyCurrent h) + +-- greedyFocus :: Window -> X () +-- greedyFocus win = do +-- ws <- withWindowSet $ \ss -> +-- return $ getLocationWorkspace =<< findWindow ss win +-- +-- mapM_ (windows . greedyView . tag) ws +-- focus win + +markCurrentWindow :: Mark -> X () +markCurrentWindow mark = do + withFocused $ \win -> + XS.modify $ \state@MarkState {markStateMap = ms} -> + state { + markStateMap = Map.insert mark win ms + } + +pushHistory :: X () -> X () +pushHistory fn = do + withMaybeFocused $ \maybeWindowBefore -> do + case maybeWindowBefore of + (Just windowBefore) -> + XS.modify $ changeHistory (historyPush (WindowSpot windowBefore)) + Nothing -> + withWindowSet $ \ws -> + XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws))) + + fn + + withMaybeFocused $ \maybeWindowAfter -> + case maybeWindowAfter of + Just windowAfter -> + XS.modify $ changeHistory (historyPush $ WindowSpot windowAfter) + Nothing -> + withWindowSet $ \ws -> + XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws) + +withHistory :: (History Spot -> X ()) -> X () +withHistory fn = do + MarkState { windowHistory = w } <- XS.get + fn w + +jumpToLast :: X () +jumpToLast = do + XS.modify (changeHistory historySwap) + normalizeWindows + +jumpToMark :: Mark -> X () +jumpToMark mark = do + MarkState {markStateMap = m} <- XS.get + case Map.lookup mark m of + Nothing -> return () + Just w -> pushHistory $ + greedyFocus (WindowSpot w) + +setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd +setFocusedWindow + window + (StackSet (Screen (Workspace t l stack) a b) vis hid float) = + let newStack = + case stack of + Nothing -> Nothing + Just (Stack _ up down) -> Just (Stack window up down) in + StackSet (Screen (Workspace t l newStack) a b) vis hid float + +swapWithFocused :: (Ord a) => a -> StackSet i l a s sd -> StackSet i l a s sd +swapWithFocused winToSwap stackSet = + case peek stackSet of + Nothing -> stackSet + Just focused -> do + setFocusedWindow winToSwap $ + mapWindows ( + \w -> if w == winToSwap then focused else w) stackSet + +swapWithLastMark :: X () +swapWithLastMark = pushHistory $ withHistory $ \hist -> do + + case historyLast hist of + Just (WindowSpot win) -> + windows $ swapWithFocused win + Nothing -> return () + +swapWithMark :: Mark -> X () +swapWithMark mark = pushHistory $ do + MarkState {markStateMap = m} <- XS.get + + case Map.lookup mark m of + Nothing -> return () + Just winToSwap -> do + windows $ swapWithFocused winToSwap + +historyPrev :: X () +historyPrev = do + XS.modify $ changeHistory historyBackward + normalizeWindows + +historyNext :: X () +historyNext = do + XS.modify $ changeHistory historyForward + normalizeWindows diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs new file mode 100644 index 0000000..488f06a --- /dev/null +++ b/src/Rahm/Desktop/MouseMotion.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ViewPatterns, BangPatterns #-} +module Rahm.Desktop.MouseMotion where + +import XMonad + +import Control.Monad (void, forever) +import Text.Printf +import Rahm.Desktop.Submap +import Control.Monad.Loops (iterateWhile) +import Control.Monad.Fix (fix) +import Rahm.Desktop.Logger + +import Linear.V2 +import Linear.Metric + +data Quadrant = NE | SE | SW | NW deriving (Enum, Show) +data Direction = CW | CCW deriving (Enum, Show) + +getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant +getQuadrant (x, y) | x >= 0 && y >= 0 = NE +getQuadrant (x, y) | x < 0 && y >= 0 = SE +getQuadrant (x, y) | x < 0 && y < 0 = SW +getQuadrant (x, y) = NW + + +getDirection :: Quadrant -> Quadrant -> Maybe Direction +getDirectory a b | a == b = Nothing +getDirection SW SE = Just CCW +getDirection SE NE = Just CCW +getDirection NE NW = Just CCW +getDirection NW SW = Just CCW +getDirection _ _ = Just CW + + +liftMouseMotionM :: X a -> MouseMotionM a +liftMouseMotionM = MouseMotionM . fmap Just + +motion :: MouseMotionM (V2 Int) +motion = MouseMotionM $ do + ev <- nextMotionOrButton + case ev of + Right button -> do + logs ("Button " ++ show button) + return Nothing + + Left motion -> return (Just $ uncurry V2 motion) + +motionSize :: Int -> MouseMotionM (V2 Int) +motionSize size = do + let fsize = fromIntegral size + + !firstmotion <- fmap fromIntegral <$> motion + + let get = do + !next <- motion + if distance (fmap fromIntegral next) firstmotion >= fsize + then return next + else get + + get + +runMouseMotionM :: MouseMotionM a -> X (Maybe a) +runMouseMotionM (MouseMotionM a) = a + +execMouseMotionM :: MouseMotionM () -> X () +execMouseMotionM = void . runMouseMotionM + +-- Monad for capturing mouse motion. Terminates and holds Nothing when a +-- button is pressed. +newtype MouseMotionM a = MouseMotionM (X (Maybe a)) + +instance Functor MouseMotionM where + fmap fn (MouseMotionM xma) = MouseMotionM (fmap (fmap fn) xma) + +instance Applicative MouseMotionM where + mf <*> ma = do + !f <- mf + !a <- ma + return (f a) + + pure = return + +instance Monad MouseMotionM where + return a = MouseMotionM (return (Just a)) + (MouseMotionM !xa) >>= fn = MouseMotionM $ do + !ma <- xa + case ma of + Just !a -> + let (MouseMotionM !xb) = fn a in xb + Nothing -> return Nothing + +mouseRotateMotion :: X () -> X () -> X () +mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse + where + doMouse = forever $ do + v <- motion + liftMouseMotionM $ logs $ "Motion: " ++ show v diff --git a/src/Rahm/Desktop/NoPersist.hs b/src/Rahm/Desktop/NoPersist.hs new file mode 100644 index 0000000..66e52da --- /dev/null +++ b/src/Rahm/Desktop/NoPersist.hs @@ -0,0 +1,23 @@ +-- Module for not persisting XMonad state. To be used with ExtensibleState +-- for data types that cannot be persisted. +module Rahm.Desktop.NoPersist where + +import Data.Default (Default, def) +import Data.Typeable + +import XMonad (ExtensionClass(..)) + +newtype NoPersist a = NoPersist a + deriving (Typeable) + +instance Show (NoPersist a) where + show (NoPersist _) = show () + +instance (Default a) => Read (NoPersist a) where + readsPrec i s = map (\(_, s) -> (NoPersist def, s)) (readsPrec i s :: [((), String)]) + +instance (Default a) => Default (NoPersist a) where + def = NoPersist def + +instance (Default a, Typeable a) => ExtensionClass (NoPersist a) where + initialValue = NoPersist def diff --git a/src/Rahm/Desktop/PassMenu.hs b/src/Rahm/Desktop/PassMenu.hs new file mode 100644 index 0000000..4c0b4c5 --- /dev/null +++ b/src/Rahm/Desktop/PassMenu.hs @@ -0,0 +1,13 @@ +module Rahm.Desktop.PassMenu where + +import XMonad +import XMonad.Util.Run +import Control.Monad + +runPassMenu :: X () +runPassMenu = void $ + safeSpawn "rofi-pass" [ + "-p", "Password ", + "-theme-str", + "* {theme-color: #f54245;}"] + diff --git a/src/Rahm/Desktop/PromptConfig.hs b/src/Rahm/Desktop/PromptConfig.hs new file mode 100644 index 0000000..ce45cb2 --- /dev/null +++ b/src/Rahm/Desktop/PromptConfig.hs @@ -0,0 +1,12 @@ +module Rahm.Desktop.PromptConfig where + +import XMonad.Prompt + +xpConfig :: XPConfig +xpConfig = def { + font = "xft:Source Code Pro:size=10" + , bgColor = "#404040" + , fgColor = "#8888ff" + , promptBorderWidth = 0 + , height = 40 + } diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs new file mode 100644 index 0000000..0b4d768 --- /dev/null +++ b/src/Rahm/Desktop/RebindKeys.hs @@ -0,0 +1,119 @@ + +-- Module for intercepting key presses not explicity mapped in the key bindings. +-- This uses some deep magic with grabKey and windows and everything else, but +-- it makes window-specific key bindings awesome! +module Rahm.Desktop.RebindKeys where + +import XMonad + +import Text.Printf +import Control.Monad.Trans.Class (lift) +import Control.Monad (forM, forM_) +import Data.Default (Default, def) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified XMonad.Util.ExtensibleState as XS +import Data.Monoid (All(..)) + +import Rahm.Desktop.Logger +import Rahm.Desktop.NoPersist + +type WindowHook = Query () + +newtype InterceptState = + InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) + +newtype RemapState = + RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) + +instance ExtensionClass InterceptState where + initialValue = InterceptState def + +instance ExtensionClass RemapState where + initialValue = RemapState def + +remapHook :: Event -> X All +remapHook event = do + RemapState (NoPersist map) <- XS.get + + case event of + KeyEvent { ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m } + | typ == keyPress-> do + XConf {display = dpy, theRoot = rootw} <- ask + keysym <- io $ keycodeToKeysym dpy code 0 + + case Map.lookup (win, (m, keysym)) map of + + Just xdo -> do + xdo + return (All False) + + Nothing -> return (All True) + + _ -> return (All True) + +getKeyCodesForKeysym :: Display -> KeySym -> IO [KeyCode] +getKeyCodesForKeysym dpy keysym = do + let (minCode, maxCode) = displayKeycodes dpy + allCodes = [fromIntegral minCode .. fromIntegral maxCode] + + syms <- forM allCodes $ \code -> keycodeToKeysym dpy code 0 + let keysymMap' = Map.fromListWith (++) (zip syms [[code] | code <- allCodes]) + + -- keycodeToKeysym returns noSymbol for all unbound keycodes, and we don't + -- want to grab those whenever someone accidentally uses def :: KeySym + let keysymMap = Map.delete noSymbol keysymMap' + let keysymToKeycodes sym = Map.findWithDefault [] keysym keysymMap + + return $ keysymToKeycodes keysym + + +doGrab :: Display -> Window -> (KeyMask, KeySym) -> X () +doGrab dpy win (keyMask, keysym) = do + let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync + + codes <- io $ getKeyCodesForKeysym dpy keysym + + forM_ codes $ \kc -> + mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers + +disableKey :: (KeyMask, KeySym) -> WindowHook +disableKey key = remapKey key (return ()) + +remapKey :: (KeyMask, KeySym) -> X () -> WindowHook +remapKey keyFrom action = do + window <- ask + Query $ lift $ do + XConf { display = disp, theRoot = rootw } <- ask + doGrab disp window keyFrom + + XS.modify $ \(RemapState (NoPersist keyMap)) -> RemapState $ NoPersist $ + Map.insert (window, keyFrom) action keyMap + +-- sendKey, but as a query. +sendKeyQ :: (KeyMask, KeySym) -> Query () +sendKeyQ key = do + win <- ask + liftX (sendKey key win) + +sendKey :: (KeyMask, KeySym) -> Window -> X () +sendKey (keymask, keysym) w = do + XConf { display = disp, theRoot = rootw } <- ask + + codes <- io $ getKeyCodesForKeysym disp keysym + + case codes of + (keycode:_) -> + io $ allocaXEvent $ \xEv -> do + setEventType xEv keyPress + setKeyEvent xEv w rootw none keymask keycode True + sendEvent disp w True keyPressMask xEv + + setEventType xEv keyRelease + sendEvent disp w True keyReleaseMask xEv + + _ -> return () + +rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook +rebindKey keyFrom keyTo = + (remapKey keyFrom . sendKey keyTo) =<< ask diff --git a/src/Rahm/Desktop/ScreenRotate.hs b/src/Rahm/Desktop/ScreenRotate.hs new file mode 100644 index 0000000..1f238b1 --- /dev/null +++ b/src/Rahm/Desktop/ScreenRotate.hs @@ -0,0 +1,19 @@ +module Rahm.Desktop.ScreenRotate where + +import XMonad.StackSet as W + +screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateBackward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = tail $ cycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + +screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateForward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = rcycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + + where rcycle l = last l : l diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs new file mode 100644 index 0000000..f3b9e23 --- /dev/null +++ b/src/Rahm/Desktop/Submap.hs @@ -0,0 +1,104 @@ +module Rahm.Desktop.Submap ( + mapNextString, + mapNextStringWithKeysym, + submapButtonsWithKey, + nextButton, + nextMotion, + nextMotionOrButton, + module X) where + +import XMonad hiding (keys) +import Control.Monad.Fix (fix) +import qualified Data.Map as Map +import Data.Map (Map) + +import XMonad.Actions.Submap as X + +{- + - Like submap fram XMonad.Actions.Submap, but sends the string from + - XLookupString to the function along side the keysym. + - + - This function allows mappings where the mapped string might be important, + - but also allows submappings for keys that may not have a character associated + - with them (for example, the function keys). + -} +mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X a) -> X a +mapNextStringWithKeysym fn = do + XConf { theRoot = root, display = d } <- ask + io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime + + (m, str, keysym) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do + maskEvent d keyPressMask p + KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + + if isModifierKey keysym + then nextkey + else return (m, str, keysym) + + io $ ungrabKeyboard d currentTime + + fn m keysym str + +{- Like submap, but on the character typed rather than the kysym. -} +mapNextString :: (KeyMask -> String -> X a) -> X a +mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) + +{- Grabs the mouse and returns the next button press. -} +nextButton :: X (ButtonMask, Button) +nextButton = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d buttonPressMask xEv + ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv + return (m, button) + + io $ ungrabPointer d currentTime + + return ret + +{- Grabs the mouse and reports the next mouse motion. -} +nextMotion :: X (Int, Int) +nextMotion = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d pointerMotionMask xEv + MotionEvent { ev_x = x, ev_y = y } <- getEvent xEv + return (fromIntegral x, fromIntegral y) + + io $ ungrabPointer d currentTime + + return ret + +{- Grabs the mouse and reports the next mouse motion or button press. -} +nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button)) +nextMotionOrButton = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d (pointerMotionMask .|. buttonPressMask) xEv + ev <- getEvent xEv + case ev of + MotionEvent { ev_x = x, ev_y = y } -> + return $ Left (fromIntegral x, fromIntegral y) + ButtonEvent { ev_button = button, ev_state = m } -> + return $ Right (m, button) + + io $ ungrabPointer d currentTime + + return ret + +submapButtonsWithKey :: + ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X () +submapButtonsWithKey defaultAction actions window = do + arg <- nextButton + + case Map.lookup arg actions of + Nothing -> defaultAction arg window + Just fn -> fn window diff --git a/src/Rahm/Desktop/Swallow.hs b/src/Rahm/Desktop/Swallow.hs new file mode 100644 index 0000000..1939c58 --- /dev/null +++ b/src/Rahm/Desktop/Swallow.hs @@ -0,0 +1,29 @@ +module Rahm.Desktop.Swallow ( + swallowHook, setSwallowEnabled, isSwallowEnabled, toggleSwallowEnabled) where + +import XMonad +import Data.Monoid (All) +import XMonad.Hooks.WindowSwallowing +import XMonad.Util.ExtensibleState as XS + +data DisableSwallow = DisableSwallow Bool deriving (Show) + +swallowHook :: Event -> X All +swallowHook = swallowEventHook (className =? "Alacritty") $ + liftX $ do + (DisableSwallow disable) <- XS.get + return (not disable) + +isSwallowEnabled :: X Bool +isSwallowEnabled = do + (DisableSwallow b) <- XS.get + return (not b) + +setSwallowEnabled :: Bool -> X () +setSwallowEnabled enable = XS.modify $ const $ DisableSwallow $ not enable + +toggleSwallowEnabled :: X () +toggleSwallowEnabled = (setSwallowEnabled . not) =<< isSwallowEnabled + +instance ExtensionClass DisableSwallow where + initialValue = DisableSwallow False diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs new file mode 100644 index 0000000..b039fdb --- /dev/null +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -0,0 +1,41 @@ +{- Swap window with the master, but save it. -} +module Rahm.Desktop.SwapMaster (swapMaster) where + +import qualified XMonad.StackSet as W + +import Rahm.Desktop.Windows (mapWindows, getMaster, swapWindows) +import Control.Monad.Trans.Maybe +import XMonad (Window, ExtensionClass(..), X(..), windows, windowset) +import Control.Monad (void) +import Control.Monad.Trans (lift) +import Data.Maybe (fromMaybe) +import Control.Monad.State (gets) + +import qualified XMonad.Util.ExtensibleState as XS + +newtype LastWindow = LastWindow { + lastWindow :: Maybe Window + } deriving (Show, Read) + +instance ExtensionClass LastWindow where + initialValue = LastWindow Nothing + +hoist :: (Monad m) => Maybe a -> MaybeT m a +hoist = MaybeT . return + +swapMaster :: X () +swapMaster = void $ runMaybeT $ do + ss <- gets windowset + + focused <- hoist $ W.peek ss + master <- hoist $ getMaster ss + + if focused == master + then do + lw <- MaybeT $ lastWindow <$> XS.get + lift $ windows (swapWindows focused lw) + else lift $ windows (swapWindows focused master) + + lift $ do + XS.put (LastWindow $ Just master) + windows W.focusMaster diff --git a/src/Rahm/Desktop/Windows.hs b/src/Rahm/Desktop/Windows.hs new file mode 100644 index 0000000..d525aac --- /dev/null +++ b/src/Rahm/Desktop/Windows.hs @@ -0,0 +1,86 @@ +module Rahm.Desktop.Windows where + +import XMonad (windowset, X, Window, get) + +import Control.Applicative ((<|>)) +import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) +import Data.Maybe (listToMaybe, catMaybes) +import qualified Data.Map as Map + +mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd +mapWindows fn (StackSet cur vis hid float) = + StackSet + (mapWindowsScreen cur) + (map mapWindowsScreen vis) + (map mapWindowsWorkspace hid) + (Map.mapKeys fn float) + where + mapWindowsScreen (Screen work a b) = Screen (mapWindowsWorkspace work) a b + mapWindowsWorkspace (Workspace t l stack) = + Workspace t l (fmap (mapStack fn) stack) + +-- | What genius decided to hide the instances for the Stack type!!??? +mapStack :: (a -> b) -> Stack a -> Stack b +mapStack fn (Stack focus up down) = Stack (fn focus) (map fn up) (map fn down) + +getMaster :: StackSet i l a s sd -> Maybe a +getMaster (StackSet (Screen (Workspace _ _ ss) _ _) _ _ _) = + head . integrate <$> ss + +swapWindows :: (Ord a) => a -> a -> StackSet i l a s d -> StackSet i l a s d +swapWindows wa wb = mapWindows $ \w -> + case w of + _ | w == wa -> wb + _ | w == wb -> wa + _ -> w + +data WindowLocation i l a s sd = + OnScreen (Screen i l a s sd) | + OnHiddenWorkspace (Workspace i l a) | + Floating + +getLocationWorkspace :: WindowLocation i l a s sd -> Maybe (Workspace i l a) +getLocationWorkspace (OnScreen (Screen w _ _)) = Just w +getLocationWorkspace (OnHiddenWorkspace w) = Just w +getLocationWorkspace _ = Nothing + +workspaceMember :: (Eq a) => Workspace i l a -> a -> Bool +workspaceMember (Workspace _ _ s) w = w `elem` integrate' s + +forAllWindows :: (Window -> X ()) -> X () +forAllWindows fn = do + stackSet <- windowset <$> get + mapM_ fn (allWindows stackSet) + +getFocusedWindow :: X (Maybe Window) +getFocusedWindow = do + peek . windowset <$> get + +{- Finds a Window and returns the screen its on and the workspace its on. + - Returns nothing if the window doesn't exist. + - + - If the window is not a screen Just (Nothing, workspace) is returned. + - If the window is a floating window Just (Nothing, Nothing) is returned. -} +findWindow :: + (Eq a) => StackSet i l a s sd -> a -> Maybe (WindowLocation i l a s sd) +findWindow (StackSet cur vis hid float) win = + listToMaybe . catMaybes $ + map findWindowScreen (cur : vis) ++ + map findWindowWorkspace hid ++ + [findWindowFloat] + + where + findWindowScreen s@(Screen ws _ _) = + if workspaceMember ws win + then Just (OnScreen s) + else Nothing + + findWindowWorkspace w = + if workspaceMember w win + then Just (OnHiddenWorkspace w) + else Nothing + + findWindowFloat = + if win `elem` Map.keys float + then Just Floating + else Nothing diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs new file mode 100644 index 0000000..f3beb86 --- /dev/null +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -0,0 +1,78 @@ +module Rahm.Desktop.XMobarLog ( XMobarLog, spawnXMobar, xMobarLogHook ) where + +import Control.Arrow (second) +import Control.Monad (forM_) +import Control.Monad.Writer (tell, execWriter) +import Data.List (sortBy) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Rahm.Desktop.LayoutDraw (drawLayout) +import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Run (spawnPipe) +import XMonad (X) +import Rahm.Desktop.Lib (getPopulatedWorkspaces, WorkspaceState(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +data XMobarLog = XMobarLog Handle + +-- The log hook for XMobar. This is a custom log hook that does not use any +-- of the Xmonad dynamic log libraries. +-- +-- This is because the given dynamic log libraries don't handle unicode properly +-- and this has been causing issues. It is also more flexible and frankly easier +-- to just DIY. + +spawnXMobar :: IO XMobarLog +spawnXMobar = do + pipe <- spawnPipe "xmobar" + hSetEncoding pipe utf8 + return (XMobarLog pipe) + + +-- XMonad Log Hook meant to be used with the XMonad config logHook. +xMobarLogHook :: XMobarLog -> X () +xMobarLogHook (XMobarLog xmproc) = do + (_, _, layoutXpm) <- drawLayout + + winset <- X.gets X.windowset + title <- maybe (pure "") (fmap show . getName) . S.peek $ winset + let wss = getPopulatedWorkspaces winset + + X.liftIO $ do + hPutStrLn xmproc $ trunc 80 $ execWriter $ do + tell layoutXpm + tell $ " │ " + + forM_ wss $ \(t, ws) -> do + case t of + Current -> tell "" + Visible -> tell "" + Hidden -> tell "" + tell (S.tag ws) + tell " " + + tell $ "│ " + tell $ title + tell $ "" + +-- Truncate an XMobar string to the provided number of _visible_ characters. +-- This is to keep long window titles from overrunning the whole bar. +trunc :: Int -> String -> String +trunc amt str = reverse $ trunc' False amt str [] + where + trunc' _ _ [] acc = acc + trunc' ignore amt (a:as) acc = + case a of + '<' -> trunc' True amt as (a : acc) + '>' -> trunc' False amt as (a : acc) + _ -> + if ignore + then trunc' True amt as (a : acc) + else + case amt of + 0 -> trunc' False 0 as acc + 3 -> trunc' False 0 as ("..." ++ acc) + _ -> trunc' False (amt - 1) as (a : acc) -- cgit From 49f20ca3391ca713c021fdf15bf9db3fe54f18f6 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 10 Apr 2022 13:51:43 -0600 Subject: More refactoring. Started breaking up Layout. Moved Language extensions into stack file. --- src/Rahm/Desktop/CornerLayout.hs | 58 ----- src/Rahm/Desktop/Keys.hs | 5 +- src/Rahm/Desktop/KeysM.hs | 2 - src/Rahm/Desktop/Layout.hs | 326 -------------------------- src/Rahm/Desktop/Layout/CornerLayout.hs | 57 +++++ src/Rahm/Desktop/Layout/Layout.hs | 283 ++++++++++++++++++++++ src/Rahm/Desktop/Layout/LayoutDraw.hs | 155 ++++++++++++ src/Rahm/Desktop/Layout/LayoutList.hs | 295 +++++++++++++++++++++++ src/Rahm/Desktop/Layout/ReinterpretMessage.hs | 48 ++++ src/Rahm/Desktop/LayoutDraw.hs | 155 ------------ src/Rahm/Desktop/LayoutList.hs | 297 ----------------------- src/Rahm/Desktop/Lib.hs | 1 - src/Rahm/Desktop/Marking.hs | 1 - src/Rahm/Desktop/MouseMotion.hs | 1 - src/Rahm/Desktop/XMobarLog.hs | 2 +- 15 files changed, 841 insertions(+), 845 deletions(-) delete mode 100644 src/Rahm/Desktop/CornerLayout.hs delete mode 100644 src/Rahm/Desktop/Layout.hs create mode 100644 src/Rahm/Desktop/Layout/CornerLayout.hs create mode 100644 src/Rahm/Desktop/Layout/Layout.hs create mode 100644 src/Rahm/Desktop/Layout/LayoutDraw.hs create mode 100644 src/Rahm/Desktop/Layout/LayoutList.hs create mode 100644 src/Rahm/Desktop/Layout/ReinterpretMessage.hs delete mode 100644 src/Rahm/Desktop/LayoutDraw.hs delete mode 100644 src/Rahm/Desktop/LayoutList.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/CornerLayout.hs b/src/Rahm/Desktop/CornerLayout.hs deleted file mode 100644 index 33f439e..0000000 --- a/src/Rahm/Desktop/CornerLayout.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} --- Creates a layout, the "corner layout" that keeps the master window in the --- corner and the other windows go around it. -module Rahm.Desktop.CornerLayout where - -import Data.Typeable (Typeable) -import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) -import qualified XMonad.StackSet as S - -data Corner a = Corner Rational Rational - deriving (Show, Typeable, Read) - -instance LayoutClass Corner a where - pureLayout (Corner frac _) screen@(Rectangle x y w h) ss = - let w' = floor $ fromIntegral w * frac - h' = floor $ fromIntegral h * frac - corner = Rectangle 0 0 w' h' - vertRect = Rectangle (fromIntegral w') 0 (w - w') h - horizRect = Rectangle 0 (fromIntegral h') w' (h - h') - ws = S.integrate ss - - vn = (length ws - 1) `div` 2 - hn = (length ws - 1) - vn - in - case ws of - [a] -> [(a, screen)] - [a, b] -> [ - (a, Rectangle x y w' h), - (b, Rectangle (x + fromIntegral w') y (w - w') h)] - _ -> - zip ws $ map ( - \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $ - corner : - splitVert vertRect vn ++ - splitHoriz horizRect hn - - pureMessage (Corner frac delta) m = fmap resize (fromMessage m) - where - resize Shrink = Corner (frac - delta) delta - resize Expand = Corner (frac + delta) delta - -splitVert :: Rectangle -> Int -> [Rectangle] -splitVert (Rectangle x y w h) i' = - map - (\i -> Rectangle x (y + fromIntegral (step * i)) w step) - [0 .. i - 1] - where - i = fromIntegral i' - step = h `div` i - -splitHoriz :: Rectangle -> Int -> [Rectangle] -splitHoriz (Rectangle x y w h) i' = - map - (\i -> Rectangle (x + fromIntegral (step * i)) y step h) - [0 .. i - 1] - where - step = w `div` i - i = fromIntegral i' diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 9712f84..0bebd6f 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} module Rahm.Desktop.Keys (applyKeys) where import XMonad.Util.Run (safeSpawn) @@ -26,7 +25,7 @@ import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Rahm.Desktop.Layout +import Rahm.Desktop.Layout.Layout import Rahm.Desktop.Marking import Rahm.Desktop.PromptConfig import System.IO @@ -46,7 +45,7 @@ import XMonad.Actions.SpawnOn as SpawnOn import qualified Data.Map as Map import qualified XMonad.StackSet as W -import Rahm.Desktop.LayoutList +import Rahm.Desktop.Layout.LayoutList import Rahm.Desktop.MouseMotion import Rahm.Desktop.Windows import Rahm.Desktop.Lib diff --git a/src/Rahm/Desktop/KeysM.hs b/src/Rahm/Desktop/KeysM.hs index ef52c24..dcbce2a 100644 --- a/src/Rahm/Desktop/KeysM.hs +++ b/src/Rahm/Desktop/KeysM.hs @@ -1,5 +1,3 @@ -{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses, - FunctionalDependencies, FlexibleInstances, TypeFamilies, FlexibleContexts #-} module Rahm.Desktop.KeysM where import Data.List diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs deleted file mode 100644 index 95854b8..0000000 --- a/src/Rahm/Desktop/Layout.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-} -module Rahm.Desktop.Layout where - -import GHC.TypeLits - -import Data.Proxy (Proxy(..)) -import Rahm.Desktop.CornerLayout (Corner(..)) -import Control.Arrow (second) -import XMonad.Hooks.ManageDocks -import XMonad.Layout.Circle -import XMonad.Layout.Accordion -import Control.Applicative -import XMonad.Layout.Spacing -import Data.List -import XMonad.Layout.Spiral -import XMonad.Layout.ThreeColumns -import XMonad.Layout.Grid -import XMonad.Layout.Dishes -import XMonad.Layout.MosaicAlt -import XMonad.Layout.Fullscreen -import qualified XMonad.Layout.Dwindle as D -import XMonad.Layout -import XMonad.Layout.LayoutModifier -import XMonad -import XMonad.Core -import XMonad.Layout.NoBorders (smartBorders, noBorders) - -import Rahm.Desktop.LayoutList -import Rahm.Desktop.Windows - -import qualified Data.Map as M -import qualified XMonad.StackSet as W - -myLayout = - fullscreenFull $ - avoidStruts $ - spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ - layoutZipper $ - mods (reinterpretIncMaster $ spiral (6/7)) |: - mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: - mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: - mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: - mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: - mods Grid |: - mods (Dishes 2 (1/6)) |: - mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: - nil - --- This is a type class that defines how to reinterpret a message. One can think --- of this as a kind of type-level function. It lets one associate a function --- (reinterpretMessage) with a type construct, which for the case below is a --- Symbol. --- --- It would be nice to attach this function to the LayoutModifier directly as a --- value, however LayoutModifiers must be Show-able and Read-able and functions --- are not. However encoding in the typesystem itsef which function is to be --- called is the best alternative I have. -class DoReinterpret (k :: t) where - reinterpretMessage :: - Proxy k -> SomeMessage -> X (Maybe SomeMessage) - --- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages --- intended to modify the master space and instead have those messages expand --- and shrink the current window. --- --- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system --- hacking one can do in Haskell. -instance DoReinterpret "ForMosaic" where - - -- IncMaster message - reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do - fmap (SomeMessage . - (if n > 0 - then expandWindowAlt - else shrinkWindowAlt)) <$> getFocusedWindow - - -- ResizeMaster message - reinterpretMessage _ (fromMessage -> Just m) = do - fmap (SomeMessage . - (case m of - Expand -> expandWindowAlt - Shrink -> shrinkWindowAlt)) <$> getFocusedWindow - - -- Messages that don't match the above, just leave it unmodified. - reinterpretMessage _ m = return (Just m) - -instance DoReinterpret "IncMasterToResizeMaster" where - reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = - return $ Just $ - if n > 0 - then SomeMessage Expand - else SomeMessage Shrink - reinterpretMessage _ m = return (Just m) - --- Data construct for association a DoReinterpret function with a concrete --- construct that can be used in the LayoutModifier instance. --- --- It wolud be nice to have ReinterpretMessage hold the function as a value --- rather than delegate to this kind-instance, however, it won't work because --- LayoutModifiers have to be Read-able and Show-able, and functions are neither --- of those, so a value-level function may not be a member of a LayoutModifier, --- thus I have to settle for delegating to a hard-coded instance using --- type-classes. -data ReinterpretMessage k a = ReinterpretMessage - deriving (Show, Read) - --- Instance for ReinterpretMessage as a Layout modifier. -instance (DoReinterpret k) => - LayoutModifier (ReinterpretMessage k) a where - - handleMessOrMaybeModifyIt self message = do - - -- Delegates to the reinterpretMessage function associatied with the - -- type-variable k. - newMessage <- reinterpretMessage (ofProxy self) message - case newMessage of - Just m -> return $ Just $ Right m - Nothing -> return $ Just $ Left self - where - -- ofProxy just provides reifies the phantom type k so the type system can - -- figure out what instance to go to. - ofProxy :: ReinterpretMessage k a -> Proxy k - ofProxy _ = Proxy - -modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a -modifyMosaic = ModifiedLayout ReinterpretMessage - -reinterpretIncMaster :: - l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a -reinterpretIncMaster = ModifiedLayout ReinterpretMessage - -mods = - ModifiedLayout (Zoomable False 0.05 0.05) . - ModifiedLayout (Flippable False) . - ModifiedLayout (HFlippable False) . - ModifiedLayout (Rotateable False) - - -data ModifyDescription m l a = ModifyDescription m (l a) - deriving (Show, Read) - -data TallDescriptionModifier = TallDescriptionModifier - deriving (Show, Read) - -data ThreeColDescMod = ThreeColDescMod - deriving (Show, Read) - -class DescriptionModifier m l where - newDescription :: m -> l a -> String -> String - -instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where - runLayout (W.Workspace t (ModifyDescription m l) a) rect = do - (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - doLayout (ModifyDescription m l) a s = do - (rects, maybeNewLayout) <- doLayout l a s - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - pureLayout (ModifyDescription m l) a s = pureLayout l a s - - emptyLayout (ModifyDescription m l) a = do - (rects, maybeNewLayout) <- emptyLayout l a - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - handleMessage (ModifyDescription m l) a = do - maybeNewLayout <- handleMessage l a - return (ModifyDescription m <$> maybeNewLayout) - - pureMessage (ModifyDescription m l) a = - let maybeNewLayout = pureMessage l a in - ModifyDescription m <$> maybeNewLayout - - description (ModifyDescription m l) = newDescription m l (description l) - -instance DescriptionModifier TallDescriptionModifier Tall where - newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" - -instance DescriptionModifier ThreeColDescMod ThreeCol where - newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" - newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" - -data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable) - -instance Message ResizeZoom where - -newtype Flippable a = Flippable Bool -- True if flipped - deriving (Show, Read) - -newtype HFlippable a = HFlippable Bool -- True if flipped - deriving (Show, Read) - -newtype Rotateable a = Rotateable Bool -- True if rotated - deriving (Show, Read) - -data FlipLayout = FlipLayout deriving (Typeable) - -data HFlipLayout = HFlipLayout deriving (Typeable) - -data DoRotate = DoRotate deriving (Typeable) - -data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window. - deriving (Show, Read) - --- Toggles if the current window should be zoomed or not. Set the boolean --- to set the zoom.mhar -data ZoomModifier = - ToggleZoom | - Zoom | - Unzoom - deriving (Typeable) - -instance Message FlipLayout where - -instance Message HFlipLayout where - -instance Message ZoomModifier where - -instance Message DoRotate where - -instance (Eq a) => LayoutModifier Rotateable a where - pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned = - if rotate - then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) - else (returned, Nothing) - where - zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h - unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h - - scaleRect (Rectangle x y w h) = - Rectangle (x * fi sw `div` fi sh) - (y * fi sh `div` fi sw) - (w * sw `div` sh) - (h * sh `div` sw) - - fi = fromIntegral - - - pureMess (Rotateable rot) mess = - fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess) - - modifyDescription (Rotateable rot) underlying = - let descr = description underlying in - if rot - then descr ++ " Rotated" - else descr - -instance (Eq a) => LayoutModifier Flippable a where - pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned = - if flip - then (map (second doFlip) returned, Nothing) - else (returned, Nothing) - where - doFlip (Rectangle x y w h) = - Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h - - pureMess (Flippable flip) message = - case fromMessage message of - Just FlipLayout -> Just (Flippable (not flip)) - Nothing -> Nothing - - modifyDescription (Flippable flipped) underlying = - let descr = description underlying in - if flipped - then descr ++ " Flipped" - else descr - -instance (Eq a) => LayoutModifier HFlippable a where - pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned = - if flip - then (map (second doFlip) returned, Nothing) - else (returned, Nothing) - where - doFlip (Rectangle x y w h) = - Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h - - pureMess (HFlippable flip) message = - case fromMessage message of - Just HFlipLayout -> Just (HFlippable (not flip)) - Nothing -> Nothing - - modifyDescription (HFlippable flipped) underlying = - let descr = description underlying in - if flipped - then descr ++ " HFlipped" - else descr - - -instance (Eq a) => LayoutModifier Zoomable a where - redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned = - if doit - then - let focused = W.focus <$> stack - (zoomed, rest) = partition ((==focused) . Just . fst) returned - in case zoomed of - [] -> return (rest, Nothing) - ((fwin, _):_) -> return ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing) - - else return (returned, Nothing) - where - wp = floor $ fromIntegral w * ws - hp = floor $ fromIntegral h * hs - - handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess = - return $ - (handleResize <$> fromMessage mess) - <|> (Left . handleZoom <$> fromMessage mess) - where - handleResize r = - if showing - then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d) - else Right $ case r of - ShrinkZoom -> SomeMessage Shrink - ExpandZoom -> SomeMessage Expand - - where d = (case r of - ShrinkZoom -> -1 - ExpandZoom -> 1) * 0.02 - - handleZoom ToggleZoom = Zoomable (not showing) sw sh - handleZoom Zoom = Zoomable True sw sh - handleZoom Unzoom = Zoomable False sw sh - - guard f | f > 1 = 1 - | f < 0 = 0 - | otherwise = f diff --git a/src/Rahm/Desktop/Layout/CornerLayout.hs b/src/Rahm/Desktop/Layout/CornerLayout.hs new file mode 100644 index 0000000..f0952c7 --- /dev/null +++ b/src/Rahm/Desktop/Layout/CornerLayout.hs @@ -0,0 +1,57 @@ +-- Creates a layout, the "corner layout" that keeps the master window in the +-- corner and the other windows go around it. +module Rahm.Desktop.Layout.CornerLayout where + +import Data.Typeable (Typeable) +import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) +import qualified XMonad.StackSet as S + +data Corner a = Corner Rational Rational + deriving (Show, Typeable, Read) + +instance LayoutClass Corner a where + pureLayout (Corner frac _) screen@(Rectangle x y w h) ss = + let w' = floor $ fromIntegral w * frac + h' = floor $ fromIntegral h * frac + corner = Rectangle 0 0 w' h' + vertRect = Rectangle (fromIntegral w') 0 (w - w') h + horizRect = Rectangle 0 (fromIntegral h') w' (h - h') + ws = S.integrate ss + + vn = (length ws - 1) `div` 2 + hn = (length ws - 1) - vn + in + case ws of + [a] -> [(a, screen)] + [a, b] -> [ + (a, Rectangle x y w' h), + (b, Rectangle (x + fromIntegral w') y (w - w') h)] + _ -> + zip ws $ map ( + \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $ + corner : + splitVert vertRect vn ++ + splitHoriz horizRect hn + + pureMessage (Corner frac delta) m = fmap resize (fromMessage m) + where + resize Shrink = Corner (frac - delta) delta + resize Expand = Corner (frac + delta) delta + +splitVert :: Rectangle -> Int -> [Rectangle] +splitVert (Rectangle x y w h) i' = + map + (\i -> Rectangle x (y + fromIntegral (step * i)) w step) + [0 .. i - 1] + where + i = fromIntegral i' + step = h `div` i + +splitHoriz :: Rectangle -> Int -> [Rectangle] +splitHoriz (Rectangle x y w h) i' = + map + (\i -> Rectangle (x + fromIntegral (step * i)) y step h) + [0 .. i - 1] + where + step = w `div` i + i = fromIntegral i' diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs new file mode 100644 index 0000000..93228e7 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -0,0 +1,283 @@ +module Rahm.Desktop.Layout.Layout where + +import GHC.TypeLits + +import Data.Proxy (Proxy(..)) +import Control.Arrow (second) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Circle +import XMonad.Layout.Accordion +import Control.Applicative +import XMonad.Layout.Spacing +import Data.List +import XMonad.Layout.Spiral +import XMonad.Layout.ThreeColumns +import XMonad.Layout.Grid +import XMonad.Layout.Dishes +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Fullscreen +import qualified XMonad.Layout.Dwindle as D +import XMonad.Layout +import XMonad.Layout.LayoutModifier +import XMonad +import XMonad.Core +import XMonad.Layout.NoBorders (smartBorders, noBorders) + +import Rahm.Desktop.Layout.CornerLayout (Corner(..)) +import Rahm.Desktop.Layout.LayoutList +import Rahm.Desktop.Windows +import Rahm.Desktop.Layout.ReinterpretMessage + +import qualified Data.Map as M +import qualified XMonad.StackSet as W + +myLayout = + fullscreenFull $ + avoidStruts $ + spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ + layoutZipper $ + mods (reinterpretIncMaster $ spiral (6/7)) |: + mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: + mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: + mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: + mods Grid |: + mods (Dishes 2 (1/6)) |: + mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: + nil + +-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages +-- intended to modify the master space and instead have those messages expand +-- and shrink the current window. +-- +-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system +-- hacking one can do in Haskell. +instance DoReinterpret "ForMosaic" where + + -- IncMaster message + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do + fmap (SomeMessage . + (if n > 0 + then expandWindowAlt + else shrinkWindowAlt)) <$> getFocusedWindow + + -- ResizeMaster message + reinterpretMessage _ (fromMessage -> Just m) = do + fmap (SomeMessage . + (case m of + Expand -> expandWindowAlt + Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + + -- Messages that don't match the above, just leave it unmodified. + reinterpretMessage _ m = return (Just m) + +instance DoReinterpret "IncMasterToResizeMaster" where + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = + return $ Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink + reinterpretMessage _ m = return (Just m) + +modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a +modifyMosaic = ModifiedLayout ReinterpretMessage + +reinterpretIncMaster :: + l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a +reinterpretIncMaster = ModifiedLayout ReinterpretMessage + +mods = + ModifiedLayout (Zoomable False 0.05 0.05) . + ModifiedLayout (Flippable False) . + ModifiedLayout (HFlippable False) . + ModifiedLayout (Rotateable False) + + +data ModifyDescription m l a = ModifyDescription m (l a) + deriving (Show, Read) + +data TallDescriptionModifier = TallDescriptionModifier + deriving (Show, Read) + +data ThreeColDescMod = ThreeColDescMod + deriving (Show, Read) + +class DescriptionModifier m l where + newDescription :: m -> l a -> String -> String + +instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where + runLayout (W.Workspace t (ModifyDescription m l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + doLayout (ModifyDescription m l) a s = do + (rects, maybeNewLayout) <- doLayout l a s + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + pureLayout (ModifyDescription m l) a s = pureLayout l a s + + emptyLayout (ModifyDescription m l) a = do + (rects, maybeNewLayout) <- emptyLayout l a + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + handleMessage (ModifyDescription m l) a = do + maybeNewLayout <- handleMessage l a + return (ModifyDescription m <$> maybeNewLayout) + + pureMessage (ModifyDescription m l) a = + let maybeNewLayout = pureMessage l a in + ModifyDescription m <$> maybeNewLayout + + description (ModifyDescription m l) = newDescription m l (description l) + +instance DescriptionModifier TallDescriptionModifier Tall where + newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" + +instance DescriptionModifier ThreeColDescMod ThreeCol where + newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" + newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" + +data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable) + +instance Message ResizeZoom where + +newtype Flippable a = Flippable Bool -- True if flipped + deriving (Show, Read) + +newtype HFlippable a = HFlippable Bool -- True if flipped + deriving (Show, Read) + +newtype Rotateable a = Rotateable Bool -- True if rotated + deriving (Show, Read) + +data FlipLayout = FlipLayout deriving (Typeable) + +data HFlipLayout = HFlipLayout deriving (Typeable) + +data DoRotate = DoRotate deriving (Typeable) + +data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window. + deriving (Show, Read) + +-- Toggles if the current window should be zoomed or not. Set the boolean +-- to set the zoom.mhar +data ZoomModifier = + ToggleZoom | + Zoom | + Unzoom + deriving (Typeable) + +instance Message FlipLayout where + +instance Message HFlipLayout where + +instance Message ZoomModifier where + +instance Message DoRotate where + +instance (Eq a) => LayoutModifier Rotateable a where + pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned = + if rotate + then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) + else (returned, Nothing) + where + zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h + unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h + + scaleRect (Rectangle x y w h) = + Rectangle (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) + + fi = fromIntegral + + + pureMess (Rotateable rot) mess = + fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess) + + modifyDescription (Rotateable rot) underlying = + let descr = description underlying in + if rot + then descr ++ " Rotated" + else descr + +instance (Eq a) => LayoutModifier Flippable a where + pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h + + pureMess (Flippable flip) message = + case fromMessage message of + Just FlipLayout -> Just (Flippable (not flip)) + Nothing -> Nothing + + modifyDescription (Flippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " Flipped" + else descr + +instance (Eq a) => LayoutModifier HFlippable a where + pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h + + pureMess (HFlippable flip) message = + case fromMessage message of + Just HFlipLayout -> Just (HFlippable (not flip)) + Nothing -> Nothing + + modifyDescription (HFlippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " HFlipped" + else descr + + +instance (Eq a) => LayoutModifier Zoomable a where + redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned = + if doit + then + let focused = W.focus <$> stack + (zoomed, rest) = partition ((==focused) . Just . fst) returned + in case zoomed of + [] -> return (rest, Nothing) + ((fwin, _):_) -> return ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing) + + else return (returned, Nothing) + where + wp = floor $ fromIntegral w * ws + hp = floor $ fromIntegral h * hs + + handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess = + return $ + (handleResize <$> fromMessage mess) + <|> (Left . handleZoom <$> fromMessage mess) + where + handleResize r = + if showing + then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d) + else Right $ case r of + ShrinkZoom -> SomeMessage Shrink + ExpandZoom -> SomeMessage Expand + + where d = (case r of + ShrinkZoom -> -1 + ExpandZoom -> 1) * 0.02 + + handleZoom ToggleZoom = Zoomable (not showing) sw sh + handleZoom Zoom = Zoomable True sw sh + handleZoom Unzoom = Zoomable False sw sh + + guard f | f > 1 = 1 + | f < 0 = 0 + | otherwise = f diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs new file mode 100644 index 0000000..7e59284 --- /dev/null +++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, +ScopedTypeVariables, BangPatterns #-} +module Rahm.Desktop.Layout.LayoutDraw (drawLayout) where + +import Control.Monad + +import Control.Arrow (second) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Control.Monad.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Hash (quickHash) +import Rahm.Desktop.Layout.Layout (ZoomModifier(..)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (()) +import Text.Printf (printf) +import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) + +import XMonad (X, + Rectangle(..), + Dimension, + LayoutClass, + Message, + Window, + SomeMessage(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +-- Draws and returns an XPM for the current layout. +-- +-- Returns +-- - Bool - true if the xpm has already been written, and is thus cached. +-- - String - description of the current layout +-- - String - the text to send to XMobar +-- +-- This function actually runs the current layout's doLayout function to +-- generate the XPM, so it's completely portable to all layouts. +-- +-- Note this function is impure and running the layout to create the XPM is also +-- impure. While in-practice most layouts are pure, it should be kept in mind. +drawLayout :: X (Bool, String, String) +drawLayout = do + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- foldM (flip ($)) layout [ + handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' Unzoom + ] + + (cached, xpm) <- drawXpmIO layout' + + return (cached , X.description layout, printf "" xpm) + +-- Returns true if a point is inside a rectangle (inclusive). +pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool +pointInRect (x, y) (Rectangle x' y' w h) = + x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce +-- noise from things like AvoidStruts, as there is unfortunately no way to force +-- avoid struts to be off, one can only toggle it. +sf :: (Integral a) => a +sf = 1024 + +handleMessage' :: + (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) +handleMessage' message layout = do + fromMaybe layout <$> X.handleMessage layout (SomeMessage message) + +-- Creates the XPM for the given layout and returns the path to it. +-- +-- This function does run doLayout on the given layout, and that should be +-- accounted for. +drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) +drawXpmIO l = do + dir <- X.getXMonadDir + + let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. + + let (w, h) = (56, 24) + let descr = X.description l + let iconCacheDir = dir "icons" "cache" + let iconPath = iconCacheDir (quickHash descr ++ ".xpm") + + let colors = [ + "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", + "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] + + (rects', _) <- + X.runLayout + (S.Workspace "0" l (S.differentiate [1 .. 5])) + (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) + + let rects = flip map rects' $ \(_, Rectangle x y w h) -> + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) + + X.liftIO $ do + exists <- doesFileExist iconPath + createDirectoryIfMissing True iconCacheDir + + unless exists $ do + let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 + writeFile iconPath xpmText + + return (exists, iconPath) + +-- +-- Create's an XPM, purely. Returns a string with the XPM contents. +-- Takes as arguments +-- +-- - dimensions of the icon. +-- - list of (color, rectangle) pairs. +-- - The amount to shrink the windows by for those pretty gaps. +-- +drawXpm :: + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String +drawXpm (w, h) rects' shrinkAmt = execWriter $ do + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c None\"a,\n" + + forM_ [0 .. h - 1] $ \y -> do + tell "\"" + forM_ [0 .. w - 1] $ \x -> + (case find (matches x y) zipRects of + Nothing -> tell "%" + Just (chr, _) -> tell [chr]) + tell "\"" + when (y /= h - 1 - shrinkAmt) (tell ",") + tell "\n" + tell "};\n" + + where + matches x y (_, (_, r)) = pointInRect (x, y) r + rects = map (second (shrink shrinkAmt)) rects' + guard a b = if a <= shrinkAmt then 1 else b + shrink amt (Rectangle x y w h) = + Rectangle + x + y + (guard w $ w - fromIntegral amt) + (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/Layout/LayoutList.hs b/src/Rahm/Desktop/Layout/LayoutList.hs new file mode 100644 index 0000000..3e72e99 --- /dev/null +++ b/src/Rahm/Desktop/Layout/LayoutList.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE UndecidableInstances #-} + +{- + - This module provides a more powerful version of the "Choose" layout that can + - be bidirectionally navigated. + - + - The indexing uses a type-safe zipper to keep track of the currently-selected + - layout. + -} +module Rahm.Desktop.Layout.LayoutList ( + LayoutList, + layoutZipper, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + (|:), + nil + )where + +import Control.Applicative ((<|>)) +import Data.Void +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe, fromJust) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +-- Type-level lists. LNil is the final of the list. LCons contains a layout and a +-- tail. +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +-- Sel - This defines a structure where either this selected, or some +-- other element is selected. +-- +-- These types can be composed to create what is effectively a bounded integer. +-- I.e. there can be a type like +-- +-- Sel (Sel (Sel (Sel End))) +-- +-- Such a type is equivalent to an integer bounded at 4, because this type can +-- exist in no more than 4 states: +-- +-- Sel +-- Skip Sel +-- Skip (Skip Sel) +-- Skip (Skip (Skip Sel)) +-- +-- Note that a type (Sel End) can only be in the Sel as End may not be +-- construted (without using undefined). +data Sel l = + Sel | + (Selector l) => Skip l +deriving instance (Read l, Selector l) => Read (Sel l) +deriving instance (Show l, Selector l) => Show (Sel l) +deriving instance (Eq l, Selector l) => Eq (Sel l) + +-- Reimplement Void as End, just to keep the two separate, but End is for all +-- intents and purposes Void. +data End +deriving instance Read End +deriving instance Show End +deriving instance Eq End + + +-- Types that constitute a selection. Selections can be moved to the next +-- selection, moved to the previous selection, optionally there could be a +-- previous selection and they may be currently selected. +class (Eq c) => Selector c where + -- Increments the selection to the next state + -- + -- Returns Nothing if the selection class is in the final state and cannot be + -- incremented any farther. (This is helpful to facilitate modular + -- arithmatic) + increment :: c -> Maybe c + + -- Decrements the selection to the previous state. Returns Nothing if the + -- state is already in its initial setting. + decrement :: c -> Maybe c + + -- The initial state. + initial :: Maybe c + + -- The final state. + final :: Maybe c + +-- +-- Is selelected can be in two states: +-- +-- 1. The current element is selected +-- 2. The current element is not selected and another element deeper in the +-- structure is selected. +instance (Selector t) => Selector (Sel t) where + -- If the current element is not selected, increment the tail. + increment (Skip l) = Skip <$> increment l + -- If the current element is selected, the increment is just the initial of + -- the tail. + increment Sel = Skip <$> initial + + -- For a selection, the initial is just this in the Sel state. + initial = Just Sel + + -- Looks ahead at the tail, sees if it is selected, if so, select this one + -- instead, if the one ahead isn't selected, then decrement that one. + decrement (Skip t) = Just $ maybe Sel Skip (decrement t) + decrement Sel = Nothing + + -- Navigates to the end of the structure to find the final form. + final = Just $ maybe Sel Skip final + +-- The End structure (which is equivalent to Void) is the "null" selector; the +-- basecase that the Sel selector terminates at. +instance Selector End where + + -- Incrementing the End Selector doesn't do anything. + increment = const Nothing + + -- Decrementing the End Selector doesn't do anythig + decrement = const Nothing + + -- There is no initial value for the End selector. + initial = Nothing + + -- There is not final state for the End selector. + final = Nothing + +-- Increment a selector, but cyclicly +incrementCycle :: (Selector c) => c -> c +incrementCycle c = + case increment c of + Nothing -> fromMaybe c initial + Just x -> x + +-- Add two selectors together, incrementing the first until the second cannot be +-- incremented anymore. +addSelector :: (Selector c) => c -> c -> c +addSelector c1 c2 = addSel c1 (decrement c2) + where + addSel c1 Nothing = c1 + addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) + +-- Turn an int into a selector by repeatably incrementing. +intToSelector :: (Selector c) => Int -> c +intToSelector 0 = fromJust initial +intToSelector n = incrementCycle $ intToSelector (n - 1) + +-- A LayoutList consists of a LayoutSelect type and a corresponding Selector. +data LayoutList l a where + LayoutList :: + (LayoutSelect l a, Selector (SelectorFor l)) => + SelectorFor l -> l a -> LayoutList l a + +deriving instance (LayoutSelect l a) => Show (LayoutList l a) +deriving instance (LayoutSelect l a) => Read (LayoutList l a) + +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons + +infixr 5 |: + +-- Constructs a LayoutList. This function enforces that the SelectorFor l +-- is a 'Sel' type. Essentially this enforces that there must be at least one +-- underlying layout, otherwise a LayoutList cannot be constructed. +layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> LayoutList l a +layoutZipper = LayoutList Sel + +-- The termination of a layout zipper. +nil :: LNil a +nil = LNil + +-- Message to navigate to a layout. +newtype NavigateLayout = + -- Sets the layout based on the given function. + NavigateLayout { + changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) + +-- NavigateLayout instance to move to the next layout, circularly. +toNextLayout :: NavigateLayout +toNextLayout = NavigateLayout $ addSelector (intToSelector 1) + +-- NavigateLayout instance to move to the previous layout, circularly. +toPreviousLayout :: NavigateLayout +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) + +-- NavigateLayotu instance to move to the first layout. +toFirstLayout :: NavigateLayout +toFirstLayout = NavigateLayout (`fromMaybe` initial) + +instance Message NavigateLayout where + +-- LayoutSelect class Describes a type that can be used to select a layout using +-- the associated type SelectorFor. +-- +-- Instances of this class are LCons and LNil. +class (Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l)) => LayoutSelect l a where + + -- The selector that is used to update the layout corresponding to the + -- selector. This selector must be an instance of the Selector class. + type SelectorFor l :: * + + -- Update applies a functor to the selected layout and maybe returns a result + -- and an updated layout. + update :: forall r m. (Monad m) => + -- The selector for this type. Determines which layout the function is + -- applied to. + SelectorFor l -> + -- The LayoutSelect being modified. + l a -> + -- Higher-ordered function to generically apply to the Layout associated + -- with the Selector. Works on all LayoutClass's. + (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> + + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) + +-- Instance for LayoutSelect for cons +instance (Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t)) => + LayoutSelect (LCons l t) a where + + -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure + -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the + -- number of Cons in this structure enforcing safe selection. + type SelectorFor (LCons l t) = Sel (SelectorFor t) + + -- The current layout in this Cons-list is selected. + update Sel (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + -- The current layout is not selected. Move on to another layout. + update (Skip s) (LCons l t) fn = + fmap (second $ \t' -> LCons l t') <$> update s t fn + +-- LNil is a layout select. It doesn't do anything. Indeed update really can't +-- be called on on this because that would require instantiating a End type. +instance LayoutSelect LNil a where + type SelectorFor LNil = End -- LNil cannot be selected. + update _ _ _ = return Nothing + +-- Instance of layout class for LayoutList. The implementation for this +-- just delegates to the underlying LayoutSelect class using the generic +-- update method. +instance (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a where + + runLayout (W.Workspace i (LayoutList idx l) ms) r = do + r <- update idx l $ \layout -> + runLayout (W.Workspace i layout ms) r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + pureLayout (LayoutList idx l) r s = runIdentity $ do + r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) + case r of + Nothing -> return [] + Just (r, a) -> return r + + emptyLayout (LayoutList idx l) r = do + r <- update idx l $ \layout -> emptyLayout layout r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = + return $ Just (LayoutList (fn idx) l) + + handleMessage (LayoutList idx l) m = do + r <- update idx l $ \layout -> ((),) <$> handleMessage layout m + return $ LayoutList idx . snd <$> r + + pureMessage (LayoutList idx l) m = runIdentity $ do + r <- update idx l $ \layout -> return ((), pureMessage layout m) + return $ LayoutList idx . snd <$> r + + description (LayoutList idx l) = runIdentity $ do + r <- update idx l $ \l -> return (description l, Nothing) + return $ + case r of + Nothing -> "No Layout" + Just (descr, _) -> descr diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs new file mode 100644 index 0000000..98bf779 --- /dev/null +++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs @@ -0,0 +1,48 @@ +module Rahm.Desktop.Layout.ReinterpretMessage where + +import XMonad (SomeMessage, X) +import XMonad.Layout.LayoutModifier (LayoutModifier(..)) +import Data.Proxy (Proxy (..)) + +-- This is a type class that defines how to reinterpret a message. One can think +-- of this as a kind of type-level function. It lets one associate a function +-- (reinterpretMessage) with a type construct, which for the case below is a +-- Symbol. +-- +-- It would be nice to attach this function to the LayoutModifier directly as a +-- value, however LayoutModifiers must be Show-able and Read-able and functions +-- are not. However encoding in the typesystem itsef which function is to be +-- called is the best alternative I have. +class DoReinterpret (k :: t) where + reinterpretMessage :: + Proxy k -> SomeMessage -> X (Maybe SomeMessage) + +-- Data construct for association a DoReinterpret function with a concrete +-- construct that can be used in the LayoutModifier instance. +-- +-- It wolud be nice to have ReinterpretMessage hold the function as a value +-- rather than delegate to this kind-instance, however, it won't work because +-- LayoutModifiers have to be Read-able and Show-able, and functions are neither +-- of those, so a value-level function may not be a member of a LayoutModifier, +-- thus I have to settle for delegating to a hard-coded instance using +-- type-classes. +data ReinterpretMessage k a = ReinterpretMessage + deriving (Show, Read) + +-- Instance for ReinterpretMessage as a Layout modifier. +instance (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a where + + handleMessOrMaybeModifyIt self message = do + + -- Delegates to the reinterpretMessage function associatied with the + -- type-variable k. + newMessage <- reinterpretMessage (ofProxy self) message + case newMessage of + Just m -> return $ Just $ Right m + Nothing -> return $ Just $ Left self + where + -- ofProxy just provides reifies the phantom type k so the type system can + -- figure out what instance to go to. + ofProxy :: ReinterpretMessage k a -> Proxy k + ofProxy _ = Proxy diff --git a/src/Rahm/Desktop/LayoutDraw.hs b/src/Rahm/Desktop/LayoutDraw.hs deleted file mode 100644 index c3d8c9e..0000000 --- a/src/Rahm/Desktop/LayoutDraw.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, -ScopedTypeVariables, BangPatterns #-} -module Rahm.Desktop.LayoutDraw (drawLayout) where - -import Control.Monad - -import Control.Arrow (second) -import Control.Concurrent (threadDelay) -import Control.Exception (handle) -import Control.Monad.Writer (execWriter, tell) -import Data.Foldable (find) -import Data.Maybe (fromMaybe) -import Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout (ZoomModifier(..)) -import System.Directory (createDirectoryIfMissing, doesFileExist) -import System.FilePath (()) -import Text.Printf (printf) -import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) - -import XMonad (X, - Rectangle(..), - Dimension, - LayoutClass, - Message, - Window, - SomeMessage(..)) - -import qualified XMonad as X -import qualified XMonad.StackSet as S - --- Draws and returns an XPM for the current layout. --- --- Returns --- - Bool - true if the xpm has already been written, and is thus cached. --- - String - description of the current layout --- - String - the text to send to XMobar --- --- This function actually runs the current layout's doLayout function to --- generate the XPM, so it's completely portable to all layouts. --- --- Note this function is impure and running the layout to create the XPM is also --- impure. While in-practice most layouts are pure, it should be kept in mind. -drawLayout :: X (Bool, String, String) -drawLayout = do - winset <- X.gets X.windowset - let layout = S.layout $ S.workspace $ S.current winset - - -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout [ - handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' Unzoom - ] - - (cached, xpm) <- drawXpmIO layout' - - return (cached , X.description layout, printf "" xpm) - --- Returns true if a point is inside a rectangle (inclusive). -pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool -pointInRect (x, y) (Rectangle x' y' w h) = - x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' - where - fi :: (Integral a, Num b) => a -> b - fi = fromIntegral - --- Scale factory. Scaling the rectangles before writing the XPM helps to reduce --- noise from things like AvoidStruts, as there is unfortunately no way to force --- avoid struts to be off, one can only toggle it. -sf :: (Integral a) => a -sf = 1024 - -handleMessage' :: - (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) -handleMessage' message layout = do - fromMaybe layout <$> X.handleMessage layout (SomeMessage message) - --- Creates the XPM for the given layout and returns the path to it. --- --- This function does run doLayout on the given layout, and that should be --- accounted for. -drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) -drawXpmIO l = do - dir <- X.getXMonadDir - - let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. - - let (w, h) = (56, 24) - let descr = X.description l - let iconCacheDir = dir "icons" "cache" - let iconPath = iconCacheDir (quickHash descr ++ ".xpm") - - let colors = [ - "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", - "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] - - (rects', _) <- - X.runLayout - (S.Workspace "0" l (S.differentiate [1 .. 5])) - (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) - - let rects = flip map rects' $ \(_, Rectangle x y w h) -> - Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) - - X.liftIO $ do - exists <- doesFileExist iconPath - createDirectoryIfMissing True iconCacheDir - - unless exists $ do - let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 - writeFile iconPath xpmText - - return (exists, iconPath) - --- --- Create's an XPM, purely. Returns a string with the XPM contents. --- Takes as arguments --- --- - dimensions of the icon. --- - list of (color, rectangle) pairs. --- - The amount to shrink the windows by for those pretty gaps. --- -drawXpm :: - (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String -drawXpm (w, h) rects' shrinkAmt = execWriter $ do - tell "/* XPM */\n" - tell "static char *out[] = {\n" - tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) - - let zipRects = zip ['A' .. 'Z'] rects - - forM_ zipRects $ \(char, (color, _)) -> do - tell $ printf "\"%c c %s\",\n" char color - tell "\"% c None\"a,\n" - - forM_ [0 .. h - 1] $ \y -> do - tell "\"" - forM_ [0 .. w - 1] $ \x -> - (case find (matches x y) zipRects of - Nothing -> tell "%" - Just (chr, _) -> tell [chr]) - tell "\"" - when (y /= h - 1 - shrinkAmt) (tell ",") - tell "\n" - tell "};\n" - - where - matches x y (_, (_, r)) = pointInRect (x, y) r - rects = map (second (shrink shrinkAmt)) rects' - guard a b = if a <= shrinkAmt then 1 else b - shrink amt (Rectangle x y w h) = - Rectangle - x - y - (guard w $ w - fromIntegral amt) - (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/LayoutList.hs b/src/Rahm/Desktop/LayoutList.hs deleted file mode 100644 index 3bc09d3..0000000 --- a/src/Rahm/Desktop/LayoutList.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, - FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, - RankNTypes, TupleSections, TypeFamilies #-} - -{- - - This module provides a more powerful version of the "Choose" layout that can - - be bidirectionally navigated. - - - - The indexing uses a type-safe zipper to keep track of the currently-selected - - layout. - -} -module Rahm.Desktop.LayoutList ( - LayoutList, - layoutZipper, - LCons, - LNil, - toNextLayout, - toPreviousLayout, - toFirstLayout, - (|:), - nil - )where - -import Control.Applicative ((<|>)) -import Data.Void -import Control.Monad.Identity (runIdentity) -import Data.Maybe (fromMaybe, fromJust) -import Control.Arrow (second) -import XMonad -import qualified XMonad.StackSet as W -import Data.Proxy - --- Type-level lists. LNil is the final of the list. LCons contains a layout and a --- tail. -data LNil a = LNil deriving (Read, Show) -data LCons l t a = LCons (l a) (t a) deriving (Read, Show) - --- Sel - This defines a structure where either this selected, or some --- other element is selected. --- --- These types can be composed to create what is effectively a bounded integer. --- I.e. there can be a type like --- --- Sel (Sel (Sel (Sel End))) --- --- Such a type is equivalent to an integer bounded at 4, because this type can --- exist in no more than 4 states: --- --- Sel --- Skip Sel --- Skip (Skip Sel) --- Skip (Skip (Skip Sel)) --- --- Note that a type (Sel End) can only be in the Sel as End may not be --- construted (without using undefined). -data Sel l = - Sel | - (Selector l) => Skip l -deriving instance (Read l, Selector l) => Read (Sel l) -deriving instance (Show l, Selector l) => Show (Sel l) -deriving instance (Eq l, Selector l) => Eq (Sel l) - --- Reimplement Void as End, just to keep the two separate, but End is for all --- intents and purposes Void. -data End -deriving instance Read End -deriving instance Show End -deriving instance Eq End - - --- Types that constitute a selection. Selections can be moved to the next --- selection, moved to the previous selection, optionally there could be a --- previous selection and they may be currently selected. -class (Eq c) => Selector c where - -- Increments the selection to the next state - -- - -- Returns Nothing if the selection class is in the final state and cannot be - -- incremented any farther. (This is helpful to facilitate modular - -- arithmatic) - increment :: c -> Maybe c - - -- Decrements the selection to the previous state. Returns Nothing if the - -- state is already in its initial setting. - decrement :: c -> Maybe c - - -- The initial state. - initial :: Maybe c - - -- The final state. - final :: Maybe c - --- --- Is selelected can be in two states: --- --- 1. The current element is selected --- 2. The current element is not selected and another element deeper in the --- structure is selected. -instance (Selector t) => Selector (Sel t) where - -- If the current element is not selected, increment the tail. - increment (Skip l) = Skip <$> increment l - -- If the current element is selected, the increment is just the initial of - -- the tail. - increment Sel = Skip <$> initial - - -- For a selection, the initial is just this in the Sel state. - initial = Just Sel - - -- Looks ahead at the tail, sees if it is selected, if so, select this one - -- instead, if the one ahead isn't selected, then decrement that one. - decrement (Skip t) = Just $ maybe Sel Skip (decrement t) - decrement Sel = Nothing - - -- Navigates to the end of the structure to find the final form. - final = Just $ maybe Sel Skip final - --- The End structure (which is equivalent to Void) is the "null" selector; the --- basecase that the Sel selector terminates at. -instance Selector End where - - -- Incrementing the End Selector doesn't do anything. - increment = const Nothing - - -- Decrementing the End Selector doesn't do anythig - decrement = const Nothing - - -- There is no initial value for the End selector. - initial = Nothing - - -- There is not final state for the End selector. - final = Nothing - --- Increment a selector, but cyclicly -incrementCycle :: (Selector c) => c -> c -incrementCycle c = - case increment c of - Nothing -> fromMaybe c initial - Just x -> x - --- Add two selectors together, incrementing the first until the second cannot be --- incremented anymore. -addSelector :: (Selector c) => c -> c -> c -addSelector c1 c2 = addSel c1 (decrement c2) - where - addSel c1 Nothing = c1 - addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) - --- Turn an int into a selector by repeatably incrementing. -intToSelector :: (Selector c) => Int -> c -intToSelector 0 = fromJust initial -intToSelector n = incrementCycle $ intToSelector (n - 1) - --- A LayoutList consists of a LayoutSelect type and a corresponding Selector. -data LayoutList l a where - LayoutList :: - (LayoutSelect l a, Selector (SelectorFor l)) => - SelectorFor l -> l a -> LayoutList l a - -deriving instance (LayoutSelect l a) => Show (LayoutList l a) -deriving instance (LayoutSelect l a) => Read (LayoutList l a) - -(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a -(|:) = LCons - -infixr 5 |: - --- Constructs a LayoutList. This function enforces that the SelectorFor l --- is a 'Sel' type. Essentially this enforces that there must be at least one --- underlying layout, otherwise a LayoutList cannot be constructed. -layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => - l a -> LayoutList l a -layoutZipper = LayoutList Sel - --- The termination of a layout zipper. -nil :: LNil a -nil = LNil - --- Message to navigate to a layout. -newtype NavigateLayout = - -- Sets the layout based on the given function. - NavigateLayout { - changeLayoutFn :: forall c. (Selector c) => c -> c - } - deriving (Typeable) - --- NavigateLayout instance to move to the next layout, circularly. -toNextLayout :: NavigateLayout -toNextLayout = NavigateLayout $ addSelector (intToSelector 1) - --- NavigateLayout instance to move to the previous layout, circularly. -toPreviousLayout :: NavigateLayout -toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) - --- NavigateLayotu instance to move to the first layout. -toFirstLayout :: NavigateLayout -toFirstLayout = NavigateLayout (`fromMaybe` initial) - -instance Message NavigateLayout where - --- LayoutSelect class Describes a type that can be used to select a layout using --- the associated type SelectorFor. --- --- Instances of this class are LCons and LNil. -class (Show (l a), - Read (l a), - Read (SelectorFor l), - Show (SelectorFor l), - Selector (SelectorFor l)) => LayoutSelect l a where - - -- The selector that is used to update the layout corresponding to the - -- selector. This selector must be an instance of the Selector class. - type SelectorFor l :: * - - -- Update applies a functor to the selected layout and maybe returns a result - -- and an updated layout. - update :: forall r m. (Monad m) => - -- The selector for this type. Determines which layout the function is - -- applied to. - SelectorFor l -> - -- The LayoutSelect being modified. - l a -> - -- Higher-ordered function to generically apply to the Layout associated - -- with the Selector. Works on all LayoutClass's. - (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> - - -- Returns a result r, and an updated LayoutSelect. - m (Maybe (r, l a)) - --- Instance for LayoutSelect for cons -instance (Read (l a), - LayoutClass l a, - LayoutSelect t a, - Show (SelectorFor t), - Read (SelectorFor t)) => - LayoutSelect (LCons l t) a where - - -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure - -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the - -- number of Cons in this structure enforcing safe selection. - type SelectorFor (LCons l t) = Sel (SelectorFor t) - - -- The current layout in this Cons-list is selected. - update Sel (LCons layout t) fn = do - (r, layout') <- fn layout - return $ Just (r, LCons (fromMaybe layout layout') t) - - -- The current layout is not selected. Move on to another layout. - update (Skip s) (LCons l t) fn = - fmap (second $ \t' -> LCons l t') <$> update s t fn - --- LNil is a layout select. It doesn't do anything. Indeed update really can't --- be called on on this because that would require instantiating a End type. -instance LayoutSelect LNil a where - type SelectorFor LNil = End -- LNil cannot be selected. - update _ _ _ = return Nothing - --- Instance of layout class for LayoutList. The implementation for this --- just delegates to the underlying LayoutSelect class using the generic --- update method. -instance (Show (l a), Typeable l, LayoutSelect l a) => - LayoutClass (LayoutList l) a where - - runLayout (W.Workspace i (LayoutList idx l) ms) r = do - r <- update idx l $ \layout -> - runLayout (W.Workspace i layout ms) r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutList idx la)) - - pureLayout (LayoutList idx l) r s = runIdentity $ do - r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) - case r of - Nothing -> return [] - Just (r, a) -> return r - - emptyLayout (LayoutList idx l) r = do - r <- update idx l $ \layout -> emptyLayout layout r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutList idx la)) - - handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = - return $ Just (LayoutList (fn idx) l) - - handleMessage (LayoutList idx l) m = do - r <- update idx l $ \layout -> ((),) <$> handleMessage layout m - return $ LayoutList idx . snd <$> r - - pureMessage (LayoutList idx l) m = runIdentity $ do - r <- update idx l $ \layout -> return ((), pureMessage layout m) - return $ LayoutList idx . snd <$> r - - description (LayoutList idx l) = runIdentity $ do - r <- update idx l $ \l -> return (description l, Nothing) - return $ - case r of - Nothing -> "No Layout" - Just (descr, _) -> descr diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs index c90a5d7..2f90d0a 100644 --- a/src/Rahm/Desktop/Lib.hs +++ b/src/Rahm/Desktop/Lib.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} module Rahm.Desktop.Lib where import Prelude hiding ((!!)) diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 8e9867d..8ca50fd 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} module Rahm.Desktop.Marking ( historyNext, historyPrev, markCurrentWindow, pushHistory, diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs index 488f06a..b5e8874 100644 --- a/src/Rahm/Desktop/MouseMotion.hs +++ b/src/Rahm/Desktop/MouseMotion.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns, BangPatterns #-} module Rahm.Desktop.MouseMotion where import XMonad diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index f3beb86..8b0ad72 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -6,7 +6,7 @@ import Control.Monad.Writer (tell, execWriter) import Data.List (sortBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) -import Rahm.Desktop.LayoutDraw (drawLayout) +import Rahm.Desktop.Layout.LayoutDraw (drawLayout) import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) import XMonad.Util.NamedWindows (getName) import XMonad.Util.Run (spawnPipe) -- cgit From 9230d82c5ee361891144f0f11347e02f54d634f5 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 11 Apr 2022 17:23:42 -0600 Subject: Add clickable workspaces to XMobar. This is using xdotool to send a keystroke, which is not the best way to do this. In fact, a proper server protocol would be better, but this is how it is at the momement unfortunately. There is a problem where trying to use xdotool to send a key for a multibyte character will cause all events to freeze on XMonad for some reason, so these actions are guarded so only 'a-zA-Z0-9' are clickable and the rest are not, which is /okay/, I don't use unicode workspaces that often. --- src/Rahm/Desktop/XMobarLog.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 8b0ad72..0f67ed4 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -12,6 +12,7 @@ import XMonad.Util.NamedWindows (getName) import XMonad.Util.Run (spawnPipe) import XMonad (X) import Rahm.Desktop.Lib (getPopulatedWorkspaces, WorkspaceState(..)) +import Text.Printf import qualified XMonad as X import qualified XMonad.StackSet as S @@ -43,6 +44,7 @@ xMobarLogHook (XMobarLog xmproc) = do X.liftIO $ do hPutStrLn xmproc $ trunc 80 $ execWriter $ do + tell " " tell layoutXpm tell $ " │ " @@ -51,12 +53,20 @@ xMobarLogHook (XMobarLog xmproc) = do Current -> tell "" Visible -> tell "" Hidden -> tell "" - tell (S.tag ws) + + tell $ toAction $ S.tag ws tell " " tell $ "│ " tell $ title tell $ "" + + where + toAction [ch] | (ch >= 'A' && ch <= 'Z') || + (ch >= 'a' && ch <= 'z') || + (ch >= '0' && ch <= '9') = + printf "%s" [ch] [ch] + toAction ch = ch -- Truncate an XMobar string to the provided number of _visible_ characters. -- This is to keep long window titles from overrunning the whole bar. -- cgit From f999e85bb5be0b7eb42a37566d45b92261e043f0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 11 Apr 2022 22:40:34 -0600 Subject: Add right click to move current window to a workspace. --- src/Rahm/Desktop/Layout/ReinterpretMessage.hs | 4 ++-- src/Rahm/Desktop/XMobarLog.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs index 98bf779..8f6a78d 100644 --- a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs +++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs @@ -20,7 +20,7 @@ class DoReinterpret (k :: t) where -- Data construct for association a DoReinterpret function with a concrete -- construct that can be used in the LayoutModifier instance. -- --- It wolud be nice to have ReinterpretMessage hold the function as a value +-- It would be nice to have ReinterpretMessage hold the function as a value -- rather than delegate to this kind-instance, however, it won't work because -- LayoutModifiers have to be Read-able and Show-able, and functions are neither -- of those, so a value-level function may not be a member of a LayoutModifier, @@ -35,7 +35,7 @@ instance (DoReinterpret k) => handleMessOrMaybeModifyIt self message = do - -- Delegates to the reinterpretMessage function associatied with the + -- Delegates to the reinterpretMessage function associated with the -- type-variable k. newMessage <- reinterpretMessage (ofProxy self) message case newMessage of diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 0f67ed4..4b266c1 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -65,7 +65,7 @@ xMobarLogHook (XMobarLog xmproc) = do toAction [ch] | (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') = - printf "%s" [ch] [ch] + printf "%s" [ch] [ch] [ch] toAction ch = ch -- Truncate an XMobar string to the provided number of _visible_ characters. -- cgit From 4ec113c501dd0435bce173110ef2f0ba0293c360 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 11 Apr 2022 22:58:45 -0600 Subject: Rename Zoom to Pop and move into its own Module. Much cleaner. --- src/Rahm/Desktop/Keys.hs | 15 +++---- src/Rahm/Desktop/Layout/Layout.hs | 60 +--------------------------- src/Rahm/Desktop/Layout/Pop.hs | 83 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 65 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/Pop.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 0bebd6f..7ca6161 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -54,6 +54,7 @@ import Rahm.Desktop.PassMenu import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow +import Rahm.Desktop.Layout.Pop (PopMessage(..)) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -311,16 +312,16 @@ keymap = runKeys $ do bind xK_j $ do justMod $ - doc "Shrink the size of the zoom region" $ - sendMessage ShrinkZoom + doc "Shrink the size of the master region" $ + sendMessage Shrink shiftMod $ doc "Go to the previous window in history." historyPrev bind xK_k $ do justMod $ - doc "Expand the size of the zoom region" $ - sendMessage ExpandZoom + doc "Expand the size of the master region" $ + sendMessage Expand shiftMod $ doc "Go to the next window in history." historyNext @@ -524,7 +525,7 @@ keymap = runKeys $ do bind xK_z $ do noMod -|- justMod $ doc "Toggle zoom on the current window." $ - sendMessage ToggleZoom + sendMessage TogglePop -- Z is reserved to create sub keybindings to do various things. -- I don't really use these at the moment. @@ -536,7 +537,7 @@ keymap = runKeys $ do -- modifier. shiftMod $ doc "Toggle zoom on the current window." $ - sendMessage ToggleZoom + sendMessage TogglePop bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" @@ -625,7 +626,7 @@ mouseMap = runButtons $ do noMod $ noWindow $ click >> CopyWindow.kill1 bind button14 $ do - noMod $ noWindow $ click >> sendMessage ToggleZoom + noMod $ noWindow $ click >> sendMessage TogglePop bind button15 $ do noMod $ noWindow $ spawnX "pavucontrol" diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs index 93228e7..fd34c33 100644 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -27,6 +27,7 @@ import Rahm.Desktop.Layout.CornerLayout (Corner(..)) import Rahm.Desktop.Layout.LayoutList import Rahm.Desktop.Windows import Rahm.Desktop.Layout.ReinterpretMessage +import Rahm.Desktop.Layout.Pop import qualified Data.Map as M import qualified XMonad.StackSet as W @@ -87,7 +88,7 @@ reinterpretIncMaster :: reinterpretIncMaster = ModifiedLayout ReinterpretMessage mods = - ModifiedLayout (Zoomable False 0.05 0.05) . + poppable . ModifiedLayout (Flippable False) . ModifiedLayout (HFlippable False) . ModifiedLayout (Rotateable False) @@ -137,10 +138,6 @@ instance DescriptionModifier ThreeColDescMod ThreeCol where newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" -data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable) - -instance Message ResizeZoom where - newtype Flippable a = Flippable Bool -- True if flipped deriving (Show, Read) @@ -156,23 +153,10 @@ data HFlipLayout = HFlipLayout deriving (Typeable) data DoRotate = DoRotate deriving (Typeable) -data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window. - deriving (Show, Read) - --- Toggles if the current window should be zoomed or not. Set the boolean --- to set the zoom.mhar -data ZoomModifier = - ToggleZoom | - Zoom | - Unzoom - deriving (Typeable) - instance Message FlipLayout where instance Message HFlipLayout where -instance Message ZoomModifier where - instance Message DoRotate where instance (Eq a) => LayoutModifier Rotateable a where @@ -241,43 +225,3 @@ instance (Eq a) => LayoutModifier HFlippable a where if flipped then descr ++ " HFlipped" else descr - - -instance (Eq a) => LayoutModifier Zoomable a where - redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned = - if doit - then - let focused = W.focus <$> stack - (zoomed, rest) = partition ((==focused) . Just . fst) returned - in case zoomed of - [] -> return (rest, Nothing) - ((fwin, _):_) -> return ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing) - - else return (returned, Nothing) - where - wp = floor $ fromIntegral w * ws - hp = floor $ fromIntegral h * hs - - handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess = - return $ - (handleResize <$> fromMessage mess) - <|> (Left . handleZoom <$> fromMessage mess) - where - handleResize r = - if showing - then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d) - else Right $ case r of - ShrinkZoom -> SomeMessage Shrink - ExpandZoom -> SomeMessage Expand - - where d = (case r of - ShrinkZoom -> -1 - ExpandZoom -> 1) * 0.02 - - handleZoom ToggleZoom = Zoomable (not showing) sw sh - handleZoom Zoom = Zoomable True sw sh - handleZoom Unzoom = Zoomable False sw sh - - guard f | f > 1 = 1 - | f < 0 = 0 - | otherwise = f diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs new file mode 100644 index 0000000..194e645 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- | The Pap layout modifier allows the user to "pop" the focused window into a +-- frame in the middle of the screen, sort of like fullscreen, but only taking +-- up a percentage of the screen rather than the whole screen so other windows +-- are still visible, alebeit typically not usable. +module Rahm.Desktop.Layout.Pop (Poppable(..), PopMessage(..), poppable) where + +import XMonad +import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) +import Data.Default (Default(..)) +import qualified XMonad.StackSet as W + +data Poppable a = Poppable { + -- True if the current window is popped out or not. + isPopped :: Bool + + -- Fraction of the screen width around the window. + , xFrac :: Float + + -- Fraction of the screen height around the window. + , yFrac :: Float + } deriving (Show, Read, Eq, Ord) + +instance Default (Poppable a) where + def = Poppable { + isPopped = False + , xFrac = 0.05 + , yFrac = 0.05 + } + +poppable :: l a -> ModifiedLayout Poppable l a +poppable = ModifiedLayout def + +-- Message to control the state of the popped layouts modifier. +data PopMessage = TogglePop | Pop | Unpop | ResizePop Float + deriving (Typeable, Show, Eq, Ord, Message) + +instance (Eq a) => LayoutModifier Poppable a where + + -- If the current layout is not popped, then just return what the underlying + -- layout returned. + redoLayout Poppable { isPopped = False } _ _ returned = + return (returned, Nothing) + + -- Can't do anything with an empty stack. + redoLayout _ _ Nothing returned = return (returned, Nothing) + + redoLayout self (Rectangle x y w h) (Just (W.focus -> focused)) returned = + return ((focused, newRect) : remaining, Nothing) + where + remaining = filter ((/=focused) . fst) returned + wp = floor $ fromIntegral w * xFrac self + hp = floor $ fromIntegral h * yFrac self + newRect = Rectangle + (x + wp) + (y + hp) + (w - fromIntegral (wp * 2)) + (h - fromIntegral (hp * 2)) + + -- Handle the Pop messages associated with this layout. + pureMess self (fromMessage -> Just mess) = + Just $ case mess of + TogglePop -> self { isPopped = not (isPopped self) } + Pop -> self { isPopped = True } + Unpop -> self { isPopped = False } + ResizePop amt -> self { + xFrac = guard (xFrac self + amt), + yFrac = guard (yFrac self + amt) + } + where + guard = min 0.45 . max 0 + + -- Handle Shrink and Expand if it is currently in the popped state. + pureMess + self@Poppable { isPopped = True } + (fromMessage -> Just mess) = + pureMess self $ SomeMessage $ + case mess of + Shrink -> ResizePop (-0.05) + Expand -> ResizePop 0.05 + + pureMess _ _ = Nothing -- cgit From 1521bb8dc5d81e68823802454576901075a5dcca Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 11 Apr 2022 23:28:18 -0600 Subject: Fix bug with Poppable where it was passing the Resize to the underlying layout. Unfortunately it's a little hacky how this ended up working, but I don't have a great solution yet. --- src/Rahm/Desktop/Layout/Layout.hs | 9 +++--- src/Rahm/Desktop/Layout/LayoutDraw.hs | 4 +-- src/Rahm/Desktop/Layout/Pop.hs | 61 +++++++++++++++++++++++------------ 3 files changed, 48 insertions(+), 26 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs index fd34c33..135b9a0 100644 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -88,10 +88,11 @@ reinterpretIncMaster :: reinterpretIncMaster = ModifiedLayout ReinterpretMessage mods = - poppable . - ModifiedLayout (Flippable False) . - ModifiedLayout (HFlippable False) . - ModifiedLayout (Rotateable False) + reinterpretResize . + poppable . + ModifiedLayout (Flippable False) . + ModifiedLayout (HFlippable False) . + ModifiedLayout (Rotateable False) data ModifyDescription m l a = ModifyDescription m (l a) diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs index 7e59284..99828e3 100644 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs @@ -11,7 +11,7 @@ import Control.Monad.Writer (execWriter, tell) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout.Layout (ZoomModifier(..)) +import Rahm.Desktop.Layout.Pop (PopMessage(..)) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (()) import Text.Printf (printf) @@ -48,7 +48,7 @@ drawLayout = do -- Gotta reset the layout to a consistent state. layout' <- foldM (flip ($)) layout [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' Unzoom + handleMessage' Unpop ] (cached, xpm) <- drawXpmIO layout' diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index 194e645..037e664 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -4,13 +4,19 @@ -- frame in the middle of the screen, sort of like fullscreen, but only taking -- up a percentage of the screen rather than the whole screen so other windows -- are still visible, alebeit typically not usable. -module Rahm.Desktop.Layout.Pop (Poppable(..), PopMessage(..), poppable) where +module Rahm.Desktop.Layout.Pop ( + Poppable(..), + PopMessage(..), + poppable, + reinterpretResize) where import XMonad import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) import Data.Default (Default(..)) import qualified XMonad.StackSet as W +import Rahm.Desktop.Layout.ReinterpretMessage + data Poppable a = Poppable { -- True if the current window is popped out or not. isPopped :: Bool @@ -29,6 +35,18 @@ instance Default (Poppable a) where , yFrac = 0.05 } +-- Returns a modified layout that converts Resize (Shrink/Expand) into ResizePop +-- messages. Unfortunately this is required because a LayoutModifier has no way +-- to intercept messages and block them from propegating, which is pretty silly. +-- +-- So, reinterpretResize will turn a Shrink/Expand into a ResizePop, this will +-- be consumed by the Poppable layout modifier. If the Poppable LayoutModifier +-- is not active, it will turn the ResizePop back into a Shrink/Expand and +-- forward it to the underlying layout. +reinterpretResize :: + l a -> ModifiedLayout (ReinterpretMessage "ForPop") l a +reinterpretResize = ModifiedLayout ReinterpretMessage + poppable :: l a -> ModifiedLayout Poppable l a poppable = ModifiedLayout def @@ -36,6 +54,15 @@ poppable = ModifiedLayout def data PopMessage = TogglePop | Pop | Unpop | ResizePop Float deriving (Typeable, Show, Eq, Ord, Message) +instance DoReinterpret "ForPop" where + reinterpretMessage _ (fromMessage -> Just mess) = + return $ Just $ SomeMessage $ + case mess of + Shrink -> ResizePop (-0.05) + Expand -> ResizePop 0.05 + + reinterpretMessage _ _ = return Nothing + instance (Eq a) => LayoutModifier Poppable a where -- If the current layout is not popped, then just return what the underlying @@ -59,25 +86,19 @@ instance (Eq a) => LayoutModifier Poppable a where (h - fromIntegral (hp * 2)) -- Handle the Pop messages associated with this layout. - pureMess self (fromMessage -> Just mess) = - Just $ case mess of - TogglePop -> self { isPopped = not (isPopped self) } - Pop -> self { isPopped = True } - Unpop -> self { isPopped = False } - ResizePop amt -> self { - xFrac = guard (xFrac self + amt), - yFrac = guard (yFrac self + amt) - } + handleMessOrMaybeModifyIt self (fromMessage -> Just mess) = + return $ Just $ case mess of + TogglePop -> Left $ self { isPopped = not (isPopped self) } + Pop -> Left $ self { isPopped = True } + Unpop -> Left $ self { isPopped = False } + ResizePop amt | isPopped self -> + Left $ self { + xFrac = guard (xFrac self + amt), + yFrac = guard (yFrac self + amt) + } + ResizePop amt -> Right $ SomeMessage $ + if amt > 0 then Expand else Shrink where guard = min 0.45 . max 0 - -- Handle Shrink and Expand if it is currently in the popped state. - pureMess - self@Poppable { isPopped = True } - (fromMessage -> Just mess) = - pureMess self $ SomeMessage $ - case mess of - Shrink -> ResizePop (-0.05) - Expand -> ResizePop 0.05 - - pureMess _ _ = Nothing + handleMessOrMaybeModifyIt _ _ = return Nothing -- cgit From f5c6a81a4aec41fe13af6db673a7c5cad6f6b2a6 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 11 Apr 2022 23:42:58 -0600 Subject: Change LayoutDraw so mosaic looks a little more interesting. --- src/Rahm/Desktop/Layout/LayoutDraw.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs index 99828e3..c3a1918 100644 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs @@ -16,6 +16,7 @@ import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (()) import Text.Printf (printf) import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) +import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) import XMonad (X, Rectangle(..), @@ -46,10 +47,15 @@ drawLayout = do let layout = S.layout $ S.workspace $ S.current winset -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout [ + layout' <- foldM (flip ($)) layout $ [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, handleMessage' Unpop - ] + ] + -- Add some changes for the Mosaic layout to handle so it get's a + -- unique looking icon. (The default state is pretty boring). + ++ replicate 10 (handleMessage' (expandWindowAlt 1)) + ++ replicate 5 (handleMessage' (expandWindowAlt 4)) + ++ replicate 1 (handleMessage' (expandWindowAlt 3)) (cached, xpm) <- drawXpmIO layout' -- cgit From e3cd7723739aed7dea5ec8bc8952e16b2cc4b06c Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 00:23:26 -0600 Subject: Break the Flippable modifiers into their own file. This also combines the two into a single type. --- src/Rahm/Desktop/Keys.hs | 6 ++- src/Rahm/Desktop/Layout/Flip.hs | 87 +++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Layout/Layout.hs | 58 +------------------------- 3 files changed, 93 insertions(+), 58 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/Flip.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 7ca6161..b8a4c4e 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -55,6 +55,7 @@ import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow import Rahm.Desktop.Layout.Pop (PopMessage(..)) +import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -245,10 +246,10 @@ keymap = runKeys $ do bind xK_f $ do justMod $ doc "Flip the current layout vertically" $ - sendMessage FlipLayout + sendMessage flipVertically shiftMod $ doc "Flip the current layout horizontally" $ - sendMessage HFlipLayout + sendMessage flipHorizontally bind xK_g $ do justMod $ @@ -625,6 +626,7 @@ mouseMap = runButtons $ do bind button13 $ do noMod $ noWindow $ click >> CopyWindow.kill1 + bind button14 $ do noMod $ noWindow $ click >> sendMessage TogglePop diff --git a/src/Rahm/Desktop/Layout/Flip.hs b/src/Rahm/Desktop/Layout/Flip.hs new file mode 100644 index 0000000..e0d3abc --- /dev/null +++ b/src/Rahm/Desktop/Layout/Flip.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- Layout modifier to flip a layout either horizontally or vertically or both. +module Rahm.Desktop.Layout.Flip ( + Flip(..), + flippable, + flipVertically, + flipHorizontally, + DoFlip + ) where + +import XMonad +import XMonad.Layout.LayoutModifier + +import Control.Arrow (second) +import Data.List (intercalate) +import Data.Default (Default(..)) + +-- A flipped layout is either flipped horizontally or vertically. +data Flip a = + Flip { + horiz :: Bool + , vert :: Bool + } deriving (Eq, Show, Ord, Read) + +-- Default instance for Flip. Both are set to false. +instance Default (Flip a) where + def = Flip False False + +-- Message for altering the Flip layout modifier. +data DoFlip where + -- Contains a function to modify Flip + DoFlip :: (forall k (a :: k). Flip a -> Flip a) -> DoFlip + deriving Message + +-- DoFlip is a monoid. +instance Semigroup DoFlip where + (<>) = mappend +instance Monoid DoFlip where + mempty = DoFlip id + mappend (DoFlip a) (DoFlip b) = DoFlip (a . b) + +-- Makes a layout Flippable. +flippable :: l a -> ModifiedLayout Flip l a +flippable = ModifiedLayout def + +-- Message to send a flipVertically message +flipVertically :: DoFlip +flipVertically = DoFlip $ \f -> f { vert = not (vert f) } + +-- Message to send a flipHorizontally message. +flipHorizontally :: DoFlip +flipHorizontally = DoFlip $ \f -> f { horiz = not (horiz f) } + +instance LayoutModifier Flip a where + + -- Modifies the layout. For each rectangle returned from the underlying + -- layout, flip it relative to the screen. + pureModifier flip (Rectangle sx sy sw sh) stack returned = + (map (second doFlip) returned, Nothing) + where + -- doFlip -- the composition of maybe flipping horizontally and + -- vertically. + doFlip = + (if horiz flip then flipHoriz else id) . + (if vert flip then flipVert else id) + + flipVert (Rectangle x y w h) = + Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h + flipHoriz (Rectangle x y w h) = + Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h + + -- Handle DoFlip messages. + pureMess flip (fromMessage -> Just (DoFlip f)) = Just (f flip) + pureMess _ _ = Nothing + + -- Modify the description to show if the layout has been flipped. + modifyDescription flip (description -> descr) = + (++) descr $ + if horiz flip || vert flip + then intercalate " and " ( + map snd $ + filter fst [ + (horiz flip, "Horizontally"), + (vert flip, "Vertically")]) + ++ " Flipped" + else "" diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs index 135b9a0..a871aa6 100644 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -28,6 +28,7 @@ import Rahm.Desktop.Layout.LayoutList import Rahm.Desktop.Windows import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop +import Rahm.Desktop.Layout.Flip import qualified Data.Map as M import qualified XMonad.StackSet as W @@ -90,8 +91,7 @@ reinterpretIncMaster = ModifiedLayout ReinterpretMessage mods = reinterpretResize . poppable . - ModifiedLayout (Flippable False) . - ModifiedLayout (HFlippable False) . + flippable . ModifiedLayout (Rotateable False) @@ -139,25 +139,11 @@ instance DescriptionModifier ThreeColDescMod ThreeCol where newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" -newtype Flippable a = Flippable Bool -- True if flipped - deriving (Show, Read) - -newtype HFlippable a = HFlippable Bool -- True if flipped - deriving (Show, Read) - newtype Rotateable a = Rotateable Bool -- True if rotated deriving (Show, Read) -data FlipLayout = FlipLayout deriving (Typeable) - -data HFlipLayout = HFlipLayout deriving (Typeable) - data DoRotate = DoRotate deriving (Typeable) -instance Message FlipLayout where - -instance Message HFlipLayout where - instance Message DoRotate where instance (Eq a) => LayoutModifier Rotateable a where @@ -186,43 +172,3 @@ instance (Eq a) => LayoutModifier Rotateable a where if rot then descr ++ " Rotated" else descr - -instance (Eq a) => LayoutModifier Flippable a where - pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned = - if flip - then (map (second doFlip) returned, Nothing) - else (returned, Nothing) - where - doFlip (Rectangle x y w h) = - Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h - - pureMess (Flippable flip) message = - case fromMessage message of - Just FlipLayout -> Just (Flippable (not flip)) - Nothing -> Nothing - - modifyDescription (Flippable flipped) underlying = - let descr = description underlying in - if flipped - then descr ++ " Flipped" - else descr - -instance (Eq a) => LayoutModifier HFlippable a where - pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned = - if flip - then (map (second doFlip) returned, Nothing) - else (returned, Nothing) - where - doFlip (Rectangle x y w h) = - Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h - - pureMess (HFlippable flip) message = - case fromMessage message of - Just HFlipLayout -> Just (HFlippable (not flip)) - Nothing -> Nothing - - modifyDescription (HFlippable flipped) underlying = - let descr = description underlying in - if flipped - then descr ++ " HFlipped" - else descr -- cgit From 9668ec077097e283435937e997edd99dbc0cfa17 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 00:38:26 -0600 Subject: Break Rotate into it's own file. --- src/Rahm/Desktop/Layout/Layout.hs | 43 ++------------------------- src/Rahm/Desktop/Layout/Rotate.hs | 62 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+), 40 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/Rotate.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs index a871aa6..88143cd 100644 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -29,10 +29,13 @@ import Rahm.Desktop.Windows import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop import Rahm.Desktop.Layout.Flip +import Rahm.Desktop.Layout.Rotate import qualified Data.Map as M import qualified XMonad.StackSet as W +mods = reinterpretResize . poppable . flippable . rotateable + myLayout = fullscreenFull $ avoidStruts $ @@ -88,12 +91,6 @@ reinterpretIncMaster :: l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a reinterpretIncMaster = ModifiedLayout ReinterpretMessage -mods = - reinterpretResize . - poppable . - flippable . - ModifiedLayout (Rotateable False) - data ModifyDescription m l a = ModifyDescription m (l a) deriving (Show, Read) @@ -138,37 +135,3 @@ instance DescriptionModifier TallDescriptionModifier Tall where instance DescriptionModifier ThreeColDescMod ThreeCol where newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" - -newtype Rotateable a = Rotateable Bool -- True if rotated - deriving (Show, Read) - -data DoRotate = DoRotate deriving (Typeable) - -instance Message DoRotate where - -instance (Eq a) => LayoutModifier Rotateable a where - pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned = - if rotate - then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) - else (returned, Nothing) - where - zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h - unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h - - scaleRect (Rectangle x y w h) = - Rectangle (x * fi sw `div` fi sh) - (y * fi sh `div` fi sw) - (w * sw `div` sh) - (h * sh `div` sw) - - fi = fromIntegral - - - pureMess (Rotateable rot) mess = - fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess) - - modifyDescription (Rotateable rot) underlying = - let descr = description underlying in - if rot - then descr ++ " Rotated" - else descr diff --git a/src/Rahm/Desktop/Layout/Rotate.hs b/src/Rahm/Desktop/Layout/Rotate.hs new file mode 100644 index 0000000..8a8583a --- /dev/null +++ b/src/Rahm/Desktop/Layout/Rotate.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveAnyClass #-} + +-- Layout modifier which optionally rotates the underlying layout. This actually +-- uses the mirrorRect, so it's not strictly rotating, but when combined with +-- flipping it works. +module Rahm.Desktop.Layout.Rotate ( + rotateable, + rotateLayout, + Rotate) where + +import XMonad +import XMonad.Layout.LayoutModifier +import Data.Default (Default(..)) +import Control.Arrow (second) + +-- Just a wrapper over a Bool. +newtype Rotate a = Rotate Bool + deriving (Read, Show, Eq, Ord) + +-- Returns a layout that can be rotated. +rotateable :: l a -> ModifiedLayout Rotate l a +rotateable = ModifiedLayout def + +-- Message to rotate the layout. +rotateLayout :: RotateMessage +rotateLayout = RotateMessage $ \(Rotate n) -> Rotate (not n) + +-- Default instance just defaults to false.. +instance Default (Rotate a) where + def = Rotate False + +-- Rotate message is a wrapper over a function to modify a Rotate instance. +data RotateMessage where + RotateMessage :: (forall k (a :: k). Rotate a -> Rotate a) -> RotateMessage + deriving (Message) + +instance (Eq a) => LayoutModifier Rotate a where + pureModifier (Rotate rotate) (Rectangle x' y' sw sh) _ returned = + if rotate + then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) + else (returned, Nothing) + where + zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h + unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h + + scaleRect (Rectangle x y w h) = + Rectangle (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) + + fi = fromIntegral + + + pureMess r (fromMessage -> Just (RotateMessage f)) = Just (f r) + pureMess _ _ = Nothing + + modifyDescription (Rotate rot) underlying = + let descr = description underlying in + if rot + then descr ++ " Rotated" + else descr -- cgit From 7e6fc4bd1427dfcfb849c9e23a64bff57b19baba Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 01:04:05 -0600 Subject: Break out the ModifyDescription into its own file. --- src/Rahm/Desktop/Keys.hs | 3 ++- src/Rahm/Desktop/Layout/Layout.hs | 50 +++++++-------------------------------- 2 files changed, 10 insertions(+), 43 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index b8a4c4e..c8d9092 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -56,6 +56,7 @@ import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow import Rahm.Desktop.Layout.Pop (PopMessage(..)) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) +import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -398,7 +399,7 @@ keymap = runKeys $ do justMod $ doc "Run a command via Rofi" runDMenu shiftMod $ doc "Rotate the current layout. (flips x, y coordinates)" $ - sendMessage DoRotate + sendMessage rotateLayout bind xK_s $ do altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs index 88143cd..2719bea 100644 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ b/src/Rahm/Desktop/Layout/Layout.hs @@ -10,6 +10,7 @@ import XMonad.Layout.Accordion import Control.Applicative import XMonad.Layout.Spacing import Data.List +import Data.Typeable (cast) import XMonad.Layout.Spiral import XMonad.Layout.ThreeColumns import XMonad.Layout.Grid @@ -30,6 +31,7 @@ import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop import Rahm.Desktop.Layout.Flip import Rahm.Desktop.Layout.Rotate +import Rahm.Desktop.Layout.Redescribe import qualified Data.Map as M import qualified XMonad.StackSet as W @@ -44,8 +46,8 @@ myLayout = mods (reinterpretIncMaster $ spiral (6/7)) |: mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: - mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: - mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: + mods (Redescribe UsingTall (Tall 1 (3/100) (1/2))) |: + mods (Redescribe UsingThreeCol (ThreeCol 1 (3/100) (1/2))) |: mods Grid |: mods (Dishes 2 (1/6)) |: mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: @@ -91,47 +93,11 @@ reinterpretIncMaster :: l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a reinterpretIncMaster = ModifiedLayout ReinterpretMessage - -data ModifyDescription m l a = ModifyDescription m (l a) - deriving (Show, Read) - -data TallDescriptionModifier = TallDescriptionModifier - deriving (Show, Read) - -data ThreeColDescMod = ThreeColDescMod - deriving (Show, Read) - -class DescriptionModifier m l where - newDescription :: m -> l a -> String -> String - -instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where - runLayout (W.Workspace t (ModifyDescription m l) a) rect = do - (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - doLayout (ModifyDescription m l) a s = do - (rects, maybeNewLayout) <- doLayout l a s - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - pureLayout (ModifyDescription m l) a s = pureLayout l a s - - emptyLayout (ModifyDescription m l) a = do - (rects, maybeNewLayout) <- emptyLayout l a - return (rects, fmap (ModifyDescription m) maybeNewLayout) - - handleMessage (ModifyDescription m l) a = do - maybeNewLayout <- handleMessage l a - return (ModifyDescription m <$> maybeNewLayout) - - pureMessage (ModifyDescription m l) a = - let maybeNewLayout = pureMessage l a in - ModifyDescription m <$> maybeNewLayout - - description (ModifyDescription m l) = newDescription m l (description l) - -instance DescriptionModifier TallDescriptionModifier Tall where +data UsingTall = UsingTall deriving (Read, Show) +instance Describer UsingTall Tall where newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" -instance DescriptionModifier ThreeColDescMod ThreeCol where +data UsingThreeCol = UsingThreeCol deriving (Read, Show) +instance Describer UsingThreeCol ThreeCol where newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" -- cgit From 1fbaaa7ce69ed6320693c389bf670fd3cf20cdd1 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 01:05:48 -0600 Subject: Move Rahm.Desktop.Layout.Layout to Rahm.Desktop.Layout --- src/Rahm/Desktop/Keys.hs | 2 +- src/Rahm/Desktop/Layout.hs | 103 ++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Layout/Layout.hs | 103 ---------------------------------- src/Rahm/Desktop/Layout/Redescribe.hs | 35 ++++++++++++ 4 files changed, 139 insertions(+), 104 deletions(-) create mode 100644 src/Rahm/Desktop/Layout.hs delete mode 100644 src/Rahm/Desktop/Layout/Layout.hs create mode 100644 src/Rahm/Desktop/Layout/Redescribe.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index c8d9092..e780fbf 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -25,7 +25,7 @@ import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Rahm.Desktop.Layout.Layout +import Rahm.Desktop.Layout import Rahm.Desktop.Marking import Rahm.Desktop.PromptConfig import System.IO diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs new file mode 100644 index 0000000..6c9ac5a --- /dev/null +++ b/src/Rahm/Desktop/Layout.hs @@ -0,0 +1,103 @@ +module Rahm.Desktop.Layout where + +import GHC.TypeLits + +import Data.Proxy (Proxy(..)) +import Control.Arrow (second) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Circle +import XMonad.Layout.Accordion +import Control.Applicative +import XMonad.Layout.Spacing +import Data.List +import Data.Typeable (cast) +import XMonad.Layout.Spiral +import XMonad.Layout.ThreeColumns +import XMonad.Layout.Grid +import XMonad.Layout.Dishes +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Fullscreen +import qualified XMonad.Layout.Dwindle as D +import XMonad.Layout +import XMonad.Layout.LayoutModifier +import XMonad +import XMonad.Core +import XMonad.Layout.NoBorders (smartBorders, noBorders) + +import Rahm.Desktop.Layout.CornerLayout (Corner(..)) +import Rahm.Desktop.Layout.LayoutList +import Rahm.Desktop.Windows +import Rahm.Desktop.Layout.ReinterpretMessage +import Rahm.Desktop.Layout.Pop +import Rahm.Desktop.Layout.Flip +import Rahm.Desktop.Layout.Rotate +import Rahm.Desktop.Layout.Redescribe + +import qualified Data.Map as M +import qualified XMonad.StackSet as W + +mods = reinterpretResize . poppable . flippable . rotateable + +myLayout = + fullscreenFull $ + avoidStruts $ + spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ + layoutZipper $ + mods (reinterpretIncMaster $ spiral (6/7)) |: + mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: + mods (Redescribe UsingTall (Tall 1 (3/100) (1/2))) |: + mods (Redescribe UsingThreeCol (ThreeCol 1 (3/100) (1/2))) |: + mods Grid |: + mods (Dishes 2 (1/6)) |: + mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: + nil + +-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages +-- intended to modify the master space and instead have those messages expand +-- and shrink the current window. +-- +-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system +-- hacking one can do in Haskell. +instance DoReinterpret "ForMosaic" where + + -- IncMaster message + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do + fmap (SomeMessage . + (if n > 0 + then expandWindowAlt + else shrinkWindowAlt)) <$> getFocusedWindow + + -- ResizeMaster message + reinterpretMessage _ (fromMessage -> Just m) = do + fmap (SomeMessage . + (case m of + Expand -> expandWindowAlt + Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + + -- Messages that don't match the above, just leave it unmodified. + reinterpretMessage _ m = return (Just m) + +instance DoReinterpret "IncMasterToResizeMaster" where + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = + return $ Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink + reinterpretMessage _ m = return (Just m) + +modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a +modifyMosaic = ModifiedLayout ReinterpretMessage + +reinterpretIncMaster :: + l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a +reinterpretIncMaster = ModifiedLayout ReinterpretMessage + +data UsingTall = UsingTall deriving (Read, Show) +instance Describer UsingTall Tall where + newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" + +data UsingThreeCol = UsingThreeCol deriving (Read, Show) +instance Describer UsingThreeCol ThreeCol where + newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" + newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs deleted file mode 100644 index 2719bea..0000000 --- a/src/Rahm/Desktop/Layout/Layout.hs +++ /dev/null @@ -1,103 +0,0 @@ -module Rahm.Desktop.Layout.Layout where - -import GHC.TypeLits - -import Data.Proxy (Proxy(..)) -import Control.Arrow (second) -import XMonad.Hooks.ManageDocks -import XMonad.Layout.Circle -import XMonad.Layout.Accordion -import Control.Applicative -import XMonad.Layout.Spacing -import Data.List -import Data.Typeable (cast) -import XMonad.Layout.Spiral -import XMonad.Layout.ThreeColumns -import XMonad.Layout.Grid -import XMonad.Layout.Dishes -import XMonad.Layout.MosaicAlt -import XMonad.Layout.Fullscreen -import qualified XMonad.Layout.Dwindle as D -import XMonad.Layout -import XMonad.Layout.LayoutModifier -import XMonad -import XMonad.Core -import XMonad.Layout.NoBorders (smartBorders, noBorders) - -import Rahm.Desktop.Layout.CornerLayout (Corner(..)) -import Rahm.Desktop.Layout.LayoutList -import Rahm.Desktop.Windows -import Rahm.Desktop.Layout.ReinterpretMessage -import Rahm.Desktop.Layout.Pop -import Rahm.Desktop.Layout.Flip -import Rahm.Desktop.Layout.Rotate -import Rahm.Desktop.Layout.Redescribe - -import qualified Data.Map as M -import qualified XMonad.StackSet as W - -mods = reinterpretResize . poppable . flippable . rotateable - -myLayout = - fullscreenFull $ - avoidStruts $ - spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ - layoutZipper $ - mods (reinterpretIncMaster $ spiral (6/7)) |: - mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: - mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: - mods (Redescribe UsingTall (Tall 1 (3/100) (1/2))) |: - mods (Redescribe UsingThreeCol (ThreeCol 1 (3/100) (1/2))) |: - mods Grid |: - mods (Dishes 2 (1/6)) |: - mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: - nil - --- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages --- intended to modify the master space and instead have those messages expand --- and shrink the current window. --- --- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system --- hacking one can do in Haskell. -instance DoReinterpret "ForMosaic" where - - -- IncMaster message - reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do - fmap (SomeMessage . - (if n > 0 - then expandWindowAlt - else shrinkWindowAlt)) <$> getFocusedWindow - - -- ResizeMaster message - reinterpretMessage _ (fromMessage -> Just m) = do - fmap (SomeMessage . - (case m of - Expand -> expandWindowAlt - Shrink -> shrinkWindowAlt)) <$> getFocusedWindow - - -- Messages that don't match the above, just leave it unmodified. - reinterpretMessage _ m = return (Just m) - -instance DoReinterpret "IncMasterToResizeMaster" where - reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = - return $ Just $ - if n > 0 - then SomeMessage Expand - else SomeMessage Shrink - reinterpretMessage _ m = return (Just m) - -modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a -modifyMosaic = ModifiedLayout ReinterpretMessage - -reinterpretIncMaster :: - l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a -reinterpretIncMaster = ModifiedLayout ReinterpretMessage - -data UsingTall = UsingTall deriving (Read, Show) -instance Describer UsingTall Tall where - newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" - -data UsingThreeCol = UsingThreeCol deriving (Read, Show) -instance Describer UsingThreeCol ThreeCol where - newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" - newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" diff --git a/src/Rahm/Desktop/Layout/Redescribe.hs b/src/Rahm/Desktop/Layout/Redescribe.hs new file mode 100644 index 0000000..c5c7472 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Redescribe.hs @@ -0,0 +1,35 @@ + +-- Module to enable redescribing layouts. Unlike LayoutModifiers though, this +-- class is aware of the underlying type as it may need to access some internals +-- to generate the new description. +module Rahm.Desktop.Layout.Redescribe where + +import XMonad + +import qualified XMonad.StackSet as W +import Data.Typeable (Typeable) + +-- Type-class to modify the description of a layout. +class Describer m l where + + -- Returns the new description from the given description modifier, the layout + -- and the existing description. + newDescription :: m -> l a -> String -> String + +-- With a DescriptionModifier, +data Redescribe m l a = Redescribe m (l a) + deriving (Show, Read) + +-- Delegates to the underlying Layout, except for the description +instance (Typeable m, Show m, Describer m l, LayoutClass l a) => + LayoutClass (Redescribe m l) a where + + runLayout (W.Workspace t (Redescribe m l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, fmap (Redescribe m) maybeNewLayout) + + handleMessage (Redescribe m l) a = do + maybeNewLayout <- handleMessage l a + return (Redescribe m <$> maybeNewLayout) + + description (Redescribe m l) = newDescription m l (description l) -- cgit From 96643003bd14195f4868712789cd056e9d3581ae Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 01:54:43 -0600 Subject: Add another layout modifier to add a hole. This is mostly an academic exercise, as there's probably not much reason to put a hole in the layout, but I must admit that sometimes is aesthetically pleasing to see a little more desktop wallpaper in some cases. --- src/Rahm/Desktop/Keys.hs | 7 +++++++ src/Rahm/Desktop/Layout.hs | 3 ++- src/Rahm/Desktop/Layout/Hole.hs | 44 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 1 deletion(-) create mode 100644 src/Rahm/Desktop/Layout/Hole.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index e780fbf..0ff8da3 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -54,6 +54,7 @@ import Rahm.Desktop.PassMenu import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow +import Rahm.Desktop.Layout.Hole (toggleHole) import Rahm.Desktop.Layout.Pop (PopMessage(..)) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) @@ -188,6 +189,12 @@ keymap = runKeys $ do doc "Print this documentation." $ logs (documentation (keymap config)) + bind xK_F8 $ + + justMod $ + doc "Print this documentation." $ + sendMessage toggleHole + bind xK_F10 $ do justMod playPauseDoc diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index 6c9ac5a..906a7fc 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -32,11 +32,12 @@ import Rahm.Desktop.Layout.Pop import Rahm.Desktop.Layout.Flip import Rahm.Desktop.Layout.Rotate import Rahm.Desktop.Layout.Redescribe +import Rahm.Desktop.Layout.Hole import qualified Data.Map as M import qualified XMonad.StackSet as W -mods = reinterpretResize . poppable . flippable . rotateable +mods = reinterpretResize . poppable . flippable . rotateable . hole myLayout = fullscreenFull $ diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs new file mode 100644 index 0000000..ee59726 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE UndecidableInstances, DeriveAnyClass #-} + +-- Delegates to a lower layout, but leaves a hole where the next window will go. +module Rahm.Desktop.Layout.Hole (hole, toggleHole) where + +import qualified XMonad.StackSet as W +import XMonad +import Data.Maybe (mapMaybe) + +import Rahm.Desktop.Windows + +data Hole (l :: * -> *) (a :: *) = Hole Bool (l a) + +deriving instance Show (l a) => Show (Hole l a) +deriving instance Read (l a) => Read (Hole l a) + +hole :: l a -> Hole l a +hole = Hole False + +toggleHole :: ManageHole +toggleHole = ManageHole $ \(Hole e l) -> Hole (not e) l + +data ManageHole where + ManageHole :: (forall l a. Hole l a -> Hole l a) -> ManageHole + deriving (Message) + +instance (LayoutClass l a, Eq a, Num a) => LayoutClass (Hole l) a where + runLayout (W.Workspace t (Hole enabled l) a) rect = do + (rects, maybeNewLayout) <- runLayout (app (-1) $ W.Workspace t l a) rect + return (filter ((/=(-1)) . fst) rects, fmap (Hole enabled) maybeNewLayout) + where + app x w | not enabled = w + app x (W.Workspace t l s) = + case s of + Nothing -> + W.Workspace t l (Just $ W.Stack x [] []) + Just (W.Stack h c e) -> + W.Workspace t l (Just $ W.Stack h c (e ++ [x])) + + handleMessage h (fromMessage -> Just (ManageHole f)) = + return $ Just $ f h + handleMessage (Hole e l) a = do + maybeNewLayout <- handleMessage l a + return (Hole e <$> maybeNewLayout) -- cgit From f8f7deeac800170a6201f74380bdfe720ee38027 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 02:04:18 -0600 Subject: Make spacing specific to the current layout rather than all layouts. Not sure how I feel about it, but Imma try it out --- src/Rahm/Desktop/Layout.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index 906a7fc..fcf7d25 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -37,12 +37,13 @@ import Rahm.Desktop.Layout.Hole import qualified Data.Map as M import qualified XMonad.StackSet as W -mods = reinterpretResize . poppable . flippable . rotateable . hole +withSpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True +mods = + withSpacing . reinterpretResize . poppable . flippable . rotateable . hole myLayout = fullscreenFull $ avoidStruts $ - spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ layoutZipper $ mods (reinterpretIncMaster $ spiral (6/7)) |: mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: -- cgit From e0d58319014226faeff1a09c7abce7865b551b30 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 11:09:19 -0600 Subject: Clean up Poppable so it's a proper proxy to the underlying layout rather than a LayoutModifier. --- src/Rahm/Desktop/Keys.hs | 8 +-- src/Rahm/Desktop/Layout.hs | 2 +- src/Rahm/Desktop/Layout/LayoutDraw.hs | 4 +- src/Rahm/Desktop/Layout/Pop.hs | 122 ++++++++++++++++------------------ 4 files changed, 64 insertions(+), 72 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 0ff8da3..5284a9d 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -55,7 +55,7 @@ import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow import Rahm.Desktop.Layout.Hole (toggleHole) -import Rahm.Desktop.Layout.Pop (PopMessage(..)) +import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) @@ -534,7 +534,7 @@ keymap = runKeys $ do bind xK_z $ do noMod -|- justMod $ doc "Toggle zoom on the current window." $ - sendMessage TogglePop + sendMessage togglePop -- Z is reserved to create sub keybindings to do various things. -- I don't really use these at the moment. @@ -546,7 +546,7 @@ keymap = runKeys $ do -- modifier. shiftMod $ doc "Toggle zoom on the current window." $ - sendMessage TogglePop + sendMessage togglePop bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" @@ -636,7 +636,7 @@ mouseMap = runButtons $ do bind button14 $ do - noMod $ noWindow $ click >> sendMessage TogglePop + noMod $ noWindow $ click >> sendMessage togglePop bind button15 $ do noMod $ noWindow $ spawnX "pavucontrol" diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index fcf7d25..aeceff9 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -39,7 +39,7 @@ import qualified XMonad.StackSet as W withSpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True mods = - withSpacing . reinterpretResize . poppable . flippable . rotateable . hole + withSpacing . poppable . flippable . rotateable . hole myLayout = fullscreenFull $ diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs index c3a1918..7e628fc 100644 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs @@ -11,7 +11,7 @@ import Control.Monad.Writer (execWriter, tell) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout.Pop (PopMessage(..)) +import Rahm.Desktop.Layout.Pop (setPop) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (()) import Text.Printf (printf) @@ -49,7 +49,7 @@ drawLayout = do -- Gotta reset the layout to a consistent state. layout' <- foldM (flip ($)) layout $ [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' Unpop + handleMessage' $ setPop $ const False ] -- Add some changes for the Mosaic layout to handle so it get's a -- unique looking icon. (The default state is pretty boring). diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index 037e664..7e3dbd1 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -8,7 +8,9 @@ module Rahm.Desktop.Layout.Pop ( Poppable(..), PopMessage(..), poppable, - reinterpretResize) where + resizePop, + togglePop, + setPop) where import XMonad import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) @@ -17,7 +19,7 @@ import qualified XMonad.StackSet as W import Rahm.Desktop.Layout.ReinterpretMessage -data Poppable a = Poppable { +data Poppable (l :: * -> *) (a :: *) = Poppable { -- True if the current window is popped out or not. isPopped :: Bool @@ -26,79 +28,69 @@ data Poppable a = Poppable { -- Fraction of the screen height around the window. , yFrac :: Float + + , wrap :: l a } deriving (Show, Read, Eq, Ord) -instance Default (Poppable a) where - def = Poppable { - isPopped = False - , xFrac = 0.05 - , yFrac = 0.05 - } - --- Returns a modified layout that converts Resize (Shrink/Expand) into ResizePop --- messages. Unfortunately this is required because a LayoutModifier has no way --- to intercept messages and block them from propegating, which is pretty silly. --- --- So, reinterpretResize will turn a Shrink/Expand into a ResizePop, this will --- be consumed by the Poppable layout modifier. If the Poppable LayoutModifier --- is not active, it will turn the ResizePop back into a Shrink/Expand and --- forward it to the underlying layout. -reinterpretResize :: - l a -> ModifiedLayout (ReinterpretMessage "ForPop") l a -reinterpretResize = ModifiedLayout ReinterpretMessage - -poppable :: l a -> ModifiedLayout Poppable l a -poppable = ModifiedLayout def - --- Message to control the state of the popped layouts modifier. -data PopMessage = TogglePop | Pop | Unpop | ResizePop Float - deriving (Typeable, Show, Eq, Ord, Message) - -instance DoReinterpret "ForPop" where - reinterpretMessage _ (fromMessage -> Just mess) = - return $ Just $ SomeMessage $ - case mess of - Shrink -> ResizePop (-0.05) - Expand -> ResizePop 0.05 - - reinterpretMessage _ _ = return Nothing - -instance (Eq a) => LayoutModifier Poppable a where +data PopMessage where + PopMessage :: (forall l a. Poppable l a -> Poppable l a) -> PopMessage + deriving (Message) + +resizePop :: Float -> PopMessage +resizePop f = PopMessage $ \(Poppable b x y l) -> + Poppable b (g $ x + f) (g $ y + f) l + where + g = max 0 . min 0.45 + +setPop :: (Bool -> Bool) -> PopMessage +setPop f = PopMessage $ \(Poppable b x y l) -> Poppable (f b) x y l + +togglePop :: PopMessage +togglePop = setPop not + +poppable :: l a -> Poppable l a +poppable = Poppable False 0.05 0.05 +instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where + -- If the current layout is not popped, then just return what the underlying -- layout returned. - redoLayout Poppable { isPopped = False } _ _ returned = - return (returned, Nothing) - -- Can't do anything with an empty stack. - redoLayout _ _ Nothing returned = return (returned, Nothing) - - redoLayout self (Rectangle x y w h) (Just (W.focus -> focused)) returned = - return ((focused, newRect) : remaining, Nothing) + runLayout (W.Workspace + t + (Poppable True xs ys l) + a@(Just (W.focus -> focused))) + rect@(Rectangle x y w h) = do + (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return + ((focused, newRect) : filter ((/=focused) . fst) returned, + Poppable True xs ys <$> maybeNewLayout) where - remaining = filter ((/=focused) . fst) returned - wp = floor $ fromIntegral w * xFrac self - hp = floor $ fromIntegral h * yFrac self + wp = floor $ fromIntegral w * xs + hp = floor $ fromIntegral h * ys newRect = Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2)) - -- Handle the Pop messages associated with this layout. - handleMessOrMaybeModifyIt self (fromMessage -> Just mess) = - return $ Just $ case mess of - TogglePop -> Left $ self { isPopped = not (isPopped self) } - Pop -> Left $ self { isPopped = True } - Unpop -> Left $ self { isPopped = False } - ResizePop amt | isPopped self -> - Left $ self { - xFrac = guard (xFrac self + amt), - yFrac = guard (yFrac self + amt) - } - ResizePop amt -> Right $ SomeMessage $ - if amt > 0 then Expand else Shrink - where - guard = min 0.45 . max 0 - - handleMessOrMaybeModifyIt _ _ = return Nothing + -- If the pop is not active, just delegate to the underlying layout. + runLayout (W.Workspace t (Poppable b x y l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, Poppable b x y <$> maybeNewLayout) + + -- If the message is a PopMessage, handle that here. + handleMessage p (fromMessage -> Just (PopMessage f)) = + return $ Just $ f p + + -- Intercept Shrink/Expand message if the pop is active, and resize the + -- pop size. + handleMessage p (fromMessage -> Just mess) | isPopped p = + case mess of + Shrink -> handleMessage p (SomeMessage $ resizePop 0.025) + Expand -> handleMessage p (SomeMessage $ resizePop (-0.025)) + + -- By default just pass the message to the underlying layout. + handleMessage (Poppable b x y l) mess = do + maybeNewLayout <- handleMessage l mess + return (Poppable b x y <$> maybeNewLayout) -- cgit From 85937a13ad9a272d4c9e462b9b7a8b121ae453a6 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 11:45:41 -0600 Subject: Change keys to make H+Space a leader key for doing layout related stuff. Not sure how I feel about it right now; it'll take some getting used to. --- src/Rahm/Desktop/Keys.hs | 44 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 5284a9d..33830dc 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -263,7 +263,7 @@ keymap = runKeys $ do justMod $ doc "Goto a workspace\n\n\t\ - \If the second character typed is alpha-numberic, jump to that\n\t\ + \If the second character typed is alpha-numeric, jump to that\n\t\ \workspace. The workspace is created on-the-fly if such a workspace\n\t\ \does not exist.\n\n\t\ @@ -412,15 +412,39 @@ keymap = runKeys $ do altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" bind xK_space $ do - justMod $ - doc "Use the next layout in the layout list." $ sendMessage toNextLayout - - altMod $ - doc "Reset the layout to the default layout." $ sendMessage toFirstLayout - - shiftMod $ - doc "Use the previous layout in the layout list." $ - sendMessage toPreviousLayout + justMod $ subkeys $ do + + bind xK_n $ + noMod $ doc "Use the next layout in the layout list." $ + sendMessage toNextLayout + + bind xK_p $ + noMod $ doc "Use the previous layout in thelayout list." $ + sendMessage toPreviousLayout + + bind xK_b $ + noMod $ doc "Go back to the first layout in the layout list." $ + sendMessage toFirstLayout + + bind xK_h $ + noMod $ doc "Flip the layout across the horizontal axis" $ + sendMessage flipVertically + + bind xK_v $ + noMod $ doc "Flip the layout across the vertical axis" $ + sendMessage flipHorizontally + + bind xK_r $ + noMod $ doc "Rotate the layout 90 degrees" $ + sendMessage rotateLayout + + bind xK_t $ + noMod $ doc "Toggle the pop window" $ + sendMessage togglePop + + bind xK_x $ + noMod $ doc "Toggle the hole" $ + sendMessage toggleHole bind xK_t $ do justMod $ -- cgit From 3c6a91392cc249a3e71c206dd06dd8a2aa79c329 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 11:55:57 -0600 Subject: noMod -> (noMod -|- justMod) --- src/Rahm/Desktop/Keys.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 33830dc..27de459 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -412,38 +412,38 @@ keymap = runKeys $ do altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" bind xK_space $ do - justMod $ subkeys $ do + justMod $ doc "Layout-related bindings" $ subkeys $ do bind xK_n $ - noMod $ doc "Use the next layout in the layout list." $ + (noMod -|- justMod) $ doc "Use the next layout in the layout list." $ sendMessage toNextLayout bind xK_p $ - noMod $ doc "Use the previous layout in thelayout list." $ + (noMod -|- justMod) $ doc "Use the previous layout in the layout list." $ sendMessage toPreviousLayout bind xK_b $ - noMod $ doc "Go back to the first layout in the layout list." $ + (noMod -|- justMod) $ doc "Go back to the first layout in the layout list." $ sendMessage toFirstLayout bind xK_h $ - noMod $ doc "Flip the layout across the horizontal axis" $ + (noMod -|- justMod) $ doc "Flip the layout across the horizontal axis" $ sendMessage flipVertically bind xK_v $ - noMod $ doc "Flip the layout across the vertical axis" $ + (noMod -|- justMod) $ doc "Flip the layout across the vertical axis" $ sendMessage flipHorizontally bind xK_r $ - noMod $ doc "Rotate the layout 90 degrees" $ + (noMod -|- justMod) $ doc "Rotate the layout 90 degrees" $ sendMessage rotateLayout bind xK_t $ - noMod $ doc "Toggle the pop window" $ + (noMod -|- justMod) $ doc "Toggle the pop window" $ sendMessage togglePop bind xK_x $ - noMod $ doc "Toggle the hole" $ + (noMod -|- justMod) $ doc "Toggle the hole" $ sendMessage toggleHole bind xK_t $ do -- cgit From 2f636306406371a32e52c1f7bd7a103d4285b586 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 12:19:02 -0600 Subject: Clean up LayoutList and move to Layout.List --- src/Rahm/Desktop/Keys.hs | 2 +- src/Rahm/Desktop/Layout.hs | 4 +- src/Rahm/Desktop/Layout/LayoutList.hs | 295 ---------------------------------- src/Rahm/Desktop/Layout/List.hs | 280 ++++++++++++++++++++++++++++++++ 4 files changed, 283 insertions(+), 298 deletions(-) delete mode 100644 src/Rahm/Desktop/Layout/LayoutList.hs create mode 100644 src/Rahm/Desktop/Layout/List.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 27de459..87f88cf 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -45,7 +45,6 @@ import XMonad.Actions.SpawnOn as SpawnOn import qualified Data.Map as Map import qualified XMonad.StackSet as W -import Rahm.Desktop.Layout.LayoutList import Rahm.Desktop.MouseMotion import Rahm.Desktop.Windows import Rahm.Desktop.Lib @@ -54,6 +53,7 @@ import Rahm.Desktop.PassMenu import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow +import Rahm.Desktop.Layout.List (toNextLayout, toPreviousLayout, toFirstLayout) import Rahm.Desktop.Layout.Hole (toggleHole) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index aeceff9..b416111 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -25,7 +25,7 @@ import XMonad.Core import XMonad.Layout.NoBorders (smartBorders, noBorders) import Rahm.Desktop.Layout.CornerLayout (Corner(..)) -import Rahm.Desktop.Layout.LayoutList +import Rahm.Desktop.Layout.List import Rahm.Desktop.Windows import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop @@ -44,7 +44,7 @@ mods = myLayout = fullscreenFull $ avoidStruts $ - layoutZipper $ + layoutList $ mods (reinterpretIncMaster $ spiral (6/7)) |: mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: diff --git a/src/Rahm/Desktop/Layout/LayoutList.hs b/src/Rahm/Desktop/Layout/LayoutList.hs deleted file mode 100644 index 3e72e99..0000000 --- a/src/Rahm/Desktop/Layout/LayoutList.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -{- - - This module provides a more powerful version of the "Choose" layout that can - - be bidirectionally navigated. - - - - The indexing uses a type-safe zipper to keep track of the currently-selected - - layout. - -} -module Rahm.Desktop.Layout.LayoutList ( - LayoutList, - layoutZipper, - LCons, - LNil, - toNextLayout, - toPreviousLayout, - toFirstLayout, - (|:), - nil - )where - -import Control.Applicative ((<|>)) -import Data.Void -import Control.Monad.Identity (runIdentity) -import Data.Maybe (fromMaybe, fromJust) -import Control.Arrow (second) -import XMonad -import qualified XMonad.StackSet as W -import Data.Proxy - --- Type-level lists. LNil is the final of the list. LCons contains a layout and a --- tail. -data LNil a = LNil deriving (Read, Show) -data LCons l t a = LCons (l a) (t a) deriving (Read, Show) - --- Sel - This defines a structure where either this selected, or some --- other element is selected. --- --- These types can be composed to create what is effectively a bounded integer. --- I.e. there can be a type like --- --- Sel (Sel (Sel (Sel End))) --- --- Such a type is equivalent to an integer bounded at 4, because this type can --- exist in no more than 4 states: --- --- Sel --- Skip Sel --- Skip (Skip Sel) --- Skip (Skip (Skip Sel)) --- --- Note that a type (Sel End) can only be in the Sel as End may not be --- construted (without using undefined). -data Sel l = - Sel | - (Selector l) => Skip l -deriving instance (Read l, Selector l) => Read (Sel l) -deriving instance (Show l, Selector l) => Show (Sel l) -deriving instance (Eq l, Selector l) => Eq (Sel l) - --- Reimplement Void as End, just to keep the two separate, but End is for all --- intents and purposes Void. -data End -deriving instance Read End -deriving instance Show End -deriving instance Eq End - - --- Types that constitute a selection. Selections can be moved to the next --- selection, moved to the previous selection, optionally there could be a --- previous selection and they may be currently selected. -class (Eq c) => Selector c where - -- Increments the selection to the next state - -- - -- Returns Nothing if the selection class is in the final state and cannot be - -- incremented any farther. (This is helpful to facilitate modular - -- arithmatic) - increment :: c -> Maybe c - - -- Decrements the selection to the previous state. Returns Nothing if the - -- state is already in its initial setting. - decrement :: c -> Maybe c - - -- The initial state. - initial :: Maybe c - - -- The final state. - final :: Maybe c - --- --- Is selelected can be in two states: --- --- 1. The current element is selected --- 2. The current element is not selected and another element deeper in the --- structure is selected. -instance (Selector t) => Selector (Sel t) where - -- If the current element is not selected, increment the tail. - increment (Skip l) = Skip <$> increment l - -- If the current element is selected, the increment is just the initial of - -- the tail. - increment Sel = Skip <$> initial - - -- For a selection, the initial is just this in the Sel state. - initial = Just Sel - - -- Looks ahead at the tail, sees if it is selected, if so, select this one - -- instead, if the one ahead isn't selected, then decrement that one. - decrement (Skip t) = Just $ maybe Sel Skip (decrement t) - decrement Sel = Nothing - - -- Navigates to the end of the structure to find the final form. - final = Just $ maybe Sel Skip final - --- The End structure (which is equivalent to Void) is the "null" selector; the --- basecase that the Sel selector terminates at. -instance Selector End where - - -- Incrementing the End Selector doesn't do anything. - increment = const Nothing - - -- Decrementing the End Selector doesn't do anythig - decrement = const Nothing - - -- There is no initial value for the End selector. - initial = Nothing - - -- There is not final state for the End selector. - final = Nothing - --- Increment a selector, but cyclicly -incrementCycle :: (Selector c) => c -> c -incrementCycle c = - case increment c of - Nothing -> fromMaybe c initial - Just x -> x - --- Add two selectors together, incrementing the first until the second cannot be --- incremented anymore. -addSelector :: (Selector c) => c -> c -> c -addSelector c1 c2 = addSel c1 (decrement c2) - where - addSel c1 Nothing = c1 - addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) - --- Turn an int into a selector by repeatably incrementing. -intToSelector :: (Selector c) => Int -> c -intToSelector 0 = fromJust initial -intToSelector n = incrementCycle $ intToSelector (n - 1) - --- A LayoutList consists of a LayoutSelect type and a corresponding Selector. -data LayoutList l a where - LayoutList :: - (LayoutSelect l a, Selector (SelectorFor l)) => - SelectorFor l -> l a -> LayoutList l a - -deriving instance (LayoutSelect l a) => Show (LayoutList l a) -deriving instance (LayoutSelect l a) => Read (LayoutList l a) - -(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a -(|:) = LCons - -infixr 5 |: - --- Constructs a LayoutList. This function enforces that the SelectorFor l --- is a 'Sel' type. Essentially this enforces that there must be at least one --- underlying layout, otherwise a LayoutList cannot be constructed. -layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => - l a -> LayoutList l a -layoutZipper = LayoutList Sel - --- The termination of a layout zipper. -nil :: LNil a -nil = LNil - --- Message to navigate to a layout. -newtype NavigateLayout = - -- Sets the layout based on the given function. - NavigateLayout { - changeLayoutFn :: forall c. (Selector c) => c -> c - } - deriving (Typeable) - --- NavigateLayout instance to move to the next layout, circularly. -toNextLayout :: NavigateLayout -toNextLayout = NavigateLayout $ addSelector (intToSelector 1) - --- NavigateLayout instance to move to the previous layout, circularly. -toPreviousLayout :: NavigateLayout -toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) - --- NavigateLayotu instance to move to the first layout. -toFirstLayout :: NavigateLayout -toFirstLayout = NavigateLayout (`fromMaybe` initial) - -instance Message NavigateLayout where - --- LayoutSelect class Describes a type that can be used to select a layout using --- the associated type SelectorFor. --- --- Instances of this class are LCons and LNil. -class (Show (l a), - Read (l a), - Read (SelectorFor l), - Show (SelectorFor l), - Selector (SelectorFor l)) => LayoutSelect l a where - - -- The selector that is used to update the layout corresponding to the - -- selector. This selector must be an instance of the Selector class. - type SelectorFor l :: * - - -- Update applies a functor to the selected layout and maybe returns a result - -- and an updated layout. - update :: forall r m. (Monad m) => - -- The selector for this type. Determines which layout the function is - -- applied to. - SelectorFor l -> - -- The LayoutSelect being modified. - l a -> - -- Higher-ordered function to generically apply to the Layout associated - -- with the Selector. Works on all LayoutClass's. - (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> - - -- Returns a result r, and an updated LayoutSelect. - m (Maybe (r, l a)) - --- Instance for LayoutSelect for cons -instance (Read (l a), - LayoutClass l a, - LayoutSelect t a, - Show (SelectorFor t), - Read (SelectorFor t)) => - LayoutSelect (LCons l t) a where - - -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure - -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the - -- number of Cons in this structure enforcing safe selection. - type SelectorFor (LCons l t) = Sel (SelectorFor t) - - -- The current layout in this Cons-list is selected. - update Sel (LCons layout t) fn = do - (r, layout') <- fn layout - return $ Just (r, LCons (fromMaybe layout layout') t) - - -- The current layout is not selected. Move on to another layout. - update (Skip s) (LCons l t) fn = - fmap (second $ \t' -> LCons l t') <$> update s t fn - --- LNil is a layout select. It doesn't do anything. Indeed update really can't --- be called on on this because that would require instantiating a End type. -instance LayoutSelect LNil a where - type SelectorFor LNil = End -- LNil cannot be selected. - update _ _ _ = return Nothing - --- Instance of layout class for LayoutList. The implementation for this --- just delegates to the underlying LayoutSelect class using the generic --- update method. -instance (Show (l a), Typeable l, LayoutSelect l a) => - LayoutClass (LayoutList l) a where - - runLayout (W.Workspace i (LayoutList idx l) ms) r = do - r <- update idx l $ \layout -> - runLayout (W.Workspace i layout ms) r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutList idx la)) - - pureLayout (LayoutList idx l) r s = runIdentity $ do - r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) - case r of - Nothing -> return [] - Just (r, a) -> return r - - emptyLayout (LayoutList idx l) r = do - r <- update idx l $ \layout -> emptyLayout layout r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutList idx la)) - - handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = - return $ Just (LayoutList (fn idx) l) - - handleMessage (LayoutList idx l) m = do - r <- update idx l $ \layout -> ((),) <$> handleMessage layout m - return $ LayoutList idx . snd <$> r - - pureMessage (LayoutList idx l) m = runIdentity $ do - r <- update idx l $ \layout -> return ((), pureMessage layout m) - return $ LayoutList idx . snd <$> r - - description (LayoutList idx l) = runIdentity $ do - r <- update idx l $ \l -> return (description l, Nothing) - return $ - case r of - Nothing -> "No Layout" - Just (descr, _) -> descr diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs new file mode 100644 index 0000000..96f9be5 --- /dev/null +++ b/src/Rahm/Desktop/Layout/List.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE UndecidableInstances #-} + +{- + - This module provides a more powerful version of the "Choose" layout that can + - be bidirectionally navigated. + - + - The indexing uses a type-safe zipper to keep track of the currently-selected + - layout. + -} +module Rahm.Desktop.Layout.List ( + LayoutList, + layoutList, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + (|:), + nil + )where + +import Control.Applicative ((<|>)) +import Data.Void +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe, fromJust) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +-- Type-level lists. LNil is the final of the list. LCons contains a layout and a +-- tail. +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +-- Sel - This defines a structure where either this selected, or some +-- other element is selected. +-- +-- These types can be composed to create what is effectively a bounded integer. +-- I.e. there can be a type like +-- +-- Sel (Sel (Sel (Sel End))) +-- +-- Such a type is equivalent to an integer bounded at 4, because this type can +-- exist in no more than 4 states: +-- +-- Sel +-- Skip Sel +-- Skip (Skip Sel) +-- Skip (Skip (Skip Sel)) +-- +-- Note that a type (Sel End) can only be in the Sel as End may not be +-- construted (without using undefined). +data Sel l = + Sel | + (Selector l) => Skip l +deriving instance (Read l, Selector l) => Read (Sel l) +deriving instance (Show l, Selector l) => Show (Sel l) +deriving instance (Eq l, Selector l) => Eq (Sel l) + +-- Reimplement Void as End, just to keep the two separate, but End is for all +-- intents and purposes Void. +data End +deriving instance Read End +deriving instance Show End +deriving instance Eq End + + +-- Types that constitute a selection. Selections can be moved to the next +-- selection, moved to the previous selection, optionally there could be a +-- previous selection and they may be currently selected. +class (Eq c) => Selector c where + -- Increments the selection to the next state + -- + -- Returns Nothing if the selection class is in the final state and cannot be + -- incremented any farther. (This is helpful to facilitate modular + -- arithmatic) + increment :: c -> Maybe c + + -- Decrements the selection to the previous state. Returns Nothing if the + -- state is already in its initial setting. + decrement :: c -> Maybe c + + -- The initial state. + initial :: Maybe c + + -- The final state. + final :: Maybe c + +-- +-- Is selelected can be in two states: +-- +-- 1. The current element is selected +-- 2. The current element is not selected and another element deeper in the +-- structure is selected. +instance (Selector t) => Selector (Sel t) where + -- If the current element is not selected, increment the tail. + increment (Skip l) = Skip <$> increment l + -- If the current element is selected, the increment is just the initial of + -- the tail. + increment Sel = Skip <$> initial + + -- For a selection, the initial is just this in the Sel state. + initial = Just Sel + + -- Looks ahead at the tail, sees if it is selected, if so, select this one + -- instead, if the one ahead isn't selected, then decrement that one. + decrement (Skip t) = Just $ maybe Sel Skip (decrement t) + decrement Sel = Nothing + + -- Navigates to the end of the structure to find the final form. + final = Just $ maybe Sel Skip final + +-- The End structure (which is equivalent to Void) is the "null" selector; the +-- basecase that the Sel selector terminates at. +instance Selector End where + + -- Incrementing the End Selector doesn't do anything. + increment = const Nothing + + -- Decrementing the End Selector doesn't do anythig + decrement = const Nothing + + -- There is no initial value for the End selector. + initial = Nothing + + -- There is not final state for the End selector. + final = Nothing + +-- Increment a selector, but cyclicly +incrementCycle :: (Selector c) => c -> c +incrementCycle c = + case increment c of + Nothing -> fromMaybe c initial + Just x -> x + +-- Add two selectors together, incrementing the first until the second cannot be +-- incremented anymore. +addSelector :: (Selector c) => c -> c -> c +addSelector c1 c2 = addSel c1 (decrement c2) + where + addSel c1 Nothing = c1 + addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) + +-- Turn an int into a selector by repeatably incrementing. +intToSelector :: (Selector c) => Int -> c +intToSelector 0 = fromJust initial +intToSelector n = incrementCycle $ intToSelector (n - 1) + +-- A LayoutList consists of a LayoutSelect type and a corresponding Selector. +data LayoutList l a where + LayoutList :: + (LayoutSelect l a, Selector (SelectorFor l)) => + SelectorFor l -> l a -> LayoutList l a + +deriving instance (LayoutSelect l a) => Show (LayoutList l a) +deriving instance (LayoutSelect l a) => Read (LayoutList l a) + +-- Cons two LayoutSelect types together. +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons + +infixr 5 |: + +-- Constructs a LayoutList. This function enforces that the SelectorFor l +-- is a 'Sel' type. Essentially this enforces that there must be at least one +-- underlying layout, otherwise a LayoutList cannot be constructed. +layoutList :: (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> LayoutList l a +layoutList = LayoutList Sel + +-- The termination of a layout zipper. +nil :: LNil a +nil = LNil + +-- Message to navigate to a layout. +newtype NavigateLayout = + -- Sets the layout based on the given function. + NavigateLayout { + changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) + +-- NavigateLayout instance to move to the next layout, circularly. +toNextLayout :: NavigateLayout +toNextLayout = NavigateLayout $ addSelector (intToSelector 1) + +-- NavigateLayout instance to move to the previous layout, circularly. +toPreviousLayout :: NavigateLayout +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) + +-- NavigateLayotu instance to move to the first layout. +toFirstLayout :: NavigateLayout +toFirstLayout = NavigateLayout (`fromMaybe` initial) + +instance Message NavigateLayout where + +-- LayoutSelect class Describes a type that can be used to select a layout using +-- the associated type SelectorFor. +-- +-- Instances of this class are LCons and LNil. +class (Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l)) => LayoutSelect l a where + + -- The selector that is used to update the layout corresponding to the + -- selector. This selector must be an instance of the Selector class. + type SelectorFor l :: * + + -- Update applies a functor to the selected layout and maybe returns a result + -- and an updated layout. + update :: forall r m. (Monad m) => + -- The selector for this type. Determines which layout the function is + -- applied to. + SelectorFor l -> + -- The LayoutSelect being modified. + l a -> + -- Higher-ordered function to generically apply to the Layout associated + -- with the Selector. Works on all LayoutClass's. + (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> + + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) + +-- Instance for LayoutSelect for cons +instance (Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t)) => + LayoutSelect (LCons l t) a where + + -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure + -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the + -- number of Cons in this structure enforcing safe selection. + type SelectorFor (LCons l t) = Sel (SelectorFor t) + + -- The current layout in this Cons-list is selected. + update Sel (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + -- The current layout is not selected. Move on to another layout. + update (Skip s) (LCons l t) fn = + fmap (second $ \t' -> LCons l t') <$> update s t fn + +-- LNil is a layout select. It doesn't do anything. Indeed update really can't +-- be called on on this because that would require instantiating a End type. +instance LayoutSelect LNil a where + type SelectorFor LNil = End -- LNil cannot be selected. + update _ _ _ = return Nothing + +-- Instance of layout class for LayoutList. The implementation for this +-- just delegates to the underlying LayoutSelect class using the generic +-- update method. +instance (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a where + + runLayout (W.Workspace i (LayoutList idx l) ms) r = do + r <- update idx l $ \layout -> + runLayout (W.Workspace i layout ms) r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = + return $ Just (LayoutList (fn idx) l) + + handleMessage (LayoutList idx l) m = do + r <- update idx l $ \layout -> ((),) <$> handleMessage layout m + return $ LayoutList idx . snd <$> r + + description (LayoutList idx l) = runIdentity $ do + r <- update idx l $ \l -> return (description l, Nothing) + return $ + case r of + Nothing -> "No Layout" + Just (descr, _) -> descr -- cgit From c0e224d7fabcf0d274419a5f3ae79bc4fea637f2 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 12:24:37 -0600 Subject: Move LayoutDraw -> Layout.Draw --- src/Rahm/Desktop/Layout/Draw.hs | 161 ++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Layout/LayoutDraw.hs | 161 ---------------------------------- src/Rahm/Desktop/XMobarLog.hs | 2 +- 3 files changed, 162 insertions(+), 162 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/Draw.hs delete mode 100644 src/Rahm/Desktop/Layout/LayoutDraw.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs new file mode 100644 index 0000000..e68bb17 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, +ScopedTypeVariables, BangPatterns #-} +module Rahm.Desktop.Layout.Draw (drawLayout) where + +import Control.Monad + +import Control.Arrow (second) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Control.Monad.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Hash (quickHash) +import Rahm.Desktop.Layout.Pop (setPop) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (()) +import Text.Printf (printf) +import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) +import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) + +import XMonad (X, + Rectangle(..), + Dimension, + LayoutClass, + Message, + Window, + SomeMessage(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +-- Draws and returns an XPM for the current layout. +-- +-- Returns +-- - Bool - true if the xpm has already been written, and is thus cached. +-- - String - description of the current layout +-- - String - the text to send to XMobar +-- +-- This function actually runs the current layout's doLayout function to +-- generate the XPM, so it's completely portable to all layouts. +-- +-- Note this function is impure and running the layout to create the XPM is also +-- impure. While in-practice most layouts are pure, it should be kept in mind. +drawLayout :: X (Bool, String, String) +drawLayout = do + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- foldM (flip ($)) layout $ [ + handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' $ setPop $ const False + ] + -- Add some changes for the Mosaic layout to handle so it get's a + -- unique looking icon. (The default state is pretty boring). + ++ replicate 10 (handleMessage' (expandWindowAlt 1)) + ++ replicate 5 (handleMessage' (expandWindowAlt 4)) + ++ replicate 1 (handleMessage' (expandWindowAlt 3)) + + (cached, xpm) <- drawXpmIO layout' + + return (cached , X.description layout, printf "" xpm) + +-- Returns true if a point is inside a rectangle (inclusive). +pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool +pointInRect (x, y) (Rectangle x' y' w h) = + x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce +-- noise from things like AvoidStruts, as there is unfortunately no way to force +-- avoid struts to be off, one can only toggle it. +sf :: (Integral a) => a +sf = 1024 + +handleMessage' :: + (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) +handleMessage' message layout = do + fromMaybe layout <$> X.handleMessage layout (SomeMessage message) + +-- Creates the XPM for the given layout and returns the path to it. +-- +-- This function does run doLayout on the given layout, and that should be +-- accounted for. +drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) +drawXpmIO l = do + dir <- X.getXMonadDir + + let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. + + let (w, h) = (56, 24) + let descr = X.description l + let iconCacheDir = dir "icons" "cache" + let iconPath = iconCacheDir (quickHash descr ++ ".xpm") + + let colors = [ + "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", + "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] + + (rects', _) <- + X.runLayout + (S.Workspace "0" l (S.differentiate [1 .. 5])) + (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) + + let rects = flip map rects' $ \(_, Rectangle x y w h) -> + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) + + X.liftIO $ do + exists <- doesFileExist iconPath + createDirectoryIfMissing True iconCacheDir + + unless exists $ do + let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 + writeFile iconPath xpmText + + return (exists, iconPath) + +-- +-- Create's an XPM, purely. Returns a string with the XPM contents. +-- Takes as arguments +-- +-- - dimensions of the icon. +-- - list of (color, rectangle) pairs. +-- - The amount to shrink the windows by for those pretty gaps. +-- +drawXpm :: + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String +drawXpm (w, h) rects' shrinkAmt = execWriter $ do + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c None\"a,\n" + + forM_ [0 .. h - 1] $ \y -> do + tell "\"" + forM_ [0 .. w - 1] $ \x -> + (case find (matches x y) zipRects of + Nothing -> tell "%" + Just (chr, _) -> tell [chr]) + tell "\"" + when (y /= h - 1 - shrinkAmt) (tell ",") + tell "\n" + tell "};\n" + + where + matches x y (_, (_, r)) = pointInRect (x, y) r + rects = map (second (shrink shrinkAmt)) rects' + guard a b = if a <= shrinkAmt then 1 else b + shrink amt (Rectangle x y w h) = + Rectangle + x + y + (guard w $ w - fromIntegral amt) + (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs deleted file mode 100644 index 7e628fc..0000000 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, -ScopedTypeVariables, BangPatterns #-} -module Rahm.Desktop.Layout.LayoutDraw (drawLayout) where - -import Control.Monad - -import Control.Arrow (second) -import Control.Concurrent (threadDelay) -import Control.Exception (handle) -import Control.Monad.Writer (execWriter, tell) -import Data.Foldable (find) -import Data.Maybe (fromMaybe) -import Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout.Pop (setPop) -import System.Directory (createDirectoryIfMissing, doesFileExist) -import System.FilePath (()) -import Text.Printf (printf) -import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) -import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) - -import XMonad (X, - Rectangle(..), - Dimension, - LayoutClass, - Message, - Window, - SomeMessage(..)) - -import qualified XMonad as X -import qualified XMonad.StackSet as S - --- Draws and returns an XPM for the current layout. --- --- Returns --- - Bool - true if the xpm has already been written, and is thus cached. --- - String - description of the current layout --- - String - the text to send to XMobar --- --- This function actually runs the current layout's doLayout function to --- generate the XPM, so it's completely portable to all layouts. --- --- Note this function is impure and running the layout to create the XPM is also --- impure. While in-practice most layouts are pure, it should be kept in mind. -drawLayout :: X (Bool, String, String) -drawLayout = do - winset <- X.gets X.windowset - let layout = S.layout $ S.workspace $ S.current winset - - -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout $ [ - handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' $ setPop $ const False - ] - -- Add some changes for the Mosaic layout to handle so it get's a - -- unique looking icon. (The default state is pretty boring). - ++ replicate 10 (handleMessage' (expandWindowAlt 1)) - ++ replicate 5 (handleMessage' (expandWindowAlt 4)) - ++ replicate 1 (handleMessage' (expandWindowAlt 3)) - - (cached, xpm) <- drawXpmIO layout' - - return (cached , X.description layout, printf "" xpm) - --- Returns true if a point is inside a rectangle (inclusive). -pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool -pointInRect (x, y) (Rectangle x' y' w h) = - x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' - where - fi :: (Integral a, Num b) => a -> b - fi = fromIntegral - --- Scale factory. Scaling the rectangles before writing the XPM helps to reduce --- noise from things like AvoidStruts, as there is unfortunately no way to force --- avoid struts to be off, one can only toggle it. -sf :: (Integral a) => a -sf = 1024 - -handleMessage' :: - (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) -handleMessage' message layout = do - fromMaybe layout <$> X.handleMessage layout (SomeMessage message) - --- Creates the XPM for the given layout and returns the path to it. --- --- This function does run doLayout on the given layout, and that should be --- accounted for. -drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) -drawXpmIO l = do - dir <- X.getXMonadDir - - let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. - - let (w, h) = (56, 24) - let descr = X.description l - let iconCacheDir = dir "icons" "cache" - let iconPath = iconCacheDir (quickHash descr ++ ".xpm") - - let colors = [ - "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", - "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] - - (rects', _) <- - X.runLayout - (S.Workspace "0" l (S.differentiate [1 .. 5])) - (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) - - let rects = flip map rects' $ \(_, Rectangle x y w h) -> - Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) - - X.liftIO $ do - exists <- doesFileExist iconPath - createDirectoryIfMissing True iconCacheDir - - unless exists $ do - let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 - writeFile iconPath xpmText - - return (exists, iconPath) - --- --- Create's an XPM, purely. Returns a string with the XPM contents. --- Takes as arguments --- --- - dimensions of the icon. --- - list of (color, rectangle) pairs. --- - The amount to shrink the windows by for those pretty gaps. --- -drawXpm :: - (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String -drawXpm (w, h) rects' shrinkAmt = execWriter $ do - tell "/* XPM */\n" - tell "static char *out[] = {\n" - tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) - - let zipRects = zip ['A' .. 'Z'] rects - - forM_ zipRects $ \(char, (color, _)) -> do - tell $ printf "\"%c c %s\",\n" char color - tell "\"% c None\"a,\n" - - forM_ [0 .. h - 1] $ \y -> do - tell "\"" - forM_ [0 .. w - 1] $ \x -> - (case find (matches x y) zipRects of - Nothing -> tell "%" - Just (chr, _) -> tell [chr]) - tell "\"" - when (y /= h - 1 - shrinkAmt) (tell ",") - tell "\n" - tell "};\n" - - where - matches x y (_, (_, r)) = pointInRect (x, y) r - rects = map (second (shrink shrinkAmt)) rects' - guard a b = if a <= shrinkAmt then 1 else b - shrink amt (Rectangle x y w h) = - Rectangle - x - y - (guard w $ w - fromIntegral amt) - (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 4b266c1..82c05b7 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -6,7 +6,7 @@ import Control.Monad.Writer (tell, execWriter) import Data.List (sortBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) -import Rahm.Desktop.Layout.LayoutDraw (drawLayout) +import Rahm.Desktop.Layout.Draw (drawLayout) import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) import XMonad.Util.NamedWindows (getName) import XMonad.Util.Run (spawnPipe) -- cgit From e5bee7f2f095bffdef1c31e27f4b036780b01654 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 13:07:17 -0600 Subject: Add type-static way to get the length of a LayoutList --- src/Rahm/Desktop/Keys.hs | 9 +++++++-- src/Rahm/Desktop/Layout.hs | 17 ++++++++++++----- src/Rahm/Desktop/Layout/List.hs | 35 +++++++++++++++++++++++++++++------ 3 files changed, 48 insertions(+), 13 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 87f88cf..321d185 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -53,7 +53,8 @@ import Rahm.Desktop.PassMenu import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow -import Rahm.Desktop.Layout.List (toNextLayout, toPreviousLayout, toFirstLayout) +import Rahm.Desktop.Layout.List ( + toNextLayout, toPreviousLayout, toFirstLayout, toIndexedLayout) import Rahm.Desktop.Layout.Hole (toggleHole) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) @@ -438,10 +439,14 @@ keymap = runKeys $ do (noMod -|- justMod) $ doc "Rotate the layout 90 degrees" $ sendMessage rotateLayout - bind xK_t $ + bind xK_c $ (noMod -|- justMod) $ doc "Toggle the pop window" $ sendMessage togglePop + bind xK_t $ + (noMod -|- justMod) $ doc "Jump to the middle layout." $ + sendMessage (toIndexedLayout (nLayouts `div` 2)) + bind xK_x $ (noMod -|- justMod) $ doc "Toggle the hole" $ sendMessage toggleHole diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index b416111..bd875d0 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -37,13 +37,17 @@ import Rahm.Desktop.Layout.Hole import qualified Data.Map as M import qualified XMonad.StackSet as W -withSpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True -mods = - withSpacing . poppable . flippable . rotateable . hole - myLayout = fullscreenFull $ - avoidStruts $ + avoidStruts myLayoutList + +mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True + + +mods = + mySpacing . poppable . flippable . rotateable . hole + +myLayoutList = layoutList $ mods (reinterpretIncMaster $ spiral (6/7)) |: mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: @@ -55,6 +59,9 @@ myLayout = mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: nil +nLayouts :: Int +nLayouts = layoutListLength myLayoutList + -- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages -- intended to modify the master space and instead have those messages expand -- and shrink the current window. diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs index 96f9be5..f533ea2 100644 --- a/src/Rahm/Desktop/Layout/List.hs +++ b/src/Rahm/Desktop/Layout/List.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, TypeOperators #-} {- - This module provides a more powerful version of the "Choose" layout that can @@ -15,18 +15,22 @@ module Rahm.Desktop.Layout.List ( toNextLayout, toPreviousLayout, toFirstLayout, + toIndexedLayout, (|:), - nil + nil, + layoutListLength, + layoutListLengthProxy )where import Control.Applicative ((<|>)) -import Data.Void +import Control.Arrow (second, (>>>)) import Control.Monad.Identity (runIdentity) import Data.Maybe (fromMaybe, fromJust) -import Control.Arrow (second) +import Data.Proxy +import Data.Void +import GHC.TypeLits import XMonad import qualified XMonad.StackSet as W -import Data.Proxy -- Type-level lists. LNil is the final of the list. LCons contains a layout and a -- tail. @@ -156,6 +160,20 @@ data LayoutList l a where deriving instance (LayoutSelect l a) => Show (LayoutList l a) deriving instance (LayoutSelect l a) => Read (LayoutList l a) +-- Type family to get the LengthOf a ConsList. +type family LengthOf (x :: * -> *) :: Nat where + LengthOf LNil = 0 + LengthOf (LCons l t) = 1 + LengthOf t + +-- Length of a LayoutList. This is calculated at Compile-time using +-- typefamilies and Nat TypeLits. +layoutListLength :: forall l n a. (LengthOf l ~ n, KnownNat n) => LayoutList l a -> Int +layoutListLength = fromIntegral . natVal . layoutListLengthProxy + +-- Proxy for the type-level Nat length of a LayoutList. +layoutListLengthProxy :: (LengthOf l ~ n) => LayoutList l a -> Proxy n +layoutListLengthProxy _ = Proxy + -- Cons two LayoutSelect types together. (|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a (|:) = LCons @@ -189,10 +207,15 @@ toNextLayout = NavigateLayout $ addSelector (intToSelector 1) toPreviousLayout :: NavigateLayout toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) --- NavigateLayotu instance to move to the first layout. +-- NavigateLayout instance to move to the first layout. toFirstLayout :: NavigateLayout toFirstLayout = NavigateLayout (`fromMaybe` initial) +-- NavigateLayout instance to go to an indexed layout. +toIndexedLayout :: Int -> NavigateLayout +toIndexedLayout i = NavigateLayout $ + (`fromMaybe` initial) >>> addSelector (intToSelector i) + instance Message NavigateLayout where -- LayoutSelect class Describes a type that can be used to select a layout using -- cgit From f85c7160e122f367a357d93689947daa1ef241ef Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 16:44:35 -0600 Subject: Fix repeatable key to do an action when first pressed. --- src/Rahm/Desktop/Keys.hs | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 321d185..622fd3a 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -115,17 +115,19 @@ button15 :: Button button15 = 15 keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l -keyBindingToKeymap bindings config = fmap bindingToX (bindings config) +keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config) where - bindingToX b = + bindingToX :: (KeyMask, KeySym) -> Documented KeyBinding -> X () + bindingToX key b = case b of Documented _ (Action x) -> x Documented _ (Submap mapping) -> - submap (fmap bindingToX mapping) - Documented _ (Repeat mapping) -> + submap (Map.mapWithKey bindingToX mapping) + Documented _ (Repeat mapping) -> do + mapM_ (bindingToX key) (Map.lookup key mapping) fix $ \recur -> - submap (fmap (\b -> bindingToX b >> recur) mapping) + submap (Map.mapWithKey (\k b -> bindingToX k b >> recur) mapping) keymap :: XConfig l -> KeyBindings keymap = runKeys $ do @@ -451,6 +453,20 @@ keymap = runKeys $ do (noMod -|- justMod) $ doc "Toggle the hole" $ sendMessage toggleHole + let spaceResize = repeatable $ do + bind xK_bracketright $ do + noMod $ + doc "Increase the gaps between windows." $ + sendMessage $ modifyWindowBorder 5 + + bind xK_bracketleft $ do + noMod $ + doc "Decrease the gaps between windows." $ + sendMessage $ modifyWindowBorder (-5) + + bind xK_bracketleft $ noMod spaceResize + bind xK_bracketright $ noMod spaceResize + bind xK_t $ do justMod $ doc "Spawn a terminal." $ spawnX (terminal config) -- cgit From 3abdbef6e5a7d8d614e5b8be5bd8ba2fbb81d01d Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 17:37:01 -0600 Subject: Add a Polling-style timeout to mapNextString. It's not the best thing in the world, but it should help keep things in a consistent state when dealing with many multi-stroke bindings. --- src/Rahm/Desktop/Submap.hs | 53 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 12 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index f3b9e23..5dc6fb0 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -11,9 +11,31 @@ import XMonad hiding (keys) import Control.Monad.Fix (fix) import qualified Data.Map as Map import Data.Map (Map) +import Control.Concurrent (threadDelay) +import Data.Word (Word64) import XMonad.Actions.Submap as X + +getMaskEventWithTimeout :: + Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a) + +getMaskEventWithTimeout timeout d mask fn = + allocaXEvent $ \ptr -> do + val <- getMaskEventWithTimeout' ptr timeout + if val + then Just <$> fn ptr + else return Nothing + + + where + getMaskEventWithTimeout' ptr t | t <= 0 = return False + getMaskEventWithTimeout' ptr timeout = do + b <- checkMaskEvent d mask ptr + if b + then return True + else threadDelay 10 >> getMaskEventWithTimeout' ptr (timeout - 10) + {- - Like submap fram XMonad.Actions.Submap, but sends the string from - XLookupString to the function along side the keysym. @@ -22,27 +44,34 @@ import XMonad.Actions.Submap as X - but also allows submappings for keys that may not have a character associated - with them (for example, the function keys). -} -mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X a) -> X a +mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X () mapNextStringWithKeysym fn = do XConf { theRoot = root, display = d } <- ask io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime - (m, str, keysym) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do - maskEvent d keyPressMask p - KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p - keysym <- keycodeToKeysym d code 0 - (_, str) <- lookupString (asKeyEvent p) + ret <- io $ fix $ \nextkey -> do + ret <- + getMaskEventWithTimeout 150000 d keyPressMask $ \p -> do + KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + return (m, str, keysym) - if isModifierKey keysym - then nextkey - else return (m, str, keysym) + case ret of + Just (m, str, keysym) -> + if isModifierKey keysym + then nextkey + else return ret - io $ ungrabKeyboard d currentTime + Nothing -> return Nothing - fn m keysym str + io $ ungrabKeyboard d currentTime + case ret of + Just (m, str, keysym) -> fn m keysym str + Nothing -> return () {- Like submap, but on the character typed rather than the kysym. -} -mapNextString :: (KeyMask -> String -> X a) -> X a +mapNextString :: (KeyMask -> String -> X ()) -> X () mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) {- Grabs the mouse and returns the next button press. -} -- cgit From 7d47e54beafbd0463e1dcf25c80511342cb6daaa Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 18:47:38 -0600 Subject: Finally fix deprecation issue --- src/Rahm/Desktop/Layout/Draw.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index e68bb17..8819e8f 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -86,7 +86,7 @@ handleMessage' message layout = do -- accounted for. drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) drawXpmIO l = do - dir <- X.getXMonadDir + dir <- X.asks (X.cfgDir . X.directories) let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. -- cgit From cbe073ecee5a5a0230f2223bd90c2fdacce06892 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 19:10:27 -0600 Subject: Replace submap and friends with my own versions that do the timeout. --- src/Rahm/Desktop/Submap.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 5dc6fb0..2306ee6 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -5,7 +5,9 @@ module Rahm.Desktop.Submap ( nextButton, nextMotion, nextMotionOrButton, - module X) where + submap, + submapDefault, + submapDefaultWithKey) where import XMonad hiding (keys) import Control.Monad.Fix (fix) @@ -14,8 +16,6 @@ import Data.Map (Map) import Control.Concurrent (threadDelay) import Data.Word (Word64) -import XMonad.Actions.Submap as X - getMaskEventWithTimeout :: Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a) @@ -74,6 +74,16 @@ mapNextStringWithKeysym fn = do mapNextString :: (KeyMask -> String -> X ()) -> X () mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) +submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () +submapDefaultWithKey def m = mapNextStringWithKeysym $ \mask sym _ -> do + Map.findWithDefault (def (mask, sym)) (mask, sym) m + +submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X () +submapDefault def = submapDefaultWithKey (const def) + +submap :: Map (KeyMask, KeySym) (X ()) -> X () +submap = submapDefault (return ()) + {- Grabs the mouse and returns the next button press. -} nextButton :: X (ButtonMask, Button) nextButton = do -- cgit From 6cee136399b92f302a9b660c140167b69b251e51 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 13 Apr 2022 00:22:08 -0600 Subject: Add ConsistentMosaic, a wrapper to make Mosaic more consistent. Right now, Mosaic operate on the windows itself. But this means that swapping windows can act very unintuitively. This wrapper changes mosaci to work on window /positions/ rather than windows themselves, so the window in position 1 will always be the same size, and when moved to position 2, it will inherit that position's size. There's still some buggy behavior, but it is in general much more intuitive than it was before. --- src/Rahm/Desktop/Keys.hs | 5 ++- src/Rahm/Desktop/Layout.hs | 17 +++---- src/Rahm/Desktop/Layout/ConsistentMosaic.hs | 69 +++++++++++++++++++++++++++++ src/Rahm/Desktop/Layout/Draw.hs | 2 +- 4 files changed, 82 insertions(+), 11 deletions(-) create mode 100644 src/Rahm/Desktop/Layout/ConsistentMosaic.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 622fd3a..f7aae3c 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -60,6 +60,7 @@ import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) +import Rahm.Desktop.Layout.ConsistentMosaic type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) @@ -362,7 +363,7 @@ keymap = runKeys $ do shiftMod $ doc "For mosaic layout, shrink the size-share of the current window" $ - withFocused $ sendMessage . shrinkWindowAlt + sendMessage =<< shrinkPositionAlt bind xK_m $ do justMod $ @@ -389,7 +390,7 @@ keymap = runKeys $ do shiftMod $ doc "For mosaic layout, increase the size-share of the current window." $ - withFocused $ sendMessage . expandWindowAlt + sendMessage =<< expandPositionAlt bind xK_q $ do shiftMod $ diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index bd875d0..d8c3442 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -33,6 +33,7 @@ import Rahm.Desktop.Layout.Flip import Rahm.Desktop.Layout.Rotate import Rahm.Desktop.Layout.Redescribe import Rahm.Desktop.Layout.Hole +import Rahm.Desktop.Layout.ConsistentMosaic import qualified Data.Map as M import qualified XMonad.StackSet as W @@ -50,7 +51,7 @@ mods = myLayoutList = layoutList $ mods (reinterpretIncMaster $ spiral (6/7)) |: - mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (MosaicWrap $ modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: mods (Redescribe UsingTall (Tall 1 (3/100) (1/2))) |: mods (Redescribe UsingThreeCol (ThreeCol 1 (3/100) (1/2))) |: @@ -72,17 +73,17 @@ instance DoReinterpret "ForMosaic" where -- IncMaster message reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do - fmap (SomeMessage . - (if n > 0 - then expandWindowAlt - else shrinkWindowAlt)) <$> getFocusedWindow + Just . SomeMessage <$> ( + if n > 0 + then expandPositionAlt + else shrinkPositionAlt) -- ResizeMaster message reinterpretMessage _ (fromMessage -> Just m) = do - fmap (SomeMessage . + Just . SomeMessage <$> (case m of - Expand -> expandWindowAlt - Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + Expand -> expandPositionAlt + Shrink -> shrinkPositionAlt) -- Messages that don't match the above, just leave it unmodified. reinterpretMessage _ m = return (Just m) diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs new file mode 100644 index 0000000..db1ce4e --- /dev/null +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -0,0 +1,69 @@ + +-- This module provides a wrapper around the Mosaic layout to create a more +-- consistent experience where instead of the windows being the ones it works +-- on, it instead works on the window places so things like window swapping +-- still work as expected. +module Rahm.Desktop.Layout.ConsistentMosaic where + +import XMonad +import qualified XMonad.StackSet as W +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (mapMaybe) + +import XMonad.Layout.MosaicAlt + +import Rahm.Desktop.Windows +import Rahm.Desktop.Logger + + +newtype MosaicWrap l a = MosaicWrap (l a) deriving (Read, Show) + +doAlt :: (Window -> HandleWindowAlt) -> X HandleWindowAlt +doAlt f = do + (W.StackSet (W.Screen (W.Workspace _ _ mStack) _ _) _ _ _) + <- windowset <$> get + + return $ + case mStack of + Nothing -> f 0 + Just (W.Stack _ u _) -> f (fromIntegral $ length u + 100) + +expandPositionAlt :: X HandleWindowAlt +expandPositionAlt = doAlt expandWindowAlt + +shrinkPositionAlt :: X HandleWindowAlt +shrinkPositionAlt = doAlt shrinkWindowAlt + + +instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicWrap l) a where + + runLayout (W.Workspace t (MosaicWrap l) (id -> Just s)) rect = do + let zs = zipStack [100..] s + s' = mapStack fst zs + m = Map.fromList (W.integrate zs) + + (rects, maybeNewLayout) <- runLayout (W.Workspace t l (Just s')) rect + let rects' = + flip mapMaybe rects $ \(place, rect) -> + (,rect) <$> Map.lookup place m + + return (rects', MosaicWrap <$> maybeNewLayout) + + where + zipStack as (W.Stack b c d) = + let (cz, bz : dz) = splitAt (length c) as in + W.Stack (bz, b) (zip (reverse cz) c) (zip dz d) + + + runLayout (W.Workspace t (MosaicWrap l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, MosaicWrap <$> maybeNewLayout) + + + -- By default just pass the message to the underlying layout. + handleMessage (MosaicWrap l) mess = do + maybeNewLayout <- handleMessage l mess + return (MosaicWrap <$> maybeNewLayout) + + description _ = "ConsistentMosaic" diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index 8819e8f..aa4dba3 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -136,7 +136,7 @@ drawXpm (w, h) rects' shrinkAmt = execWriter $ do forM_ zipRects $ \(char, (color, _)) -> do tell $ printf "\"%c c %s\",\n" char color - tell "\"% c None\"a,\n" + tell "\"% c None\",\n" forM_ [0 .. h - 1] $ \y -> do tell "\"" -- cgit From 0dfe872da02d5d63eb2b334decd3a8292aff3ca3 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 13 Apr 2022 11:17:12 -0600 Subject: Consistent timeouts using the clock rather than counting threadDelay. Add timeout to nextButton --- src/Rahm/Desktop/KeysM.hs | 2 +- src/Rahm/Desktop/Submap.hs | 43 ++++++++++++++++++++++++++----------------- 2 files changed, 27 insertions(+), 18 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/KeysM.hs b/src/Rahm/Desktop/KeysM.hs index dcbce2a..403b3fc 100644 --- a/src/Rahm/Desktop/KeysM.hs +++ b/src/Rahm/Desktop/KeysM.hs @@ -470,7 +470,7 @@ documentation = execWriter . document' "" group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) prettyShow :: (KeyMask, KeySym) -> String - prettyShow (mask, key) = printf "<%s%s>" (showMask mask) (keysymToString key) + prettyShow (mask, key) = printf "%s%s" (showMask mask) (keysymToString key) hasSubmap b = case b of Action _ -> False diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 2306ee6..da9fe77 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -15,26 +15,36 @@ import qualified Data.Map as Map import Data.Map (Map) import Control.Concurrent (threadDelay) import Data.Word (Word64) +import Data.Time.Clock.POSIX + + +currentTimeMillis :: IO Int +currentTimeMillis = round . (*1000) <$> getPOSIXTime getMaskEventWithTimeout :: Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a) -getMaskEventWithTimeout timeout d mask fn = +getMaskEventWithTimeout timeout d mask fn = do + curTime <- currentTimeMillis allocaXEvent $ \ptr -> do - val <- getMaskEventWithTimeout' ptr timeout + val <- getMaskEventWithTimeout' ptr (curTime + timeout) if val then Just <$> fn ptr else return Nothing where - getMaskEventWithTimeout' ptr t | t <= 0 = return False getMaskEventWithTimeout' ptr timeout = do - b <- checkMaskEvent d mask ptr - if b - then return True - else threadDelay 10 >> getMaskEventWithTimeout' ptr (timeout - 10) + curTime <- currentTimeMillis + + if curTime >= timeout + then return False + else do + b <- checkMaskEvent d mask ptr + if b + then return True + else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout {- - Like submap fram XMonad.Actions.Submap, but sends the string from @@ -51,7 +61,7 @@ mapNextStringWithKeysym fn = do ret <- io $ fix $ \nextkey -> do ret <- - getMaskEventWithTimeout 150000 d keyPressMask $ \p -> do + getMaskEventWithTimeout 1000 d keyPressMask $ \p -> do KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p keysym <- keycodeToKeysym d code 0 (_, str) <- lookupString (asKeyEvent p) @@ -84,14 +94,14 @@ submapDefault def = submapDefaultWithKey (const def) submap :: Map (KeyMask, KeySym) (X ()) -> X () submap = submapDefault (return ()) -{- Grabs the mouse and returns the next button press. -} -nextButton :: X (ButtonMask, Button) +-- Returns the next button press, or Nothing if the timeout expires before the +-- next button is pressed. +nextButton :: X (Maybe (ButtonMask, Button)) nextButton = do XConf { theRoot = root, display = d } <- ask io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime - ret <- io $ allocaXEvent $ \xEv -> do - maskEvent d buttonPressMask xEv + ret <- io $ getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv return (m, button) @@ -136,8 +146,7 @@ nextMotionOrButton = do submapButtonsWithKey :: ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X () submapButtonsWithKey defaultAction actions window = do - arg <- nextButton - - case Map.lookup arg actions of - Nothing -> defaultAction arg window - Just fn -> fn window + maybe (return ()) (\arg -> + case Map.lookup arg actions of + Nothing -> defaultAction arg window + Just fn -> fn window) =<< nextButton -- cgit From c92cd07aaf7c54cd528166fc46dbade8008f5392 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 13 Apr 2022 18:29:27 -0600 Subject: [WIP] Working on better workspaces --- src/Rahm/Desktop/Keys.hs | 95 +++++++++++++++------------- src/Rahm/Desktop/Lib.hs | 108 ++------------------------------ src/Rahm/Desktop/Marking.hs | 8 ++- src/Rahm/Desktop/Workspaces.hs | 136 +++++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/XMobarLog.hs | 2 +- 5 files changed, 201 insertions(+), 148 deletions(-) create mode 100644 src/Rahm/Desktop/Workspaces.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index f7aae3c..2f30763 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -61,6 +61,7 @@ import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) import Rahm.Desktop.Layout.ConsistentMosaic +import Rahm.Desktop.Workspaces type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) @@ -264,6 +265,19 @@ keymap = runKeys $ do sendMessage flipHorizontally bind xK_g $ do + let selectWorkspace :: (KeySym, String) -> Maybe (X WorkspaceId) + selectWorkspace s = case s of + (_, [ch]) | isAlphaNum ch -> Just $ return [ch] + (_, "]") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace + (_, "[") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace + (_, "}") -> Just $ adjacentScreen next + (_, "{") -> Just $ adjacentScreen prev + (_, "/") -> Just $ runMaybeT $ do + windowId <- askWindowId + workspaceWithWindow askWindowId + (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace + _ -> Nothing + justMod $ doc "Goto a workspace\n\n\t\ @@ -279,35 +293,45 @@ keymap = runKeys $ do \: Jump to the accompaning workspace.\n\t\t\ \F1: display this help.\n" $ mapNextStringWithKeysym $ \_ keysym str -> - case (keysym, str) of - (_, [ch]) | isAlphaNum ch -> gotoWorkspace ch - (_, "]") -> pushHistory $ withRelativeWorkspace next W.greedyView - (_, "[") -> pushHistory $ withRelativeWorkspace prev W.greedyView - (_, "}") -> windows screenRotateForward - (_, "{") -> windows screenRotateBackward - (_, " ") -> gotoAccompaningWorkspace - + case ((keysym, str), selectWorkspace (keysym, str)) of + (_, Just w) -> pushHistory $ gotoWorkspace =<< w -- Test binding. Tests that I can still submap keysyms alone (keys -- where XLookupString won't return anything helpful.) - (f, _) | f == xK_F1 -> + ((f, _), _) | f == xK_F1 -> (safeSpawn "gxmessage" [ "-fn", "Source Code Pro", documentation (keymap config)] :: X ()) - _ -> return () + shiftMod $ doc "Move the currently focused window to another workspace" $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> shiftToWorkspace ch - "]" -> withRelativeWorkspace next W.shift - "[" -> withRelativeWorkspace prev W.shift + mapNextStringWithKeysym $ \_ keysym str -> + case ((keysym, str), selectWorkspace (keysym, str)) of + (_, Just w) -> shiftToWorkspace =<< w + _ -> return () + + controlMod $ + doc "Move the current focused window to another workspace and view that workspace" $ + mapNextStringWithKeysym $ \_ keysym str -> + case ((keysym, str), selectWorkspace (keysym, str)) of + (_, Just w) -> pushHistory $ do + ws <- w + shiftToWorkspace ws + gotoWorkspace ws + _ -> return () + + altMod $ + doc "Copy a window to the given workspace" $ + mapNextStringWithKeysym $ \_ keysym str -> + case ((keysym, str), selectWorkspace (keysym, str)) of + (_, Just ws) -> windows . CopyWindow.copy =<< ws _ -> return () + shiftAltMod $ doc "Swap this workspace with another workspace (rename)." $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> swapWorkspace ch + mapNextStringWithKeysym $ \_ keysym str -> + case ((keysym, str), selectWorkspace (keysym, str)) of + (_, Just ws) -> swapWorkspace =<< ws _ -> return () bind xK_h $ do @@ -373,16 +397,6 @@ keymap = runKeys $ do [ch] | isAlphaNum ch -> markCurrentWindow ch _ -> return () - bind xK_n $ do - justMod $ - doc "Shift to the next workspace." $ - withRelativeWorkspace next W.greedyView - - bind xK_p $ do - justMod $ - doc "Shift to the previous workspace." $ - withRelativeWorkspace prev W.greedyView - bind xK_plus $ do justMod $ doc "Increase the number of windows in the master region." $ @@ -511,14 +525,6 @@ keymap = runKeys $ do doc "Less often used keybindings." $ subkeys $ do - 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) $ doc "Go to the prior window in the history" historyPrev @@ -660,10 +666,12 @@ mouseMap = runButtons $ do justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster bind button6 $ - justMod $ noWindow (withRelativeWorkspace prev W.greedyView) + justMod $ + noWindow (viewAdjacent prev) bind button7 $ - justMod $ noWindow (withRelativeWorkspace next W.greedyView) + justMod $ + noWindow (viewAdjacent next) bind button8 $ justMod $ noWindow mediaPrev @@ -675,7 +683,7 @@ mouseMap = runButtons $ do noMod $ subMouse $ do bind button3 $ - noMod $ noWindow (gotoWorkspace 's') + noMod $ noWindow (gotoWorkspace "s") bind button13 $ do noMod $ noWindow $ click >> CopyWindow.kill1 @@ -714,7 +722,10 @@ mouseMap = runButtons $ do bind button15 $ do noMod $ subMouse $ do - bind button13 $ noMod $ noWindow gotoAccompaningWorkspace + bind button13 $ + noMod $ + noWindow $ + gotoWorkspace =<< (accompaningWorkspace <$> getCurrentWorkspace) bind button15 $ do noMod $ noWindow jumpToLast @@ -723,8 +734,8 @@ mouseMap = runButtons $ do let workspaceButtons = [ (button2, swapMaster), - (button9, withRelativeWorkspace next W.greedyView), - (button8, withRelativeWorkspace prev W.greedyView), + (button9, viewAdjacent next), + (button8, viewAdjacent prev), (button4, windows W.focusUp), (button5, windows W.focusDown), diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs index 2f90d0a..3b4ee9c 100644 --- a/src/Rahm/Desktop/Lib.hs +++ b/src/Rahm/Desktop/Lib.hs @@ -25,86 +25,12 @@ import Data.Ord (comparing) import qualified XMonad.StackSet as S import Rahm.Desktop.Windows -type WorkspaceName = Char -newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) - data WinPrompt = WinPrompt instance XPrompt WinPrompt where showXPrompt _ = "[Window] " commandToComplete _ = id -data WorkspaceState = Current | Hidden | Visible - deriving (Ord, Eq, Enum) - --- Returns all the workspaces that are either visible, current or Hidden but --- have windows and that workspace's state. --- --- In other words, filters out workspaces that have no windows and are not --- visible. --- --- This function will sort the result by the workspace tag. -getPopulatedWorkspaces :: - (Ord i) => S.StackSet i l a sid sd -> [(WorkspaceState, S.Workspace i l a)] -getPopulatedWorkspaces (S.StackSet (S.Screen cur _ _) vis hi _) = - sortOn (tag . snd) $ - mapMaybe (\w@(S.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ - map (\(S.Screen w _ _) -> (Visible, w)) vis ++ - [(Current, cur)] - -getHorizontallyOrderedScreens :: - StackSet wid l a ScreenId ScreenDetail -> - [Screen wid l a ScreenId ScreenDetail] --- ^ Returns a list of screens ordered from leftmost to rightmost. -getHorizontallyOrderedScreens windowSet = - flip sortBy screens $ \sc1 sc2 -> - let (SD (Rectangle x1 _ _ _)) = screenDetail sc1 - (SD (Rectangle x2 _ _ _)) = screenDetail sc2 - in x1 `compare` x2 - where - screens = current windowSet : visible windowSet - -getCurrentWorkspace :: X WorkspaceName -getCurrentWorkspace = withWindowSet $ - \(StackSet (Screen (Workspace t _ _) _ _) _ _ _) -> do - return (head t) - -gotoAccompaningWorkspace :: X () -gotoAccompaningWorkspace = do - cur <- getCurrentWorkspace - if isUpper cur - then gotoWorkspace (toLower cur) - else gotoWorkspace (toUpper cur) - -gotoWorkspace :: WorkspaceName -> X () -gotoWorkspace ch = pushHistory $ do - addHiddenWorkspace [ch] - windows $ greedyView $ return ch - -shiftToWorkspace :: WorkspaceName -> X () -shiftToWorkspace ch = do - addHiddenWorkspace [ch] - (windows . shift . return) ch - -swapWorkspace :: WorkspaceName -> X () -swapWorkspace toWorkspaceName = do - addHiddenWorkspace [toWorkspaceName] - windows $ \ss -> do - let fromWorkspace = tag $ workspace $ current ss - toWorkspace = [toWorkspaceName] in - StackSet (swapSc fromWorkspace toWorkspace $ current ss) - (map (swapSc fromWorkspace toWorkspace) $ visible ss) - (map (swapWs fromWorkspace toWorkspace) $ hidden ss) - (floating ss) - where - swapSc fromWorkspace toWorkspace (Screen ws a b) = - Screen (swapWs fromWorkspace toWorkspace ws) a b - - swapWs fromWorkspace toWorkspace ws@(Workspace t' l s) - | t' == fromWorkspace = Workspace toWorkspace l s - | t' == toWorkspace = Workspace fromWorkspace l s - | otherwise = ws - fuzzyCompletion :: String -> String -> Bool fuzzyCompletion str0 str1 = all (`isInfixOf`l0) ws @@ -121,38 +47,16 @@ getString = runQuery $ do then t else printf "%s - %s" t a -withRelativeWorkspace :: Selector -> (WorkspaceId -> WindowSet -> WindowSet) -> X () -withRelativeWorkspace (Selector selector) fn = - windows $ \ss -> - let tags = sort (tag . snd <$> filter (\x -> fst x /= Visible ) (getPopulatedWorkspaces ss)) - from = tag $ workspace $ current ss - to = selector from tags - in fn to ss - -next :: Selector -next = Selector $ \a l -> select a l l - where select n (x:y:xs) _ | n == x = y - select n [x] (y:_) | n == x = y - select n (x:xs) orig = select n xs orig - select n _ _ = n - -prev :: Selector -prev = Selector $ \a l -> - let (Selector fn) = next in fn a (reverse l) +askWindowId :: X (Maybe Window) +askWindowId = pushHistory $ do + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) -withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () -withScreen fn n = do - windows $ \windowSet -> - case getHorizontallyOrderedScreens windowSet !! n of - Nothing -> windowSet - Just screen -> fn (tag $ workspace screen) windowSet + runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId windowJump :: X () windowJump = pushHistory $ do - windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) - - windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId + windowId <- askWindowId case windowId of Nothing -> return () diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 8ca50fd..1144ad7 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -94,7 +94,7 @@ instance ExtensionClass MarkState where changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState) changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)} -withMaybeFocused :: (Maybe Window -> X ()) -> X () +withMaybeFocused :: (Maybe Window -> X a) -> X a withMaybeFocused f = withWindowSet $ f . peek normalizeWindows :: X () @@ -118,7 +118,7 @@ markCurrentWindow mark = do markStateMap = Map.insert mark win ms } -pushHistory :: X () -> X () +pushHistory :: X a -> X a pushHistory fn = do withMaybeFocused $ \maybeWindowBefore -> do case maybeWindowBefore of @@ -128,7 +128,7 @@ pushHistory fn = do withWindowSet $ \ws -> XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws))) - fn + ret <- fn withMaybeFocused $ \maybeWindowAfter -> case maybeWindowAfter of @@ -138,6 +138,8 @@ pushHistory fn = do withWindowSet $ \ws -> XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws) + return ret + withHistory :: (History Spot -> X ()) -> X () withHistory fn = do MarkState { windowHistory = w } <- XS.get diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs new file mode 100644 index 0000000..87d112e --- /dev/null +++ b/src/Rahm/Desktop/Workspaces.hs @@ -0,0 +1,136 @@ + +-- Common ways to select workspaces +module Rahm.Desktop.Workspaces where + +import Prelude hiding ((!!)) + +import Control.Arrow (second, (&&&)) +import qualified XMonad.StackSet as W +import XMonad + +import Data.List.Safe ((!!)) + +import XMonad.Actions.DynamicWorkspaces +import Data.List (sortOn, sort, sortBy, find) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.Char (isUpper, toUpper, toLower) + +newtype Selector = Selector (forall a. (a -> Bool) -> [a] -> Maybe a) + +data WorkspaceState = Current | Hidden | Visible + deriving (Ord, Eq, Enum) + +-- Returns all the workspaces that are either visible, current or Hidden but +-- have windows and that workspace's state. +-- +-- In other words, filters out workspaces that have no windows and are not +-- visible. +-- +-- This function will sort the result by the workspace tag. +getPopulatedWorkspaces :: + (Ord i) => W.StackSet i l a sid sd -> [(WorkspaceState, W.Workspace i l a)] +getPopulatedWorkspaces (W.StackSet (W.Screen cur _ _) vis hi _) = + sortOn (W.tag . snd) $ + mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ + map (\(W.Screen w _ _) -> (Visible, w)) vis ++ + [(Current, cur)] + +next :: Selector +next = Selector $ \f l -> select f l l + where select f (x:y:xs) _ | f x = Just y + select f [x] (y:_) | f x = Just y + select f (x:xs) orig = select f xs orig + select f _ _ = Nothing + +prev :: Selector +prev = Selector $ \f l -> + let (Selector fn) = next in fn f (reverse l) + +getCurrentWorkspace :: X WorkspaceId +getCurrentWorkspace = withWindowSet $ + \(W.StackSet (W.Screen (W.Workspace t _ _) _ _) _ _ _) -> do + return t + +getHorizontallyOrderedScreens :: + W.StackSet wid l a ScreenId ScreenDetail -> + [(Bool, W.Screen wid l a ScreenId ScreenDetail)] +-- ^ Returns a list of screens ordered from leftmost to rightmost. +getHorizontallyOrderedScreens windowSet = + flip sortBy screens $ \sc1 sc2 -> + let (SD (Rectangle x1 _ _ _)) = W.screenDetail (snd sc1) + (SD (Rectangle x2 _ _ _)) = W.screenDetail (snd sc2) + in x1 `compare` x2 + where + screens = (True, W.current windowSet) : map (False,) (W.visible windowSet) + +gotoWorkspace :: WorkspaceId -> X () +gotoWorkspace wid = do + addHiddenWorkspace wid + windows $ W.greedyView wid + +shiftToWorkspace :: WorkspaceId -> X () +shiftToWorkspace t = do + addHiddenWorkspace t + windows . W.shift $ t + + +accompaningWorkspace :: WorkspaceId -> WorkspaceId +accompaningWorkspace [s] = return $ + if isUpper s + then toLower s + else toUpper s +accompaningWorkspace s = s + +swapWorkspace :: WorkspaceId -> X () +swapWorkspace toWorkspace = do + addHiddenWorkspace toWorkspace + windows $ \ss -> do + let fromWorkspace = W.tag $ W.workspace $ W.current ss in + W.StackSet (swapSc fromWorkspace toWorkspace $ W.current ss) + (map (swapSc fromWorkspace toWorkspace) $ W.visible ss) + (map (swapWs fromWorkspace toWorkspace) $ W.hidden ss) + (W.floating ss) + where + swapSc fromWorkspace toWorkspace (W.Screen ws a b) = + W.Screen (swapWs fromWorkspace toWorkspace ws) a b + + swapWs fromWorkspace toWorkspace ws@(W.Workspace t' l s) + | t' == fromWorkspace = W.Workspace toWorkspace l s + | t' == toWorkspace = W.Workspace fromWorkspace l s + | otherwise = ws + +adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId +adjacentWorkspace (Selector selector) from = + withWindowSet $ \ss -> + let tags = sort $ + W.tag . snd <$> (filter (\x -> fst x /= Visible) $ + getPopulatedWorkspaces ss) + in + return $ fromMaybe from $ selector (==from) tags + +viewAdjacent :: Selector -> X () +viewAdjacent sel = + gotoWorkspace =<< (adjacentWorkspace sel =<< getCurrentWorkspace) + +adjacentScreen :: Selector -> X WorkspaceId +adjacentScreen (Selector f) = do + (screens, current) <- + withWindowSet $ return . (getHorizontallyOrderedScreens &&& W.current) + + return $ W.tag $ W.workspace $ fromMaybe current (snd <$> f fst screens) + +withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () +withScreen fn n = do + windows $ \windowSet -> + case map snd (getHorizontallyOrderedScreens windowSet) !! n of + Nothing -> windowSet + Just screen -> fn (W.tag $ W.workspace screen) windowSet + + +workspaceWithWindow :: Window -> X (Maybe WorkspaceId) +workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> + return $ + W.tag <$> + find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) + (map W.workspace (c : v) ++ h) + diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 82c05b7..4f8bbb8 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -11,7 +11,7 @@ import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) import XMonad.Util.NamedWindows (getName) import XMonad.Util.Run (spawnPipe) import XMonad (X) -import Rahm.Desktop.Lib (getPopulatedWorkspaces, WorkspaceState(..)) +import Rahm.Desktop.Workspaces (getPopulatedWorkspaces, WorkspaceState(..)) import Text.Printf import qualified XMonad as X -- cgit From 3cc28186cd3ab934e29c4864f7c6b074475906a1 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 14 Apr 2022 01:24:30 -0600 Subject: Make workspaces more consistent --- src/Rahm/Desktop/Keys.hs | 44 +++++++++++++++++++++++++++--------------- src/Rahm/Desktop/Workspaces.hs | 28 ++++++++++++++++++++------- 2 files changed, 49 insertions(+), 23 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 2f30763..6e16c25 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -5,6 +5,7 @@ import Data.Monoid (Endo(..)) import Control.Monad.Trans.Class import Control.Monad.Reader import Control.Monad.Writer +import Control.Monad.Trans.Maybe import Control.Monad.Loops (iterateWhile) import Control.Monad.Fix (fix) import Graphics.X11.ExtraTypes.XF86; @@ -267,30 +268,38 @@ keymap = runKeys $ do bind xK_g $ do let selectWorkspace :: (KeySym, String) -> Maybe (X WorkspaceId) selectWorkspace s = case s of - (_, [ch]) | isAlphaNum ch -> Just $ return [ch] + (_, [ch]) | isAlphaNum ch || ch == '*' -> Just $ return [ch] (_, "]") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace (_, "[") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace (_, "}") -> Just $ adjacentScreen next (_, "{") -> Just $ adjacentScreen prev - (_, "/") -> Just $ runMaybeT $ do - windowId <- askWindowId - workspaceWithWindow askWindowId + (_, "^") -> Just firstWorkspaceId + (_, "$") -> Just lastWorkspaceId + (_, "/") -> Just $ do + cur <- getCurrentWorkspace + fromMaybe cur <$> runMaybeT (do + windowId <- MaybeT askWindowId + MaybeT $ workspaceWithWindow windowId) (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace _ -> Nothing justMod $ - doc "Goto a workspace\n\n\t\ - - \If the second character typed is alpha-numeric, jump to that\n\t\ - \workspace. The workspace is created on-the-fly if such a workspace\n\t\ - \does not exist.\n\n\t\ - - \If the second character typed is:\n\t\t\ - \]: go to the next workspace\n\t\t\ - \[: go to the previous workspace\n\t\t\ - \}: cycle the workspaces on the screens to the right\n\t\t\ - \{: cycle the workspaces on the screens to the left\n\t\t\ - \: Jump to the accompaning workspace.\n\t\t\ + doc "Goto/Send/Etc To a workspace\n\n\t\ + + \Workspaces are alphanumeric characters. So if the next key typed is an\n\t\ + \alphanumeric character, that's the workspace to operate on\n\n\ + + \The following special characters can also reference workspaces:\n\t\t\ + \]: The next non-visible workspace\n\t\t\ + \[: The previous non-visible workspace\n\t\t\ + \}: The workspace on the screen to the right\n\t\t\ + \{: The workspace on the screen to the left\n\t\t\ + \: The accompaningWorkspace (toggled case)\n\t\t\ + \/: Prompt to select a window, and reference that workspace\n\t\t\ + \^: The first populated workspace\n\t\t\ + \$: The last populated workspace\n\t\t\ + \*: The hidden workspace.\n\t\t\ + \_: Black hole. Sending a window here closes it.\n\t\t\ \F1: display this help.\n" $ mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of @@ -308,6 +317,7 @@ keymap = runKeys $ do mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of (_, Just w) -> shiftToWorkspace =<< w + ((_, "_"), _) -> CopyWindow.kill1 _ -> return () controlMod $ @@ -332,6 +342,8 @@ keymap = runKeys $ do mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of (_, Just ws) -> swapWorkspace =<< ws + ((_, "_"), _) -> + mapM_ (\w -> focus w >> CopyWindow.kill1) =<< windowsInCurrentWorkspace _ -> return () bind xK_h $ do diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 87d112e..2a266b7 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -28,12 +28,13 @@ data WorkspaceState = Current | Hidden | Visible -- -- This function will sort the result by the workspace tag. getPopulatedWorkspaces :: - (Ord i) => W.StackSet i l a sid sd -> [(WorkspaceState, W.Workspace i l a)] + W.StackSet String l a sid sd -> [(WorkspaceState, W.Workspace String l a)] getPopulatedWorkspaces (W.StackSet (W.Screen cur _ _) vis hi _) = - sortOn (W.tag . snd) $ - mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ - map (\(W.Screen w _ _) -> (Visible, w)) vis ++ - [(Current, cur)] + filter ((/="*") . W.tag . snd) $ + sortOn (W.tag . snd) $ + mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ + map (\(W.Screen w _ _) -> (Visible, w)) vis ++ + [(Current, cur)] next :: Selector next = Selector $ \f l -> select f l l @@ -46,11 +47,24 @@ prev :: Selector prev = Selector $ \f l -> let (Selector fn) = next in fn f (reverse l) +lastWorkspaceId :: X WorkspaceId +lastWorkspaceId = + W.tag . snd . last <$> withWindowSet (return . getPopulatedWorkspaces) + +firstWorkspaceId :: X WorkspaceId +firstWorkspaceId = + W.tag . snd . head <$> withWindowSet (return . getPopulatedWorkspaces) + getCurrentWorkspace :: X WorkspaceId getCurrentWorkspace = withWindowSet $ \(W.StackSet (W.Screen (W.Workspace t _ _) _ _) _ _ _) -> do return t +windowsInCurrentWorkspace :: X [Window] +windowsInCurrentWorkspace = withWindowSet $ + \(W.StackSet (W.Screen (W.Workspace _ _ s) _ _) _ _ _) -> do + return $ W.integrate' s + getHorizontallyOrderedScreens :: W.StackSet wid l a ScreenId ScreenDetail -> [(Bool, W.Screen wid l a ScreenId ScreenDetail)] @@ -103,7 +117,7 @@ adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId adjacentWorkspace (Selector selector) from = withWindowSet $ \ss -> let tags = sort $ - W.tag . snd <$> (filter (\x -> fst x /= Visible) $ + W.tag . snd <$> filter (\x -> fst x /= Visible) ( getPopulatedWorkspaces ss) in return $ fromMaybe from $ selector (==from) tags @@ -117,7 +131,7 @@ adjacentScreen (Selector f) = do (screens, current) <- withWindowSet $ return . (getHorizontallyOrderedScreens &&& W.current) - return $ W.tag $ W.workspace $ fromMaybe current (snd <$> f fst screens) + return $ W.tag $ W.workspace $ maybe current snd (f fst screens) withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () withScreen fn n = do -- cgit From 0992b3df262c9ac91cc87133bd451ddcd4fcc6ad Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 14 Apr 2022 12:11:45 -0600 Subject: Minor changes --- src/Rahm/Desktop/Keys.hs | 36 ++++++++++++++++++++++++------------ src/Rahm/Desktop/Workspaces.hs | 13 ++++++++++--- 2 files changed, 34 insertions(+), 15 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 6e16c25..1bf1b2f 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -269,17 +269,18 @@ keymap = runKeys $ do let selectWorkspace :: (KeySym, String) -> Maybe (X WorkspaceId) selectWorkspace s = case s of (_, [ch]) | isAlphaNum ch || ch == '*' -> Just $ return [ch] - (_, "]") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace - (_, "[") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace + (_, "]") -> Just $ adjacentWorkspaceNotVisible next + =<< getCurrentWorkspace + (_, "[") -> Just $ adjacentWorkspaceNotVisible prev + =<< getCurrentWorkspace + (_, ")") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace + (_, "(") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace (_, "}") -> Just $ adjacentScreen next (_, "{") -> Just $ adjacentScreen prev (_, "^") -> Just firstWorkspaceId (_, "$") -> Just lastWorkspaceId - (_, "/") -> Just $ do - cur <- getCurrentWorkspace - fromMaybe cur <$> runMaybeT (do - windowId <- MaybeT askWindowId - MaybeT $ workspaceWithWindow windowId) + (_, "/") -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT ( + (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace _ -> Nothing @@ -289,9 +290,11 @@ keymap = runKeys $ do \Workspaces are alphanumeric characters. So if the next key typed is an\n\t\ \alphanumeric character, that's the workspace to operate on\n\n\ - \The following special characters can also reference workspaces:\n\t\t\ - \]: The next non-visible workspace\n\t\t\ - \[: The previous non-visible workspace\n\t\t\ + \\tThe following special characters can also reference workspaces:\n\t\t\ + \]: The next workspace, skipping those already visible.\n\t\t\ + \[: The previous workspace, skipping those already visible.\n\t\t\ + \): The next workspace.\n\t\t\ + \(: The previous workspace.\n\t\t\ \}: The workspace on the screen to the right\n\t\t\ \{: The workspace on the screen to the left\n\t\t\ \: The accompaningWorkspace (toggled case)\n\t\t\ @@ -299,8 +302,9 @@ keymap = runKeys $ do \^: The first populated workspace\n\t\t\ \$: The last populated workspace\n\t\t\ \*: The hidden workspace.\n\t\t\ - \_: Black hole. Sending a window here closes it.\n\t\t\ - \F1: display this help.\n" $ + \_: Black hole. Sending a window here closes it.\n\n\t\ + \Other keybindings starting with H-g\n\t\t\ + \F1: display this help.\n\n\t" $ mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of (_, Just w) -> pushHistory $ gotoWorkspace =<< w @@ -725,6 +729,14 @@ mouseMap = runButtons $ do bind button2 $ noMod $ windows . W.sink bind button3 $ noMod mouseResizeWindow + let swapButtons = [ + (button6, windows W.swapDown), + (button7, windows W.swapUp) + ] + + forM_ (map fst swapButtons) $ \b -> + bind b $ noMod $ \w -> click >> (continuous swapButtons b) w + bind button13 $ noMod $ subMouse $ do bind button13 $ noMod $ subMouse $ do bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 2a266b7..1349fea 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -113,8 +113,8 @@ swapWorkspace toWorkspace = do | t' == toWorkspace = W.Workspace fromWorkspace l s | otherwise = ws -adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId -adjacentWorkspace (Selector selector) from = +adjacentWorkspaceNotVisible :: Selector -> WorkspaceId -> X WorkspaceId +adjacentWorkspaceNotVisible (Selector selector) from = withWindowSet $ \ss -> let tags = sort $ W.tag . snd <$> filter (\x -> fst x /= Visible) ( @@ -122,9 +122,16 @@ adjacentWorkspace (Selector selector) from = in return $ fromMaybe from $ selector (==from) tags +adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId +adjacentWorkspace (Selector selector) from = + withWindowSet $ \ss -> + let tags = sort $ W.tag . snd <$> getPopulatedWorkspaces ss + in + return $ fromMaybe from $ selector (==from) tags + viewAdjacent :: Selector -> X () viewAdjacent sel = - gotoWorkspace =<< (adjacentWorkspace sel =<< getCurrentWorkspace) + gotoWorkspace =<< (adjacentWorkspaceNotVisible sel =<< getCurrentWorkspace) adjacentScreen :: Selector -> X WorkspaceId adjacentScreen (Selector f) = do -- cgit From 643642e5e76fd5278a26f560dca60e5b18ac8933 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 14 Apr 2022 16:50:03 -0600 Subject: Rename KeysM -> Keys/Dsl --- src/Rahm/Desktop/Keys.hs | 81 +++---- src/Rahm/Desktop/Keys/Dsl.hs | 496 +++++++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/KeysM.hs | 495 ------------------------------------------ 3 files changed, 539 insertions(+), 533 deletions(-) create mode 100644 src/Rahm/Desktop/Keys/Dsl.hs delete mode 100644 src/Rahm/Desktop/KeysM.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 1bf1b2f..fec7ce5 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -1,67 +1,66 @@ module Rahm.Desktop.Keys (applyKeys) where -import XMonad.Util.Run (safeSpawn) -import Data.Monoid (Endo(..)) -import Control.Monad.Trans.Class -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.Trans.Maybe -import Control.Monad.Loops (iterateWhile) -import Control.Monad.Fix (fix) -import Graphics.X11.ExtraTypes.XF86; -import Rahm.Desktop.KeysM -import Rahm.Desktop.SwapMaster (swapMaster) -import XMonad.Hooks.ManageDocks -import XMonad.Layout.MosaicAlt -import Graphics.X11.ExtraTypes.XorgDefault -import System.Process -import XMonad.Util.Ungrab -import XMonad.Layout.Spacing -import Data.Maybe (isJust, fromMaybe) -import Debug.Trace import Control.Applicative -import Prelude hiding ((!!)) import Control.Monad +import Control.Monad.Fix (fix) +import Control.Monad.Loops (iterateWhile) +import Control.Monad.Reader +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Writer import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Rahm.Desktop.Layout -import Rahm.Desktop.Marking -import Rahm.Desktop.PromptConfig +import Data.Maybe (isJust, fromMaybe) +import Data.Monoid (Endo(..)) +import Debug.Trace +import Graphics.X11.ExtraTypes.XF86; +import Graphics.X11.ExtraTypes.XorgDefault +import Prelude hiding ((!!)) import System.IO +import System.Process import Text.Printf import XMonad -import Rahm.Desktop.Submap +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Actions.RotSlaves +import XMonad.Actions.SpawnOn as SpawnOn import XMonad.Actions.WindowNavigation +import XMonad.Hooks.ManageDocks +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Spacing import XMonad.Prompt import XMonad.Prompt.Input import XMonad.Prompt.Shell import XMonad.Util.CustomKeys +import XMonad.Util.Run (safeSpawn) import XMonad.Util.Scratchpad -import XMonad.Actions.RotSlaves -import XMonad.Actions.CopyWindow as CopyWindow -import XMonad.Actions.SpawnOn as SpawnOn +import XMonad.Util.Ungrab import qualified Data.Map as Map import qualified XMonad.StackSet as W -import Rahm.Desktop.MouseMotion -import Rahm.Desktop.Windows -import Rahm.Desktop.Lib import Rahm.Desktop.DMenu -import Rahm.Desktop.PassMenu -import Rahm.Desktop.Logger -import Rahm.Desktop.RebindKeys -import Rahm.Desktop.Swallow -import Rahm.Desktop.Layout.List ( - toNextLayout, toPreviousLayout, toFirstLayout, toIndexedLayout) +import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.Layout +import Rahm.Desktop.Layout.ConsistentMosaic +import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Hole (toggleHole) +import Rahm.Desktop.Layout.List (toNextLayout, toPreviousLayout, toFirstLayout, toIndexedLayout) import Rahm.Desktop.Layout.Pop (togglePop) -import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) +import Rahm.Desktop.Lib +import Rahm.Desktop.Logger +import Rahm.Desktop.Marking +import Rahm.Desktop.MouseMotion +import Rahm.Desktop.PassMenu +import Rahm.Desktop.PromptConfig +import Rahm.Desktop.RebindKeys import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) -import Rahm.Desktop.Layout.ConsistentMosaic +import Rahm.Desktop.Submap +import Rahm.Desktop.Swallow +import Rahm.Desktop.SwapMaster (swapMaster) +import Rahm.Desktop.Windows import Rahm.Desktop.Workspaces type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -851,8 +850,14 @@ windowSpecificBindings config = do rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) bind xK_d $ + rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_Tab) + + bind xK_Escape $ rawMask controlMask $ emitKey (controlMask, xK_w) + bind xK_i $ do + rawMask controlMask $ emitKey (controlMask, xK_Tab) + bind xK_F2 $ -- Experimental. noMod $ logs "This is a test" diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs new file mode 100644 index 0000000..2c596fc --- /dev/null +++ b/src/Rahm/Desktop/Keys/Dsl.hs @@ -0,0 +1,496 @@ +-- Domain-specific language for configuring key/button bindings. +module Rahm.Desktop.Keys.Dsl where + +import Data.List +import Data.Bits ((.&.)) +import Control.Monad.Writer +import Text.Printf +import Control.Arrow (second, first) +import Control.Monad (void) +import Control.Monad.State (State(..), modify', get, execState) +import XMonad +import Data.Map (Map) +import qualified Data.Map as Map + +data Documented t = Documented String t + +data KeyBinding = + Action (X ()) | + Submap KeyBindings | + Repeat KeyBindings + +type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding) + +type ButtonBinding = Window -> X () +type ButtonBindings = Map (KeyMask, Button) ButtonBinding + +{- Module that defines a DSL for binding keys. -} +newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) + deriving (Functor, Applicative, Monad) + +newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a) + deriving (Functor, Applicative, Monad) + +newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a) + deriving (Functor, Applicative, Monad) + +class HasConfig m where + getConfig :: m l (XConfig l) + +class Bindable k where + type BindableValue k :: * + 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 + + rawMask :: KeyMask -> k -> BindingBuilder b () + rawMask m x = BindingBuilder $ modify' (second ((m, toB x):)) + +instance Binding (X ()) (Documented KeyBinding) where + toB = Documented "" . Action + +instance Binding KeyBindings (Documented KeyBinding) where + toB = Documented "" . Submap + +instance Binding a (Documented a) where + toB = Documented "" + +instance Binding a a where + toB = id + +doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding +doc str k = let (Documented _ t) = toB k in Documented str t + +runKeys :: KeysM l a -> XConfig l -> KeyBindings +runKeys (KeysM stateM) config = + snd $ execState stateM (config, Map.empty) + +runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings +runButtons (ButtonsM stateM) config = + snd $ execState stateM (config, Map.empty) + +instance HasConfig KeysM where + getConfig = fst <$> KeysM get + +instance HasConfig ButtonsM where + getConfig = fst <$> ButtonsM get + +{- Generally it is assumed that the mod key shoud be pressed, but not always. -} +noMod :: (Binding k b) => k -> BindingBuilder b () +noMod = rawMask 0 + +maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b () +maskMod mask action = do + modMask <- fst <$> BindingBuilder get + rawMask (modMask .|. mask) action + +altMask :: KeyMask +altMask = mod1Mask + +hyperMask :: KeyMask +hyperMask = mod3Mask + +altgrMask :: KeyMask +altgrMask = 0x80 + +superMask :: KeyMask +superMask = mod4Mask + +justMod :: (Binding k b) => k -> BindingBuilder b () +justMod = maskMod 0 + +instance Bindable KeySym where + type BindableValue KeySym = Documented KeyBinding + type BindableMonad KeySym = KeysM + + -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l () + bind key (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + 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 + + -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () + bind button (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + ButtonsM $ modify' $ second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) + +shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask) + +shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask) + +shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask) + +shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask) + +shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask) + +shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltMod = + maskMod (shiftMask .|. controlMask .|. altMask) + +shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask) + +shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask) + +shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperMod = + maskMod (shiftMask .|. controlMask .|. superMask) + +shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask) + +shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperMod = + maskMod (shiftMask .|. controlMask .|. hyperMask) + +shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltgrMod = + maskMod (shiftMask .|. controlMask .|. altgrMask) + +shiftControlMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlMod = + maskMod (shiftMask .|. controlMask) + +shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask) + +shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask) + +shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperMod = + maskMod (shiftMask .|. altMask .|. superMask) + +shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperMod = + maskMod (shiftMask .|. altMask .|. hyperMask) + +shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltAltgrMod = + maskMod (shiftMask .|. altMask .|. altgrMask) + +shiftAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltMod = + maskMod (shiftMask .|. altMask) + +shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperAltgrMod = + maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperMod = + maskMod (shiftMask .|. superMask .|. hyperMask) + +shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperAltgrMod = + maskMod (shiftMask .|. superMask .|. altgrMask) + +shiftSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperMod = + maskMod (shiftMask .|. superMask) + +shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperAltgrMod = + maskMod (shiftMask .|. hyperMask .|. altgrMask) + +shiftHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperMod = + maskMod (shiftMask .|. hyperMask) + +shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltgrMod = + maskMod (shiftMask .|. altgrMask) + +shiftMod :: (Binding k b) => k -> BindingBuilder b () +shiftMod = maskMod shiftMask + +controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask) + +controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. altgrMask) + +controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperMod = + maskMod (controlMask .|. altMask .|. superMask) + +controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperAltgrMod = + maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask) + +controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperMod = + maskMod (controlMask .|. altMask .|. hyperMask) + +controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltAltgrMod = + maskMod (controlMask .|. altMask .|. altgrMask) + +controlAltMod :: (Binding k b) => k -> BindingBuilder b () +controlAltMod = + maskMod (controlMask .|. altMask) + +controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperAltgrMod = + maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask) + +controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperMod = + maskMod (controlMask .|. superMask .|. hyperMask) + +controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperAltgrMod = + maskMod (controlMask .|. superMask .|. altgrMask) + +controlSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperMod = + maskMod (controlMask .|. superMask) + +controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperAltgrMod = + maskMod (controlMask .|. hyperMask .|. altgrMask) + +controlHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperMod = + maskMod (controlMask .|. hyperMask) + +controlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltgrMod = + maskMod (controlMask .|. altgrMask) + +controlMod :: (Binding k b) => k -> BindingBuilder b () +controlMod = maskMod controlMask + +altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperAltgrMod = + maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask) + +altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperMod = + maskMod (altMask .|. superMask .|. hyperMask) + +altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperAltgrMod = + maskMod (altMask .|. superMask .|. altgrMask) + +altSuperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperMod = + maskMod (altMask .|. superMask) + +altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altHyperAltgrMod = + maskMod (altMask .|. hyperMask .|. altgrMask) + +altHyperMod :: (Binding k b) => k -> BindingBuilder b () +altHyperMod = + maskMod (altMask .|. hyperMask) + +altAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altAltgrMod = + maskMod (altMask .|. altgrMask) + +altMod :: (Binding k b) => k -> BindingBuilder b () +altMod = maskMod altMask + +superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superHyperAltgrMod = + maskMod (superMask .|. hyperMask .|. altgrMask) + +superHyperMod :: (Binding k b) => k -> BindingBuilder b () +superHyperMod = + maskMod (superMask .|. hyperMask) + +superAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superAltgrMod = + maskMod (superMask .|. altgrMask) + +superMod :: (Binding k b) => k -> BindingBuilder b () +superMod = maskMod superMask + +hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +hyperAltgrMod = + maskMod (hyperMask .|. altgrMask) + +hyperMod :: (Binding k b) => k -> BindingBuilder b () +hyperMod = maskMod hyperMask + +altgrMod :: (Binding k b) => k -> BindingBuilder b () +altgrMod = maskMod altgrMask + +{- Can combine two or more of the functions above to apply the same action to + - multiple masks. -} +(-|-) :: (Binding k b) => + (k -> BindingBuilder b ()) -> + (k -> BindingBuilder b ()) -> + k -> BindingBuilder b () +(-|-) fn1 fn2 f = fn1 f >> fn2 f + +{- Meant for submapping, binds all alphanumeric charactes to (fn c). -} +mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbersAndAlpha km fn = do + mapNumbers km fn + mapAlpha km fn + +{- Meant for submapping. This binds all numbers to (fn x) where x is the number + - pressed and fn is the function provided. -} +mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbers km fn = do + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) + [ (xK_0, '0') + , (xK_1, '1') + , (xK_2, '2') + , (xK_3, '3') + , (xK_4, '4') + , (xK_5, '5') + , (xK_6, '6') + , (xK_7, '7') + , (xK_8, '8') + , (xK_9, '9') + -- Programmer Dvorak shifts the numbers so I have to map to their unshifted + -- form. + , (xK_bracketright, '6') + , (xK_exclam, '8') + , (xK_bracketleft, '7') + , (xK_braceleft, '5') + , (xK_braceright, '3') + , (xK_parenleft, '1') + , (xK_equal, '9') + , (xK_asterisk, '0') + , (xK_parenright, '2') + , (xK_plus, '4') ] + +{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the + - character pressed and fn is the function provided. -} +mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapAlpha km fn = + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) [ + (xK_a, 'a') + , (xK_b, 'b') + , (xK_c, 'c') + , (xK_d, 'd') + , (xK_e, 'e') + , (xK_f, 'f') + , (xK_g, 'g') + , (xK_h, 'h') + , (xK_i, 'i') + , (xK_j, 'j') + , (xK_k, 'k') + , (xK_l, 'l') + , (xK_m, 'm') + , (xK_n, 'n') + , (xK_o, 'o') + , (xK_p, 'p') + , (xK_q, 'q') + , (xK_r, 'r') + , (xK_s, 's') + , (xK_t, 't') + , (xK_u, 'u') + , (xK_v, 'v') + , (xK_w, 'w') + , (xK_x, 'x') + , (xK_y, 'y') + , (xK_z, 'z') + ] + + +documentation :: KeyBindings -> String +documentation = execWriter . document' "" + where + 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 ++ " ") submap + Repeat submap -> do + tell pref + tell " (repeatable):\n" + 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]))) + + diff --git a/src/Rahm/Desktop/KeysM.hs b/src/Rahm/Desktop/KeysM.hs deleted file mode 100644 index 403b3fc..0000000 --- a/src/Rahm/Desktop/KeysM.hs +++ /dev/null @@ -1,495 +0,0 @@ -module Rahm.Desktop.KeysM where - -import Data.List -import Data.Bits ((.&.)) -import Control.Monad.Writer -import Text.Printf -import Control.Arrow (second, first) -import Control.Monad (void) -import Control.Monad.State (State(..), modify', get, execState) -import XMonad -import Data.Map (Map) -import qualified Data.Map as Map - -data Documented t = Documented String t - -data KeyBinding = - Action (X ()) | - Submap KeyBindings | - Repeat KeyBindings - -type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding) - -type ButtonBinding = Window -> X () -type ButtonBindings = Map (KeyMask, Button) ButtonBinding - -{- Module that defines a DSL for binding keys. -} -newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) - deriving (Functor, Applicative, Monad) - -newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a) - deriving (Functor, Applicative, Monad) - -newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a) - deriving (Functor, Applicative, Monad) - -class HasConfig m where - getConfig :: m l (XConfig l) - -class Bindable k where - type BindableValue k :: * - 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 - - rawMask :: KeyMask -> k -> BindingBuilder b () - rawMask m x = BindingBuilder $ modify' (second ((m, toB x):)) - -instance Binding (X ()) (Documented KeyBinding) where - toB = Documented "" . Action - -instance Binding KeyBindings (Documented KeyBinding) where - toB = Documented "" . Submap - -instance Binding a (Documented a) where - toB = Documented "" - -instance Binding a a where - toB = id - -doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding -doc str k = let (Documented _ t) = toB k in Documented str t - -runKeys :: KeysM l a -> XConfig l -> KeyBindings -runKeys (KeysM stateM) config = - snd $ execState stateM (config, Map.empty) - -runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings -runButtons (ButtonsM stateM) config = - snd $ execState stateM (config, Map.empty) - -instance HasConfig KeysM where - getConfig = fst <$> KeysM get - -instance HasConfig ButtonsM where - getConfig = fst <$> ButtonsM get - -{- Generally it is assumed that the mod key shoud be pressed, but not always. -} -noMod :: (Binding k b) => k -> BindingBuilder b () -noMod = rawMask 0 - -maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b () -maskMod mask action = do - modMask <- fst <$> BindingBuilder get - rawMask (modMask .|. mask) action - -altMask :: KeyMask -altMask = mod1Mask - -hyperMask :: KeyMask -hyperMask = mod3Mask - -altgrMask :: KeyMask -altgrMask = 0x80 - -superMask :: KeyMask -superMask = mod4Mask - -justMod :: (Binding k b) => k -> BindingBuilder b () -justMod = maskMod 0 - -instance Bindable KeySym where - type BindableValue KeySym = Documented KeyBinding - type BindableMonad KeySym = KeysM - - -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l () - bind key (BindingBuilder stM) = do - m <- modMask <$> getConfig - let (_, values) = execState stM (m, []) - - 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 - - -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () - bind button (BindingBuilder stM) = do - m <- modMask <$> getConfig - let (_, values) = execState stM (m, []) - - ButtonsM $ modify' $ second $ - flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) - -shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperHyperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask) - -shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask) - -shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltSuperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. superMask) - -shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask) - -shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltHyperMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask) - -shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltAltgrMod = - maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask) - -shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltMod = - maskMod (shiftMask .|. controlMask .|. altMask) - -shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperHyperMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask) - -shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperAltgrMod = - maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask) - -shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlSuperMod = - maskMod (shiftMask .|. controlMask .|. superMask) - -shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlHyperAltgrMod = - maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask) - -shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlHyperMod = - maskMod (shiftMask .|. controlMask .|. hyperMask) - -shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlAltgrMod = - maskMod (shiftMask .|. controlMask .|. altgrMask) - -shiftControlMod :: (Binding k b) => k -> BindingBuilder b () -shiftControlMod = - maskMod (shiftMask .|. controlMask) - -shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperHyperAltgrMod = - maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperHyperMod = - maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask) - -shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperAltgrMod = - maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask) - -shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltSuperMod = - maskMod (shiftMask .|. altMask .|. superMask) - -shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltHyperAltgrMod = - maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask) - -shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltHyperMod = - maskMod (shiftMask .|. altMask .|. hyperMask) - -shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltAltgrMod = - maskMod (shiftMask .|. altMask .|. altgrMask) - -shiftAltMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltMod = - maskMod (shiftMask .|. altMask) - -shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperHyperAltgrMod = - maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask) - -shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperHyperMod = - maskMod (shiftMask .|. superMask .|. hyperMask) - -shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperAltgrMod = - maskMod (shiftMask .|. superMask .|. altgrMask) - -shiftSuperMod :: (Binding k b) => k -> BindingBuilder b () -shiftSuperMod = - maskMod (shiftMask .|. superMask) - -shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftHyperAltgrMod = - maskMod (shiftMask .|. hyperMask .|. altgrMask) - -shiftHyperMod :: (Binding k b) => k -> BindingBuilder b () -shiftHyperMod = - maskMod (shiftMask .|. hyperMask) - -shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b () -shiftAltgrMod = - maskMod (shiftMask .|. altgrMask) - -shiftMod :: (Binding k b) => k -> BindingBuilder b () -shiftMod = maskMod shiftMask - -controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperHyperAltgrMod = - maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) - -controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperHyperMod = - maskMod (controlMask .|. altMask .|. superMask .|. hyperMask) - -controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperAltgrMod = - maskMod (controlMask .|. altMask .|. superMask .|. altgrMask) - -controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltSuperMod = - maskMod (controlMask .|. altMask .|. superMask) - -controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltHyperAltgrMod = - maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask) - -controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlAltHyperMod = - maskMod (controlMask .|. altMask .|. hyperMask) - -controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltAltgrMod = - maskMod (controlMask .|. altMask .|. altgrMask) - -controlAltMod :: (Binding k b) => k -> BindingBuilder b () -controlAltMod = - maskMod (controlMask .|. altMask) - -controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperHyperAltgrMod = - maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask) - -controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperHyperMod = - maskMod (controlMask .|. superMask .|. hyperMask) - -controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperAltgrMod = - maskMod (controlMask .|. superMask .|. altgrMask) - -controlSuperMod :: (Binding k b) => k -> BindingBuilder b () -controlSuperMod = - maskMod (controlMask .|. superMask) - -controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlHyperAltgrMod = - maskMod (controlMask .|. hyperMask .|. altgrMask) - -controlHyperMod :: (Binding k b) => k -> BindingBuilder b () -controlHyperMod = - maskMod (controlMask .|. hyperMask) - -controlAltgrMod :: (Binding k b) => k -> BindingBuilder b () -controlAltgrMod = - maskMod (controlMask .|. altgrMask) - -controlMod :: (Binding k b) => k -> BindingBuilder b () -controlMod = maskMod controlMask - -altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altSuperHyperAltgrMod = - maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask) - -altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () -altSuperHyperMod = - maskMod (altMask .|. superMask .|. hyperMask) - -altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altSuperAltgrMod = - maskMod (altMask .|. superMask .|. altgrMask) - -altSuperMod :: (Binding k b) => k -> BindingBuilder b () -altSuperMod = - maskMod (altMask .|. superMask) - -altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altHyperAltgrMod = - maskMod (altMask .|. hyperMask .|. altgrMask) - -altHyperMod :: (Binding k b) => k -> BindingBuilder b () -altHyperMod = - maskMod (altMask .|. hyperMask) - -altAltgrMod :: (Binding k b) => k -> BindingBuilder b () -altAltgrMod = - maskMod (altMask .|. altgrMask) - -altMod :: (Binding k b) => k -> BindingBuilder b () -altMod = maskMod altMask - -superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -superHyperAltgrMod = - maskMod (superMask .|. hyperMask .|. altgrMask) - -superHyperMod :: (Binding k b) => k -> BindingBuilder b () -superHyperMod = - maskMod (superMask .|. hyperMask) - -superAltgrMod :: (Binding k b) => k -> BindingBuilder b () -superAltgrMod = - maskMod (superMask .|. altgrMask) - -superMod :: (Binding k b) => k -> BindingBuilder b () -superMod = maskMod superMask - -hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () -hyperAltgrMod = - maskMod (hyperMask .|. altgrMask) - -hyperMod :: (Binding k b) => k -> BindingBuilder b () -hyperMod = maskMod hyperMask - -altgrMod :: (Binding k b) => k -> BindingBuilder b () -altgrMod = maskMod altgrMask - -{- Can combine two or more of the functions above to apply the same action to - - multiple masks. -} -(-|-) :: (Binding k b) => - (k -> BindingBuilder b ()) -> - (k -> BindingBuilder b ()) -> - k -> BindingBuilder b () -(-|-) fn1 fn2 f = fn1 f >> fn2 f - -{- Meant for submapping, binds all alphanumeric charactes to (fn c). -} -mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () -mapNumbersAndAlpha km fn = do - mapNumbers km fn - mapAlpha km fn - -{- Meant for submapping. This binds all numbers to (fn x) where x is the number - - pressed and fn is the function provided. -} -mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l () -mapNumbers km fn = do - mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) - [ (xK_0, '0') - , (xK_1, '1') - , (xK_2, '2') - , (xK_3, '3') - , (xK_4, '4') - , (xK_5, '5') - , (xK_6, '6') - , (xK_7, '7') - , (xK_8, '8') - , (xK_9, '9') - -- Programmer Dvorak shifts the numbers so I have to map to their unshifted - -- form. - , (xK_bracketright, '6') - , (xK_exclam, '8') - , (xK_bracketleft, '7') - , (xK_braceleft, '5') - , (xK_braceright, '3') - , (xK_parenleft, '1') - , (xK_equal, '9') - , (xK_asterisk, '0') - , (xK_parenright, '2') - , (xK_plus, '4') ] - -{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the - - character pressed and fn is the function provided. -} -mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () -mapAlpha km fn = - mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) [ - (xK_a, 'a') - , (xK_b, 'b') - , (xK_c, 'c') - , (xK_d, 'd') - , (xK_e, 'e') - , (xK_f, 'f') - , (xK_g, 'g') - , (xK_h, 'h') - , (xK_i, 'i') - , (xK_j, 'j') - , (xK_k, 'k') - , (xK_l, 'l') - , (xK_m, 'm') - , (xK_n, 'n') - , (xK_o, 'o') - , (xK_p, 'p') - , (xK_q, 'q') - , (xK_r, 'r') - , (xK_s, 's') - , (xK_t, 't') - , (xK_u, 'u') - , (xK_v, 'v') - , (xK_w, 'w') - , (xK_x, 'x') - , (xK_y, 'y') - , (xK_z, 'z') - ] - - -documentation :: KeyBindings -> String -documentation = execWriter . document' "" - where - 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 ++ " ") submap - Repeat submap -> do - tell pref - tell " (repeatable):\n" - 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 From a14486b47a51e772a3b230bc82390cb667f2ecd5 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 14 Apr 2022 23:09:50 -0600 Subject: Some changes to marking --- src/Rahm/Desktop/Keys.hs | 9 +++++++++ src/Rahm/Desktop/Marking.hs | 7 ++++++- 2 files changed, 15 insertions(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index fec7ce5..d302b59 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -150,6 +150,15 @@ keymap = runKeys $ do _ -> return () shiftMod $ + doc "Move the marked windo to the current workspace." $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> do + ws <- getCurrentWorkspace + maybe (return ()) (windows . W.shiftWin ws) =<< markToWindow ch + _ -> return () + + controlMod $ doc "Swap the current window with a mark." $ mapNextString $ \_ str -> case str of diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 1144ad7..98c96bb 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -2,7 +2,7 @@ module Rahm.Desktop.Marking ( historyNext, historyPrev, markCurrentWindow, pushHistory, jumpToMark, jumpToLast, swapWithLastMark, - swapWithMark + swapWithMark, markToWindow ) where import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) @@ -185,6 +185,11 @@ swapWithLastMark = pushHistory $ withHistory $ \hist -> do windows $ swapWithFocused win Nothing -> return () +markToWindow :: Mark -> X (Maybe Window) +markToWindow m = do + MarkState { markStateMap = mp } <- XS.get + return $ Map.lookup m mp + swapWithMark :: Mark -> X () swapWithMark mark = pushHistory $ do MarkState {markStateMap = m} <- XS.get -- cgit From 588e87efb099927fda713380e5bf64e8c7f1fdcd Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 15 Apr 2022 01:14:50 -0600 Subject: [WIP] - Window change hooks --- src/Rahm/Desktop/History.hs | 25 +++++++++++++++++++ src/Rahm/Desktop/Hooks/WindowChange.hs | 45 ++++++++++++++++++++++++++++++++++ 2 files changed, 70 insertions(+) create mode 100644 src/Rahm/Desktop/History.hs create mode 100644 src/Rahm/Desktop/Hooks/WindowChange.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs new file mode 100644 index 0000000..8aff845 --- /dev/null +++ b/src/Rahm/Desktop/History.hs @@ -0,0 +1,25 @@ +module Rahm.Desktop.History where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Default + +import Rahm.Desktop.Hooks.WindowChange + +data History = History { + currentIndex :: Int + , history :: IntMap Location + } + +instance Default History where + def = History 0 IntMap.empty + +addToHistory :: Location -> History -> History +addToHistory loc (History currentIndex hist) = + let hist' = if currentIndex > 100 + then IntMap.delete (currentIndex - 100) hist + else hist + in History (currentIndex + 1 ) (IntMap.insert currentIndex loc hist) + +historyHook :: Location -> Location -> X () +historyHook = undefined diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs new file mode 100644 index 0000000..0038f47 --- /dev/null +++ b/src/Rahm/Desktop/Hooks/WindowChange.hs @@ -0,0 +1,45 @@ +module Rahm.Desktop.Hooks.WindowChange where + +import XMonad +import Control.Monad +import qualified XMonad.Util.ExtensibleState as XS +import Data.Default +import Rahm.Desktop.Workspaces + +import qualified XMonad.StackSet as W + +data Location = Location WorkspaceId (Maybe Window) + deriving (Read, Show, Eq) + +newtype LastLocation = LastLocation (Maybe Location) + deriving (Read, Show) + +instance Default LastLocation where + def = LastLocation Nothing + +instance ExtensionClass LastLocation where + initialValue = def + extensionType = PersistentExtension + +-- Creates a log hook from the function provided. +-- +-- The first argument to the function is the old window, the second argument in +-- the new window. +withLocationChangeHook :: (Location -> Location -> X ()) -> XConfig l -> XConfig l +withLocationChangeHook fn config = + config { + logHook = do + logHook config + + currentLocation <- + Location <$> getCurrentWorkspace <*> withWindowSet (return . W.peek) + + LastLocation last <- XS.get + + whenJust last $ \lastLocation -> + when (lastLocation /= currentLocation) $ + fn lastLocation currentLocation + + XS.put $ LastLocation $ Just currentLocation + return () + } -- cgit From 7a5051f7955a8b4e69b2c28b5a9b34f9730e21f0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 15 Apr 2022 23:55:35 -0600 Subject: Make history much, much more reliable. This time history is being done using a hook to keep track of history. This means I don't have to manually call pushHistory every time I focus a new window. --- src/Rahm/Desktop/History.hs | 91 +++++++++++++++++++++++++++----- src/Rahm/Desktop/Keys.hs | 39 +++++++++----- src/Rahm/Desktop/Lib.hs | 4 +- src/Rahm/Desktop/Marking.hs | 124 ++------------------------------------------ src/Rahm/Desktop/Submap.hs | 2 +- 5 files changed, 113 insertions(+), 147 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs index 8aff845..dfecc63 100644 --- a/src/Rahm/Desktop/History.hs +++ b/src/Rahm/Desktop/History.hs @@ -1,25 +1,92 @@ module Rahm.Desktop.History where +import XMonad +import Text.Printf +import qualified XMonad.StackSet as W import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Default +import qualified XMonad.Util.ExtensibleState as XS +import Data.Foldable (toList) +import Rahm.Desktop.Workspaces (gotoWorkspace) import Rahm.Desktop.Hooks.WindowChange +import Rahm.Desktop.Logger +import Rahm.Desktop.Marking +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq -data History = History { - currentIndex :: Int - , history :: IntMap Location - } +data BoundedSeqZipper a = BoundedSeqZipper Int (Seq a) (Seq a) + deriving (Eq, Show, Ord, Read) + +instance Functor BoundedSeqZipper where + fmap fn (BoundedSeqZipper i h t) = BoundedSeqZipper i (fmap fn h) (fmap fn t) + +zipperDbgPrint :: (Show a) => BoundedSeqZipper a -> String +zipperDbgPrint (BoundedSeqZipper _ h (c :<| t)) = + concat $ + map (printf " %s " . show) (toList h) ++ + [printf "[%s]" (show c)] ++ + map (printf " %s " . show) (toList t) +zipperDbgPrint _ = "" + +pushZipper :: a -> BoundedSeqZipper a -> BoundedSeqZipper a +pushZipper e (BoundedSeqZipper maxSize _ (tail :|> _)) + | maxSize <= Seq.length tail = + BoundedSeqZipper maxSize mempty (e :<| tail) +pushZipper e (BoundedSeqZipper maxSize _ tail) = + BoundedSeqZipper maxSize mempty (e :<| tail) + +getZipper :: BoundedSeqZipper a -> Maybe a +getZipper (BoundedSeqZipper _ _ (e :<| _)) = Just e +getZipper _ = Nothing + +zipperBack :: BoundedSeqZipper a -> BoundedSeqZipper a +zipperBack (BoundedSeqZipper s h (e :<| t)) = BoundedSeqZipper s (e :<| h) t +zipperBack b = b + +zipperForward :: BoundedSeqZipper a -> BoundedSeqZipper a +zipperForward (BoundedSeqZipper s (e :<| h) t) = BoundedSeqZipper s h (e :<| t) +zipperForward b = b + +newtype History = History { + currentZipper :: BoundedSeqZipper Location +} deriving (Read, Show) instance Default History where - def = History 0 IntMap.empty + def = History (BoundedSeqZipper 1000 mempty mempty) -addToHistory :: Location -> History -> History -addToHistory loc (History currentIndex hist) = - let hist' = if currentIndex > 100 - then IntMap.delete (currentIndex - 100) hist - else hist - in History (currentIndex + 1 ) (IntMap.insert currentIndex loc hist) +instance ExtensionClass History where + initialValue = def + -- extensionType = PersistentExtension + +historyBack :: X () +historyBack = do + History z <- XS.get + let z' = zipperBack z + mapM_ focusLocation (getZipper z') + XS.put (History z') + +historyForward :: X () +historyForward = do + History z <- XS.get + let z' = zipperForward z + mapM_ focusLocation (getZipper z') + XS.put (History z') + +lastWindow :: X (Maybe Location) +lastWindow = getZipper . zipperBack . currentZipper <$> XS.get + +jumpToLastLocation :: X () +jumpToLastLocation = mapM_ focusLocation =<< lastWindow + historyHook :: Location -> Location -> X () -historyHook = undefined +historyHook (Location ws _) l@(Location ws' _) | ws /= ws' = do + XS.modify $ \(History z) -> History (pushZipper l z) + +historyHook _ _ = return () + +focusLocation :: Location -> X () +focusLocation (Location ws Nothing) = gotoWorkspace ws +focusLocation (Location _ (Just win)) = windows $ W.focusWindow win diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index d302b59..ebc8b7f 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -62,6 +62,7 @@ import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) import Rahm.Desktop.Windows import Rahm.Desktop.Workspaces +import Rahm.Desktop.History type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) @@ -143,10 +144,10 @@ keymap = runKeys $ do doc "Jumps between marks." $ mapNextString $ \_ str -> case str of - ['\''] -> jumpToLast + ['\''] -> jumpToLastLocation [ch] | isAlphaNum ch -> jumpToMark ch - "[" -> historyPrev - "]" -> historyNext + "[" -> historyBack + "]" -> historyForward _ -> return () shiftMod $ @@ -162,7 +163,7 @@ keymap = runKeys $ do doc "Swap the current window with a mark." $ mapNextString $ \_ str -> case str of - ['\''] -> swapWithLastMark + -- ['\''] -> swapWithLastMark [ch] | isAlphaNum ch -> swapWithMark ch _ -> return () @@ -315,7 +316,7 @@ keymap = runKeys $ do \F1: display this help.\n\n\t" $ mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of - (_, Just w) -> pushHistory $ gotoWorkspace =<< w + (_, Just w) -> gotoWorkspace =<< w -- Test binding. Tests that I can still submap keysyms alone (keys -- where XLookupString won't return anything helpful.) ((f, _), _) | f == xK_F1 -> @@ -336,7 +337,7 @@ keymap = runKeys $ do doc "Move the current focused window to another workspace and view that workspace" $ mapNextStringWithKeysym $ \_ keysym str -> case ((keysym, str), selectWorkspace (keysym, str)) of - (_, Just w) -> pushHistory $ do + (_, Just w) -> do ws <- w shiftToWorkspace ws gotoWorkspace ws @@ -377,7 +378,7 @@ keymap = runKeys $ do sendMessage Shrink shiftMod $ - doc "Go to the previous window in history." historyPrev + doc "Go to the previous window in history." historyBack bind xK_k $ do justMod $ @@ -385,7 +386,7 @@ keymap = runKeys $ do sendMessage Expand shiftMod $ - doc "Go to the next window in history." historyNext + doc "Go to the next window in history." historyForward bind xK_l $ do justMod $ @@ -551,7 +552,7 @@ keymap = runKeys $ do bind xK_p $ do (justMod -|- noMod) $ - doc "Go to the prior window in the history" historyPrev + doc "Go to the prior window in the history" historyBack bind xK_t $ do (justMod -|- noMod) $ logs "Test Log" @@ -562,7 +563,7 @@ keymap = runKeys $ do -- spawnX (terminal config ++ " -t Notes -e notes new") bind xK_n $ do (justMod -|- noMod) $ - doc "Go to the next window in the history" historyNext + doc "Go to the next window in the history" historyForward bind xK_c $ do shiftMod $ @@ -606,6 +607,18 @@ keymap = runKeys $ do doc "Set the volume of an application via rofi." $ spawnX "set-volume.sh -a" + let navigateHistory = repeatable $ do + bind xK_bracketright $ do + noMod $ + doc "Move forward in location history" historyForward + + bind xK_bracketleft $ do + noMod $ + doc "Move backward in location history" historyBack + + bind xK_bracketleft $ noMod navigateHistory + bind xK_bracketright $ noMod navigateHistory + -- Double-tap Z to toggle zoom. bind xK_z $ do noMod -|- justMod $ @@ -723,8 +736,8 @@ mouseMap = runButtons $ do (button4, increaseVolume), (button5, decreaseVolume), (button2, playPause), - (button9, historyNext), - (button8, historyPrev), + (button9, historyForward), + (button8, historyBack), (button6, mediaPrev), (button7, mediaNext) ] @@ -760,7 +773,7 @@ mouseMap = runButtons $ do gotoWorkspace =<< (accompaningWorkspace <$> getCurrentWorkspace) bind button15 $ do - noMod $ noWindow jumpToLast + noMod $ noWindow jumpToLastLocation let workspaceButtons = [ diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs index 3b4ee9c..c7cfca4 100644 --- a/src/Rahm/Desktop/Lib.hs +++ b/src/Rahm/Desktop/Lib.hs @@ -48,14 +48,14 @@ getString = runQuery $ do else printf "%s - %s" t a askWindowId :: X (Maybe Window) -askWindowId = pushHistory $ do +askWindowId = do windowTitlesToWinId <- withWindowSet $ \ss -> Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId windowJump :: X () -windowJump = pushHistory $ do +windowJump = do windowId <- askWindowId case windowId of diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 98c96bb..639aae2 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,7 +1,6 @@ module Rahm.Desktop.Marking ( - historyNext, historyPrev, - markCurrentWindow, pushHistory, - jumpToMark, jumpToLast, swapWithLastMark, + markCurrentWindow, + jumpToMark, swapWithMark, markToWindow ) where @@ -27,81 +26,19 @@ import qualified Data.Map as Map type Mark = Char -historySize = 100 -- max number of history elements the tail. - -data History a = History [a] (Seq a) - deriving (Read, Show) - -instance Default (History a) where - - def = History [] Seq.empty - -seqPush :: a -> Seq a -> Seq a -seqPush elem s@(seq :|> _) | Seq.length s >= historySize = elem :<| seq -seqPush elem s = elem :<| s - -historyForward :: History a -> History a -historyForward (History (a:as) tail) = History as (seqPush a tail) -historyForward z = z - -historyBackward :: History a -> History a -historyBackward (History head (a :<| as)) = History (a : head) as -historyBackward z = z - -historyCurrent :: History a -> Maybe a -historyCurrent (History (a:_) _) = Just a -historyCurrent _ = Nothing - -historyPush :: (Eq a) => a -> History a -> History a -historyPush a h@(History (w : _) _) | a == w = h -historyPush a (History (w : _) tail) = History [a] (seqPush w tail) -historyPush a (History _ tail) = History [a] tail - -historySwap :: History a -> History a -historySwap (History (a:as) (t :<| ts)) = History (t : as) (seqPush a ts) -historySwap z = z - -historyLast :: History a -> Maybe a -historyLast (History _ (t :<| _)) = Just t -historyLast _ = Nothing - -data Spot = - WindowSpot Window | -- Focus is on a window. - TagSpot String -- Focus is on an (empty) tag - deriving (Read, Show, Eq, Ord) - -greedyFocus :: Spot -> X () -greedyFocus (WindowSpot win) = do - ws <- withWindowSet $ \ss -> - return $ getLocationWorkspace =<< findWindow ss win - - mapM_ (windows . greedyView . tag) ws - focus win -greedyFocus (TagSpot tag) = - windows $ greedyView tag - data MarkState = MarkState { markStateMap :: Map Mark Window - , windowHistory :: History Spot } deriving (Read, Show) instance ExtensionClass MarkState where - initialValue = MarkState Map.empty def + initialValue = MarkState Map.empty extensionType = PersistentExtension -changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState) -changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)} - withMaybeFocused :: (Maybe Window -> X a) -> X a withMaybeFocused f = withWindowSet $ f . peek -normalizeWindows :: X () -normalizeWindows = do - MarkState { windowHistory = h } <- XS.get - mapM_ greedyFocus (historyCurrent h) - -- greedyFocus :: Window -> X () -- greedyFocus win = do -- ws <- withWindowSet $ \ss -> @@ -118,45 +55,12 @@ markCurrentWindow mark = do markStateMap = Map.insert mark win ms } -pushHistory :: X a -> X a -pushHistory fn = do - withMaybeFocused $ \maybeWindowBefore -> do - case maybeWindowBefore of - (Just windowBefore) -> - XS.modify $ changeHistory (historyPush (WindowSpot windowBefore)) - Nothing -> - withWindowSet $ \ws -> - XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws))) - - ret <- fn - - withMaybeFocused $ \maybeWindowAfter -> - case maybeWindowAfter of - Just windowAfter -> - XS.modify $ changeHistory (historyPush $ WindowSpot windowAfter) - Nothing -> - withWindowSet $ \ws -> - XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws) - - return ret - -withHistory :: (History Spot -> X ()) -> X () -withHistory fn = do - MarkState { windowHistory = w } <- XS.get - fn w - -jumpToLast :: X () -jumpToLast = do - XS.modify (changeHistory historySwap) - normalizeWindows - jumpToMark :: Mark -> X () jumpToMark mark = do MarkState {markStateMap = m} <- XS.get case Map.lookup mark m of Nothing -> return () - Just w -> pushHistory $ - greedyFocus (WindowSpot w) + Just w -> windows $ focusWindow w setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd setFocusedWindow @@ -177,34 +81,16 @@ swapWithFocused winToSwap stackSet = mapWindows ( \w -> if w == winToSwap then focused else w) stackSet -swapWithLastMark :: X () -swapWithLastMark = pushHistory $ withHistory $ \hist -> do - - case historyLast hist of - Just (WindowSpot win) -> - windows $ swapWithFocused win - Nothing -> return () - markToWindow :: Mark -> X (Maybe Window) markToWindow m = do MarkState { markStateMap = mp } <- XS.get return $ Map.lookup m mp swapWithMark :: Mark -> X () -swapWithMark mark = pushHistory $ do +swapWithMark mark = do MarkState {markStateMap = m} <- XS.get case Map.lookup mark m of Nothing -> return () Just winToSwap -> do windows $ swapWithFocused winToSwap - -historyPrev :: X () -historyPrev = do - XS.modify $ changeHistory historyBackward - normalizeWindows - -historyNext :: X () -historyNext = do - XS.modify $ changeHistory historyForward - normalizeWindows diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index da9fe77..ad245ab 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -61,7 +61,7 @@ mapNextStringWithKeysym fn = do ret <- io $ fix $ \nextkey -> do ret <- - getMaskEventWithTimeout 1000 d keyPressMask $ \p -> do + getMaskEventWithTimeout 2000 d keyPressMask $ \p -> do KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p keysym <- keycodeToKeysym d code 0 (_, str) <- lookupString (asKeyEvent p) -- cgit From d1a00e6e42b4b513f7de66a9e710f62faca2ef00 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 16 Apr 2022 00:20:03 -0600 Subject: fix some hlint warnings --- src/Rahm/Desktop/History.hs | 2 +- src/Rahm/Desktop/Keys.hs | 16 +++++++++------- src/Rahm/Desktop/Layout.hs | 4 ++-- src/Rahm/Desktop/Layout/ConsistentMosaic.hs | 4 ++-- src/Rahm/Desktop/Layout/Flip.hs | 2 +- src/Rahm/Desktop/Layout/Hole.hs | 4 ++-- src/Rahm/Desktop/Layout/List.hs | 4 ++-- src/Rahm/Desktop/Layout/Pop.hs | 4 ++-- src/Rahm/Desktop/Layout/Redescribe.hs | 2 +- src/Rahm/Desktop/Layout/ReinterpretMessage.hs | 2 +- src/Rahm/Desktop/Marking.hs | 4 ++-- src/Rahm/Desktop/Submap.hs | 4 ++-- src/Rahm/Desktop/Workspaces.hs | 6 +++--- src/Rahm/Desktop/XMobarLog.hs | 2 +- 14 files changed, 31 insertions(+), 29 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs index dfecc63..5e15fe6 100644 --- a/src/Rahm/Desktop/History.hs +++ b/src/Rahm/Desktop/History.hs @@ -79,7 +79,7 @@ lastWindow = getZipper . zipperBack . currentZipper <$> XS.get jumpToLastLocation :: X () jumpToLastLocation = mapM_ focusLocation =<< lastWindow - + historyHook :: Location -> Location -> X () historyHook (Location ws _) l@(Location ws' _) | ws /= ws' = do diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index ebc8b7f..3e660b5 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -292,7 +292,7 @@ keymap = runKeys $ do (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace _ -> Nothing - + justMod $ doc "Goto/Send/Etc To a workspace\n\n\t\ @@ -319,7 +319,7 @@ keymap = runKeys $ do (_, Just w) -> gotoWorkspace =<< w -- Test binding. Tests that I can still submap keysyms alone (keys -- where XLookupString won't return anything helpful.) - ((f, _), _) | f == xK_F1 -> + ((f, _), _) | f == xK_F1 -> (safeSpawn "gxmessage" [ "-fn", "Source Code Pro", documentation (keymap config)] :: X ()) @@ -456,7 +456,7 @@ keymap = runKeys $ do bind xK_space $ do justMod $ doc "Layout-related bindings" $ subkeys $ do - + bind xK_n $ (noMod -|- justMod) $ doc "Use the next layout in the layout list." $ sendMessage toNextLayout @@ -616,8 +616,10 @@ keymap = runKeys $ do noMod $ doc "Move backward in location history" historyBack - bind xK_bracketleft $ noMod navigateHistory - bind xK_bracketright $ noMod navigateHistory + bind xK_bracketleft $ noMod $ + doc "Move forward in location history" navigateHistory + bind xK_bracketright $ noMod $ + doc "Move backward in location history" navigateHistory -- Double-tap Z to toggle zoom. bind xK_z $ do @@ -756,7 +758,7 @@ mouseMap = runButtons $ do ] forM_ (map fst swapButtons) $ \b -> - bind b $ noMod $ \w -> click >> (continuous swapButtons b) w + bind b $ noMod $ \w -> click >> continuous swapButtons b w bind button13 $ noMod $ subMouse $ do bind button13 $ noMod $ subMouse $ do @@ -770,7 +772,7 @@ mouseMap = runButtons $ do bind button13 $ noMod $ noWindow $ - gotoWorkspace =<< (accompaningWorkspace <$> getCurrentWorkspace) + gotoWorkspace . accompaningWorkspace =<< getCurrentWorkspace bind button15 $ do noMod $ noWindow jumpToLastLocation diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index d8c3442..f6e714c 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -70,14 +70,14 @@ nLayouts = layoutListLength myLayoutList -- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system -- hacking one can do in Haskell. instance DoReinterpret "ForMosaic" where - + -- IncMaster message reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do Just . SomeMessage <$> ( if n > 0 then expandPositionAlt else shrinkPositionAlt) - + -- ResizeMaster message reinterpretMessage _ (fromMessage -> Just m) = do Just . SomeMessage <$> diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs index db1ce4e..a84a2f1 100644 --- a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -37,7 +37,7 @@ shrinkPositionAlt = doAlt shrinkWindowAlt instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicWrap l) a where - + runLayout (W.Workspace t (MosaicWrap l) (id -> Just s)) rect = do let zs = zipStack [100..] s s' = mapStack fst zs @@ -59,7 +59,7 @@ instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicW runLayout (W.Workspace t (MosaicWrap l) a) rect = do (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect return (rects, MosaicWrap <$> maybeNewLayout) - + -- By default just pass the message to the underlying layout. handleMessage (MosaicWrap l) mess = do diff --git a/src/Rahm/Desktop/Layout/Flip.hs b/src/Rahm/Desktop/Layout/Flip.hs index e0d3abc..fe425e9 100644 --- a/src/Rahm/Desktop/Layout/Flip.hs +++ b/src/Rahm/Desktop/Layout/Flip.hs @@ -69,7 +69,7 @@ instance LayoutModifier Flip a where Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h flipHoriz (Rectangle x y w h) = Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h - + -- Handle DoFlip messages. pureMess flip (fromMessage -> Just (DoFlip f)) = Just (f flip) pureMess _ _ = Nothing diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs index ee59726..3f7c9b7 100644 --- a/src/Rahm/Desktop/Layout/Hole.hs +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -32,11 +32,11 @@ instance (LayoutClass l a, Eq a, Num a) => LayoutClass (Hole l) a where app x w | not enabled = w app x (W.Workspace t l s) = case s of - Nothing -> + Nothing -> W.Workspace t l (Just $ W.Stack x [] []) Just (W.Stack h c e) -> W.Workspace t l (Just $ W.Stack h c (e ++ [x])) - + handleMessage h (fromMessage -> Just (ManageHole f)) = return $ Just $ f h handleMessage (Hole e l) a = do diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs index f533ea2..77b53c9 100644 --- a/src/Rahm/Desktop/Layout/List.hs +++ b/src/Rahm/Desktop/Layout/List.hs @@ -102,7 +102,7 @@ instance (Selector t) => Selector (Sel t) where increment (Skip l) = Skip <$> increment l -- If the current element is selected, the increment is just the initial of -- the tail. - increment Sel = Skip <$> initial + increment Sel = Skip <$> initial -- For a selection, the initial is just this in the Sel state. initial = Just Sel @@ -178,7 +178,7 @@ layoutListLengthProxy _ = Proxy (|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a (|:) = LCons -infixr 5 |: +infixr 5 |: -- Constructs a LayoutList. This function enforces that the SelectorFor l -- is a 'Sel' type. Essentially this enforces that there must be at least one diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index 7e3dbd1..e06ff25 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -37,7 +37,7 @@ data PopMessage where deriving (Message) resizePop :: Float -> PopMessage -resizePop f = PopMessage $ \(Poppable b x y l) -> +resizePop f = PopMessage $ \(Poppable b x y l) -> Poppable b (g $ x + f) (g $ y + f) l where g = max 0 . min 0.45 @@ -52,7 +52,7 @@ poppable :: l a -> Poppable l a poppable = Poppable False 0.05 0.05 instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where - + -- If the current layout is not popped, then just return what the underlying -- layout returned. diff --git a/src/Rahm/Desktop/Layout/Redescribe.hs b/src/Rahm/Desktop/Layout/Redescribe.hs index c5c7472..036bc88 100644 --- a/src/Rahm/Desktop/Layout/Redescribe.hs +++ b/src/Rahm/Desktop/Layout/Redescribe.hs @@ -11,7 +11,7 @@ import Data.Typeable (Typeable) -- Type-class to modify the description of a layout. class Describer m l where - + -- Returns the new description from the given description modifier, the layout -- and the existing description. newDescription :: m -> l a -> String -> String diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs index 8f6a78d..e3434b1 100644 --- a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs +++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs @@ -31,7 +31,7 @@ data ReinterpretMessage k a = ReinterpretMessage -- Instance for ReinterpretMessage as a Layout modifier. instance (DoReinterpret k) => - LayoutModifier (ReinterpretMessage k) a where + LayoutModifier (ReinterpretMessage k) a where handleMessOrMaybeModifyIt self message = do diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 639aae2..b1783cc 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,6 +1,6 @@ module Rahm.Desktop.Marking ( markCurrentWindow, - jumpToMark, + jumpToMark, swapWithMark, markToWindow ) where @@ -43,7 +43,7 @@ withMaybeFocused f = withWindowSet $ f . peek -- greedyFocus win = do -- ws <- withWindowSet $ \ss -> -- return $ getLocationWorkspace =<< findWindow ss win --- +-- -- mapM_ (windows . greedyView . tag) ws -- focus win diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index ad245ab..5db8928 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -76,12 +76,12 @@ mapNextStringWithKeysym fn = do Nothing -> return Nothing io $ ungrabKeyboard d currentTime - case ret of + case ret of Just (m, str, keysym) -> fn m keysym str Nothing -> return () {- Like submap, but on the character typed rather than the kysym. -} -mapNextString :: (KeyMask -> String -> X ()) -> X () +mapNextString :: (KeyMask -> String -> X ()) -> X () mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 1349fea..de481ac 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -114,7 +114,7 @@ swapWorkspace toWorkspace = do | otherwise = ws adjacentWorkspaceNotVisible :: Selector -> WorkspaceId -> X WorkspaceId -adjacentWorkspaceNotVisible (Selector selector) from = +adjacentWorkspaceNotVisible (Selector selector) from = withWindowSet $ \ss -> let tags = sort $ W.tag . snd <$> filter (\x -> fst x /= Visible) ( @@ -123,7 +123,7 @@ adjacentWorkspaceNotVisible (Selector selector) from = return $ fromMaybe from $ selector (==from) tags adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId -adjacentWorkspace (Selector selector) from = +adjacentWorkspace (Selector selector) from = withWindowSet $ \ss -> let tags = sort $ W.tag . snd <$> getPopulatedWorkspaces ss in @@ -154,4 +154,4 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> W.tag <$> find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) (map W.workspace (c : v) ++ h) - + diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 4f8bbb8..f2cccf8 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -60,7 +60,7 @@ xMobarLogHook (XMobarLog xmproc) = do tell $ "│ " tell $ title tell $ "" - + where toAction [ch] | (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || -- cgit From 65456557536f7886ae079fa2b980a1ef7f0619c0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 16 Apr 2022 00:54:01 -0600 Subject: Remove the "│" from xmobar. I think it makes it cleaner, but it is not a slam dunk. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Rahm/Desktop/XMobarLog.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index f2cccf8..637670e 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -46,7 +46,7 @@ xMobarLogHook (XMobarLog xmproc) = do hPutStrLn xmproc $ trunc 80 $ execWriter $ do tell " " tell layoutXpm - tell $ " │ " + tell $ " " forM_ wss $ \(t, ws) -> do case t of @@ -57,7 +57,7 @@ xMobarLogHook (XMobarLog xmproc) = do tell $ toAction $ S.tag ws tell " " - tell $ "│ " + tell $ " " tell $ title tell $ "" -- cgit From e7d0c65ef807cf6d595273a764ec95d17c8708b5 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 16 Apr 2022 11:33:57 -0600 Subject: Switch Ctrl-i and Ctrl-d for chrome bindings --- src/Rahm/Desktop/Keys.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index d302b59..6912473 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -859,13 +859,13 @@ windowSpecificBindings config = do rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) bind xK_d $ - rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_Tab) + rawMask controlMask $ emitKey (controlMask, xK_Tab) bind xK_Escape $ rawMask controlMask $ emitKey (controlMask, xK_w) bind xK_i $ do - rawMask controlMask $ emitKey (controlMask, xK_Tab) + rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_Tab) bind xK_F2 $ -- Experimental. -- cgit From 9dc562c177fef4ad3b25bfac348c21a6c57839f5 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 17 Apr 2022 23:15:55 -0600 Subject: Starting to implement window management language --- src/Rahm/Desktop/Common.hs | 86 ++++++++++++++++++++++ src/Rahm/Desktop/History.hs | 37 ++++++---- src/Rahm/Desktop/Hooks/WindowChange.hs | 16 ++--- src/Rahm/Desktop/Keys.hs | 70 ++++++------------ src/Rahm/Desktop/Lib.hs | 63 ---------------- src/Rahm/Desktop/Marking.hs | 127 +++++++++++++++++++++++---------- src/Rahm/Desktop/Workspaces.hs | 38 +++++++--- 7 files changed, 259 insertions(+), 178 deletions(-) create mode 100644 src/Rahm/Desktop/Common.hs delete mode 100644 src/Rahm/Desktop/Lib.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs new file mode 100644 index 0000000..926d5ff --- /dev/null +++ b/src/Rahm/Desktop/Common.hs @@ -0,0 +1,86 @@ +module Rahm.Desktop.Common where + +import Prelude hiding ((!!)) + +import Control.Monad.Trans.Maybe +import XMonad.Actions.DynamicWorkspaces +import XMonad.Util.Run +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell + +import Rahm.Desktop.PromptConfig + +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Maybe +import Text.Printf +import XMonad hiding (workspaces, Screen) +import XMonad.StackSet hiding (filter, focus) +import qualified Data.Map as Map +import Rahm.Desktop.DMenu +import Data.Ord (comparing) + +import qualified XMonad.StackSet as S +import Rahm.Desktop.Windows + +-- A location is a workspace and maybe a window with that workspace. +data Location = Location { + locationWorkspace :: WorkspaceId, + locationWindow :: Maybe Window + } deriving (Read, Show, Eq, Ord) + +focusLocation :: Location -> X () +focusLocation (Location ws Nothing) = windows $ S.greedyView ws +focusLocation (Location _ (Just win)) = windows $ S.focusWindow win + +masterWindow :: MaybeT X Window +masterWindow = MaybeT $ withWindowSet $ \ss -> + let windows = (S.integrate' . S.stack . S.workspace . S.current) ss + in case windows of + (a:_) -> return $ Just a + _ -> return Nothing + +data WinPrompt = WinPrompt + +instance XPrompt WinPrompt where + showXPrompt _ = "[Window] " + commandToComplete _ = id + +fuzzyCompletion :: String -> String -> Bool +fuzzyCompletion str0 str1 = + all (`isInfixOf`l0) ws + where + ws = filter (not . all isSpace) $ words (map toLower str0) + l0 = map toLower str1 + +getString :: Window -> X String +getString = runQuery $ do + t <- title + a <- appName + return $ + if map toLower a `isInfixOf` map toLower t + then t + else printf "%s - %s" t a + +askWindowId :: X (Maybe Window) +askWindowId = do + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + + runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId + +windowJump :: X () +windowJump = mapM_ focus =<< askWindowId + +gotoWorkspace :: WorkspaceId -> X () +gotoWorkspace wid = do + addHiddenWorkspace wid + windows $ S.greedyView wid + +getCurrentWorkspace :: X WorkspaceId +getCurrentWorkspace = withWindowSet $ + \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do + return t + diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs index 5e15fe6..9195a92 100644 --- a/src/Rahm/Desktop/History.hs +++ b/src/Rahm/Desktop/History.hs @@ -9,10 +9,9 @@ import Data.Default import qualified XMonad.Util.ExtensibleState as XS import Data.Foldable (toList) -import Rahm.Desktop.Workspaces (gotoWorkspace) import Rahm.Desktop.Hooks.WindowChange +import Rahm.Desktop.Common import Rahm.Desktop.Logger -import Rahm.Desktop.Marking import Data.Sequence (Seq(..)) import qualified Data.Sequence as Seq @@ -60,6 +59,20 @@ instance ExtensionClass History where initialValue = def -- extensionType = PersistentExtension +pastHistory :: Int -> X (Maybe Location) +pastHistory i = do + History (BoundedSeqZipper _ _ t) <- XS.get + return $ t Seq.!? i + +getMostRecentLocationInHistory :: X (Maybe Location) +getMostRecentLocationInHistory = do + History z <- XS.get + case z of + (BoundedSeqZipper _ (_ :|> h) _) -> return $ Just h + (BoundedSeqZipper _ _ (t :<| _)) -> return $ Just t + _ -> return Nothing + + historyBack :: X () historyBack = do History z <- XS.get @@ -74,19 +87,19 @@ historyForward = do mapM_ focusLocation (getZipper z') XS.put (History z') -lastWindow :: X (Maybe Location) -lastWindow = getZipper . zipperBack . currentZipper <$> XS.get +lastLocation :: X (Maybe Location) +lastLocation = getZipper . zipperBack . currentZipper <$> XS.get -jumpToLastLocation :: X () -jumpToLastLocation = mapM_ focusLocation =<< lastWindow +nextLocation :: X (Maybe Location) +nextLocation = getZipper . zipperForward . currentZipper <$> XS.get +jumpToLastLocation :: X () +jumpToLastLocation = mapM_ focusLocation =<< lastLocation -historyHook :: Location -> Location -> X () -historyHook (Location ws _) l@(Location ws' _) | ws /= ws' = do +historyHook :: Maybe Location -> Location -> X () +historyHook Nothing loc = + XS.modify $ \(History z) -> History (pushZipper loc z) +historyHook (Just (Location ws _)) l@(Location ws' _) | ws /= ws' = do XS.modify $ \(History z) -> History (pushZipper l z) historyHook _ _ = return () - -focusLocation :: Location -> X () -focusLocation (Location ws Nothing) = gotoWorkspace ws -focusLocation (Location _ (Just win)) = windows $ W.focusWindow win diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs index 0038f47..ec8e445 100644 --- a/src/Rahm/Desktop/Hooks/WindowChange.hs +++ b/src/Rahm/Desktop/Hooks/WindowChange.hs @@ -4,13 +4,10 @@ import XMonad import Control.Monad import qualified XMonad.Util.ExtensibleState as XS import Data.Default -import Rahm.Desktop.Workspaces +import Rahm.Desktop.Common import qualified XMonad.StackSet as W -data Location = Location WorkspaceId (Maybe Window) - deriving (Read, Show, Eq) - newtype LastLocation = LastLocation (Maybe Location) deriving (Read, Show) @@ -20,12 +17,14 @@ instance Default LastLocation where instance ExtensionClass LastLocation where initialValue = def extensionType = PersistentExtension - + -- Creates a log hook from the function provided. -- -- The first argument to the function is the old window, the second argument in -- the new window. -withLocationChangeHook :: (Location -> Location -> X ()) -> XConfig l -> XConfig l +-- +-- If the first window is Nothing, this is the first time XMonad started. +withLocationChangeHook :: (Maybe Location -> Location -> X ()) -> XConfig l -> XConfig l withLocationChangeHook fn config = config { logHook = do @@ -36,9 +35,8 @@ withLocationChangeHook fn config = LastLocation last <- XS.get - whenJust last $ \lastLocation -> - when (lastLocation /= currentLocation) $ - fn lastLocation currentLocation + when (last /= Just currentLocation) $ + fn last currentLocation XS.put $ LastLocation $ Just currentLocation return () diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 74960df..1369a17 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -6,7 +6,6 @@ import Control.Monad.Fix (fix) import Control.Monad.Loops (iterateWhile) import Control.Monad.Reader import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe import Control.Monad.Writer import Data.Char import Data.List hiding ((!!)) @@ -49,7 +48,7 @@ import Rahm.Desktop.Layout.Hole (toggleHole) import Rahm.Desktop.Layout.List (toNextLayout, toPreviousLayout, toFirstLayout, toIndexedLayout) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Rotate (rotateLayout) -import Rahm.Desktop.Lib +import Rahm.Desktop.Common import Rahm.Desktop.Logger import Rahm.Desktop.Marking import Rahm.Desktop.MouseMotion @@ -142,30 +141,13 @@ keymap = runKeys $ do bind xK_apostrophe $ do justMod $ doc "Jumps between marks." $ - mapNextString $ \_ str -> - case str of - ['\''] -> jumpToLastLocation - [ch] | isAlphaNum ch -> jumpToMark ch - "[" -> historyBack - "]" -> historyForward - _ -> return () + mapNextString $ const (mapM_ focusLocation <=< markToLocation) shiftMod $ - doc "Move the marked windo to the current workspace." $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> do - ws <- getCurrentWorkspace - maybe (return ()) (windows . W.shiftWin ws) =<< markToWindow ch - _ -> return () - - controlMod $ - doc "Swap the current window with a mark." $ - mapNextString $ \_ str -> - case str of - -- ['\''] -> swapWithLastMark - [ch] | isAlphaNum ch -> swapWithMark ch - _ -> return () + doc "Move the marked window to the current workspace." $ + mapNextString $ \_ str -> do + mapM_ (\loc -> moveLocationToWorkspace loc <$> getCurrentWorkspace) + =<< markToLocation str bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if @@ -275,23 +257,6 @@ keymap = runKeys $ do sendMessage flipHorizontally bind xK_g $ do - let selectWorkspace :: (KeySym, String) -> Maybe (X WorkspaceId) - selectWorkspace s = case s of - (_, [ch]) | isAlphaNum ch || ch == '*' -> Just $ return [ch] - (_, "]") -> Just $ adjacentWorkspaceNotVisible next - =<< getCurrentWorkspace - (_, "[") -> Just $ adjacentWorkspaceNotVisible prev - =<< getCurrentWorkspace - (_, ")") -> Just $ adjacentWorkspace next =<< getCurrentWorkspace - (_, "(") -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace - (_, "}") -> Just $ adjacentScreen next - (_, "{") -> Just $ adjacentScreen prev - (_, "^") -> Just firstWorkspaceId - (_, "$") -> Just lastWorkspaceId - (_, "/") -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT ( - (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) - (_, " ") -> Just $ accompaningWorkspace <$> getCurrentWorkspace - _ -> Nothing justMod $ doc "Goto/Send/Etc To a workspace\n\n\t\ @@ -315,7 +280,7 @@ keymap = runKeys $ do \Other keybindings starting with H-g\n\t\t\ \F1: display this help.\n\n\t" $ mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace (keysym, str)) of + case ((keysym, str), selectWorkspace str) of (_, Just w) -> gotoWorkspace =<< w -- Test binding. Tests that I can still submap keysyms alone (keys -- where XLookupString won't return anything helpful.) @@ -328,7 +293,7 @@ keymap = runKeys $ do shiftMod $ doc "Move the currently focused window to another workspace" $ mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace (keysym, str)) of + case ((keysym, str), selectWorkspace str) of (_, Just w) -> shiftToWorkspace =<< w ((_, "_"), _) -> CopyWindow.kill1 _ -> return () @@ -336,7 +301,7 @@ keymap = runKeys $ do controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace (keysym, str)) of + case ((keysym, str), selectWorkspace str) of (_, Just w) -> do ws <- w shiftToWorkspace ws @@ -346,14 +311,14 @@ keymap = runKeys $ do altMod $ doc "Copy a window to the given workspace" $ mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace (keysym, str)) of + case ((keysym, str), selectWorkspace str) of (_, Just ws) -> windows . CopyWindow.copy =<< ws _ -> return () shiftAltMod $ doc "Swap this workspace with another workspace (rename)." $ mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace (keysym, str)) of + case ((keysym, str), selectWorkspace str) of (_, Just ws) -> swapWorkspace =<< ws ((_, "_"), _) -> mapM_ (\w -> focus w >> CopyWindow.kill1) =<< windowsInCurrentWorkspace @@ -419,7 +384,7 @@ keymap = runKeys $ do doc "Mark the current window with the next typed character." $ mapNextString $ \_ str -> case str of - [ch] | isAlphaNum ch -> markCurrentWindow ch + [ch] | isAlpha ch -> markCurrentWindow str _ -> return () bind xK_plus $ do @@ -452,6 +417,17 @@ keymap = runKeys $ do sendMessage rotateLayout bind xK_s $ do + justMod $ + mapNextString $ \_ mark -> do + loc' <- markToLocation mark + case loc' of + Nothing -> return () + Just loc -> do + mapM_ setAlternateWindow (locationWindow loc) + mapNextString $ \_ ws -> do + mapM_ (moveLocationToWorkspace loc=<<) (selectWorkspace ws) + + altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" bind xK_space $ do diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs deleted file mode 100644 index c7cfca4..0000000 --- a/src/Rahm/Desktop/Lib.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Rahm.Desktop.Lib where - -import Prelude hiding ((!!)) - -import XMonad.Actions.DynamicWorkspaces -import XMonad.Util.Run -import XMonad.Prompt -import XMonad.Prompt.Input -import XMonad.Prompt.Shell - -import Rahm.Desktop.PromptConfig - -import Data.Char -import Data.List hiding ((!!)) -import Data.List.Safe ((!!)) -import Data.Maybe -import Rahm.Desktop.Marking -import Text.Printf -import XMonad hiding (workspaces, Screen) -import XMonad.StackSet hiding (filter, focus) -import qualified Data.Map as Map -import Rahm.Desktop.DMenu -import Data.Ord (comparing) - -import qualified XMonad.StackSet as S -import Rahm.Desktop.Windows - -data WinPrompt = WinPrompt - -instance XPrompt WinPrompt where - showXPrompt _ = "[Window] " - commandToComplete _ = id - -fuzzyCompletion :: String -> String -> Bool -fuzzyCompletion str0 str1 = - all (`isInfixOf`l0) ws - where - ws = filter (not . all isSpace) $ words (map toLower str0) - l0 = map toLower str1 - -getString :: Window -> X String -getString = runQuery $ do - t <- title - a <- appName - return $ - if map toLower a `isInfixOf` map toLower t - then t - else printf "%s - %s" t a - -askWindowId :: X (Maybe Window) -askWindowId = do - windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) - - runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId - -windowJump :: X () -windowJump = do - windowId <- askWindowId - - case windowId of - Nothing -> return () - Just wid -> focus wid diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index b1783cc..5caaa3b 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,44 +1,50 @@ module Rahm.Desktop.Marking ( markCurrentWindow, jumpToMark, - swapWithMark, markToWindow + markToLocation, + moveLocationToWorkspace, + setAlternateWindow, + getAlternateWindow ) where - -import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) -import XMonad -import XMonad.StackSet hiding (focus) +import Data.Ord (Down(..)) +import Control.Exception +import Control.Monad (when) +import Control.Monad.Trans.Maybe +import Data.Char (isAlpha, isDigit, ord) import Data.IORef +import Data.List (sortOn, sort, sortBy, find) import Data.Map (Map) -import Control.Monad (when) - +import Data.Maybe (catMaybes) +import Data.Sequence (Seq(..)) +import Rahm.Desktop.Common +import Rahm.Desktop.History +import Rahm.Desktop.Hooks.WindowChange +import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) +import Rahm.Desktop.Workspaces +import System.Environment import System.FilePath import System.IO -import Control.Exception -import System.Environment +import XMonad +import XMonad.StackSet hiding (focus) +import qualified Data.Map as Map import qualified Data.Sequence as Seq -import Data.Sequence (Seq(..)) - import qualified XMonad.Util.ExtensibleState as XS -import qualified Data.Map as Map - {- Submodule that handles marking windows so they can be jumped back to. -} -type Mark = Char +type Mark = String data MarkState = MarkState { - markStateMap :: Map Mark Window + markStateMap :: Map Mark Location + , alternateWindow :: Maybe Window } deriving (Read, Show) instance ExtensionClass MarkState where - initialValue = MarkState Map.empty + initialValue = MarkState Map.empty Nothing extensionType = PersistentExtension -withMaybeFocused :: (Maybe Window -> X a) -> X a -withMaybeFocused f = withWindowSet $ f . peek - -- greedyFocus :: Window -> X () -- greedyFocus win = do -- ws <- withWindowSet $ \ss -> @@ -47,20 +53,34 @@ withMaybeFocused f = withWindowSet $ f . peek -- mapM_ (windows . greedyView . tag) ws -- focus win +setAlternateWindow :: Window -> X () +setAlternateWindow win = XS.modify (\m -> m { alternateWindow = Just win }) + +getAlternateWindow :: MaybeT X Window +getAlternateWindow = MaybeT $ alternateWindow <$> XS.get + +withMaybeFocused :: (Maybe Window -> X a) -> X a +withMaybeFocused f = withWindowSet $ f . peek + +getCurrentLocation :: X Location +getCurrentLocation = + (\ws -> withMaybeFocused (return . Location ws)) =<< getCurrentWorkspace + + markCurrentWindow :: Mark -> X () markCurrentWindow mark = do + ws <- getCurrentWorkspace + withFocused $ \win -> XS.modify $ \state@MarkState {markStateMap = ms} -> state { - markStateMap = Map.insert mark win ms + markStateMap = Map.insert mark (Location ws $ Just win) ms } jumpToMark :: Mark -> X () jumpToMark mark = do MarkState {markStateMap = m} <- XS.get - case Map.lookup mark m of - Nothing -> return () - Just w -> windows $ focusWindow w + mapM_ focusLocation $ Map.lookup mark m setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd setFocusedWindow @@ -81,16 +101,51 @@ swapWithFocused winToSwap stackSet = mapWindows ( \w -> if w == winToSwap then focused else w) stackSet -markToWindow :: Mark -> X (Maybe Window) -markToWindow m = do - MarkState { markStateMap = mp } <- XS.get - return $ Map.lookup m mp - -swapWithMark :: Mark -> X () -swapWithMark mark = do - MarkState {markStateMap = m} <- XS.get - - case Map.lookup mark m of - Nothing -> return () - Just winToSwap -> do - windows $ swapWithFocused winToSwap +moveLocationToWorkspace :: Location -> WorkspaceId -> X () +moveLocationToWorkspace (Location _ (Just win)) wid = + windows $ shiftWin wid win +moveLocationToWorkspace _ _ = return () + +windowRect :: Window -> X (Maybe Rectangle) +windowRect win = withDisplay $ \dpy -> (do + (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win + return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw)) + `catchX` return Nothing + +getWindowsAndRects :: X [(Window, Rectangle)] +getWindowsAndRects = + catMaybes <$> (mapM (\w -> fmap (w,) <$> windowRect w) + =<< withWindowSet (return . allWindows)) + +windowLocation :: Window -> MaybeT X Location +windowLocation win = do + tag <- MaybeT $ withWindowSet $ return . findTag win + return (Location tag (Just win)) + +markToLocation :: Mark -> X (Maybe Location) +markToLocation mark = + case mark of + [ch] | isAlpha ch -> Map.lookup mark . markStateMap <$> XS.get + "0" -> getMostRecentLocationInHistory + [ch] | isDigit ch -> pastHistory (ord ch - 0x30) + "." -> Just <$> getCurrentLocation + "\"" -> nextLocation + "'" -> lastLocation + "/" -> runMaybeT $ windowLocation =<< MaybeT askWindowId + "^" -> do + rects <- sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects + case rects of + ((w, _) : _) -> runMaybeT (windowLocation w) + _ -> return Nothing + "$" -> do + rects <- sortOn (Down . \(_, Rectangle x _ _ _) -> x) + <$> getWindowsAndRects + case rects of + ((w, _) : _) -> runMaybeT (windowLocation w) + _ -> return Nothing + + "*" -> runMaybeT (windowLocation =<< masterWindow) + + "@" -> runMaybeT (windowLocation =<< getAlternateWindow) + + _ -> return Nothing diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index de481ac..3a26823 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -4,16 +4,19 @@ module Rahm.Desktop.Workspaces where import Prelude hiding ((!!)) +import Control.Monad.Trans.Maybe import Control.Arrow (second, (&&&)) import qualified XMonad.StackSet as W import XMonad import Data.List.Safe ((!!)) +import Rahm.Desktop.Common +import Rahm.Desktop.History import XMonad.Actions.DynamicWorkspaces import Data.List (sortOn, sort, sortBy, find) import Data.Maybe (mapMaybe, fromMaybe) -import Data.Char (isUpper, toUpper, toLower) +import Data.Char (isUpper, toUpper, toLower, isAlphaNum) newtype Selector = Selector (forall a. (a -> Bool) -> [a] -> Maybe a) @@ -55,11 +58,6 @@ firstWorkspaceId :: X WorkspaceId firstWorkspaceId = W.tag . snd . head <$> withWindowSet (return . getPopulatedWorkspaces) -getCurrentWorkspace :: X WorkspaceId -getCurrentWorkspace = withWindowSet $ - \(W.StackSet (W.Screen (W.Workspace t _ _) _ _) _ _ _) -> do - return t - windowsInCurrentWorkspace :: X [Window] windowsInCurrentWorkspace = withWindowSet $ \(W.StackSet (W.Screen (W.Workspace _ _ s) _ _) _ _ _) -> do @@ -77,11 +75,6 @@ getHorizontallyOrderedScreens windowSet = where screens = (True, W.current windowSet) : map (False,) (W.visible windowSet) -gotoWorkspace :: WorkspaceId -> X () -gotoWorkspace wid = do - addHiddenWorkspace wid - windows $ W.greedyView wid - shiftToWorkspace :: WorkspaceId -> X () shiftToWorkspace t = do addHiddenWorkspace t @@ -155,3 +148,26 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) (map W.workspace (c : v) ++ h) +selectWorkspace :: String -> Maybe (X WorkspaceId) +selectWorkspace s = case s of + [ch] | isAlphaNum ch || ch == '*' -> Just $ return [ch] + "]" -> Just $ adjacentWorkspaceNotVisible next + =<< getCurrentWorkspace + "[" -> Just $ adjacentWorkspaceNotVisible prev + =<< getCurrentWorkspace + ")" -> Just $ adjacentWorkspace next =<< getCurrentWorkspace + "(" -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace + "}" -> Just $ adjacentScreen next + "{" -> Just $ adjacentScreen prev + "^" -> Just firstWorkspaceId + "'" -> Just $ do + l <- lastLocation + case l of + Just (Location ws _) -> return ws + Nothing -> getCurrentWorkspace + "." -> Just getCurrentWorkspace + "$" -> Just lastWorkspaceId + "/" -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT ( + (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) + " " -> Just $ accompaningWorkspace <$> getCurrentWorkspace + _ -> Nothing -- cgit From dac3bec93f90b58d1bf97e81d992651b1cf83458 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 01:31:22 -0600 Subject: Add basic language for moving windows around --- src/Rahm/Desktop/Common.hs | 17 ++++++ src/Rahm/Desktop/Keys.hs | 88 +++++++++++----------------- src/Rahm/Desktop/Lang.hs | 127 +++++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Marking.hs | 98 ++++++++++++++++--------------- src/Rahm/Desktop/Submap.hs | 20 ++++--- src/Rahm/Desktop/Workspaces.hs | 24 -------- 6 files changed, 242 insertions(+), 132 deletions(-) create mode 100644 src/Rahm/Desktop/Lang.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 926d5ff..5a5aecf 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -2,6 +2,7 @@ module Rahm.Desktop.Common where import Prelude hiding ((!!)) +import Control.Monad (void) import Control.Monad.Trans.Maybe import XMonad.Actions.DynamicWorkspaces import XMonad.Util.Run @@ -42,6 +43,14 @@ masterWindow = MaybeT $ withWindowSet $ \ss -> (a:_) -> return $ Just a _ -> return Nothing +windowsInWorkspace :: WorkspaceId -> X [Location] +windowsInWorkspace wid = + withWindowSet $ + return . concatMap (\ws -> + if S.tag ws == wid + then map (Location wid . Just) $ S.integrate' (S.stack ws) + else []) . S.workspaces + data WinPrompt = WinPrompt instance XPrompt WinPrompt where @@ -84,3 +93,11 @@ getCurrentWorkspace = withWindowSet $ \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do return t +getCurrentLocation :: X Location +getCurrentLocation = do + ws <- getCurrentWorkspace + win <- withWindowSet (return . peek) + return (Location ws win) + +runMaybeT_ :: (Monad m) => MaybeT m a -> m () +runMaybeT_ = void . runMaybeT diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 1369a17..23927ef 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -1,5 +1,6 @@ module Rahm.Desktop.Keys (applyKeys) where +import Control.Monad.Trans.Maybe import Control.Applicative import Control.Monad import Control.Monad.Fix (fix) @@ -11,7 +12,7 @@ import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust, fromMaybe, mapMaybe) import Data.Monoid (Endo(..)) import Debug.Trace import Graphics.X11.ExtraTypes.XF86; @@ -51,6 +52,7 @@ import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.Common import Rahm.Desktop.Logger import Rahm.Desktop.Marking +import Rahm.Desktop.Lang import Rahm.Desktop.MouseMotion import Rahm.Desktop.PassMenu import Rahm.Desktop.PromptConfig @@ -141,13 +143,11 @@ keymap = runKeys $ do bind xK_apostrophe $ do justMod $ doc "Jumps between marks." $ - mapNextString $ const (mapM_ focusLocation <=< markToLocation) - - shiftMod $ - doc "Move the marked window to the current workspace." $ - mapNextString $ \_ str -> do - mapM_ (\loc -> moveLocationToWorkspace loc <$> getCurrentWorkspace) - =<< markToLocation str + runMaybeT_ $ do + l <- readNextLocationSet + case l of + (h:_) -> lift (focusLocation h) + _ -> return () bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if @@ -279,50 +279,23 @@ keymap = runKeys $ do \_: Black hole. Sending a window here closes it.\n\n\t\ \Other keybindings starting with H-g\n\t\t\ \F1: display this help.\n\n\t" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> gotoWorkspace =<< w - -- Test binding. Tests that I can still submap keysyms alone (keys - -- where XLookupString won't return anything helpful.) - ((f, _), _) | f == xK_F1 -> - (safeSpawn "gxmessage" [ - "-fn", "Source Code Pro", - documentation (keymap config)] :: X ()) - _ -> return () + runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace shiftMod $ doc "Move the currently focused window to another workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> shiftToWorkspace =<< w - ((_, "_"), _) -> CopyWindow.kill1 - _ -> return () + runMaybeT_ $ do + ws <- readNextWorkspace + loc <- lift getCurrentLocation + lift $ moveLocationToWorkspaceFn ws loc controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just w) -> do - ws <- w - shiftToWorkspace ws - gotoWorkspace ws - _ -> return () - - altMod $ - doc "Copy a window to the given workspace" $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just ws) -> windows . CopyWindow.copy =<< ws - _ -> return () - - shiftAltMod $ - doc "Swap this workspace with another workspace (rename)." $ - mapNextStringWithKeysym $ \_ keysym str -> - case ((keysym, str), selectWorkspace str) of - (_, Just ws) -> swapWorkspace =<< ws - ((_, "_"), _) -> - mapM_ (\w -> focus w >> CopyWindow.kill1) =<< windowsInCurrentWorkspace - _ -> return () + runMaybeT_ $ do + ws <- readNextWorkspace + loc <- lift getCurrentLocation + lift $ do + moveLocationToWorkspaceFn ws loc + gotoWorkspaceFn ws bind xK_h $ do justMod $ @@ -382,7 +355,7 @@ keymap = runKeys $ do bind xK_m $ do justMod $ doc "Mark the current window with the next typed character." $ - mapNextString $ \_ str -> + runMaybeT_ $ mapNextString $ \_ str -> lift $ case str of [ch] | isAlpha ch -> markCurrentWindow str _ -> return () @@ -417,16 +390,19 @@ keymap = runKeys $ do sendMessage rotateLayout bind xK_s $ do - justMod $ - mapNextString $ \_ mark -> do - loc' <- markToLocation mark - case loc' of - Nothing -> return () - Just loc -> do - mapM_ setAlternateWindow (locationWindow loc) - mapNextString $ \_ ws -> do - mapM_ (moveLocationToWorkspace loc=<<) (selectWorkspace ws) + justMod $ runMaybeT_ $ do + locations <- readNextLocationSet + + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + lift $ setAlternateWindows (mapMaybe locationWindow locations) + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ logs $ printf "setAlternate %s %s" (show win) (show $ locationWorkspace loc) + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs new file mode 100644 index 0000000..374500d --- /dev/null +++ b/src/Rahm/Desktop/Lang.hs @@ -0,0 +1,127 @@ +module Rahm.Desktop.Lang where + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class + +import Data.Char (isAlphaNum, isAlpha, isDigit, ord) +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Util.Run (safeSpawn) +import qualified XMonad.StackSet as W + +import Rahm.Desktop.Common +import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.History +import Rahm.Desktop.Marking +import Rahm.Desktop.Workspaces +import Rahm.Desktop.Submap +import Rahm.Desktop.Logger + +import Text.Printf + +import XMonad + +data Workspace = + Workspace { + moveLocationToWorkspaceFn :: Location -> X () + , gotoWorkspaceFn :: X () + , workspaceName :: String + } + +justWorkspace :: String -> Workspace +justWorkspace s = + Workspace { + moveLocationToWorkspaceFn = flip moveLocationToWorkspace s + , gotoWorkspaceFn = gotoWorkspace s + , workspaceName = s + } + +blackHoleWorkspace :: Workspace +blackHoleWorkspace = + Workspace { + moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow + , gotoWorkspaceFn = return () -- can't navigate to black hole + , workspaceName = "blackhole" + } + +alternateWorkspace :: Workspace +alternateWorkspace = + Workspace { + moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do + logs $ "Moving Location: " ++ show l + case maybeWin of + Nothing -> return () + Just win -> do + alter <- getAlternateWorkspace win + logs $ printf "Moving %s to %s" (show win) (show alter) + mapM_ (moveLocationToWorkspace l) alter + + , gotoWorkspaceFn = do + (Location _ maybeWin) <- getCurrentLocation + case maybeWin of + Nothing -> return () + Just win -> do + mapM_ gotoWorkspace =<< getAlternateWorkspace win + + , workspaceName = "@" + } + +readNextWorkspace :: MaybeT X Workspace +readNextWorkspace = + mapNextStringWithKeysym $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] + (_, _, "[") -> lift $ + justWorkspace <$> + (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace) + (_, _, "]") -> lift $ + justWorkspace <$> + (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace) + (_, _, "(") -> lift $ + justWorkspace <$> + (adjacentWorkspace prev =<< getCurrentWorkspace) + (_, _, ")") -> lift $ + justWorkspace <$> + (adjacentWorkspace next =<< getCurrentWorkspace) + (_, _, "}") -> lift $ justWorkspace <$> adjacentScreen next + (_, _, "{") -> lift $ justWorkspace <$> adjacentScreen prev + (_, _, "^") -> lift $ justWorkspace <$> firstWorkspaceId + (_, _, "'") -> justWorkspace . locationWorkspace <$> MaybeT lastLocation + (_, _, ".") -> lift $ justWorkspace <$> getCurrentWorkspace + (_, _, "$") -> lift $ justWorkspace <$> lastWorkspaceId + (_, _, "/") -> do + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) + (_, _, " ") -> lift $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + (_, _, "_") -> return blackHoleWorkspace + (_, _, "-") -> return alternateWorkspace + _ -> MaybeT (return Nothing) + +readNextLocationSet :: MaybeT X [Location] +readNextLocationSet = + mapNextStringWithKeysym $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlpha ch -> lift $ getMarkedLocations [ch] + (_, _, "0") -> (:[]) <$> MaybeT getMostRecentLocationInHistory + (_, _, [ch]) | isDigit ch -> + (:[]) <$> MaybeT (pastHistory (ord ch - 0x30)) + (_, _, ".") -> (:[]) <$> lift getCurrentLocation + (_, _, "^") -> (:[]) <$> farLeftWindow + (_, _, "$") -> (:[]) <$> farRightWindow + (_, _, "\"") -> (:[]) <$> MaybeT nextLocation + (_, _, "'") -> (:[]) <$> MaybeT lastLocation + (_, _, "*") -> (:[]) <$> (windowLocation =<< masterWindow) + (_, _, "-") -> mapM windowLocation =<< lift getAlternateWindows + (_, _, "/") -> (:[]) <$> (windowLocation =<< MaybeT askWindowId) + (_, _, "%") -> + mapM windowLocation =<< lift (withWindowSet (return . W.allWindows)) + (_, _, "@") -> (lift . windowsInWorkspace . workspaceName) =<< readNextWorkspace + (_, _, "&") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return (l1 ++ l2) + (_, _, "\\") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return $ filter (not . flip elem l2) l1 + + _ -> MaybeT (return Nothing) diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 5caaa3b..f4e0d9a 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,18 +1,29 @@ module Rahm.Desktop.Marking ( markCurrentWindow, jumpToMark, - markToLocation, moveLocationToWorkspace, - setAlternateWindow, - getAlternateWindow + setAlternateWindows, + getAlternateWindows, + setAlternateWorkspace, + getAlternateWorkspace, + getMarkedLocations, + farLeftWindow, + farRightWindow, + windowLocation ) where + +import Prelude hiding (head) + +import Data.Maybe (fromMaybe) +import Control.Monad.Trans (lift) import Data.Ord (Down(..)) import Control.Exception -import Control.Monad (when) +import Control.Monad (when, (<=<)) import Control.Monad.Trans.Maybe import Data.Char (isAlpha, isDigit, ord) import Data.IORef import Data.List (sortOn, sort, sortBy, find) +import Data.List.Safe (head) import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Sequence (Seq(..)) @@ -36,13 +47,14 @@ type Mark = String data MarkState = MarkState { - markStateMap :: Map Mark Location - , alternateWindow :: Maybe Window + markStateMap :: Map Mark [Location] + , alternateWindows :: [Window] + , alternateWorkspaces :: Map Window WorkspaceId } deriving (Read, Show) instance ExtensionClass MarkState where - initialValue = MarkState Map.empty Nothing + initialValue = MarkState Map.empty [] Map.empty extensionType = PersistentExtension -- greedyFocus :: Window -> X () @@ -53,19 +65,24 @@ instance ExtensionClass MarkState where -- mapM_ (windows . greedyView . tag) ws -- focus win -setAlternateWindow :: Window -> X () -setAlternateWindow win = XS.modify (\m -> m { alternateWindow = Just win }) +setAlternateWorkspace :: Window -> WorkspaceId -> X () +setAlternateWorkspace win wid = + XS.modify $ \m -> m { + alternateWorkspaces = Map.insert win wid (alternateWorkspaces m) + } -getAlternateWindow :: MaybeT X Window -getAlternateWindow = MaybeT $ alternateWindow <$> XS.get +getAlternateWorkspace :: Window -> X (Maybe WorkspaceId) +getAlternateWorkspace window = + Map.lookup window . alternateWorkspaces <$> XS.get -withMaybeFocused :: (Maybe Window -> X a) -> X a -withMaybeFocused f = withWindowSet $ f . peek +setAlternateWindows :: [Window] -> X () +setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) -getCurrentLocation :: X Location -getCurrentLocation = - (\ws -> withMaybeFocused (return . Location ws)) =<< getCurrentWorkspace +getAlternateWindows :: X [Window] +getAlternateWindows = alternateWindows <$> XS.get +withMaybeFocused :: (Maybe Window -> X a) -> X a +withMaybeFocused f = withWindowSet $ f . peek markCurrentWindow :: Mark -> X () markCurrentWindow mark = do @@ -74,13 +91,18 @@ markCurrentWindow mark = do withFocused $ \win -> XS.modify $ \state@MarkState {markStateMap = ms} -> state { - markStateMap = Map.insert mark (Location ws $ Just win) ms + markStateMap = Map.insertWith (++) mark [Location ws $ Just win] ms } jumpToMark :: Mark -> X () jumpToMark mark = do MarkState {markStateMap = m} <- XS.get - mapM_ focusLocation $ Map.lookup mark m + mapM_ focusLocation $ head =<< Map.lookup mark m + +getMarkedLocations :: Mark -> X [Location] +getMarkedLocations mark = do + MarkState {markStateMap = m} <- XS.get + return (fromMaybe [] $ Map.lookup mark m) setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd setFocusedWindow @@ -122,30 +144,16 @@ windowLocation win = do tag <- MaybeT $ withWindowSet $ return . findTag win return (Location tag (Just win)) -markToLocation :: Mark -> X (Maybe Location) -markToLocation mark = - case mark of - [ch] | isAlpha ch -> Map.lookup mark . markStateMap <$> XS.get - "0" -> getMostRecentLocationInHistory - [ch] | isDigit ch -> pastHistory (ord ch - 0x30) - "." -> Just <$> getCurrentLocation - "\"" -> nextLocation - "'" -> lastLocation - "/" -> runMaybeT $ windowLocation =<< MaybeT askWindowId - "^" -> do - rects <- sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects - case rects of - ((w, _) : _) -> runMaybeT (windowLocation w) - _ -> return Nothing - "$" -> do - rects <- sortOn (Down . \(_, Rectangle x _ _ _) -> x) - <$> getWindowsAndRects - case rects of - ((w, _) : _) -> runMaybeT (windowLocation w) - _ -> return Nothing - - "*" -> runMaybeT (windowLocation =<< masterWindow) - - "@" -> runMaybeT (windowLocation =<< getAlternateWindow) - - _ -> return Nothing +farLeftWindow :: MaybeT X Location +farLeftWindow = do + rects <- lift $ sortOn (\(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects + case rects of + ((w, _) : _) -> windowLocation w + _ -> MaybeT (return Nothing) + +farRightWindow :: MaybeT X Location +farRightWindow = do + rects <- lift $ sortOn (Down . \(_, Rectangle x _ _ _) -> x) <$> getWindowsAndRects + case rects of + ((w, _) : _) -> windowLocation w + _ -> MaybeT (return Nothing) diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 5db8928..48a3144 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -9,6 +9,10 @@ module Rahm.Desktop.Submap ( submapDefault, submapDefaultWithKey) where +import Rahm.Desktop.Common +import Control.Monad.Trans.Maybe +import Control.Monad.Trans +import Control.Monad (void) import XMonad hiding (keys) import Control.Monad.Fix (fix) import qualified Data.Map as Map @@ -54,7 +58,8 @@ getMaskEventWithTimeout timeout d mask fn = do - but also allows submappings for keys that may not have a character associated - with them (for example, the function keys). -} -mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X () +mapNextStringWithKeysym :: + (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a mapNextStringWithKeysym fn = do XConf { theRoot = root, display = d } <- ask io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime @@ -76,17 +81,18 @@ mapNextStringWithKeysym fn = do Nothing -> return Nothing io $ ungrabKeyboard d currentTime - case ret of - Just (m, str, keysym) -> fn m keysym str - Nothing -> return () + + (m, str, keysym) <- MaybeT $ return ret + fn m keysym str {- Like submap, but on the character typed rather than the kysym. -} -mapNextString :: (KeyMask -> String -> X ()) -> X () +mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () -submapDefaultWithKey def m = mapNextStringWithKeysym $ \mask sym _ -> do - Map.findWithDefault (def (mask, sym)) (mask, sym) m +submapDefaultWithKey def m = runMaybeT_ $ + mapNextStringWithKeysym $ \mask sym _ -> lift $ do + Map.findWithDefault (def (mask, sym)) (mask, sym) m submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X () submapDefault def = submapDefaultWithKey (const def) diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 3a26823..f11520a 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -147,27 +147,3 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> W.tag <$> find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) (map W.workspace (c : v) ++ h) - -selectWorkspace :: String -> Maybe (X WorkspaceId) -selectWorkspace s = case s of - [ch] | isAlphaNum ch || ch == '*' -> Just $ return [ch] - "]" -> Just $ adjacentWorkspaceNotVisible next - =<< getCurrentWorkspace - "[" -> Just $ adjacentWorkspaceNotVisible prev - =<< getCurrentWorkspace - ")" -> Just $ adjacentWorkspace next =<< getCurrentWorkspace - "(" -> Just $ adjacentWorkspace prev =<< getCurrentWorkspace - "}" -> Just $ adjacentScreen next - "{" -> Just $ adjacentScreen prev - "^" -> Just firstWorkspaceId - "'" -> Just $ do - l <- lastLocation - case l of - Just (Location ws _) -> return ws - Nothing -> getCurrentWorkspace - "." -> Just getCurrentWorkspace - "$" -> Just lastWorkspaceId - "/" -> Just $ fromMaybe <$> getCurrentWorkspace <*> runMaybeT ( - (MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) - " " -> Just $ accompaningWorkspace <$> getCurrentWorkspace - _ -> Nothing -- cgit From 8b6c4a54f79b35ba153acf6dd6b6f1804237c545 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 10:11:05 -0600 Subject: Extend marking language to the mark command itself --- src/Rahm/Desktop/Keys.hs | 7 ++++--- src/Rahm/Desktop/Marking.hs | 8 ++++++++ 2 files changed, 12 insertions(+), 3 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 23927ef..da3b695 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -355,10 +355,11 @@ keymap = runKeys $ do bind xK_m $ do justMod $ doc "Mark the current window with the next typed character." $ - runMaybeT_ $ mapNextString $ \_ str -> lift $ + runMaybeT_ $ do + locs <- readNextLocationSet + mapNextString $ \_ str -> lift $ case str of - [ch] | isAlpha ch -> markCurrentWindow str - _ -> return () + [ch] | isAlpha ch -> markAllLocations str locs bind xK_plus $ do justMod $ diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index f4e0d9a..90808cf 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -7,6 +7,7 @@ module Rahm.Desktop.Marking ( setAlternateWorkspace, getAlternateWorkspace, getMarkedLocations, + markAllLocations, farLeftWindow, farRightWindow, windowLocation @@ -84,6 +85,13 @@ getAlternateWindows = alternateWindows <$> XS.get withMaybeFocused :: (Maybe Window -> X a) -> X a withMaybeFocused f = withWindowSet $ f . peek +markAllLocations :: Mark -> [Location] -> X () +markAllLocations mark locs = + XS.modify $ \m -> + m { + markStateMap = Map.insert mark locs (markStateMap m) + } + markCurrentWindow :: Mark -> X () markCurrentWindow mark = do ws <- getCurrentWorkspace -- cgit From 75886bd10e782425179f244d0a650d9861bc2843 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 16:38:05 -0600 Subject: Rename Lang to WindowManagementLanguage (Moved to Wml.hs). Add more features to it. --- src/Rahm/Desktop/Common.hs | 13 ++- src/Rahm/Desktop/DMenu.hs | 2 +- src/Rahm/Desktop/Keys.hs | 12 +-- src/Rahm/Desktop/Keys/Wml.hs | 252 +++++++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/Lang.hs | 127 ---------------------- src/Rahm/Desktop/Marking.hs | 6 -- 6 files changed, 264 insertions(+), 148 deletions(-) create mode 100644 src/Rahm/Desktop/Keys/Wml.hs delete mode 100644 src/Rahm/Desktop/Lang.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 5a5aecf..c12322a 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -57,13 +57,6 @@ instance XPrompt WinPrompt where showXPrompt _ = "[Window] " commandToComplete _ = id -fuzzyCompletion :: String -> String -> Bool -fuzzyCompletion str0 str1 = - all (`isInfixOf`l0) ws - where - ws = filter (not . all isSpace) $ words (map toLower str0) - l0 = map toLower str1 - getString :: Window -> X String getString = runQuery $ do t <- title @@ -88,6 +81,12 @@ gotoWorkspace wid = do addHiddenWorkspace wid windows $ S.greedyView wid +moveLocationToWorkspace :: Location -> WorkspaceId -> X () +moveLocationToWorkspace (Location _ (Just win)) wid = do + addHiddenWorkspace wid + windows $ shiftWin wid win +moveLocationToWorkspace _ _ = return () + getCurrentWorkspace :: X WorkspaceId getCurrentWorkspace = withWindowSet $ \(S.StackSet (S.Screen (S.Workspace t _ _) _ _) _ _ _) -> do diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs index 62ecdd3..d20d001 100644 --- a/src/Rahm/Desktop/DMenu.hs +++ b/src/Rahm/Desktop/DMenu.hs @@ -16,7 +16,7 @@ data Colors = } | DefaultColors menuCommand :: [String] -menuCommand = ["rofi", "-monitor", "-4", "-dmenu", "-sort", "-levenshtein-sort"] +menuCommand = ["rofi", "-monitor", "-4", "-i", "-dmenu", "-sort", "-levenshtein-sort"] menuCommandString :: String menuCommandString = unwords menuCommand diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index da3b695..6973b81 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -52,7 +52,7 @@ import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.Common import Rahm.Desktop.Logger import Rahm.Desktop.Marking -import Rahm.Desktop.Lang +import Rahm.Desktop.Keys.Wml import Rahm.Desktop.MouseMotion import Rahm.Desktop.PassMenu import Rahm.Desktop.PromptConfig @@ -140,7 +140,7 @@ keymap = runKeys $ do let subkeys keysM = Submap (runKeys keysM config) repeatable keysM = Repeat (runKeys keysM config) - bind xK_apostrophe $ do + forM_ [xK_apostrophe, xK_w] $ \k -> bind k $ do justMod $ doc "Jumps between marks." $ runMaybeT_ $ do @@ -189,8 +189,9 @@ keymap = runKeys $ do bind xK_F8 $ justMod $ - doc "Print this documentation." $ - sendMessage toggleHole + doc "Experimental" $ do + (logs . printf "WS: %s" . show . fmap workspaceName) =<< workspaceForString ",^" + (logs . printf "Wins: %s" . show) =<< locationSetForString "&s@,^" bind xK_F10 $ do justMod playPauseDoc @@ -489,9 +490,6 @@ keymap = runKeys $ do bind xK_v $ justMod (return () :: X ()) - bind xK_w $ do - justMod $ doc "Jump to a window (via rofi)" windowJump - bind xK_x $ do justMod $ doc "Toggles respect for struts." $ diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs new file mode 100644 index 0000000..47be2e7 --- /dev/null +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -0,0 +1,252 @@ +-- Wml: Window Management Language. +-- +-- Parser for WML objects +-- +-- Some examples of WML objects are: +-- +-- a // The workspace or window (context dependent) tagged 'a' +-- @a // All windows on workspace 'a' or the workspace with window 'a' +-- ,. // The workspace to to the right of the current one. +-- @,. // All windows on the workspace to the right of the current one. +-- @,^ // All the windows on the screen second from the left +-- &z!~@,,^ // The window tagged with z and The last window on the screen third from the left +-- @@s // All the windows that share a workspace with the window tagged s +-- \%@s // All windows except those on workspace 's' +module Rahm.Desktop.Keys.Wml where + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State as S +import Control.Monad.Trans.Class +import Control.Monad (join, forM_) + +import Data.Char (isAlphaNum, isAlpha, isDigit, ord) +import Data.Maybe (fromMaybe) +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Util.Run (safeSpawn) +import Prelude hiding (head, last) +import Data.List.Safe (head, last) +import qualified XMonad.StackSet as W + +import Rahm.Desktop.Common +import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.History +import Rahm.Desktop.Marking +import Rahm.Desktop.Workspaces +import Rahm.Desktop.Submap +import Rahm.Desktop.Logger + +import Text.Printf + +import XMonad + +data Workspace = + Workspace { + moveLocationToWorkspaceFn :: Location -> X () + , gotoWorkspaceFn :: X () + , workspaceName :: String + } + +justWorkspace :: String -> Workspace +justWorkspace s = + Workspace { + moveLocationToWorkspaceFn = flip moveLocationToWorkspace s + , gotoWorkspaceFn = gotoWorkspace s + , workspaceName = s + } + +blackHoleWorkspace :: Workspace +blackHoleWorkspace = + Workspace { + moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow + , gotoWorkspaceFn = return () -- can't navigate to black hole + , workspaceName = "blackhole" + } + +alternateWorkspace :: Workspace +alternateWorkspace = + Workspace { + moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do + logs $ "Moving Location: " ++ show l + case maybeWin of + Nothing -> return () + Just win -> do + alter <- getAlternateWorkspace win + logs $ printf "Moving %s to %s" (show win) (show alter) + mapM_ (moveLocationToWorkspace l) alter + + , gotoWorkspaceFn = do + (Location _ maybeWin) <- getCurrentLocation + case maybeWin of + Nothing -> return () + Just win -> do + mapM_ gotoWorkspace =<< getAlternateWorkspace win + + , workspaceName = "@" + } + +floatWorkspace :: Workspace -> Workspace +floatWorkspace ws = + Workspace { + moveLocationToWorkspaceFn = \location -> do + forM_ (locationWindow location) $ \win -> do + logs $ "Float " ++ show win + windows $ W.float win (W.RationalRect 0 0 100 100) + withWindowSet $ logs . show . W.floating + moveLocationToWorkspaceFn ws location + , gotoWorkspaceFn = gotoWorkspaceFn ws + , workspaceName = workspaceName ws + } + +joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a +joinMaybe (MaybeT ma) = MaybeT $ join <$> ma + +class (Monad m) => KeyFeeder m where + fromX :: X a -> m a + + fromMaybeTX :: MaybeT X a -> MaybeT m a + fromMaybeTX = mapMaybeT fromX + + readNextKey :: + (KeyMask -> KeySym -> String -> MaybeT m a) -> MaybeT m a + +instance KeyFeeder X where + fromX = id + readNextKey = mapNextStringWithKeysym + +newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT String X a } + deriving (Monad, Functor, Applicative) + +instance KeyFeeder FeedKeys where + fromX = FeedKeys . lift + + readNextKey fn = do + ls <- lift $ FeedKeys S.get + case ls of + (h:t) -> do + lift $ FeedKeys $ S.put t + fn 0 0 [h] + _ -> MaybeT (return Nothing) + +feedKeys :: String -> MaybeT FeedKeys a -> X (Maybe a) +feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf + +feedKeysT :: String -> MaybeT FeedKeys a -> MaybeT X a +feedKeysT s mf = MaybeT $ feedKeys s mf + +-- Allows a reference to a workspace in terms of its description in the window +-- management language. +workspaceForStringT :: String -> MaybeT X Workspace +workspaceForStringT str = feedKeysT str readNextWorkspace + +-- Like the above, but unwrap the MaybeT +workspaceForString :: String -> X (Maybe Workspace) +workspaceForString = runMaybeT . workspaceForStringT + +-- Like the above, but unwrap the MaybeT +locationSetForStringT :: String -> MaybeT X [Location] +locationSetForStringT s = feedKeysT s readNextLocationSet + +locationSetForString :: String -> X [Location] +locationSetForString s = fromMaybe [] <$> (runMaybeT $ locationSetForStringT s) + +-- Returns the next workspaces associated with the next set of keystrokes. +readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace +readNextWorkspace = + readNextKey $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] + (_, _, "[") -> mt $ + justWorkspace <$> + (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace) + (_, _, "]") -> mt $ + justWorkspace <$> + (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace) + (_, _, "(") -> mt $ + justWorkspace <$> + (adjacentWorkspace prev =<< getCurrentWorkspace) + (_, _, ")") -> mt $ + justWorkspace <$> + (adjacentWorkspace next =<< getCurrentWorkspace) + (_, _, "}") -> mt $ justWorkspace <$> adjacentScreen next + (_, _, "{") -> mt $ justWorkspace <$> adjacentScreen prev + (_, _, "^") -> mapMaybeT fromX $ MaybeT $ + withWindowSet $ \ws -> return $ + (fmap (justWorkspace . W.tag . W.workspace . snd) . head) + (getHorizontallyOrderedScreens ws) + (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation + (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace + (_, _, "$") -> MaybeT $ fromX $ + withWindowSet $ \ws -> return $ + (fmap (justWorkspace . W.tag . W.workspace . snd) . last) + (getHorizontallyOrderedScreens ws) + (_, _, ":") -> floatWorkspace <$> readNextWorkspace + (_, _, ",") -> do + ws <- readNextWorkspace + screens <- + mt $ + map (W.tag . W.workspace . snd) + <$> withWindowSet (return . getHorizontallyOrderedScreens) + + let (_, rest) = break (==workspaceName ws) (screens ++ screens) + + justWorkspace <$> (MaybeT $ return $ head $ tail $ rest) + + (_, _, "/") -> fromMaybeTX $ do + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) + + (_, _, "@") -> do + loc <- readNextLocationSet + MaybeT (return $ (justWorkspace . locationWorkspace) <$> head loc) + + (_, _, " ") -> mt $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + (_, _, "_") -> return blackHoleWorkspace + (_, _, "-") -> return alternateWorkspace + _ -> MaybeT (return Nothing) + where + mt :: (KeyFeeder m) => X a -> MaybeT m a + mt = lift . fromX + +readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location] +readNextLocationSet = + readNextKey $ \mask sym str -> + case (mask, sym, str) of + (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch] + (_, _, "0") -> (:[]) <$> MaybeT (fromX getMostRecentLocationInHistory) + (_, _, [ch]) | isDigit ch -> + (:[]) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30)) + (_, _, ".") -> (:[]) <$> mt getCurrentLocation + (_, _, "^") -> (:[]) <$> fromMaybeTX farLeftWindow + (_, _, "$") -> (:[]) <$> fromMaybeTX farRightWindow + (_, _, "\"") -> (:[]) <$> MaybeT (fromX nextLocation) + (_, _, "'") -> (:[]) <$> MaybeT (fromX lastLocation) + (_, _, "*") -> fromMaybeTX $ (:[]) <$> (windowLocation =<< masterWindow) + (_, _, "-") -> fromMaybeTX $ + mapM windowLocation =<< lift getAlternateWindows + (_, _, "/") -> fromMaybeTX $ + (:[]) <$> (windowLocation =<< MaybeT askWindowId) + (_, _, "%") -> fromMaybeTX $ + mapM windowLocation =<< lift (withWindowSet (return . W.allWindows)) + (_, _, "@") -> + (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace + (_, _, "!") -> (:[]) <$> (joinMaybe $ head <$> readNextLocationSet) + (_, _, ",") -> tail <$> readNextLocationSet + (_, _, "~") -> reverse <$> readNextLocationSet + (_, _, "?") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return $ if null l1 then l2 else l1 + + (_, _, "&") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return (l1 ++ l2) + (_, _, "\\") -> do + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return $ filter (not . flip elem l2) l1 + + _ -> MaybeT (return Nothing) + where + mt :: (KeyFeeder m) => X a -> MaybeT m a + mt = lift . fromX diff --git a/src/Rahm/Desktop/Lang.hs b/src/Rahm/Desktop/Lang.hs deleted file mode 100644 index 374500d..0000000 --- a/src/Rahm/Desktop/Lang.hs +++ /dev/null @@ -1,127 +0,0 @@ -module Rahm.Desktop.Lang where - -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Class - -import Data.Char (isAlphaNum, isAlpha, isDigit, ord) -import XMonad.Actions.CopyWindow as CopyWindow -import XMonad.Util.Run (safeSpawn) -import qualified XMonad.StackSet as W - -import Rahm.Desktop.Common -import Rahm.Desktop.Keys.Dsl -import Rahm.Desktop.History -import Rahm.Desktop.Marking -import Rahm.Desktop.Workspaces -import Rahm.Desktop.Submap -import Rahm.Desktop.Logger - -import Text.Printf - -import XMonad - -data Workspace = - Workspace { - moveLocationToWorkspaceFn :: Location -> X () - , gotoWorkspaceFn :: X () - , workspaceName :: String - } - -justWorkspace :: String -> Workspace -justWorkspace s = - Workspace { - moveLocationToWorkspaceFn = flip moveLocationToWorkspace s - , gotoWorkspaceFn = gotoWorkspace s - , workspaceName = s - } - -blackHoleWorkspace :: Workspace -blackHoleWorkspace = - Workspace { - moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow - , gotoWorkspaceFn = return () -- can't navigate to black hole - , workspaceName = "blackhole" - } - -alternateWorkspace :: Workspace -alternateWorkspace = - Workspace { - moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do - logs $ "Moving Location: " ++ show l - case maybeWin of - Nothing -> return () - Just win -> do - alter <- getAlternateWorkspace win - logs $ printf "Moving %s to %s" (show win) (show alter) - mapM_ (moveLocationToWorkspace l) alter - - , gotoWorkspaceFn = do - (Location _ maybeWin) <- getCurrentLocation - case maybeWin of - Nothing -> return () - Just win -> do - mapM_ gotoWorkspace =<< getAlternateWorkspace win - - , workspaceName = "@" - } - -readNextWorkspace :: MaybeT X Workspace -readNextWorkspace = - mapNextStringWithKeysym $ \mask sym str -> - case (mask, sym, str) of - (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] - (_, _, "[") -> lift $ - justWorkspace <$> - (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace) - (_, _, "]") -> lift $ - justWorkspace <$> - (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace) - (_, _, "(") -> lift $ - justWorkspace <$> - (adjacentWorkspace prev =<< getCurrentWorkspace) - (_, _, ")") -> lift $ - justWorkspace <$> - (adjacentWorkspace next =<< getCurrentWorkspace) - (_, _, "}") -> lift $ justWorkspace <$> adjacentScreen next - (_, _, "{") -> lift $ justWorkspace <$> adjacentScreen prev - (_, _, "^") -> lift $ justWorkspace <$> firstWorkspaceId - (_, _, "'") -> justWorkspace . locationWorkspace <$> MaybeT lastLocation - (_, _, ".") -> lift $ justWorkspace <$> getCurrentWorkspace - (_, _, "$") -> lift $ justWorkspace <$> lastWorkspaceId - (_, _, "/") -> do - justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) - (_, _, " ") -> lift $ - justWorkspace . accompaningWorkspace <$> getCurrentWorkspace - (_, _, "_") -> return blackHoleWorkspace - (_, _, "-") -> return alternateWorkspace - _ -> MaybeT (return Nothing) - -readNextLocationSet :: MaybeT X [Location] -readNextLocationSet = - mapNextStringWithKeysym $ \mask sym str -> - case (mask, sym, str) of - (_, _, [ch]) | isAlpha ch -> lift $ getMarkedLocations [ch] - (_, _, "0") -> (:[]) <$> MaybeT getMostRecentLocationInHistory - (_, _, [ch]) | isDigit ch -> - (:[]) <$> MaybeT (pastHistory (ord ch - 0x30)) - (_, _, ".") -> (:[]) <$> lift getCurrentLocation - (_, _, "^") -> (:[]) <$> farLeftWindow - (_, _, "$") -> (:[]) <$> farRightWindow - (_, _, "\"") -> (:[]) <$> MaybeT nextLocation - (_, _, "'") -> (:[]) <$> MaybeT lastLocation - (_, _, "*") -> (:[]) <$> (windowLocation =<< masterWindow) - (_, _, "-") -> mapM windowLocation =<< lift getAlternateWindows - (_, _, "/") -> (:[]) <$> (windowLocation =<< MaybeT askWindowId) - (_, _, "%") -> - mapM windowLocation =<< lift (withWindowSet (return . W.allWindows)) - (_, _, "@") -> (lift . windowsInWorkspace . workspaceName) =<< readNextWorkspace - (_, _, "&") -> do - l1 <- readNextLocationSet - l2 <- readNextLocationSet - return (l1 ++ l2) - (_, _, "\\") -> do - l1 <- readNextLocationSet - l2 <- readNextLocationSet - return $ filter (not . flip elem l2) l1 - - _ -> MaybeT (return Nothing) diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 90808cf..1ea9782 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,7 +1,6 @@ module Rahm.Desktop.Marking ( markCurrentWindow, jumpToMark, - moveLocationToWorkspace, setAlternateWindows, getAlternateWindows, setAlternateWorkspace, @@ -131,11 +130,6 @@ swapWithFocused winToSwap stackSet = mapWindows ( \w -> if w == winToSwap then focused else w) stackSet -moveLocationToWorkspace :: Location -> WorkspaceId -> X () -moveLocationToWorkspace (Location _ (Just win)) wid = - windows $ shiftWin wid win -moveLocationToWorkspace _ _ = return () - windowRect :: Window -> X (Maybe Rectangle) windowRect win = withDisplay $ \dpy -> (do (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win -- cgit From 25958a8363691a86a60667ca4f92b65247c51d89 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 20:47:07 -0600 Subject: Change window border when selecting windows --- src/Rahm/Desktop/Common.hs | 35 +++++++++++++++++++++++++++++++---- src/Rahm/Desktop/Keys.hs | 29 ++++++++++++++++------------- src/Rahm/Desktop/Keys/Wml.hs | 40 ++++++++++++++++++++++++++++++++-------- src/Rahm/Desktop/Submap.hs | 2 +- 4 files changed, 80 insertions(+), 26 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index c12322a..9187edf 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -2,13 +2,14 @@ module Rahm.Desktop.Common where import Prelude hiding ((!!)) -import Control.Monad (void) +import Control.Monad (void, when, forM_) import Control.Monad.Trans.Maybe import XMonad.Actions.DynamicWorkspaces import XMonad.Util.Run import XMonad.Prompt import XMonad.Prompt.Input import XMonad.Prompt.Shell +import XMonad.Util.XUtils import Rahm.Desktop.PromptConfig @@ -66,15 +67,41 @@ getString = runQuery $ do then t else printf "%s - %s" t a -askWindowId :: X (Maybe Window) +askWindowId :: X (Maybe [Window]) askWindowId = do windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + Map.fromListWith (++) <$> mapM (\wid -> (,) <$> getString wid <*> return [wid]) (allWindows ss) runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId windowJump :: X () -windowJump = mapM_ focus =<< askWindowId +windowJump = (mapM_ (focus . head)) =<< askWindowId + +-- Temporarily set the border color of the given windows. +withBorderColor :: String -> [Window] -> X a -> X a +withBorderColor color wins fn = do + d <- asks display + px <- stringToPixel d color + oPx <- stringToPixel d =<< asks (normalBorderColor . config) + fPx <- stringToPixel d =<< asks (focusedBorderColor . config) + + colorName <- io (pixelToString d px) + oColorName <- io (pixelToString d oPx) + fColorName <- io (pixelToString d fPx) + + forM_ wins $ \w -> + setWindowBorderWithFallback d w colorName px + + ret <- fn + + withFocused $ \fw -> do + forM_ wins $ \w -> + when (w /= fw) $ + setWindowBorderWithFallback d w oColorName oPx + + setWindowBorderWithFallback d fw fColorName fPx + + return ret gotoWorkspace :: WorkspaceId -> X () gotoWorkspace wid = do diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 6973b81..69873e4 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -32,6 +32,7 @@ import XMonad.Layout.Spacing import XMonad.Prompt import XMonad.Prompt.Input import XMonad.Prompt.Shell +import XMonad.Util.XUtils import XMonad.Util.CustomKeys import XMonad.Util.Run (safeSpawn) import XMonad.Util.Scratchpad @@ -392,19 +393,21 @@ keymap = runKeys $ do sendMessage rotateLayout bind xK_s $ do - justMod $ runMaybeT_ $ do - locations <- readNextLocationSet - - workspace <- readNextWorkspace - mapM_ (lift . moveLocationToWorkspaceFn workspace) locations - - lift $ setAlternateWindows (mapMaybe locationWindow locations) - forM_ locations $ \loc -> - case locationWindow loc of - Nothing -> return () - Just win -> do - lift $ logs $ printf "setAlternate %s %s" (show win) (show $ locationWorkspace loc) - lift $ setAlternateWorkspace win (locationWorkspace loc) + justMod $ do + locations <- fromMaybe [] <$> runMaybeT readNextLocationSet + let locationWindows = mapMaybe locationWindow locations + + withBorderColor "#00ffff" locationWindows $ do + runMaybeT_ $ do + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + + lift $ setAlternateWindows locationWindows + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 47be2e7..21b8c4c 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -18,9 +18,11 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.State as S import Control.Monad.Trans.Class import Control.Monad (join, forM_) +import Data.List (sortOn, intercalate) +import Data.Ord (Down(..)) import Data.Char (isAlphaNum, isAlpha, isDigit, ord) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import XMonad.Actions.CopyWindow as CopyWindow import XMonad.Util.Run (safeSpawn) import Prelude hiding (head, last) @@ -191,8 +193,19 @@ readNextWorkspace = justWorkspace <$> (MaybeT $ return $ head $ tail $ rest) + (_, _, ";") -> do + ws <- readNextWorkspace + screens <- + mt $ + map (W.tag . W.workspace . snd) + <$> withWindowSet (return . getHorizontallyOrderedScreens) + + let (front, _) = break (==workspaceName ws) (screens ++ screens) + + justWorkspace <$> (MaybeT $ return $ last $ front) + (_, _, "/") -> fromMaybeTX $ do - justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT askWindowId) + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT ((head=<<) <$> askWindowId)) (_, _, "@") -> do loc <- readNextLocationSet @@ -220,13 +233,20 @@ readNextLocationSet = (_, _, "$") -> (:[]) <$> fromMaybeTX farRightWindow (_, _, "\"") -> (:[]) <$> MaybeT (fromX nextLocation) (_, _, "'") -> (:[]) <$> MaybeT (fromX lastLocation) - (_, _, "*") -> fromMaybeTX $ (:[]) <$> (windowLocation =<< masterWindow) + (_, _, "*") -> mt $ do -- All visible windows. + wins <- withWindowSet $ + return . concatMap (W.integrate' . W.stack . W.workspace) . W.screens + + catMaybes <$> mapM (runMaybeT . windowLocation) wins + (_, _, "-") -> fromMaybeTX $ mapM windowLocation =<< lift getAlternateWindows (_, _, "/") -> fromMaybeTX $ - (:[]) <$> (windowLocation =<< MaybeT askWindowId) - (_, _, "%") -> fromMaybeTX $ - mapM windowLocation =<< lift (withWindowSet (return . W.allWindows)) + (mapM windowLocation =<< MaybeT askWindowId) + (_, _, "%") -> fromMaybeTX $ do + ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) + lift $ logs $ "allWindows " ++ intercalate "\n" (map show ret) + return ret (_, _, "@") -> (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace (_, _, "!") -> (:[]) <$> (joinMaybe $ head <$> readNextLocationSet) @@ -236,15 +256,19 @@ readNextLocationSet = l1 <- readNextLocationSet l2 <- readNextLocationSet return $ if null l1 then l2 else l1 - - (_, _, "&") -> do + (_, _, "|") -> do l1 <- readNextLocationSet l2 <- readNextLocationSet return (l1 ++ l2) + (_, _, "_") -> return [] (_, _, "\\") -> do l1 <- readNextLocationSet l2 <- readNextLocationSet return $ filter (not . flip elem l2) l1 + (_, _, "&") -> do -- intersection + l1 <- readNextLocationSet + l2 <- readNextLocationSet + return $ filter (flip elem l2) l1 _ -> MaybeT (return Nothing) where diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 48a3144..5a05f9e 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -66,7 +66,7 @@ mapNextStringWithKeysym fn = do ret <- io $ fix $ \nextkey -> do ret <- - getMaskEventWithTimeout 2000 d keyPressMask $ \p -> do + getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p keysym <- keycodeToKeysym d code 0 (_, str) <- lookupString (asKeyEvent p) -- cgit From 41b4bf01d61a0d42d27145700e41318715b37e1f Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 18 Apr 2022 23:00:26 -0600 Subject: Highlight windows for marking too --- src/Rahm/Desktop/Keys.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 69873e4..9ae9c30 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -354,14 +354,16 @@ keymap = runKeys $ do doc "For mosaic layout, shrink the size-share of the current window" $ sendMessage =<< shrinkPositionAlt - bind xK_m $ do + bind xK_m $ justMod $ - doc "Mark the current window with the next typed character." $ - runMaybeT_ $ do - locs <- readNextLocationSet - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> markAllLocations str locs + doc "Mark the current window with the next typed character." $ do + locs <- fromMaybe [] <$> runMaybeT readNextLocationSet + withBorderColor "#00ffff" (mapMaybe locationWindow locs) $ do + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> markAllLocations str locs + _ -> return () bind xK_plus $ do justMod $ -- cgit From decdf01bd651cfb0bd77e496143c364389e90008 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 19 Apr 2022 21:33:51 -0600 Subject: Add : object to reference floating windows --- src/Rahm/Desktop/Keys/Wml.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 21b8c4c..babf3b5 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -21,6 +21,7 @@ import Control.Monad (join, forM_) import Data.List (sortOn, intercalate) import Data.Ord (Down(..)) +import qualified Data.Map as Map import Data.Char (isAlphaNum, isAlpha, isDigit, ord) import Data.Maybe (fromMaybe, catMaybes) import XMonad.Actions.CopyWindow as CopyWindow @@ -149,7 +150,7 @@ locationSetForStringT :: String -> MaybeT X [Location] locationSetForStringT s = feedKeysT s readNextLocationSet locationSetForString :: String -> X [Location] -locationSetForString s = fromMaybe [] <$> (runMaybeT $ locationSetForStringT s) +locationSetForString s = fromMaybe [] <$> runMaybeT (locationSetForStringT s) -- Returns the next workspaces associated with the next set of keystrokes. readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace @@ -191,7 +192,7 @@ readNextWorkspace = let (_, rest) = break (==workspaceName ws) (screens ++ screens) - justWorkspace <$> (MaybeT $ return $ head $ tail $ rest) + justWorkspace <$> MaybeT (return $ head $ tail rest) (_, _, ";") -> do ws <- readNextWorkspace @@ -202,14 +203,14 @@ readNextWorkspace = let (front, _) = break (==workspaceName ws) (screens ++ screens) - justWorkspace <$> (MaybeT $ return $ last $ front) + justWorkspace <$> MaybeT (return $ last front) (_, _, "/") -> fromMaybeTX $ do justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT ((head=<<) <$> askWindowId)) (_, _, "@") -> do loc <- readNextLocationSet - MaybeT (return $ (justWorkspace . locationWorkspace) <$> head loc) + MaybeT (return $ justWorkspace . locationWorkspace <$> head loc) (_, _, " ") -> mt $ justWorkspace . accompaningWorkspace <$> getCurrentWorkspace @@ -242,16 +243,22 @@ readNextLocationSet = (_, _, "-") -> fromMaybeTX $ mapM windowLocation =<< lift getAlternateWindows (_, _, "/") -> fromMaybeTX $ - (mapM windowLocation =<< MaybeT askWindowId) + mapM windowLocation =<< MaybeT askWindowId (_, _, "%") -> fromMaybeTX $ do ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) lift $ logs $ "allWindows " ++ intercalate "\n" (map show ret) return ret (_, _, "@") -> (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace - (_, _, "!") -> (:[]) <$> (joinMaybe $ head <$> readNextLocationSet) + (_, _, "!") -> (:[]) <$> joinMaybe (head <$> readNextLocationSet) (_, _, ",") -> tail <$> readNextLocationSet (_, _, "~") -> reverse <$> readNextLocationSet + (_, _, ":") -> mt $ + withWindowSet $ + fmap catMaybes . + mapM (runMaybeT . windowLocation) . + Map.keys . + W.floating (_, _, "?") -> do l1 <- readNextLocationSet l2 <- readNextLocationSet @@ -268,7 +275,7 @@ readNextLocationSet = (_, _, "&") -> do -- intersection l1 <- readNextLocationSet l2 <- readNextLocationSet - return $ filter (flip elem l2) l1 + return $ filter (`elem` l2) l1 _ -> MaybeT (return Nothing) where -- cgit From cfa9b9fbefa247ce06ed1e985fdfacf162f781c8 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 19 Apr 2022 22:45:32 -0600 Subject: Add :: object to tile windows onto a workspace --- src/Rahm/Desktop/Keys/Wml.hs | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index babf3b5..0dfb852 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -17,9 +17,10 @@ module Rahm.Desktop.Keys.Wml where import Control.Monad.Trans.Maybe import Control.Monad.Trans.State as S import Control.Monad.Trans.Class -import Control.Monad (join, forM_) +import Control.Monad (join, forM_, unless) import Data.List (sortOn, intercalate) import Data.Ord (Down(..)) +import Data.Typeable (cast) import qualified Data.Map as Map import Data.Char (isAlphaNum, isAlpha, isDigit, ord) @@ -43,10 +44,11 @@ import Text.Printf import XMonad data Workspace = - Workspace { + forall a. (Typeable a) => Workspace { moveLocationToWorkspaceFn :: Location -> X () , gotoWorkspaceFn :: X () , workspaceName :: String + , extraWorkspaceData :: a } justWorkspace :: String -> Workspace @@ -55,6 +57,7 @@ justWorkspace s = moveLocationToWorkspaceFn = flip moveLocationToWorkspace s , gotoWorkspaceFn = gotoWorkspace s , workspaceName = s + , extraWorkspaceData = () } blackHoleWorkspace :: Workspace @@ -63,6 +66,7 @@ blackHoleWorkspace = moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow , gotoWorkspaceFn = return () -- can't navigate to black hole , workspaceName = "blackhole" + , extraWorkspaceData = () } alternateWorkspace :: Workspace @@ -85,19 +89,32 @@ alternateWorkspace = mapM_ gotoWorkspace =<< getAlternateWorkspace win , workspaceName = "@" + , extraWorkspaceData = () } +newtype FloatWorkspace = FloatWorkspace Workspace + floatWorkspace :: Workspace -> Workspace -floatWorkspace ws = +floatWorkspace ws@Workspace { extraWorkspaceData = d } = Workspace { moveLocationToWorkspaceFn = \location -> do + forM_ (locationWindow location) $ \win -> do - logs $ "Float " ++ show win - windows $ W.float win (W.RationalRect 0 0 100 100) - withWindowSet $ logs . show . W.floating - moveLocationToWorkspaceFn ws location + case cast d of + Just (FloatWorkspace ws') -> do + windows $ W.sink win + moveLocationToWorkspaceFn ws' location + Nothing -> do + windows $ \ss -> + if win `Map.member` W.floating ss + then ss -- win is already floating + else W.float win (W.RationalRect (1/8) (1/8) (6/8) (6/8)) ss + moveLocationToWorkspaceFn ws location + + , gotoWorkspaceFn = gotoWorkspaceFn ws , workspaceName = workspaceName ws + , extraWorkspaceData = FloatWorkspace ws } joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a @@ -248,7 +265,7 @@ readNextLocationSet = ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) lift $ logs $ "allWindows " ++ intercalate "\n" (map show ret) return ret - (_, _, "@") -> + (_, _, s) | s == "\t" || s == "@" || s == "\n" -> (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace (_, _, "!") -> (:[]) <$> joinMaybe (head <$> readNextLocationSet) (_, _, ",") -> tail <$> readNextLocationSet -- cgit From 6bfec2037120cd5e3dbd46f7f911fbfb9b718daf Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 20 Apr 2022 00:56:29 -0600 Subject: Add macro support to WML. Macros may be defined by using w begins defining a windowset macro t begins defining a workspace macro The next character typed is the key chord to save the macro to. The next sequence of keys read up until the Return key is the macro value. This macro may then be used as WML objects. Macros are pretty primitive right now. I need to think about if it would be worthwhile to make these macros either take arguments or add some kind of state to WML a la sed to take a step to make the language Turing complete, and if such a development would actually be desirable. If anything it would be an academic exercise. --- src/Rahm/Desktop/Keys.hs | 19 +++++++----- src/Rahm/Desktop/Keys/Wml.hs | 72 +++++++++++++++++++++++++++++++++----------- 2 files changed, 66 insertions(+), 25 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 9ae9c30..a453df1 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -187,13 +187,6 @@ keymap = runKeys $ do doc "Print this documentation." $ logs (documentation (keymap config)) - bind xK_F8 $ - - justMod $ - doc "Experimental" $ do - (logs . printf "WS: %s" . show . fmap workspaceName) =<< workspaceForString ",^" - (logs . printf "Wins: %s" . show) =<< locationSetForString "&s@,^" - bind xK_F10 $ do justMod playPauseDoc @@ -299,6 +292,18 @@ keymap = runKeys $ do moveLocationToWorkspaceFn ws loc gotoWorkspaceFn ws + bind xK_d $ + justMod $ + doc "Record (define) macros." $ + subkeys $ do + bind xK_w $ noMod $ + doc "Record a windowset macro" $ + runMaybeT_ readWindowsetMacro + + bind xK_t $ noMod $ + doc "Record a workspace macro" $ + runMaybeT_ readWorkspaceMacro + bind xK_h $ do justMod $ doc "Focus on the next window down in the stack" $ diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 0dfb852..7659a7d 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -14,6 +14,7 @@ -- \%@s // All windows except those on workspace 's' module Rahm.Desktop.Keys.Wml where +import qualified XMonad.Util.ExtensibleState as XS import Control.Monad.Trans.Maybe import Control.Monad.Trans.State as S import Control.Monad.Trans.Class @@ -23,6 +24,7 @@ import Data.Ord (Down(..)) import Data.Typeable (cast) import qualified Data.Map as Map +import Data.Map (Map) import Data.Char (isAlphaNum, isAlpha, isDigit, ord) import Data.Maybe (fromMaybe, catMaybes) import XMonad.Actions.CopyWindow as CopyWindow @@ -43,6 +45,17 @@ import Text.Printf import XMonad +type KeyString = [(KeyMask, KeySym, String)] + +data Macros = Macros { + workspaceMacros :: Map (KeyMask, KeySym) KeyString +, windowsetMacros :: Map (KeyMask, KeySym) KeyString +} deriving (Read, Show) + +instance ExtensionClass Macros where + initialValue = Macros Map.empty Map.empty + extensionType = PersistentExtension + data Workspace = forall a. (Typeable a) => Workspace { moveLocationToWorkspaceFn :: Location -> X () @@ -51,6 +64,27 @@ data Workspace = , extraWorkspaceData :: a } +readWorkspaceMacro :: MaybeT X () +readWorkspaceMacro = + mapNextStringWithKeysym $ \mask sym _ -> do + macro <- readMacroString + lift $ XS.modify $ \m -> m { + workspaceMacros = Map.insert (mask, sym) macro (workspaceMacros m) } + +readWindowsetMacro :: MaybeT X () +readWindowsetMacro = + mapNextStringWithKeysym $ \mask sym _ -> do + macro <- readMacroString + lift $ XS.modify $ \m -> m { + windowsetMacros = Map.insert (mask, sym) macro (windowsetMacros m) } + +readMacroString :: MaybeT X KeyString +readMacroString = do + mapNextStringWithKeysym $ \m k s -> case (m, k, s) of + _ | k == xK_Return -> return [] + _ | k == xK_Escape -> MaybeT $ return Nothing + r -> ([r]++) <$> readMacroString + justWorkspace :: String -> Workspace justWorkspace s = Workspace { @@ -133,7 +167,7 @@ instance KeyFeeder X where fromX = id readNextKey = mapNextStringWithKeysym -newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT String X a } +newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT KeyString X a } deriving (Monad, Functor, Applicative) instance KeyFeeder FeedKeys where @@ -142,32 +176,32 @@ instance KeyFeeder FeedKeys where readNextKey fn = do ls <- lift $ FeedKeys S.get case ls of - (h:t) -> do + ((mask, sym, str):t) -> do lift $ FeedKeys $ S.put t - fn 0 0 [h] + fn mask sym str _ -> MaybeT (return Nothing) -feedKeys :: String -> MaybeT FeedKeys a -> X (Maybe a) +feedKeys :: KeyString -> MaybeT FeedKeys a -> X (Maybe a) feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf -feedKeysT :: String -> MaybeT FeedKeys a -> MaybeT X a +feedKeysT :: KeyString -> MaybeT FeedKeys a -> MaybeT X a feedKeysT s mf = MaybeT $ feedKeys s mf -- Allows a reference to a workspace in terms of its description in the window -- management language. -workspaceForStringT :: String -> MaybeT X Workspace -workspaceForStringT str = feedKeysT str readNextWorkspace +workspaceForKeysT :: KeyString -> MaybeT X Workspace +workspaceForKeysT str = feedKeysT str readNextWorkspace -- Like the above, but unwrap the MaybeT -workspaceForString :: String -> X (Maybe Workspace) -workspaceForString = runMaybeT . workspaceForStringT +workspaceForKeys :: KeyString -> X (Maybe Workspace) +workspaceForKeys = runMaybeT . workspaceForKeysT -- Like the above, but unwrap the MaybeT -locationSetForStringT :: String -> MaybeT X [Location] -locationSetForStringT s = feedKeysT s readNextLocationSet +locationSetForKeysT :: KeyString -> MaybeT X [Location] +locationSetForKeysT s = feedKeysT s readNextLocationSet -locationSetForString :: String -> X [Location] -locationSetForString s = fromMaybe [] <$> runMaybeT (locationSetForStringT s) +locationSetForKeys :: KeyString -> X [Location] +locationSetForKeys s = fromMaybe [] <$> runMaybeT (locationSetForKeysT s) -- Returns the next workspaces associated with the next set of keystrokes. readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace @@ -187,8 +221,6 @@ readNextWorkspace = (_, _, ")") -> mt $ justWorkspace <$> (adjacentWorkspace next =<< getCurrentWorkspace) - (_, _, "}") -> mt $ justWorkspace <$> adjacentScreen next - (_, _, "{") -> mt $ justWorkspace <$> adjacentScreen prev (_, _, "^") -> mapMaybeT fromX $ MaybeT $ withWindowSet $ \ws -> return $ (fmap (justWorkspace . W.tag . W.workspace . snd) . head) @@ -233,7 +265,9 @@ readNextWorkspace = justWorkspace . accompaningWorkspace <$> getCurrentWorkspace (_, _, "_") -> return blackHoleWorkspace (_, _, "-") -> return alternateWorkspace - _ -> MaybeT (return Nothing) + (mask, keysym, _) -> do + macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . workspaceMacros <$> XS.get) + fromMaybeTX $ workspaceForKeysT macro where mt :: (KeyFeeder m) => X a -> MaybeT m a mt = lift . fromX @@ -293,8 +327,10 @@ readNextLocationSet = l1 <- readNextLocationSet l2 <- readNextLocationSet return $ filter (`elem` l2) l1 - - _ -> MaybeT (return Nothing) + (mask, keysym, _) -> do + macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . windowsetMacros <$> XS.get) + lift $ fromX $ logs $ "Executing Macro: " ++ show macro + fromMaybeTX $ locationSetForKeysT macro where mt :: (KeyFeeder m) => X a -> MaybeT m a mt = lift . fromX -- cgit From 8df47403a0f5ed1a3ef853e25868fa305b2f3a1b Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 21 Apr 2022 17:04:08 -0600 Subject: Some changes to XMobar look and feel --- src/Rahm/Desktop/Layout/Draw.hs | 24 +++++++++++++++--------- src/Rahm/Desktop/XMobarLog.hs | 4 ++-- 2 files changed, 17 insertions(+), 11 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index aa4dba3..8380e98 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -130,23 +130,29 @@ drawXpm :: drawXpm (w, h) rects' shrinkAmt = execWriter $ do tell "/* XPM */\n" tell "static char *out[] = {\n" - tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + tell $ printf "\"%d %d %d 1 \",\n" (w + 7) (h + 7) (length rects + 1) let zipRects = zip ['A' .. 'Z'] rects forM_ zipRects $ \(char, (color, _)) -> do tell $ printf "\"%c c %s\",\n" char color - tell "\"% c None\",\n" - - forM_ [0 .. h - 1] $ \y -> do - tell "\"" - forM_ [0 .. w - 1] $ \x -> + tell "\"% c #000000\",\n" + + forM_ [0..2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" + forM_ [0 .. h] $ \y -> do + tell "\"%%%" + forM_ [0 .. w] $ \x -> (case find (matches x y) zipRects of Nothing -> tell "%" Just (chr, _) -> tell [chr]) - tell "\"" - when (y /= h - 1 - shrinkAmt) (tell ",") - tell "\n" + tell "%%%\"\n" + forM_ [0..2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" tell "};\n" where diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 637670e..d0dcc4f 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -46,7 +46,7 @@ xMobarLogHook (XMobarLog xmproc) = do hPutStrLn xmproc $ trunc 80 $ execWriter $ do tell " " tell layoutXpm - tell $ " " + tell $ " " forM_ wss $ \(t, ws) -> do case t of @@ -57,7 +57,7 @@ xMobarLogHook (XMobarLog xmproc) = do tell $ toAction $ S.tag ws tell " " - tell $ " " + tell $ " " tell $ title tell $ "" -- cgit From fd7831aba6f1698883906258a0a1966880427d94 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 22 Apr 2022 00:27:36 -0600 Subject: Infrastructure for better logging, finally! Right now all existing logs are logged at Info, but this will change. This should make it significantly easier to debug things wit log levels like Trace. I may at some point define more log level endpoints or come up with a more expressive logging system, but this is a good start. --- src/Rahm/Desktop/Keys.hs | 16 +++++++------- src/Rahm/Desktop/Keys/Wml.hs | 8 +++---- src/Rahm/Desktop/Logger.hs | 48 +++++++++++++++++++++++++++-------------- src/Rahm/Desktop/MouseMotion.hs | 4 ++-- 4 files changed, 46 insertions(+), 30 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index a453df1..c8abbf0 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -172,7 +172,7 @@ keymap = runKeys $ do -- things all for BS security theater, but I guess there might be some way -- to do this via XTest? shiftMod $ forAllWindows $ \w -> do - logs $ "Try send to " ++ show w + logs Info "Try send to %s" (show w) sendKey (0, xK_a) w justMod $ @@ -185,7 +185,7 @@ keymap = runKeys $ do justMod $ doc "Print this documentation." $ - logs (documentation (keymap config)) + (logs Info "%s" (documentation (keymap config)) :: X ()) bind xK_F10 $ do justMod playPauseDoc @@ -221,7 +221,7 @@ keymap = runKeys $ do withScreen W.shift idx altgrMod $ - logs "Test altgr" + (logs Info "Test altgr" :: X ()) bind xK_bracketright $ do justMod $ @@ -391,7 +391,7 @@ keymap = runKeys $ do bind xK_q $ (justMod -|- noMod) $ doc "EXPERIMENTAL: Move mouse to control media." $ - mouseRotateMotion (logs "CW") (logs "CCW") + mouseRotateMotion (logs Info "CW") (logs Info "CCW") bind xK_r $ do justMod $ doc "Run a command via Rofi" runDMenu @@ -516,7 +516,7 @@ keymap = runKeys $ do doc "Go to the prior window in the history" historyBack bind xK_t $ do - (justMod -|- noMod) $ logs "Test Log" + (justMod -|- noMod) $ (logs Info "Test Log" :: X ()) -- bind xK_n $ do -- (justMod -|- noMod) $ @@ -845,7 +845,7 @@ windowSpecificBindings config = do bind xK_F2 $ -- Experimental. - noMod $ logs "This is a test" + noMod $ (logs Info "This is a test" :: X ()) -- Add a binding to xev as a test. configureIf (title =? "Event Tester") $ @@ -878,9 +878,9 @@ windowBindings xconfig = map <- execWriterT $ windowSpecificBindings xconfig w <- ask - liftX $ logs $ printf "For Window: %s" (show w) + liftX $ logs Info "For Window: %s" (show w) forM_ (Map.toList map) $ \(key, action) -> do - liftX $ logs $ printf " -- remap: %s" (show key) + liftX $ logs Info " -- remap: %s" (show key) remapKey key action applyKeys :: XConfig l -> IO (XConfig l) diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 7659a7d..dd82922 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -107,12 +107,12 @@ alternateWorkspace :: Workspace alternateWorkspace = Workspace { moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do - logs $ "Moving Location: " ++ show l + logs Info "Moving Location: %s" (show l) case maybeWin of Nothing -> return () Just win -> do alter <- getAlternateWorkspace win - logs $ printf "Moving %s to %s" (show win) (show alter) + logs Info "Moving %s to %s" (show win) (show alter) mapM_ (moveLocationToWorkspace l) alter , gotoWorkspaceFn = do @@ -297,7 +297,7 @@ readNextLocationSet = mapM windowLocation =<< MaybeT askWindowId (_, _, "%") -> fromMaybeTX $ do ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) - lift $ logs $ "allWindows " ++ intercalate "\n" (map show ret) + lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret)) return ret (_, _, s) | s == "\t" || s == "@" || s == "\n" -> (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace @@ -329,7 +329,7 @@ readNextLocationSet = return $ filter (`elem` l2) l1 (mask, keysym, _) -> do macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . windowsetMacros <$> XS.get) - lift $ fromX $ logs $ "Executing Macro: " ++ show macro + lift $ fromX $ logs Info "Executing Macro: %s" (show macro) fromMaybeTX $ locationSetForKeysT macro where mt :: (KeyFeeder m) => X a -> MaybeT m a diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs index c73942f..3da70d1 100644 --- a/src/Rahm/Desktop/Logger.hs +++ b/src/Rahm/Desktop/Logger.hs @@ -1,32 +1,48 @@ module Rahm.Desktop.Logger where +import Control.Monad (when) import XMonad import qualified XMonad.Util.ExtensibleState as XS import System.IO import Rahm.Desktop.NoPersist +import Text.Printf + +data LogLevel = Trace | Debug | Info | Warn | Error | Fatal + deriving (Show, Read, Ord, Eq, Enum) newtype LoggerState = LoggerState { - logHandle :: Maybe (NoPersist Handle) - } + logLevel :: LogLevel + } deriving (Show, Read, Eq) instance ExtensionClass LoggerState where - initialValue = LoggerState Nothing + initialValue = LoggerState Info + extensionType = PersistentExtension + +class (PrintfType (Printf t)) => LoggerType t where + type EndResult t :: * + type Printf t :: * + + gp :: (String -> EndResult t) -> Printf t -> t + +instance (PrintfArg a, LoggerType b) => LoggerType (a -> b) where + type EndResult (a -> b) = EndResult b + type Printf (a -> b) = a -> Printf b + + gp f g a = gp f (g a) -logs :: String -> X () -logs s = do - LoggerState handle' <- XS.get +instance (a ~ ()) => LoggerType (X a) where + type EndResult (X a) = X () + type Printf (X a) = String - handle <- - case handle' of - Nothing -> do - handle <- io $ openFile "/tmp/xmonad.log" AppendMode - XS.put $ LoggerState $ Just $ NoPersist handle - return handle + gp fn str = fn str - Just (NoPersist h) -> return h +logs :: (LoggerType r, EndResult r ~ X ()) => LogLevel -> String -> r +logs ll fmt = gp (\s -> do + LoggerState ll' <- XS.get + when (ll >= ll') $ + io $ putStrLn ("[" ++ show ll ++ "] " ++ s)) (printf fmt) - io $ do - hPutStrLn handle s - hFlush handle +test :: X () +test = logs Info "Test %s" diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs index b5e8874..cacb52f 100644 --- a/src/Rahm/Desktop/MouseMotion.hs +++ b/src/Rahm/Desktop/MouseMotion.hs @@ -39,7 +39,7 @@ motion = MouseMotionM $ do ev <- nextMotionOrButton case ev of Right button -> do - logs ("Button " ++ show button) + logs Info "Button %s" (show button) return Nothing Left motion -> return (Just $ uncurry V2 motion) @@ -93,4 +93,4 @@ mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse where doMouse = forever $ do v <- motion - liftMouseMotionM $ logs $ "Motion: " ++ show v + liftMouseMotionM $ logs Info "Motion: %s" (show v) -- cgit From 7dfbd2e4bc893f7527f9cc4ebf9c474ddfb0dc65 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 22 Apr 2022 16:22:30 -0600 Subject: Some new styling and better logging capabilites --- src/Rahm/Desktop/Keys.hs | 14 ++++++++++++++ src/Rahm/Desktop/Logger.hs | 37 ++++++++++++++++++++----------------- src/Rahm/Desktop/XMobarLog.hs | 43 ++++++++++++++++++++++++++++--------------- 3 files changed, 62 insertions(+), 32 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index c8abbf0..d0305b3 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -73,6 +73,9 @@ type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) spawnX :: String -> X () spawnX = spawn +safeSpawnX :: String -> [String] -> X () +safeSpawnX = safeSpawn + noWindow :: b -> Window -> b noWindow = const @@ -600,6 +603,17 @@ keymap = runKeys $ do doc "Toggle zoom on the current window." $ sendMessage togglePop + bind xK_F8 $ do + justMod $ do + ll <- getLogLevel + let next = if minBound == ll then maxBound else pred ll + + safeSpawnX "notify-send" + ["-t", "2000", printf "LogLevel set to %s" (show next)] + setLogLevel next + logs next "LogLevel set to %s." (show next) + + bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs index 3da70d1..95a65ca 100644 --- a/src/Rahm/Desktop/Logger.hs +++ b/src/Rahm/Desktop/Logger.hs @@ -1,15 +1,16 @@ module Rahm.Desktop.Logger where -import Control.Monad (when) +import Control.Monad (when, forM_, join) import XMonad import qualified XMonad.Util.ExtensibleState as XS import System.IO +import Data.Time.LocalTime (getZonedTime) import Rahm.Desktop.NoPersist import Text.Printf data LogLevel = Trace | Debug | Info | Warn | Error | Fatal - deriving (Show, Read, Ord, Eq, Enum) + deriving (Show, Read, Ord, Eq, Enum, Bounded) newtype LoggerState = LoggerState { @@ -21,28 +22,30 @@ instance ExtensionClass LoggerState where extensionType = PersistentExtension class (PrintfType (Printf t)) => LoggerType t where - type EndResult t :: * type Printf t :: * - - gp :: (String -> EndResult t) -> Printf t -> t + gp :: Printf t -> (String -> X ()) -> t instance (PrintfArg a, LoggerType b) => LoggerType (a -> b) where - type EndResult (a -> b) = EndResult b type Printf (a -> b) = a -> Printf b - - gp f g a = gp f (g a) + gp g f a = gp (g a) f instance (a ~ ()) => LoggerType (X a) where - type EndResult (X a) = X () type Printf (X a) = String + gp str fn = fn str - gp fn str = fn str +getLogLevel :: X LogLevel +getLogLevel = logLevel <$> XS.get -logs :: (LoggerType r, EndResult r ~ X ()) => LogLevel -> String -> r -logs ll fmt = gp (\s -> do - LoggerState ll' <- XS.get - when (ll >= ll') $ - io $ putStrLn ("[" ++ show ll ++ "] " ++ s)) (printf fmt) +setLogLevel :: LogLevel -> X () +setLogLevel ll = do + XS.put $ LoggerState ll + join $ asks (logHook . config) -test :: X () -test = logs Info "Test %s" +logs :: (LoggerType r) => LogLevel -> String -> r +logs ll fmt = gp (printf fmt) $ \ss -> do + LoggerState ll' <- XS.get + io $ do + zoneTime <- getZonedTime + when (ll >= ll') $ + forM_ (lines ss) $ \s -> + putStrLn (printf "[%s %s] - %s" (take 23 $ show zoneTime) (show ll) s) diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index d0dcc4f..6ec4ac7 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -13,6 +13,7 @@ import XMonad.Util.Run (spawnPipe) import XMonad (X) import Rahm.Desktop.Workspaces (getPopulatedWorkspaces, WorkspaceState(..)) import Text.Printf +import Rahm.Desktop.Logger import qualified XMonad as X import qualified XMonad.StackSet as S @@ -38,28 +39,33 @@ xMobarLogHook :: XMobarLog -> X () xMobarLogHook (XMobarLog xmproc) = do (_, _, layoutXpm) <- drawLayout + loglevel <- getLogLevel + winset <- X.gets X.windowset title <- maybe (pure "") (fmap show . getName) . S.peek $ winset let wss = getPopulatedWorkspaces winset - X.liftIO $ do - hPutStrLn xmproc $ trunc 80 $ execWriter $ do - tell " " - tell layoutXpm - tell $ " " + let log = trunc 80 $ execWriter $ do + tell " " + tell layoutXpm + tell $ " " + tell $ logLevelToXMobar loglevel + + forM_ wss $ \(t, ws) -> do + case t of + Current -> tell "" + Visible -> tell "" + Hidden -> tell "" - forM_ wss $ \(t, ws) -> do - case t of - Current -> tell "" - Visible -> tell "" - Hidden -> tell "" + tell $ toAction $ S.tag ws + tell " " - tell $ toAction $ S.tag ws - tell " " + tell $ " " + tell $ title + tell $ "" - tell $ " " - tell $ title - tell $ "" + logs Trace "XMobar: %s" log + X.io $ hPutStrLn xmproc log where toAction [ch] | (ch >= 'A' && ch <= 'Z') || @@ -68,6 +74,13 @@ xMobarLogHook (XMobarLog xmproc) = do printf "%s" [ch] [ch] [ch] toAction ch = ch + logLevelToXMobar Trace = "[Trace] " + logLevelToXMobar Debug = "[Debug] " + logLevelToXMobar Warn = "[Warn] " + logLevelToXMobar Error = "[Error] " + logLevelToXMobar Fatal = "[Fatal] " + logLevelToXMobar _ = "" + -- Truncate an XMobar string to the provided number of _visible_ characters. -- This is to keep long window titles from overrunning the whole bar. trunc :: Int -> String -> String -- cgit From 32a394483e5d8f571b27a70f9a7156cae1ed6180 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 22 Apr 2022 18:03:27 -0600 Subject: Run hlint --- src/Rahm/Desktop/Common.hs | 2 +- src/Rahm/Desktop/Keys.hs | 10 +++++----- src/Rahm/Desktop/Keys/Dsl.hs | 6 +++--- src/Rahm/Desktop/Layout/Draw.hs | 4 ++-- src/Rahm/Desktop/Marking.hs | 7 +++---- src/Rahm/Desktop/XMobarLog.hs | 15 ++++++++------- 6 files changed, 22 insertions(+), 22 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 9187edf..6d86c0e 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -75,7 +75,7 @@ askWindowId = do runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId windowJump :: X () -windowJump = (mapM_ (focus . head)) =<< askWindowId +windowJump = mapM_ (focus . head) =<< askWindowId -- Temporarily set the border color of the given windows. withBorderColor :: String -> [Window] -> X a -> X a diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index d0305b3..728db52 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -187,7 +187,7 @@ keymap = runKeys $ do bind xK_F7 $ justMod $ - doc "Print this documentation." $ + doc "Print this documentation." (logs Info "%s" (documentation (keymap config)) :: X ()) bind xK_F10 $ do @@ -223,7 +223,7 @@ keymap = runKeys $ do doc ("Move the current window to screne " ++ show idx) $ withScreen W.shift idx - altgrMod $ + altgrMod (logs Info "Test altgr" :: X ()) bind xK_bracketright $ do @@ -519,7 +519,7 @@ keymap = runKeys $ do doc "Go to the prior window in the history" historyBack bind xK_t $ do - (justMod -|- noMod) $ (logs Info "Test Log" :: X ()) + (justMod -|- noMod) (logs Info "Test Log" :: X ()) -- bind xK_n $ do -- (justMod -|- noMod) $ @@ -612,7 +612,7 @@ keymap = runKeys $ do ["-t", "2000", printf "LogLevel set to %s" (show next)] setLogLevel next logs next "LogLevel set to %s." (show next) - + bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" @@ -859,7 +859,7 @@ windowSpecificBindings config = do bind xK_F2 $ -- Experimental. - noMod $ (logs Info "This is a test" :: X ()) + noMod (logs Info "This is a test" :: X ()) -- Add a binding to xev as a test. configureIf (title =? "Event Tester") $ diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs index 2c596fc..55912f8 100644 --- a/src/Rahm/Desktop/Keys/Dsl.hs +++ b/src/Rahm/Desktop/Keys/Dsl.hs @@ -455,7 +455,7 @@ documentation = execWriter . document' "" where 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) $ + when (not (null doc) || hasSubmap thing) $ tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc case thing of Action _ -> return () @@ -467,7 +467,7 @@ documentation = execWriter . document' "" keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)]) keyBindingsToList b = - fmap (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) $ + (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) prettyShow :: (KeyMask, KeySym) -> String @@ -490,7 +490,7 @@ documentation = execWriter . document' "" concatMap ((++"-") . snd) $ filter ((/=0) . (.&.mask) . fst) masks - group :: (Ord b) => (a -> b) -> [a] -> (Map b [a]) + group :: (Ord b) => (a -> b) -> [a] -> Map b [a] group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index 8380e98..165af75 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, -ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-} + module Rahm.Desktop.Layout.Draw (drawLayout) where import Control.Monad diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 1ea9782..3b4873d 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -14,7 +14,7 @@ module Rahm.Desktop.Marking ( import Prelude hiding (head) -import Data.Maybe (fromMaybe) +import Data.Maybe ( fromMaybe, catMaybes ) import Control.Monad.Trans (lift) import Data.Ord (Down(..)) import Control.Exception @@ -25,7 +25,6 @@ import Data.IORef import Data.List (sortOn, sort, sortBy, find) import Data.List.Safe (head) import Data.Map (Map) -import Data.Maybe (catMaybes) import Data.Sequence (Seq(..)) import Rahm.Desktop.Common import Rahm.Desktop.History @@ -76,7 +75,7 @@ getAlternateWorkspace window = Map.lookup window . alternateWorkspaces <$> XS.get setAlternateWindows :: [Window] -> X () -setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) +setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) getAlternateWindows :: X [Window] getAlternateWindows = alternateWindows <$> XS.get @@ -94,7 +93,7 @@ markAllLocations mark locs = markCurrentWindow :: Mark -> X () markCurrentWindow mark = do ws <- getCurrentWorkspace - + withFocused $ \win -> XS.modify $ \state@MarkState {markStateMap = ms} -> state { diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 6ec4ac7..629e021 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -6,6 +6,7 @@ import Control.Monad.Writer (tell, execWriter) import Data.List (sortBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Rahm.Desktop.Layout.Draw (drawLayout) import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) import XMonad.Util.NamedWindows (getName) @@ -48,7 +49,7 @@ xMobarLogHook (XMobarLog xmproc) = do let log = trunc 80 $ execWriter $ do tell " " tell layoutXpm - tell $ " " + tell " " tell $ logLevelToXMobar loglevel forM_ wss $ \(t, ws) -> do @@ -60,17 +61,17 @@ xMobarLogHook (XMobarLog xmproc) = do tell $ toAction $ S.tag ws tell " " - tell $ " " - tell $ title - tell $ "" + tell " " + tell title + tell "" logs Trace "XMobar: %s" log X.io $ hPutStrLn xmproc log where - toAction [ch] | (ch >= 'A' && ch <= 'Z') || - (ch >= 'a' && ch <= 'z') || - (ch >= '0' && ch <= '9') = + toAction [ch] | (isAsciiUpper ch) || + (isAsciiLower ch) || + (isDigit ch) = printf "%s" [ch] [ch] [ch] toAction ch = ch -- cgit From 72414e1732064079719b1f1021dc4badce654903 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 24 Apr 2022 20:34:51 -0600 Subject: Add R.D.StackSet as a replacement for StackSet. --- src/Rahm/Desktop/Common.hs | 31 +++++++++++------- src/Rahm/Desktop/History.hs | 2 +- src/Rahm/Desktop/Hooks/WindowChange.hs | 2 +- src/Rahm/Desktop/Keys.hs | 51 +++++++++++++++++------------ src/Rahm/Desktop/Keys/Wml.hs | 2 +- src/Rahm/Desktop/Layout.hs | 2 +- src/Rahm/Desktop/Layout/ConsistentMosaic.hs | 2 +- src/Rahm/Desktop/Layout/CornerLayout.hs | 2 +- src/Rahm/Desktop/Layout/Draw.hs | 2 +- src/Rahm/Desktop/Layout/Hole.hs | 2 +- src/Rahm/Desktop/Layout/List.hs | 2 +- src/Rahm/Desktop/Layout/Pop.hs | 2 +- src/Rahm/Desktop/Layout/Redescribe.hs | 2 +- src/Rahm/Desktop/Marking.hs | 2 +- src/Rahm/Desktop/ScreenRotate.hs | 2 +- src/Rahm/Desktop/StackSet.hs | 51 +++++++++++++++++++++++++++++ src/Rahm/Desktop/SwapMaster.hs | 2 +- src/Rahm/Desktop/Windows.hs | 2 +- src/Rahm/Desktop/Workspaces.hs | 27 +-------------- src/Rahm/Desktop/XMobarLog.hs | 15 ++++++--- 20 files changed, 127 insertions(+), 78 deletions(-) create mode 100644 src/Rahm/Desktop/StackSet.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 6d86c0e..273984e 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -4,7 +4,6 @@ import Prelude hiding ((!!)) import Control.Monad (void, when, forM_) import Control.Monad.Trans.Maybe -import XMonad.Actions.DynamicWorkspaces import XMonad.Util.Run import XMonad.Prompt import XMonad.Prompt.Input @@ -19,12 +18,11 @@ import Data.List.Safe ((!!)) import Data.Maybe import Text.Printf import XMonad hiding (workspaces, Screen) -import XMonad.StackSet hiding (filter, focus) import qualified Data.Map as Map import Rahm.Desktop.DMenu import Data.Ord (comparing) -import qualified XMonad.StackSet as S +import qualified Rahm.Desktop.StackSet as S import Rahm.Desktop.Windows -- A location is a workspace and maybe a window with that workspace. @@ -70,7 +68,7 @@ getString = runQuery $ do askWindowId :: X (Maybe [Window]) askWindowId = do windowTitlesToWinId <- withWindowSet $ \ss -> - Map.fromListWith (++) <$> mapM (\wid -> (,) <$> getString wid <*> return [wid]) (allWindows ss) + Map.fromListWith (++) <$> mapM (\wid -> (,) <$> getString wid <*> return [wid]) (S.allWindows ss) runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId @@ -103,15 +101,26 @@ withBorderColor color wins fn = do return ret +withBorderWidth :: Int -> [Window] -> X a -> X a +withBorderWidth width ws fn = do + d <- asks display + + forM_ ws $ \window -> + io $ setWindowBorderWidth d window $ fromIntegral width + + ret <- fn + + forM_ ws $ \window -> + io $ setWindowBorderWidth d window 2 + + return ret + gotoWorkspace :: WorkspaceId -> X () -gotoWorkspace wid = do - addHiddenWorkspace wid - windows $ S.greedyView wid +gotoWorkspace wid = windows $ S.greedyView wid moveLocationToWorkspace :: Location -> WorkspaceId -> X () -moveLocationToWorkspace (Location _ (Just win)) wid = do - addHiddenWorkspace wid - windows $ shiftWin wid win +moveLocationToWorkspace (Location _ (Just win)) wid = + windows $ S.shiftWin wid win moveLocationToWorkspace _ _ = return () getCurrentWorkspace :: X WorkspaceId @@ -122,7 +131,7 @@ getCurrentWorkspace = withWindowSet $ getCurrentLocation :: X Location getCurrentLocation = do ws <- getCurrentWorkspace - win <- withWindowSet (return . peek) + win <- withWindowSet (return . S.peek) return (Location ws win) runMaybeT_ :: (Monad m) => MaybeT m a -> m () diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs index 9195a92..516cd94 100644 --- a/src/Rahm/Desktop/History.hs +++ b/src/Rahm/Desktop/History.hs @@ -2,7 +2,7 @@ module Rahm.Desktop.History where import XMonad import Text.Printf -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Default diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs index ec8e445..3bc66a4 100644 --- a/src/Rahm/Desktop/Hooks/WindowChange.hs +++ b/src/Rahm/Desktop/Hooks/WindowChange.hs @@ -6,7 +6,7 @@ import qualified XMonad.Util.ExtensibleState as XS import Data.Default import Rahm.Desktop.Common -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W newtype LastLocation = LastLocation (Maybe Location) deriving (Read, Show) diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 728db52..a8b05a4 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -37,9 +37,9 @@ import XMonad.Util.CustomKeys import XMonad.Util.Run (safeSpawn) import XMonad.Util.Scratchpad import XMonad.Util.Ungrab +import Prettyprinter import qualified Data.Map as Map -import qualified XMonad.StackSet as W import Rahm.Desktop.DMenu import Rahm.Desktop.Keys.Dsl @@ -64,6 +64,7 @@ import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) import Rahm.Desktop.Windows import Rahm.Desktop.Workspaces +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.History type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -280,11 +281,11 @@ keymap = runKeys $ do runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace shiftMod $ - doc "Move the currently focused window to another workspace" $ + doc "Swap a workspace with another workspace." $ runMaybeT_ $ do - ws <- readNextWorkspace - loc <- lift getCurrentLocation - lift $ moveLocationToWorkspaceFn ws loc + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace + lift $ windows $ W.swapWorkspaces (workspaceName ws1) (workspaceName ws2) controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ @@ -366,12 +367,14 @@ keymap = runKeys $ do justMod $ doc "Mark the current window with the next typed character." $ do locs <- fromMaybe [] <$> runMaybeT readNextLocationSet - withBorderColor "#00ffff" (mapMaybe locationWindow locs) $ do - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> markAllLocations str locs - _ -> return () + let wins = mapMaybe locationWindow locs + withBorderWidth 4 wins $ + withBorderColor "#00ffff" wins $ do + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> markAllLocations str locs + _ -> return () bind xK_plus $ do justMod $ @@ -407,17 +410,18 @@ keymap = runKeys $ do locations <- fromMaybe [] <$> runMaybeT readNextLocationSet let locationWindows = mapMaybe locationWindow locations - withBorderColor "#00ffff" locationWindows $ do - runMaybeT_ $ do - workspace <- readNextWorkspace - mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + withBorderWidth 4 locationWindows $ + withBorderColor "#00ffff" locationWindows $ do + runMaybeT_ $ do + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations - lift $ setAlternateWindows locationWindows - forM_ locations $ \loc -> - case locationWindow loc of - Nothing -> return () - Just win -> do - lift $ setAlternateWorkspace win (locationWorkspace loc) + lift $ setAlternateWindows locationWindows + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" @@ -613,6 +617,11 @@ keymap = runKeys $ do setLogLevel next logs next "LogLevel set to %s." (show next) + shiftMod $ do + ss <- withWindowSet return + logs Info "Current Stack Set:%s" + (show $ viaShow $ W.mapLayout (const ()) ss) + bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index dd82922..5ce455c 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -31,7 +31,7 @@ import XMonad.Actions.CopyWindow as CopyWindow import XMonad.Util.Run (safeSpawn) import Prelude hiding (head, last) import Data.List.Safe (head, last) -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.Common import Rahm.Desktop.Keys.Dsl diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index f6e714c..ea80ba9 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -36,7 +36,7 @@ import Rahm.Desktop.Layout.Hole import Rahm.Desktop.Layout.ConsistentMosaic import qualified Data.Map as M -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W myLayout = fullscreenFull $ diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs index a84a2f1..0a6215a 100644 --- a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -6,7 +6,7 @@ module Rahm.Desktop.Layout.ConsistentMosaic where import XMonad -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (mapMaybe) diff --git a/src/Rahm/Desktop/Layout/CornerLayout.hs b/src/Rahm/Desktop/Layout/CornerLayout.hs index f0952c7..7cf4421 100644 --- a/src/Rahm/Desktop/Layout/CornerLayout.hs +++ b/src/Rahm/Desktop/Layout/CornerLayout.hs @@ -4,7 +4,7 @@ module Rahm.Desktop.Layout.CornerLayout where import Data.Typeable (Typeable) import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) -import qualified XMonad.StackSet as S +import qualified Rahm.Desktop.StackSet as S data Corner a = Corner Rational Rational deriving (Show, Typeable, Read) diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index 165af75..ff90b9e 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -27,7 +27,7 @@ import XMonad (X, SomeMessage(..)) import qualified XMonad as X -import qualified XMonad.StackSet as S +import qualified Rahm.Desktop.StackSet as S -- Draws and returns an XPM for the current layout. -- diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs index 3f7c9b7..f6632d5 100644 --- a/src/Rahm/Desktop/Layout/Hole.hs +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -3,7 +3,7 @@ -- Delegates to a lower layout, but leaves a hole where the next window will go. module Rahm.Desktop.Layout.Hole (hole, toggleHole) where -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import XMonad import Data.Maybe (mapMaybe) diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs index 77b53c9..d6ab6ba 100644 --- a/src/Rahm/Desktop/Layout/List.hs +++ b/src/Rahm/Desktop/Layout/List.hs @@ -30,7 +30,7 @@ import Data.Proxy import Data.Void import GHC.TypeLits import XMonad -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W -- Type-level lists. LNil is the final of the list. LCons contains a layout and a -- tail. diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index e06ff25..a7e2762 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -15,7 +15,7 @@ module Rahm.Desktop.Layout.Pop ( import XMonad import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) import Data.Default (Default(..)) -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.Layout.ReinterpretMessage diff --git a/src/Rahm/Desktop/Layout/Redescribe.hs b/src/Rahm/Desktop/Layout/Redescribe.hs index 036bc88..7f955d8 100644 --- a/src/Rahm/Desktop/Layout/Redescribe.hs +++ b/src/Rahm/Desktop/Layout/Redescribe.hs @@ -6,7 +6,7 @@ module Rahm.Desktop.Layout.Redescribe where import XMonad -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import Data.Typeable (Typeable) -- Type-class to modify the description of a layout. diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 3b4873d..9bc2cb6 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -35,7 +35,7 @@ import System.Environment import System.FilePath import System.IO import XMonad -import XMonad.StackSet hiding (focus) +import Rahm.Desktop.StackSet hiding (focus) import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified XMonad.Util.ExtensibleState as XS diff --git a/src/Rahm/Desktop/ScreenRotate.hs b/src/Rahm/Desktop/ScreenRotate.hs index 1f238b1..718976d 100644 --- a/src/Rahm/Desktop/ScreenRotate.hs +++ b/src/Rahm/Desktop/ScreenRotate.hs @@ -1,6 +1,6 @@ module Rahm.Desktop.ScreenRotate where -import XMonad.StackSet as W +import Rahm.Desktop.StackSet as W screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd screenRotateBackward (W.StackSet current visible others floating) = do diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs new file mode 100644 index 0000000..251bee3 --- /dev/null +++ b/src/Rahm/Desktop/StackSet.hs @@ -0,0 +1,51 @@ +module Rahm.Desktop.StackSet ( + masterWindow, + findWorkspace, + ensureWorkspace, + swapWorkspaces, + greedyView, + shiftWin, + module W) where + +import Prelude hiding (head, tail) +import Data.List.Safe (head, tail) +import Data.List (find) +import XMonad.StackSet as W hiding (greedyView, shiftWin) +import qualified XMonad.StackSet +import Data.Default +import Data.Maybe (fromMaybe) + +masterWindow :: StackSet i l a s sd -> Maybe a +masterWindow = head . integrate' . stack . workspace . current + +findWorkspace :: (Eq i) => + i -> StackSet i l a s sd -> Maybe (Workspace i l a) +findWorkspace wid = find ((==wid) . tag) . workspaces + +ensureWorkspace :: (Eq i) => + i -> StackSet i l a s sd -> (StackSet i l a s sd, Workspace i l a) +ensureWorkspace t ss = + case findWorkspace t ss of + Nothing -> + let ws = Workspace t (layout . workspace . current $ ss) Nothing in + (ss { hidden = ws : hidden ss }, ws) + Just ws -> (ss, ws) + +swapWorkspaces :: + (Eq i) => + i -> i -> StackSet i l a s sd -> StackSet i l a s sd +swapWorkspaces wid1 wid2 ss = + let (ss', workspace1) = ensureWorkspace wid1 ss + (ss'', workspace2) = ensureWorkspace wid2 ss' + in + mapWorkspace (\w -> + case () of + _ | tag w == wid1 -> workspace2 + _ | tag w == wid2 -> workspace1 + _ -> w) ss'' + +greedyView :: (Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd +greedyView wid ss = swapWorkspaces (tag . workspace . current $ ss) wid ss + +shiftWin :: (Ord a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd +shiftWin wid a = XMonad.StackSet.shiftWin wid a . fst . ensureWorkspace wid diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs index b039fdb..fd61a50 100644 --- a/src/Rahm/Desktop/SwapMaster.hs +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -1,7 +1,7 @@ {- Swap window with the master, but save it. -} module Rahm.Desktop.SwapMaster (swapMaster) where -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.Windows (mapWindows, getMaster, swapWindows) import Control.Monad.Trans.Maybe diff --git a/src/Rahm/Desktop/Windows.hs b/src/Rahm/Desktop/Windows.hs index d525aac..2aa5995 100644 --- a/src/Rahm/Desktop/Windows.hs +++ b/src/Rahm/Desktop/Windows.hs @@ -3,7 +3,7 @@ module Rahm.Desktop.Windows where import XMonad (windowset, X, Window, get) import Control.Applicative ((<|>)) -import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) +import Rahm.Desktop.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) import Data.Maybe (listToMaybe, catMaybes) import qualified Data.Map as Map diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index f11520a..6c52f01 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -6,14 +6,13 @@ import Prelude hiding ((!!)) import Control.Monad.Trans.Maybe import Control.Arrow (second, (&&&)) -import qualified XMonad.StackSet as W +import qualified Rahm.Desktop.StackSet as W import XMonad import Data.List.Safe ((!!)) import Rahm.Desktop.Common import Rahm.Desktop.History -import XMonad.Actions.DynamicWorkspaces import Data.List (sortOn, sort, sortBy, find) import Data.Maybe (mapMaybe, fromMaybe) import Data.Char (isUpper, toUpper, toLower, isAlphaNum) @@ -75,12 +74,6 @@ getHorizontallyOrderedScreens windowSet = where screens = (True, W.current windowSet) : map (False,) (W.visible windowSet) -shiftToWorkspace :: WorkspaceId -> X () -shiftToWorkspace t = do - addHiddenWorkspace t - windows . W.shift $ t - - accompaningWorkspace :: WorkspaceId -> WorkspaceId accompaningWorkspace [s] = return $ if isUpper s @@ -88,24 +81,6 @@ accompaningWorkspace [s] = return $ else toUpper s accompaningWorkspace s = s -swapWorkspace :: WorkspaceId -> X () -swapWorkspace toWorkspace = do - addHiddenWorkspace toWorkspace - windows $ \ss -> do - let fromWorkspace = W.tag $ W.workspace $ W.current ss in - W.StackSet (swapSc fromWorkspace toWorkspace $ W.current ss) - (map (swapSc fromWorkspace toWorkspace) $ W.visible ss) - (map (swapWs fromWorkspace toWorkspace) $ W.hidden ss) - (W.floating ss) - where - swapSc fromWorkspace toWorkspace (W.Screen ws a b) = - W.Screen (swapWs fromWorkspace toWorkspace ws) a b - - swapWs fromWorkspace toWorkspace ws@(W.Workspace t' l s) - | t' == fromWorkspace = W.Workspace toWorkspace l s - | t' == toWorkspace = W.Workspace fromWorkspace l s - | otherwise = ws - adjacentWorkspaceNotVisible :: Selector -> WorkspaceId -> X WorkspaceId adjacentWorkspaceNotVisible (Selector selector) from = withWindowSet $ \ss -> diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 629e021..af0a1a1 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -17,7 +17,7 @@ import Text.Printf import Rahm.Desktop.Logger import qualified XMonad as X -import qualified XMonad.StackSet as S +import qualified Rahm.Desktop.StackSet as S data XMobarLog = XMobarLog Handle @@ -48,7 +48,7 @@ xMobarLogHook (XMobarLog xmproc) = do let log = trunc 80 $ execWriter $ do tell " " - tell layoutXpm + tell (toChangeLayoutAction layoutXpm) tell " " tell $ logLevelToXMobar loglevel @@ -69,12 +69,17 @@ xMobarLogHook (XMobarLog xmproc) = do X.io $ hPutStrLn xmproc log where - toAction [ch] | (isAsciiUpper ch) || - (isAsciiLower ch) || - (isDigit ch) = + toAction [ch] | isAsciiUpper ch || + isAsciiLower ch || + isDigit ch = printf "%s" [ch] [ch] [ch] toAction ch = ch + toChangeLayoutAction :: String -> String + toChangeLayoutAction = + printf "\ + \%s" + logLevelToXMobar Trace = "[Trace] " logLevelToXMobar Debug = "[Debug] " logLevelToXMobar Warn = "[Warn] " -- cgit From 1ff9a98f85df0c3df4e3f1c3f332100922d18317 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 24 Apr 2022 20:47:40 -0600 Subject: Roll ScreenRotate into StackSet --- src/Rahm/Desktop/Keys.hs | 5 ++--- src/Rahm/Desktop/ScreenRotate.hs | 19 ------------------- src/Rahm/Desktop/StackSet.hs | 22 ++++++++++++++++++++-- 3 files changed, 22 insertions(+), 24 deletions(-) delete mode 100644 src/Rahm/Desktop/ScreenRotate.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index a8b05a4..0f61018 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -58,7 +58,6 @@ import Rahm.Desktop.MouseMotion import Rahm.Desktop.PassMenu import Rahm.Desktop.PromptConfig import Rahm.Desktop.RebindKeys -import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) import Rahm.Desktop.Submap import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) @@ -771,8 +770,8 @@ mouseMap = runButtons $ do (button4, windows W.focusUp), (button5, windows W.focusDown), - (button7, windows screenRotateForward), - (button6, windows screenRotateBackward) + (button7, windows W.screenRotateForward), + (button6, windows W.screenRotateBackward) ] forM_ (map fst workspaceButtons) $ \b -> diff --git a/src/Rahm/Desktop/ScreenRotate.hs b/src/Rahm/Desktop/ScreenRotate.hs deleted file mode 100644 index 718976d..0000000 --- a/src/Rahm/Desktop/ScreenRotate.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Rahm.Desktop.ScreenRotate where - -import Rahm.Desktop.StackSet as W - -screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd -screenRotateBackward (W.StackSet current visible others floating) = do - let screens = current : visible - workspaces = tail $ cycle $ map W.workspace screens - (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces - in W.StackSet current' visible' others floating - -screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd -screenRotateForward (W.StackSet current visible others floating) = do - let screens = current : visible - workspaces = rcycle $ map W.workspace screens - (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces - in W.StackSet current' visible' others floating - - where rcycle l = last l : l diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs index 251bee3..8db16c1 100644 --- a/src/Rahm/Desktop/StackSet.hs +++ b/src/Rahm/Desktop/StackSet.hs @@ -5,10 +5,12 @@ module Rahm.Desktop.StackSet ( swapWorkspaces, greedyView, shiftWin, + screenRotateBackward, + screenRotateForward, module W) where -import Prelude hiding (head, tail) -import Data.List.Safe (head, tail) +import Prelude hiding (head) +import Data.List.Safe (head) import Data.List (find) import XMonad.StackSet as W hiding (greedyView, shiftWin) import qualified XMonad.StackSet @@ -49,3 +51,19 @@ greedyView wid ss = swapWorkspaces (tag . workspace . current $ ss) wid ss shiftWin :: (Ord a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd shiftWin wid a = XMonad.StackSet.shiftWin wid a . fst . ensureWorkspace wid + +screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateBackward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = tail $ cycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + +screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateForward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = rcycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + + where rcycle l = last l : l -- cgit From 07252ce0461d8746481881dbcc6ca07b71fd8553 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 24 Apr 2022 21:06:10 -0600 Subject: Roll Windows.hs into R.D.StackSet --- src/Rahm/Desktop/Common.hs | 1 - src/Rahm/Desktop/Keys.hs | 7 +-- src/Rahm/Desktop/Layout.hs | 1 - src/Rahm/Desktop/Layout/ConsistentMosaic.hs | 3 +- src/Rahm/Desktop/Layout/Hole.hs | 3 +- src/Rahm/Desktop/Marking.hs | 1 - src/Rahm/Desktop/StackSet.hs | 70 ++++++++++++++++++++++- src/Rahm/Desktop/SwapMaster.hs | 7 +-- src/Rahm/Desktop/Windows.hs | 86 ----------------------------- 9 files changed, 77 insertions(+), 102 deletions(-) delete mode 100644 src/Rahm/Desktop/Windows.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 273984e..8790d84 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -23,7 +23,6 @@ import Rahm.Desktop.DMenu import Data.Ord (comparing) import qualified Rahm.Desktop.StackSet as S -import Rahm.Desktop.Windows -- A location is a workspace and maybe a window with that workspace. data Location = Location { diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 0f61018..8cb2b76 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -61,7 +61,6 @@ import Rahm.Desktop.RebindKeys import Rahm.Desktop.Submap import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) -import Rahm.Desktop.Windows import Rahm.Desktop.Workspaces import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.History @@ -174,9 +173,9 @@ keymap = runKeys $ do -- focused. It's pretty annoying because it keeps me from doing some cool -- things all for BS security theater, but I guess there might be some way -- to do this via XTest? - shiftMod $ forAllWindows $ \w -> do + shiftMod $ withWindowSet $ mapM_ (\w -> do logs Info "Try send to %s" (show w) - sendKey (0, xK_a) w + sendKey (0, xK_a) w) . W.allWindows justMod $ doc "Print this documentation" @@ -888,7 +887,7 @@ windowBindings :: XConfig l -> XConfig l windowBindings xconfig = xconfig { startupHook = do - forAllWindows (runQuery doQuery) + withWindowSet $ mapM_ (runQuery doQuery) . W.allWindows startupHook xconfig, manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index ea80ba9..ad54d4a 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -26,7 +26,6 @@ import XMonad.Layout.NoBorders (smartBorders, noBorders) import Rahm.Desktop.Layout.CornerLayout (Corner(..)) import Rahm.Desktop.Layout.List -import Rahm.Desktop.Windows import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop import Rahm.Desktop.Layout.Flip diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs index 0a6215a..3dbc44c 100644 --- a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -13,7 +13,6 @@ import Data.Maybe (mapMaybe) import XMonad.Layout.MosaicAlt -import Rahm.Desktop.Windows import Rahm.Desktop.Logger @@ -40,7 +39,7 @@ instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicW runLayout (W.Workspace t (MosaicWrap l) (id -> Just s)) rect = do let zs = zipStack [100..] s - s' = mapStack fst zs + s' = fmap fst zs m = Map.fromList (W.integrate zs) (rects, maybeNewLayout) <- runLayout (W.Workspace t l (Just s')) rect diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs index f6632d5..fe48340 100644 --- a/src/Rahm/Desktop/Layout/Hole.hs +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -3,11 +3,10 @@ -- Delegates to a lower layout, but leaves a hole where the next window will go. module Rahm.Desktop.Layout.Hole (hole, toggleHole) where -import qualified Rahm.Desktop.StackSet as W import XMonad import Data.Maybe (mapMaybe) -import Rahm.Desktop.Windows +import qualified Rahm.Desktop.StackSet as W data Hole (l :: * -> *) (a :: *) = Hole Bool (l a) diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 9bc2cb6..4da2a46 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -29,7 +29,6 @@ import Data.Sequence (Seq(..)) import Rahm.Desktop.Common import Rahm.Desktop.History import Rahm.Desktop.Hooks.WindowChange -import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) import Rahm.Desktop.Workspaces import System.Environment import System.FilePath diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs index 8db16c1..652dafe 100644 --- a/src/Rahm/Desktop/StackSet.hs +++ b/src/Rahm/Desktop/StackSet.hs @@ -7,6 +7,12 @@ module Rahm.Desktop.StackSet ( shiftWin, screenRotateBackward, screenRotateForward, + mapWindows, + swapWindows, + getLocationWorkspace, + WindowLocation(..), + windowMemberOfWorkspace, + findWindow, module W) where import Prelude hiding (head) @@ -15,7 +21,37 @@ import Data.List (find) import XMonad.StackSet as W hiding (greedyView, shiftWin) import qualified XMonad.StackSet import Data.Default -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes, listToMaybe) +import qualified Data.Map as Map + +data WindowLocation i l a s sd = + OnScreen (Screen i l a s sd) | + OnHiddenWorkspace (Workspace i l a) | + Floating + +getLocationWorkspace :: WindowLocation i l a s sd -> Maybe (Workspace i l a) +getLocationWorkspace (OnScreen (Screen w _ _)) = Just w +getLocationWorkspace (OnHiddenWorkspace w) = Just w +getLocationWorkspace _ = Nothing + +mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd +mapWindows fn (StackSet cur vis hid float) = + StackSet + (mapWindowsScreen cur) + (map mapWindowsScreen vis) + (map mapWindowsWorkspace hid) + (Map.mapKeys fn float) + where + mapWindowsScreen (Screen work a b) = Screen (mapWindowsWorkspace work) a b + mapWindowsWorkspace (Workspace t l stack) = + Workspace t l (fmap (fmap fn) stack) + +swapWindows :: (Ord a) => a -> a -> StackSet i l a s d -> StackSet i l a s d +swapWindows wa wb = mapWindows $ \w -> + case w of + _ | w == wa -> wb + _ | w == wb -> wa + _ -> w masterWindow :: StackSet i l a s sd -> Maybe a masterWindow = head . integrate' . stack . workspace . current @@ -67,3 +103,35 @@ screenRotateForward (W.StackSet current visible others floating) = do in W.StackSet current' visible' others floating where rcycle l = last l : l + +{- Finds a Window and returns the screen its on and the workspace its on. + - Returns nothing if the window doesn't exist. + - + - If the window is not a screen Just (Nothing, workspace) is returned. + - If the window is a floating window Just (Nothing, Nothing) is returned. -} +findWindow :: + (Eq a) => StackSet i l a s sd -> a -> Maybe (WindowLocation i l a s sd) +findWindow (StackSet cur vis hid float) win = + listToMaybe . catMaybes $ + map findWindowScreen (cur : vis) ++ + map findWindowWorkspace hid ++ + [findWindowFloat] + + where + findWindowScreen s@(Screen ws _ _) = + if windowMemberOfWorkspace ws win + then Just (OnScreen s) + else Nothing + + findWindowWorkspace w = + if windowMemberOfWorkspace w win + then Just (OnHiddenWorkspace w) + else Nothing + + findWindowFloat = + if win `elem` Map.keys float + then Just Floating + else Nothing + +windowMemberOfWorkspace :: (Eq a) => Workspace i l a -> a -> Bool +windowMemberOfWorkspace (Workspace _ _ s) w = w `elem` integrate' s diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs index fd61a50..96417ed 100644 --- a/src/Rahm/Desktop/SwapMaster.hs +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -3,7 +3,6 @@ module Rahm.Desktop.SwapMaster (swapMaster) where import qualified Rahm.Desktop.StackSet as W -import Rahm.Desktop.Windows (mapWindows, getMaster, swapWindows) import Control.Monad.Trans.Maybe import XMonad (Window, ExtensionClass(..), X(..), windows, windowset) import Control.Monad (void) @@ -28,13 +27,13 @@ swapMaster = void $ runMaybeT $ do ss <- gets windowset focused <- hoist $ W.peek ss - master <- hoist $ getMaster ss + master <- hoist $ W.masterWindow ss if focused == master then do lw <- MaybeT $ lastWindow <$> XS.get - lift $ windows (swapWindows focused lw) - else lift $ windows (swapWindows focused master) + lift $ windows (W.swapWindows focused lw) + else lift $ windows (W.swapWindows focused master) lift $ do XS.put (LastWindow $ Just master) diff --git a/src/Rahm/Desktop/Windows.hs b/src/Rahm/Desktop/Windows.hs deleted file mode 100644 index 2aa5995..0000000 --- a/src/Rahm/Desktop/Windows.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Rahm.Desktop.Windows where - -import XMonad (windowset, X, Window, get) - -import Control.Applicative ((<|>)) -import Rahm.Desktop.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) -import Data.Maybe (listToMaybe, catMaybes) -import qualified Data.Map as Map - -mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd -mapWindows fn (StackSet cur vis hid float) = - StackSet - (mapWindowsScreen cur) - (map mapWindowsScreen vis) - (map mapWindowsWorkspace hid) - (Map.mapKeys fn float) - where - mapWindowsScreen (Screen work a b) = Screen (mapWindowsWorkspace work) a b - mapWindowsWorkspace (Workspace t l stack) = - Workspace t l (fmap (mapStack fn) stack) - --- | What genius decided to hide the instances for the Stack type!!??? -mapStack :: (a -> b) -> Stack a -> Stack b -mapStack fn (Stack focus up down) = Stack (fn focus) (map fn up) (map fn down) - -getMaster :: StackSet i l a s sd -> Maybe a -getMaster (StackSet (Screen (Workspace _ _ ss) _ _) _ _ _) = - head . integrate <$> ss - -swapWindows :: (Ord a) => a -> a -> StackSet i l a s d -> StackSet i l a s d -swapWindows wa wb = mapWindows $ \w -> - case w of - _ | w == wa -> wb - _ | w == wb -> wa - _ -> w - -data WindowLocation i l a s sd = - OnScreen (Screen i l a s sd) | - OnHiddenWorkspace (Workspace i l a) | - Floating - -getLocationWorkspace :: WindowLocation i l a s sd -> Maybe (Workspace i l a) -getLocationWorkspace (OnScreen (Screen w _ _)) = Just w -getLocationWorkspace (OnHiddenWorkspace w) = Just w -getLocationWorkspace _ = Nothing - -workspaceMember :: (Eq a) => Workspace i l a -> a -> Bool -workspaceMember (Workspace _ _ s) w = w `elem` integrate' s - -forAllWindows :: (Window -> X ()) -> X () -forAllWindows fn = do - stackSet <- windowset <$> get - mapM_ fn (allWindows stackSet) - -getFocusedWindow :: X (Maybe Window) -getFocusedWindow = do - peek . windowset <$> get - -{- Finds a Window and returns the screen its on and the workspace its on. - - Returns nothing if the window doesn't exist. - - - - If the window is not a screen Just (Nothing, workspace) is returned. - - If the window is a floating window Just (Nothing, Nothing) is returned. -} -findWindow :: - (Eq a) => StackSet i l a s sd -> a -> Maybe (WindowLocation i l a s sd) -findWindow (StackSet cur vis hid float) win = - listToMaybe . catMaybes $ - map findWindowScreen (cur : vis) ++ - map findWindowWorkspace hid ++ - [findWindowFloat] - - where - findWindowScreen s@(Screen ws _ _) = - if workspaceMember ws win - then Just (OnScreen s) - else Nothing - - findWindowWorkspace w = - if workspaceMember w win - then Just (OnHiddenWorkspace w) - else Nothing - - findWindowFloat = - if win `elem` Map.keys float - then Just Floating - else Nothing -- cgit From 9b60476c272d5a9dd8cce4b811c2da6ee4a203aa Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 24 Apr 2022 21:37:30 -0600 Subject: Add M-S-s to swap windows with eachother --- src/Rahm/Desktop/Keys.hs | 44 +++++++++++++++++++++++++++--------------- src/Rahm/Desktop/StackSet.hs | 11 +++++------ src/Rahm/Desktop/SwapMaster.hs | 4 ++-- 3 files changed, 35 insertions(+), 24 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 8cb2b76..50b7104 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -404,22 +404,34 @@ keymap = runKeys $ do sendMessage rotateLayout bind xK_s $ do - justMod $ do - locations <- fromMaybe [] <$> runMaybeT readNextLocationSet - let locationWindows = mapMaybe locationWindow locations - - withBorderWidth 4 locationWindows $ - withBorderColor "#00ffff" locationWindows $ do - runMaybeT_ $ do - workspace <- readNextWorkspace - mapM_ (lift . moveLocationToWorkspaceFn workspace) locations - - lift $ setAlternateWindows locationWindows - forM_ locations $ \loc -> - case locationWindow loc of - Nothing -> return () - Just win -> do - lift $ setAlternateWorkspace win (locationWorkspace loc) + forM_ [(False, justMod), (True, shiftMod)] $ \(doSwap, f) -> + f $ + doc (if doSwap + then "Swap a windowset with another windowset." + else "Shift a windowset to a workspace") $ do + locations <- fromMaybe [] <$> runMaybeT readNextLocationSet + let locationWindows = mapMaybe locationWindow locations + + withBorderWidth 4 locationWindows $ + withBorderColor "#00ffff" locationWindows $ do + runMaybeT_ $ do + if doSwap + then do + otherWindows <- + lift $ mapMaybe locationWindow . fromMaybe [] <$> + runMaybeT readNextLocationSet + lift $ windows $ + W.swapWindows (zip locationWindows otherWindows) + else do + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + + lift $ setAlternateWindows locationWindows + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs index 652dafe..6b90fab 100644 --- a/src/Rahm/Desktop/StackSet.hs +++ b/src/Rahm/Desktop/StackSet.hs @@ -46,12 +46,11 @@ mapWindows fn (StackSet cur vis hid float) = mapWindowsWorkspace (Workspace t l stack) = Workspace t l (fmap (fmap fn) stack) -swapWindows :: (Ord a) => a -> a -> StackSet i l a s d -> StackSet i l a s d -swapWindows wa wb = mapWindows $ \w -> - case w of - _ | w == wa -> wb - _ | w == wb -> wa - _ -> w +swapWindows :: (Ord a) => [(a, a)] -> StackSet i l a s d -> StackSet i l a s d +swapWindows toSwap = mapWindows $ \w -> + fromMaybe w (Map.lookup w toSwapM) + where + toSwapM = Map.fromList (toSwap ++ map (\(a, b) -> (b, a)) toSwap) masterWindow :: StackSet i l a s sd -> Maybe a masterWindow = head . integrate' . stack . workspace . current diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs index 96417ed..cd47c01 100644 --- a/src/Rahm/Desktop/SwapMaster.hs +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -32,8 +32,8 @@ swapMaster = void $ runMaybeT $ do if focused == master then do lw <- MaybeT $ lastWindow <$> XS.get - lift $ windows (W.swapWindows focused lw) - else lift $ windows (W.swapWindows focused master) + lift $ windows (W.swapWindows [(focused, lw)]) + else lift $ windows (W.swapWindows [(focused, master)]) lift $ do XS.put (LastWindow $ Just master) -- cgit From fcea6ce1371de988deb2dd719263cb2c9c59dfd7 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 28 Apr 2022 18:15:34 -0600 Subject: Add Bordering layout. The bordering layout can add windows along the border of the screen, that way something like videos or something can be shown in the corner of the screen. --- src/Rahm/Desktop/Common.hs | 2 + src/Rahm/Desktop/Keys.hs | 40 ++++++++ src/Rahm/Desktop/Layout.hs | 3 +- src/Rahm/Desktop/Layout/Bordering.hs | 194 +++++++++++++++++++++++++++++++++++ 4 files changed, 238 insertions(+), 1 deletion(-) create mode 100644 src/Rahm/Desktop/Layout/Bordering.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 8790d84..3e6d54c 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -112,6 +112,8 @@ withBorderWidth width ws fn = do forM_ ws $ \window -> io $ setWindowBorderWidth d window 2 + refresh + return ret gotoWorkspace :: WorkspaceId -> X () diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 50b7104..26021bb 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -14,6 +14,7 @@ import Data.List.Safe ((!!)) import Data.Map (Map) import Data.Maybe (isJust, fromMaybe, mapMaybe) import Data.Monoid (Endo(..)) +import Data.Proxy import Debug.Trace import Graphics.X11.ExtraTypes.XF86; import Graphics.X11.ExtraTypes.XorgDefault @@ -44,6 +45,7 @@ import qualified Data.Map as Map import Rahm.Desktop.DMenu import Rahm.Desktop.Keys.Dsl import Rahm.Desktop.Layout +import Rahm.Desktop.Layout.Bordering import Rahm.Desktop.Layout.ConsistentMosaic import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Hole (toggleHole) @@ -294,6 +296,44 @@ keymap = runKeys $ do moveLocationToWorkspaceFn ws loc gotoWorkspaceFn ws + bind xK_n $ do + justMod $ + doc "Banish the current window to the border" $ + withFocused $ sendMessage . toggleBanish + + shiftMod $ + doc "Rotate border windows" $ repeatable $ do + + bind xK_h $ do + + (justMod -|- noMod) $ + withFocused $ sendMessage . moveForward + + shiftMod $ + sendMessage (rotateBorderForward (Proxy :: Proxy Window)) + + bind xK_l $ do + + (justMod -|- noMod) $ + withFocused $ sendMessage . moveBackward + + shiftMod $ + sendMessage (rotateBorderBackward (Proxy :: Proxy Window)) + + bind xK_plus $ do + + (justMod -|- noMod) $ + sendMessage $ + changeWidth Proxy (1/24) <> + changeHeight (Proxy :: Proxy Window) (1/24) + + bind xK_minus $ do + + (justMod -|- noMod) $ + sendMessage $ + changeWidth Proxy (-1/24) <> + changeHeight (Proxy :: Proxy Window) (-1/24) + bind xK_d $ justMod $ doc "Record (define) macros." $ diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index ad54d4a..08bd8d1 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -33,6 +33,7 @@ import Rahm.Desktop.Layout.Rotate import Rahm.Desktop.Layout.Redescribe import Rahm.Desktop.Layout.Hole import Rahm.Desktop.Layout.ConsistentMosaic +import Rahm.Desktop.Layout.Bordering import qualified Data.Map as M import qualified Rahm.Desktop.StackSet as W @@ -45,7 +46,7 @@ mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True mods = - mySpacing . poppable . flippable . rotateable . hole + bordering . mySpacing . poppable . flippable . rotateable . hole myLayoutList = layoutList $ diff --git a/src/Rahm/Desktop/Layout/Bordering.hs b/src/Rahm/Desktop/Layout/Bordering.hs new file mode 100644 index 0000000..0a06319 --- /dev/null +++ b/src/Rahm/Desktop/Layout/Bordering.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DeriveAnyClass #-} +module Rahm.Desktop.Layout.Bordering + (Bordering(..), banishToBorder, unbanish, rotateBorderForward, + rotateBorderBackward, bordering, toggleBanish, + changeWidth, changeHeight, moveForward, moveBackward) where + +import XMonad + +import Control.Monad +import Data.Tuple (swap) +import Control.Arrow +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import Data.List (partition, find) +import qualified Data.Set as Set +import Data.Typeable (cast) +import Data.Proxy (Proxy) + +import Rahm.Desktop.Logger +import qualified Rahm.Desktop.StackSet as W + +data BorderPosition = + North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +data BorderingData a = + BorderingData { + extraWindows :: Map BorderPosition a + , borderingWidth :: Rational + , borderingHeight :: Rational + , borderingPadding :: Int + } deriving (Eq, Ord, Show, Read) + +data Bordering (l :: * -> *) (a :: *) = + Bordering { + borderingData :: BorderingData a, + wrappedLayout :: l a + } deriving (Eq, Ord, Show, Read) + +data ModifyBordering a = + ModifyBordering (BorderingData a -> BorderingData a) + deriving (Message) + +enumNext :: (Eq a, Enum a, Bounded a) => a -> a +enumNext a + | a == maxBound = minBound + | otherwise = succ a + +enumPrev :: (Eq a, Enum a, Bounded a) => a -> a +enumPrev a + | a == minBound = maxBound + | otherwise = pred a + +bordering :: l a -> Bordering l a +bordering = Bordering (BorderingData mempty (1/6) (1/6) 10) + +banishToBorder :: a -> ModifyBordering a +banishToBorder win = + let allPositions = + (\(a, b) -> b ++ a) $ break (==SouthEast) [minBound .. maxBound] + in + ModifyBordering $ \dat -> + maybe + dat + (\pos -> + dat { extraWindows = Map.insert pos win (extraWindows dat)}) $ + find (not . (`Map.member`extraWindows dat)) allPositions + +toggleBanish :: (Eq a) => a -> ModifyBordering a +toggleBanish win = ModifyBordering $ \dat -> + let (ModifyBordering fn) = + if elem win $ Map.elems $ extraWindows dat + then unbanish win + else banishToBorder win + in fn dat + + +unbanish :: (Eq a) => a -> ModifyBordering a +unbanish win = + ModifyBordering $ \dat -> + maybe + dat + (\pos -> dat { extraWindows = Map.delete pos (extraWindows dat) }) $ + (fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat)) + +rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a +rotateBorder next = ModifyBordering $ \dat -> + dat { extraWindows = Map.mapKeys next (extraWindows dat) } + +rotateBorderForward :: Proxy a -> ModifyBordering a +rotateBorderForward _ = rotateBorder enumNext + +rotateBorderBackward :: Proxy a -> ModifyBordering a +rotateBorderBackward _ = rotateBorder enumPrev + +changeWidth :: Proxy a -> Rational -> ModifyBordering a +changeWidth _ amt = ModifyBordering $ \dat -> + dat { borderingWidth = guard $ borderingWidth dat + amt } + where guard x | x < 1/12 = 1/12 + | x > 4/12 = 4/12 + | otherwise = x + +changeHeight :: Proxy a -> Rational -> ModifyBordering a +changeHeight _ amt = ModifyBordering $ \dat -> + dat { borderingHeight = guard $ borderingHeight dat + amt } + where guard x | x < 1/12 = 1/12 + | x > 4/12 = 4/12 + | otherwise = x + +instance Semigroup (ModifyBordering a) where + (<>) = mappend + +instance Monoid (ModifyBordering a) where + + mempty = ModifyBordering id + mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1) + + +move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a +move fn win = ModifyBordering $ \dat -> + let mKey = fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat) in + case mKey of + Nothing -> dat + Just key -> + let newKey = until (\k -> not (Map.member k (extraWindows dat) && k /= key)) + fn (fn key) + wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat + in + dat { extraWindows = wins' } + +moveForward :: (Eq a) => a -> ModifyBordering a +moveForward = move enumNext + +moveBackward :: (Eq a) => a -> ModifyBordering a +moveBackward = move enumPrev + + +instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where + runLayout (W.Workspace t (Bordering dat l) as) rect = do + let (out, rest) = filterStack as + (rects, maybeNewLayout) <- runLayout (W.Workspace t l rest) rect + return (layoutRest out ++ rects, Bordering dat <$> maybeNewLayout) + where + filterStack Nothing = ([], Nothing) + filterStack (Just (W.Stack f h t)) = do + let elSet = Set.fromList (Map.elems $ extraWindows dat) + ((hp, h'), (tp, t')) = dbl (partition (`Set.member`elSet)) (h, t) + in case (Set.member f elSet, h', t', hp ++ tp) of + (False, _, _, r) -> (r, Just $ W.Stack f h' t') + (True, (a:h''), _, r) -> (f:r, Just $ W.Stack a h'' t') + (True, [], (a:t''), r) -> (f:r, Just $ W.Stack a [] t'') + (True, [], [], r) -> (f:r, Nothing) + + layoutRest windows = + map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $ + filter ((`elem`windows) . snd) $ + Map.toList (extraWindows dat) + + padRect (Rectangle x y w h) = + let p :: (Integral a) => a + p = fromIntegral (borderingPadding dat) in + Rectangle (x + p) (y + p) (w - p*2) (h - p*2) + + loc2Rect loc = case loc of + North -> W.RationalRect (1/2 - (bw / 2)) 0 bw bh + NorthEast -> W.RationalRect (1 - bw) 0 bw bh + East -> W.RationalRect (1 - bw) (1/2 - (bh / 2)) bw bh + SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh + South -> W.RationalRect (1/2 - (bw / 2)) (1 - bh) bw bh + SouthWest -> W.RationalRect 0 (1 - bh) bw bh + West -> W.RationalRect 0 (1/2 - (bh / 2)) bw bh + NorthWest -> W.RationalRect 0 0 bw bh + + where + + bw = borderingWidth dat + bh = borderingHeight dat + + dbl f = f *** f + + handleMessage (Bordering d l) m@(fromMessage -> Just e@DestroyWindowEvent {ev_window = w}) = do + maybeNewLayout <- handleMessage l m + return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout) + where + f e@BorderingData{ extraWindows = ws } = + e { extraWindows = Map.filter (maybe True (/=w) . cast) ws } + + handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) = + return (Just $ Bordering (fn d) l) + + handleMessage (Bordering d l) a = do + maybeNewLayout <- handleMessage l a + return (Bordering d <$> maybeNewLayout) -- cgit From 13f2c99387be8217fd48a252057957f6bf6ac230 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 1 May 2022 15:49:35 -0600 Subject: Change WML workspaces to have a Maybe name. --- src/Rahm/Desktop/Keys.hs | 7 +++---- src/Rahm/Desktop/Keys/Wml.hs | 40 +++++++++++++++++++++++++--------------- 2 files changed, 28 insertions(+), 19 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 26021bb..ab72645 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -282,10 +282,9 @@ keymap = runKeys $ do shiftMod $ doc "Swap a workspace with another workspace." $ - runMaybeT_ $ do - ws1 <- readNextWorkspace - ws2 <- readNextWorkspace - lift $ windows $ W.swapWorkspaces (workspaceName ws1) (workspaceName ws2) + runMaybeT_ $ + lift . windows . uncurry W.swapWorkspaces =<< + (,) <$> readNextWorkspaceName <*> readNextWorkspaceName controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 5ce455c..af04e44 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -60,7 +60,7 @@ data Workspace = forall a. (Typeable a) => Workspace { moveLocationToWorkspaceFn :: Location -> X () , gotoWorkspaceFn :: X () - , workspaceName :: String + , workspaceName :: Maybe String , extraWorkspaceData :: a } @@ -90,7 +90,7 @@ justWorkspace s = Workspace { moveLocationToWorkspaceFn = flip moveLocationToWorkspace s , gotoWorkspaceFn = gotoWorkspace s - , workspaceName = s + , workspaceName = Just s , extraWorkspaceData = () } @@ -99,7 +99,7 @@ blackHoleWorkspace = Workspace { moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow , gotoWorkspaceFn = return () -- can't navigate to black hole - , workspaceName = "blackhole" + , workspaceName = Nothing , extraWorkspaceData = () } @@ -122,7 +122,7 @@ alternateWorkspace = Just win -> do mapM_ gotoWorkspace =<< getAlternateWorkspace win - , workspaceName = "@" + , workspaceName = Nothing , extraWorkspaceData = () } @@ -203,24 +203,32 @@ locationSetForKeysT s = feedKeysT s readNextLocationSet locationSetForKeys :: KeyString -> X [Location] locationSetForKeys s = fromMaybe [] <$> runMaybeT (locationSetForKeysT s) +lift1 :: (KeyFeeder m) => (a -> X b) -> (a -> MaybeT m b) +lift1 = fmap (lift . fromX) + +readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId +readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace + -- Returns the next workspaces associated with the next set of keystrokes. readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace readNextWorkspace = readNextKey $ \mask sym str -> case (mask, sym, str) of (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] - (_, _, "[") -> mt $ + (_, _, "[") -> justWorkspace <$> - (adjacentWorkspaceNotVisible prev =<< getCurrentWorkspace) - (_, _, "]") -> mt $ + (lift1 (adjacentWorkspaceNotVisible prev) =<< + readNextWorkspaceName) + (_, _, "]") -> justWorkspace <$> - (adjacentWorkspaceNotVisible next =<< getCurrentWorkspace) - (_, _, "(") -> mt $ + (lift1 (adjacentWorkspaceNotVisible next) =<< + readNextWorkspaceName) + (_, _, "(") -> justWorkspace <$> - (adjacentWorkspace prev =<< getCurrentWorkspace) - (_, _, ")") -> mt $ + (lift1 (adjacentWorkspace prev) =<< readNextWorkspaceName) + (_, _, ")") -> justWorkspace <$> - (adjacentWorkspace next =<< getCurrentWorkspace) + (lift1 (adjacentWorkspace next) =<< readNextWorkspaceName) (_, _, "^") -> mapMaybeT fromX $ MaybeT $ withWindowSet $ \ws -> return $ (fmap (justWorkspace . W.tag . W.workspace . snd) . head) @@ -239,7 +247,7 @@ readNextWorkspace = map (W.tag . W.workspace . snd) <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (_, rest) = break (==workspaceName ws) (screens ++ screens) + let (_, rest) = break ((==workspaceName ws) . Just) (screens ++ screens) justWorkspace <$> MaybeT (return $ head $ tail rest) @@ -250,7 +258,7 @@ readNextWorkspace = map (W.tag . W.workspace . snd) <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (front, _) = break (==workspaceName ws) (screens ++ screens) + let (front, _) = break ((==workspaceName ws) . Just) (screens ++ screens) justWorkspace <$> MaybeT (return $ last front) @@ -261,6 +269,8 @@ readNextWorkspace = loc <- readNextLocationSet MaybeT (return $ justWorkspace . locationWorkspace <$> head loc) + (_, _, "~") -> + justWorkspace . accompaningWorkspace <$> readNextWorkspaceName (_, _, " ") -> mt $ justWorkspace . accompaningWorkspace <$> getCurrentWorkspace (_, _, "_") -> return blackHoleWorkspace @@ -300,7 +310,7 @@ readNextLocationSet = lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret)) return ret (_, _, s) | s == "\t" || s == "@" || s == "\n" -> - (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace + (mt . windowsInWorkspace) =<< readNextWorkspaceName (_, _, "!") -> (:[]) <$> joinMaybe (head <$> readNextLocationSet) (_, _, ",") -> tail <$> readNextLocationSet (_, _, "~") -> reverse <$> readNextLocationSet -- cgit From 69be48b87dbad3fec795236592fdd90f15cbb396 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 8 Jun 2022 10:29:04 -0600 Subject: Change up the override keys for browsers --- src/Rahm/Desktop/Keys.hs | 55 +++++++++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 26 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index ab72645..b57d310 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -839,9 +839,29 @@ windowSpecificBindings config = do w <- lift ask + let mods = permuteMods [shiftMask, controlMask, 0] let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) emitKey = flip sendKey w + configureIf (flip elem (browsers ++ spotify) <$> className) $ do + + bind xK_h $ do + rawMask controlMask $ emitKey (0, xK_BackSpace) + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Left) + + bind xK_t $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Down) + + bind xK_c $ + forM_ mods $ \mask -> + rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) + + bind xK_n $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) + configureIf (flip elem browsers <$> className) $ do -- if the window is a browser, configure these bindings. Lots of browsers @@ -865,25 +885,6 @@ windowSpecificBindings config = do -- Ctrl+d -> Delete current tab. - let mods = permuteMods [shiftMask, controlMask, 0] - - bind xK_h $ do - rawMask controlMask $ emitKey (0, xK_BackSpace) - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Left) - - bind xK_j $ - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Down) - - bind xK_k $ - forM_ mods $ \mask -> - rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) - - bind xK_l $ - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) - bind xK_u $ rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_BackSpace) @@ -891,20 +892,21 @@ windowSpecificBindings config = do rawMask controlMask $ emitKey (controlMask, xK_BackSpace) bind xK_b $ do - rawMask controlMask $ emitKey (controlMask, xK_Left) - rawMask (controlMask .|. shiftMask) $ + rawMask altMask $ emitKey (controlMask, xK_Left) + rawMask (altMask .|. shiftMask) $ emitKey (controlMask .|. shiftMask, xK_Left) bind xK_e $ do - rawMask controlMask $ emitKey (controlMask, xK_Right) - rawMask (controlMask .|. shiftMask) $ + rawMask altMask $ emitKey (controlMask, xK_Right) + rawMask (altMask .|. shiftMask) $ emitKey (controlMask .|. shiftMask, xK_Right) bind xK_dollar $ - rawMask controlMask $ emitKey (0, xK_End) + rawMask altMask $ emitKey (0, xK_End) - bind xK_at $ - rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) + bind xK_at $ do + rawMask (altMask .|. shiftMask) $ emitKey (shiftMask, xK_Home) + rawMask altMask $ emitKey (0, xK_Home) bind xK_d $ rawMask controlMask $ emitKey (controlMask, xK_Tab) @@ -926,6 +928,7 @@ windowSpecificBindings config = do where browsers = ["Google-chrome", "Brave-browser", "firefox-default"] + spotify = ["Spotify"] -- Create a permutation from a list of modifiers. -- -- cgit From 7b91c18a7b6b16fb3f18eafb4ce2657bd155d55d Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 2 Aug 2022 12:23:45 -0600 Subject: Add more Wml adjectives. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These are: '~ws' - Associated workspace, which is the workspace of the toggled case. I.e. workspace ~w == W, or ~. is the toggled case of the current workspace. '=ws₀ws₁ws₂ws₃' ws₂ if name(ws₀) == name(ws₁) otherwise ws₃ while not _that_ helpful for interactive usage, it is useful for programming macros. I.e. to jump to Spotify, unless I'm already on spotify, in which case go back to where I was, I can record this macro on my keyboard: =.s's or a macro to jump back and forth between the current workspace and the associated workspace on the next monitor: =.~,.'~,. --- src/Rahm/Desktop/Keys/Wml.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index af04e44..adb1d9f 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -273,8 +273,27 @@ readNextWorkspace = justWorkspace . accompaningWorkspace <$> readNextWorkspaceName (_, _, " ") -> mt $ justWorkspace . accompaningWorkspace <$> getCurrentWorkspace + (_, _, "~") -> do + ws <- readNextWorkspace + case workspaceName ws of + Just [a] | isAlphaNum a -> + return (justWorkspace $ accompaningWorkspace [a]) + _ -> MaybeT (return Nothing) + (_, _, "_") -> return blackHoleWorkspace (_, _, "-") -> return alternateWorkspace + (_, _, "=") -> do + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace + + ws3 <- readNextWorkspace + ws4 <- readNextWorkspace + + return $ + if workspaceName ws1 == workspaceName ws2 + then ws3 + else ws4 + (mask, keysym, _) -> do macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . workspaceMacros <$> XS.get) fromMaybeTX $ workspaceForKeysT macro -- cgit From b67dbf6462187a9a8346a8d312b46b33e8d74fa3 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 3 Aug 2022 14:00:30 -0600 Subject: Add new conditional description for workspaces. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds the "<" condition, it used as "in" i.e. " do loc <- readNextLocationSet - MaybeT (return $ justWorkspace . locationWorkspace <$> head loc) + MaybeT $ fromX $ withWindowSet $ \ws -> return $ do + win <- locationWindow =<< head loc + winLocation <- W.findWindow ws win + (justWorkspace . W.tag) <$> W.getLocationWorkspace winLocation (_, _, "~") -> justWorkspace . accompaningWorkspace <$> readNextWorkspaceName (_, _, " ") -> mt $ justWorkspace . accompaningWorkspace <$> getCurrentWorkspace - (_, _, "~") -> do - ws <- readNextWorkspace - case workspaceName ws of - Just [a] | isAlphaNum a -> - return (justWorkspace $ accompaningWorkspace [a]) - _ -> MaybeT (return Nothing) (_, _, "_") -> return blackHoleWorkspace (_, _, "-") -> return alternateWorkspace @@ -294,6 +291,28 @@ readNextWorkspace = then ws3 else ws4 + (_, _, "<") -> do + lift . fromX $ + logs Trace "Doing thing" + + l1 <- map locationWindow <$> readNextLocationSet + + lift . fromX $ + logs Trace "%s" (show l1) + + l2 <- map locationWindow <$> readNextLocationSet + + ws1 <- readNextWorkspace + ws2 <- readNextWorkspace + + (lift . fromX) $ (logs Trace "%s < %s? %s" (show l1) (show l2) (show $ all (`elem`l2) l1) :: X ()) + (lift . fromX) $ (logs Trace "%s %s" (show $ workspaceName ws1) (show $ workspaceName ws2)) + + return $ + if all (`elem`l2) l1 + then ws1 + else ws2 + (mask, keysym, _) -> do macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . workspaceMacros <$> XS.get) fromMaybeTX $ workspaceForKeysT macro diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index 4da2a46..f239399 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -9,7 +9,9 @@ module Rahm.Desktop.Marking ( markAllLocations, farLeftWindow, farRightWindow, - windowLocation + windowLocation, + markWindow, + Mark ) where import Prelude hiding (head) @@ -27,6 +29,7 @@ import Data.List.Safe (head) import Data.Map (Map) import Data.Sequence (Seq(..)) import Rahm.Desktop.Common +import Rahm.Desktop.Logger import Rahm.Desktop.History import Rahm.Desktop.Hooks.WindowChange import Rahm.Desktop.Workspaces @@ -83,21 +86,26 @@ withMaybeFocused :: (Maybe Window -> X a) -> X a withMaybeFocused f = withWindowSet $ f . peek markAllLocations :: Mark -> [Location] -> X () -markAllLocations mark locs = +markAllLocations mark locs = do + logs Debug "Marking locations %s as \"%s\"" (show locs) (show mark) + XS.modify $ \m -> m { markStateMap = Map.insert mark locs (markStateMap m) } -markCurrentWindow :: Mark -> X () -markCurrentWindow mark = do +markWindow :: Mark -> Window -> X () +markWindow mark window = do + logs Debug "Marking window %s as \"%s\"" (show window) (show mark) + ws <- getCurrentWorkspace + XS.modify $ \state@MarkState {markStateMap = ms} -> + state { + markStateMap = Map.insertWith (++) mark [Location ws $ Just window] ms + } - withFocused $ \win -> - XS.modify $ \state@MarkState {markStateMap = ms} -> - state { - markStateMap = Map.insertWith (++) mark [Location ws $ Just win] ms - } +markCurrentWindow :: Mark -> X () +markCurrentWindow = withFocused . markWindow jumpToMark :: Mark -> X () jumpToMark mark = do -- cgit From c9159878868bea1fcc7d40d85f09cb29428ba0d5 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 3 Aug 2022 15:27:34 -0600 Subject: Actually, change the workspace conditional operator. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It was ?&s@.'@s This reads as, if (?) the intersection between the Spotify window and the windows on the current workspace (&s@.) is not empty (if spotify is on the current window), go to the last workspace ('), otherwise go to the workspace Spotify is on (@s). --- src/Rahm/Desktop/Keys/Wml.hs | 21 ++++++--------------- 1 file changed, 6 insertions(+), 15 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 647234c..9074b66 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -291,27 +291,18 @@ readNextWorkspace = then ws3 else ws4 - (_, _, "<") -> do - lift . fromX $ - logs Trace "Doing thing" + -- ?&s@.'@s - l1 <- map locationWindow <$> readNextLocationSet - - lift . fromX $ - logs Trace "%s" (show l1) - - l2 <- map locationWindow <$> readNextLocationSet + (_, _, "?") -> do + l1 <- readNextLocationSet ws1 <- readNextWorkspace ws2 <- readNextWorkspace - (lift . fromX) $ (logs Trace "%s < %s? %s" (show l1) (show l2) (show $ all (`elem`l2) l1) :: X ()) - (lift . fromX) $ (logs Trace "%s %s" (show $ workspaceName ws1) (show $ workspaceName ws2)) - return $ - if all (`elem`l2) l1 - then ws1 - else ws2 + if null l1 + then ws2 + else ws1 (mask, keysym, _) -> do macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . workspaceMacros <$> XS.get) -- cgit From 6122cd030e03945382dad927c32a259c077bd468 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 3 Aug 2022 15:49:24 -0600 Subject: Add check for xK_Escape to end trynig ot type a Wml object. --- src/Rahm/Desktop/Keys/Wml.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 9074b66..34dabd2 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -214,6 +214,8 @@ readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace readNextWorkspace = readNextKey $ \mask sym str -> case (mask, sym, str) of + (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing + (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] (_, _, "[") -> justWorkspace <$> @@ -291,14 +293,14 @@ readNextWorkspace = then ws3 else ws4 - -- ?&s@.'@s - (_, _, "?") -> do l1 <- readNextLocationSet ws1 <- readNextWorkspace ws2 <- readNextWorkspace + mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2) + return $ if null l1 then ws2 @@ -315,6 +317,8 @@ readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location] readNextLocationSet = readNextKey $ \mask sym str -> case (mask, sym, str) of + (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing + (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch] (_, _, "0") -> (:[]) <$> MaybeT (fromX getMostRecentLocationInHistory) (_, _, [ch]) | isDigit ch -> -- cgit From 539bbd4045c010bedc785f5859e29b03814b5796 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 3 Aug 2022 16:04:48 -0600 Subject: Add preferred window for some Workspace jumps. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The wml workspace @w refers to the workspace that contains the window marked 'w', however when jumping to that workspace, an arbitrary window is focused. It's more intuitive to set focus to the window 'w'. This means that @• is the same as •. --- src/Rahm/Desktop/Keys/Wml.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 34dabd2..d6289bd 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -94,6 +94,22 @@ justWorkspace s = , extraWorkspaceData = () } +justWorkspaceWithPreferredWindow :: Window -> String -> Workspace +justWorkspaceWithPreferredWindow w s = + Workspace { + moveLocationToWorkspaceFn = flip moveLocationToWorkspace s + , gotoWorkspaceFn = do + windows $ \ws' -> + let ws = W.greedyView s ws' + l = W.integrate' $ W.stack $ W.workspace $ W.current ws in + if w `elem` l + then W.focusWindow w ws + else ws + + , workspaceName = Just s + , extraWorkspaceData = () + } + blackHoleWorkspace :: Workspace blackHoleWorkspace = Workspace { @@ -272,7 +288,7 @@ readNextWorkspace = MaybeT $ fromX $ withWindowSet $ \ws -> return $ do win <- locationWindow =<< head loc winLocation <- W.findWindow ws win - (justWorkspace . W.tag) <$> W.getLocationWorkspace winLocation + (justWorkspaceWithPreferredWindow win . W.tag) <$> W.getLocationWorkspace winLocation (_, _, "~") -> justWorkspace . accompaningWorkspace <$> readNextWorkspaceName -- cgit From ad4024b1c688531fca783736cefcdc79d0a1b411 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 3 Aug 2022 16:18:53 -0600 Subject: Jumping to the black hole workspace will exit Xmonad (with confirmation). --- src/Rahm/Desktop/Keys/Wml.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index d6289bd..7cff173 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -22,6 +22,8 @@ import Control.Monad (join, forM_, unless) import Data.List (sortOn, intercalate) import Data.Ord (Down(..)) import Data.Typeable (cast) +import XMonad.Prompt.ConfirmPrompt (confirmPrompt) +import System.Exit (exitWith, ExitCode(..)) import qualified Data.Map as Map import Data.Map (Map) @@ -114,7 +116,8 @@ blackHoleWorkspace :: Workspace blackHoleWorkspace = Workspace { moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow - , gotoWorkspaceFn = return () -- can't navigate to black hole + , gotoWorkspaceFn = + confirmPrompt def "Do you want to exit xmonad" $ io (exitWith ExitSuccess) , workspaceName = Nothing , extraWorkspaceData = () } -- cgit From 9bd7b8fd7e15ff0a1b1114fb459066ebf90616c0 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 12 Aug 2022 10:08:27 -0600 Subject: Disable swallow by default --- src/Rahm/Desktop/Swallow.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Swallow.hs b/src/Rahm/Desktop/Swallow.hs index 1939c58..a411b3f 100644 --- a/src/Rahm/Desktop/Swallow.hs +++ b/src/Rahm/Desktop/Swallow.hs @@ -26,4 +26,4 @@ toggleSwallowEnabled :: X () toggleSwallowEnabled = (setSwallowEnabled . not) =<< isSwallowEnabled instance ExtensionClass DisableSwallow where - initialValue = DisableSwallow False + initialValue = DisableSwallow True -- cgit From 3c49e047d920c8662b61726460df3eb31df0b146 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 18 Nov 2022 12:17:19 -0700 Subject: Add "Theater" concept. This is the set of the current set of screens and workspaces. It can be saved and restored. In a sense it works like how most other tiling managers handle "workspaces" where one can change all screens at once. Not that it's a superior system to XMonad (it's not), but it's sometimes helpful. --- src/Rahm/Desktop/Keys.hs | 30 ++++++++++++++++++----- src/Rahm/Desktop/Theater.hs | 60 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 84 insertions(+), 6 deletions(-) create mode 100644 src/Rahm/Desktop/Theater.hs (limited to 'src/Rahm') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index b57d310..fb49394 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -64,6 +64,8 @@ import Rahm.Desktop.Submap import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) import Rahm.Desktop.Workspaces +import Rahm.Desktop.Theater + import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.History @@ -281,10 +283,18 @@ keymap = runKeys $ do runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace shiftMod $ - doc "Swap a workspace with another workspace." $ - runMaybeT_ $ - lift . windows . uncurry W.swapWorkspaces =<< - (,) <$> readNextWorkspaceName <*> readNextWorkspaceName + doc "Restore the theater marked with the next typed character." $ + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> restoreTheater [ch] + _ -> return () + + -- shiftMod $ + -- doc "Swap a workspace with another workspace." $ + -- runMaybeT_ $ + -- lift . windows . uncurry W.swapWorkspaces =<< + -- (,) <$> readNextWorkspaceName <*> readNextWorkspaceName controlMod $ doc "Move the current focused window to another workspace and view that workspace" $ @@ -400,12 +410,12 @@ keymap = runKeys $ do doc "For mosaic layout, shrink the size-share of the current window" $ sendMessage =<< shrinkPositionAlt - bind xK_m $ + bind xK_m $ do justMod $ doc "Mark the current window with the next typed character." $ do locs <- fromMaybe [] <$> runMaybeT readNextLocationSet let wins = mapMaybe locationWindow locs - withBorderWidth 4 wins $ + withBorderWidth 2 wins $ withBorderColor "#00ffff" wins $ do runMaybeT_ $ do mapNextString $ \_ str -> lift $ @@ -413,6 +423,14 @@ keymap = runKeys $ do [ch] | isAlpha ch -> markAllLocations str locs _ -> return () + shiftMod $ + doc "Mark the current theater with the next typed character." $ + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> saveCurrentTheater str + _ -> return () + bind xK_plus $ do justMod $ doc "Increase the number of windows in the master region." $ diff --git a/src/Rahm/Desktop/Theater.hs b/src/Rahm/Desktop/Theater.hs new file mode 100644 index 0000000..b0404b7 --- /dev/null +++ b/src/Rahm/Desktop/Theater.hs @@ -0,0 +1,60 @@ +module Rahm.Desktop.Theater where + +-- A "Theater" is a mapping from screen -> workspace. This is used to save the +-- state of the current screen -> workspace and thus restore it. + +-- import XMonad.Operations +import Data.Maybe (fromMaybe) +import Control.Monad (forM_) +import XMonad (X(..)) +import qualified XMonad.StackSet as W +import qualified XMonad as X +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Default +import qualified XMonad.Util.ExtensibleState as XS + +newtype Theater si wi = Theater (Map si wi) + deriving (Read, Show) + +newtype Theaters = Theaters { + theaters :: Map String (Theater X.ScreenId X.WorkspaceId) +} deriving (Read, Show) + +instance Default Theaters where + def = Theaters mempty + +instance X.ExtensionClass Theaters where + initialValue = def + extensionType = X.PersistentExtension + +saveCurrentTheater :: String -> X () +saveCurrentTheater name = + X.withWindowSet $ \windowSet -> + XS.modify $ \(Theaters m) -> + Theaters $ flip (Map.insert name) m $ + Theater $ Map.fromList $ + map (\(W.Screen ws sid _) -> (sid, W.tag ws)) $ W.screens windowSet + +restoreTheater :: String -> X () +restoreTheater name = do + (Theaters theaters) <- XS.get + forM_ (Map.lookup name theaters) $ \(Theater screenToWorkspace) -> + X.windows $ \ws@(W.StackSet cur vis hidden float) -> + let workspacesById = Map.fromList $ map (\ws -> (W.tag ws, ws)) (W.workspaces ws) + + newScreenWorkspace scr = + fromMaybe scr $ do + wid <- Map.lookup (W.screen scr) screenToWorkspace + workspace <- Map.lookup wid workspacesById + return $ scr { W.workspace = workspace } + + newScreens = map newScreenWorkspace (cur : vis) + newVisibleWorkspaces = map (W.tag . W.workspace) newScreens + newHiddenWorkspaces = + filter (\ws -> not (W.tag ws `elem` newVisibleWorkspaces)) $ + W.workspaces ws + + (newCur:newVisible) = newScreens + in + W.StackSet newCur newVisible newHiddenWorkspaces float -- cgit