diff options
Diffstat (limited to 'src/Rahm/Desktop')
| -rw-r--r-- | src/Rahm/Desktop/CornerLayout.hs | 58 | ||||
| -rw-r--r-- | src/Rahm/Desktop/DMenu.hs | 45 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Hash.hs | 11 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 820 | ||||
| -rw-r--r-- | src/Rahm/Desktop/KeysM.hs | 497 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Layout.hs | 326 | ||||
| -rw-r--r-- | src/Rahm/Desktop/LayoutDraw.hs | 155 | ||||
| -rw-r--r-- | src/Rahm/Desktop/LayoutList.hs | 297 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Lib.hs | 160 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Logger.hs | 32 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Marking.hs | 204 | ||||
| -rw-r--r-- | src/Rahm/Desktop/MouseMotion.hs | 97 | ||||
| -rw-r--r-- | src/Rahm/Desktop/NoPersist.hs | 23 | ||||
| -rw-r--r-- | src/Rahm/Desktop/PassMenu.hs | 13 | ||||
| -rw-r--r-- | src/Rahm/Desktop/PromptConfig.hs | 12 | ||||
| -rw-r--r-- | src/Rahm/Desktop/RebindKeys.hs | 119 | ||||
| -rw-r--r-- | src/Rahm/Desktop/ScreenRotate.hs | 19 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Submap.hs | 104 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Swallow.hs | 29 | ||||
| -rw-r--r-- | src/Rahm/Desktop/SwapMaster.hs | 41 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Windows.hs | 86 | ||||
| -rw-r--r-- | src/Rahm/Desktop/XMobarLog.hs | 78 |
22 files changed, 3226 insertions, 0 deletions
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\ + \<space>: 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 "<icon=%s/>" 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 $ "<fc=#404040> │ </fc>" + + forM_ wss $ \(t, ws) -> do + case t of + Current -> tell "<fn=1><fc=#ff8888>" + Visible -> tell "<fn=6><fc=#8888ff>" + Hidden -> tell "<fn=2><fc=#888888>" + tell (S.tag ws) + tell " </fc></fn>" + + tell $ "<fc=#404040>│ </fc><fc=#a0a0a0><fn=3>" + tell $ title + tell $ "</fn></fc>" + +-- 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) |