From a652c330707e2e9bbe963e01af79ce730cf3452e Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 10 Apr 2022 13:26:16 -0600 Subject: Rename Internal to Rahm.Desktop --- src/Internal/CornerLayout.hs | 58 --- src/Internal/DMenu.hs | 45 --- src/Internal/Hash.hs | 11 - src/Internal/Keys.hs | 820 ------------------------------------------- src/Internal/KeysM.hs | 497 -------------------------- src/Internal/Layout.hs | 326 ----------------- src/Internal/LayoutDraw.hs | 155 -------- src/Internal/LayoutList.hs | 297 ---------------- src/Internal/Lib.hs | 160 --------- src/Internal/Logger.hs | 32 -- src/Internal/Marking.hs | 204 ----------- src/Internal/MouseMotion.hs | 97 ----- src/Internal/NoPersist.hs | 23 -- src/Internal/PassMenu.hs | 13 - src/Internal/PromptConfig.hs | 12 - src/Internal/RebindKeys.hs | 119 ------- src/Internal/ScreenRotate.hs | 19 - src/Internal/Submap.hs | 104 ------ src/Internal/Swallow.hs | 29 -- src/Internal/SwapMaster.hs | 41 --- src/Internal/Windows.hs | 86 ----- src/Internal/XMobarLog.hs | 78 ---- 22 files changed, 3226 deletions(-) delete mode 100644 src/Internal/CornerLayout.hs delete mode 100644 src/Internal/DMenu.hs delete mode 100644 src/Internal/Hash.hs delete mode 100644 src/Internal/Keys.hs delete mode 100644 src/Internal/KeysM.hs delete mode 100644 src/Internal/Layout.hs delete mode 100644 src/Internal/LayoutDraw.hs delete mode 100644 src/Internal/LayoutList.hs delete mode 100644 src/Internal/Lib.hs delete mode 100644 src/Internal/Logger.hs delete mode 100644 src/Internal/Marking.hs delete mode 100644 src/Internal/MouseMotion.hs delete mode 100644 src/Internal/NoPersist.hs delete mode 100644 src/Internal/PassMenu.hs delete mode 100644 src/Internal/PromptConfig.hs delete mode 100644 src/Internal/RebindKeys.hs delete mode 100644 src/Internal/ScreenRotate.hs delete mode 100644 src/Internal/Submap.hs delete mode 100644 src/Internal/Swallow.hs delete mode 100644 src/Internal/SwapMaster.hs delete mode 100644 src/Internal/Windows.hs delete mode 100644 src/Internal/XMobarLog.hs (limited to 'src/Internal') diff --git a/src/Internal/CornerLayout.hs b/src/Internal/CornerLayout.hs deleted file mode 100644 index 5545aef..0000000 --- a/src/Internal/CornerLayout.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} --- Creates a layout, the "corner layout" that keeps the master window in the --- corner and the other windows go around it. -module Internal.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/Internal/DMenu.hs b/src/Internal/DMenu.hs deleted file mode 100644 index 0d22b55..0000000 --- a/src/Internal/DMenu.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Internal.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/Internal/Hash.hs b/src/Internal/Hash.hs deleted file mode 100644 index 272808b..0000000 --- a/src/Internal/Hash.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Internal.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/Internal/Keys.hs b/src/Internal/Keys.hs deleted file mode 100644 index ad9d719..0000000 --- a/src/Internal/Keys.hs +++ /dev/null @@ -1,820 +0,0 @@ -{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} -module Internal.Keys (applyKeys) where - -import XMonad.Util.Run (safeSpawn) -import Data.Monoid (Endo(..)) -import Control.Monad.Trans.Class -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.Loops (iterateWhile) -import Control.Monad.Fix (fix) -import Graphics.X11.ExtraTypes.XF86; -import Internal.KeysM -import Internal.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 Internal.Layout -import Internal.Marking -import Internal.PromptConfig -import System.IO -import Text.Printf -import XMonad -import Internal.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 Internal.LayoutList -import Internal.MouseMotion -import Internal.Windows -import Internal.Lib -import Internal.DMenu -import Internal.PassMenu -import Internal.Logger -import Internal.RebindKeys -import Internal.Swallow -import Internal.ScreenRotate (screenRotateForward, screenRotateBackward) - -type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) -type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) - - -spawnX :: String -> X () -spawnX = spawn - -noWindow :: b -> Window -> b -noWindow = const - -decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%" -increaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ +5%" -playPause = spawnX "spotify-control play" -mediaPrev = spawnX "spotify-control prev" -mediaNext = spawnX "spotify-control next" - -decreaseVolumeDoc = doc "Decrease volume" decreaseVolume -increaseVolumeDoc = doc "Increase volume" increaseVolume -playPauseDoc = doc "Play/Pause current media" playPause -mediaPrevDoc = doc "Previous media" mediaPrev -mediaNextDoc = doc "Next media" mediaNext - - -button6 :: Button -button6 = 6 - -button7 :: Button -button7 = 7 - -button8 :: Button -button8 = 8 - -button9 :: Button -button9 = 9 - -button10 :: Button -button10 = 10 - -button11 :: Button -button11 = 11 - -button12 :: Button -button12 = 12 - -button13 :: Button -button13 = 13 - -button14 :: Button -button14 = 14 - -button15 :: Button -button15 = 15 - -keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l -keyBindingToKeymap bindings config = fmap bindingToX (bindings config) - - where - bindingToX b = - case b of - Documented _ (Action x) -> x - Documented _ (Submap mapping) -> - submap (fmap bindingToX mapping) - Documented _ (Repeat mapping) -> - fix $ \recur -> - submap (fmap (\b -> bindingToX b >> recur) mapping) - -keymap :: XConfig l -> KeyBindings -keymap = runKeys $ do - config <- getConfig - - let subkeys keysM = Submap (runKeys keysM config) - repeatable keysM = Repeat (runKeys keysM config) - - bind xK_apostrophe $ do - justMod $ - doc "Jumps between marks." $ - mapNextString $ \_ str -> - case str of - ['\''] -> jumpToLast - [ch] | isAlphaNum ch -> jumpToMark ch - "[" -> historyPrev - "]" -> historyNext - _ -> return () - - shiftMod $ - doc "Swap the current window with a mark." $ - mapNextString $ \_ str -> - case str of - ['\''] -> swapWithLastMark - [ch] | isAlphaNum ch -> swapWithMark ch - _ -> return () - - bind xK_BackSpace $ do - -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if - -- something goes wrong with the keyboard layout and for first-time boots - -- where dmenu/alacritty may not be installed. - rawMask mod4Mask $ - doc "Spawns XTerm as a fallback if xkb is messed up." $ - spawnX "xterm" - - -- Moves xmobar to different monitors. - justMod $ - doc "Move XMobar to another screen." $ - spawnX "pkill -SIGUSR1 xmobar" - - bind xK_F1 $ do - -- Experimental. Sends 'a' to all windows. - -- - -- I've discovered that many clients ignore such synthetic events, including - -- Spotify, Chrome and Gedit. Some, like Chrome, seem to honor them if it's - -- focused. It's pretty annoying because it keeps me from doing some cool - -- things all for BS security theater, but I guess there might be some way - -- to do this via XTest? - shiftMod $ forAllWindows $ \w -> do - logs $ "Try send to " ++ show w - sendKey (0, xK_a) w - - justMod $ - doc "Print this documentation" - (safeSpawn "gxmessage" [ - "-fn", "Source Code Pro", - documentation (keymap config)] :: X ()) - - bind xK_F7 $ - - justMod $ - doc "Print this documentation." $ - logs (documentation (keymap config)) - - bind xK_F10 $ do - justMod playPauseDoc - - bind xK_F11 $ do - justMod mediaPrevDoc - - bind xK_F12 $ do - justMod mediaNextDoc - - bind xK_Return $ do - justMod swapMaster - - bind xK_Tab $ do - justMod $ windows W.focusDown - shiftMod $ windows W.focusUp - - -- Switch between different screens. These are the leftmost keys on the home - -- row in a Dvorak layout. One might want to switch these to ASD for QWERTY. - forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) -> - bind key $ do - -- Move focus to that screen. - justMod $ - doc ("Switch focus to screen " ++ show idx) $ - withScreen W.view idx - -- Swap the current screen with the one given - altMod $ - doc ("Swap the current screen with screen " ++ show idx) $ - withScreen W.greedyView idx - -- Move the current window to the select screen. - shiftMod $ - doc ("Move the current window to screne " ++ show idx) $ - withScreen W.shift idx - - altgrMod $ - logs "Test altgr" - - bind xK_bracketright $ do - justMod $ - doc "Increase the gaps between windows." $ - sendMessage $ modifyWindowBorder 5 - - bind xK_bracketleft $ do - justMod $ - doc "Decrease the gaps between windows." $ - sendMessage $ modifyWindowBorder (-5) - - bind xK_b $ do - justMod $ spawnX "bluetooth-select.sh" - - bind xK_c $ do - justMod $ - doc "Run PassMenu" runPassMenu - - shiftMod $ - doc "Kill the current window" CopyWindow.kill1 - - bind xK_f $ do - justMod $ - doc "Flip the current layout vertically" $ - sendMessage FlipLayout - shiftMod $ - doc "Flip the current layout horizontally" $ - sendMessage HFlipLayout - - bind xK_g $ do - justMod $ - doc "Goto a workspace\n\n\t\ - - \If the second character typed is alpha-numberic, jump to that\n\t\ - \workspace. The workspace is created on-the-fly if such a workspace\n\t\ - \does not exist.\n\n\t\ - - \If the second character typed is:\n\t\t\ - \]: go to the next workspace\n\t\t\ - \[: go to the previous workspace\n\t\t\ - \}: cycle the workspaces on the screens to the right\n\t\t\ - \{: cycle the workspaces on the screens to the left\n\t\t\ - \: Jump to the accompaning workspace.\n\t\t\ - \F1: display this help.\n" $ - mapNextStringWithKeysym $ \_ keysym str -> - case (keysym, str) of - (_, [ch]) | isAlphaNum ch -> gotoWorkspace ch - (_, "]") -> pushHistory $ withRelativeWorkspace next W.greedyView - (_, "[") -> pushHistory $ withRelativeWorkspace prev W.greedyView - (_, "}") -> windows screenRotateForward - (_, "{") -> windows screenRotateBackward - (_, " ") -> gotoAccompaningWorkspace - - -- Test binding. Tests that I can still submap keysyms alone (keys - -- where XLookupString won't return anything helpful.) - (f, _) | f == xK_F1 -> - (safeSpawn "gxmessage" [ - "-fn", "Source Code Pro", - documentation (keymap config)] :: X ()) - - _ -> return () - shiftMod $ - doc "Move the currently focused window to another workspace" $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> shiftToWorkspace ch - "]" -> withRelativeWorkspace next W.shift - "[" -> withRelativeWorkspace prev W.shift - _ -> return () - shiftAltMod $ - doc "Swap this workspace with another workspace (rename)." $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> swapWorkspace ch - _ -> return () - - bind xK_h $ do - justMod $ - doc "Focus on the next window down in the stack" $ - windows W.focusDown - - shiftMod $ - doc "Swap the current window with the next one down in the stack" $ - windows W.swapDown - - controlMod $ - doc "Rotate all the windows down the stack" - rotAllDown - - bind xK_j $ do - justMod $ - doc "Shrink the size of the zoom region" $ - sendMessage ShrinkZoom - - shiftMod $ - doc "Go to the previous window in history." historyPrev - - bind xK_k $ do - justMod $ - doc "Expand the size of the zoom region" $ - sendMessage ExpandZoom - - shiftMod $ - doc "Go to the next window in history." historyNext - - bind xK_l $ do - justMod $ - doc "Focus the next window in the stack" $ - windows W.focusUp - - shiftMod $ - doc "Swap the currently focused window with the next window in the stack." $ - windows W.swapUp - - controlMod $ - doc "Rotate the windows up." - rotAllUp - - altMod $ - doc "Lock the screen" $ - spawnX "xsecurelock" - - bind xK_minus $ do - justMod $ - doc "Decrease the number of windows in the master region." $ - sendMessage (IncMasterN (-1)) - - shiftMod $ - doc "For mosaic layout, shrink the size-share of the current window" $ - withFocused $ sendMessage . shrinkWindowAlt - - bind xK_m $ do - justMod $ - doc "Mark the current window with the next typed character." $ - mapNextString $ \_ str -> - case str of - [ch] | isAlphaNum ch -> markCurrentWindow ch - _ -> return () - - bind xK_n $ do - justMod $ - doc "Shift to the next workspace." $ - withRelativeWorkspace next W.greedyView - - bind xK_p $ do - justMod $ - doc "Shift to the previous workspace." $ - withRelativeWorkspace prev W.greedyView - - bind xK_plus $ do - justMod $ - doc "Increase the number of windows in the master region." $ - sendMessage (IncMasterN 1) - - shiftMod $ - doc "For mosaic layout, increase the size-share of the current window." $ - withFocused $ sendMessage . expandWindowAlt - - bind xK_q $ do - shiftMod $ - doc "Recompile and restart XMonad" $ - spawnX "xmonad --recompile && xmonad --restart" - - justMod $ - doc "Experimental Bindings" $ - subkeys $ do - - bind xK_q $ - (justMod -|- noMod) $ - doc "EXPERIMENTAL: Move mouse to control media." $ - mouseRotateMotion (logs "CW") (logs "CCW") - - bind xK_r $ do - justMod $ doc "Run a command via Rofi" runDMenu - shiftMod $ - doc "Rotate the current layout. (flips x, y coordinates)" $ - sendMessage DoRotate - - bind xK_s $ do - altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" - - bind xK_space $ do - justMod $ - doc "Use the next layout in the layout list." $ sendMessage toNextLayout - - altMod $ - doc "Reset the layout to the default layout." $ sendMessage toFirstLayout - - shiftMod $ - doc "Use the previous layout in the layout list." $ - sendMessage toPreviousLayout - - bind xK_t $ do - justMod $ - doc "Spawn a terminal." $ spawnX (terminal config) - - shiftMod $ - doc "Sink the current window into the tiling." $ withFocused $ windows . W.sink - - altMod $ - doc "Spawn a floating terminal" $ spawnX (terminal config ++ " -t Floating\\ Term") - - bind xK_v $ - -- Allows repeated strokes of M-h and M-l to reduce and increase volume - -- respectively. - justMod $ - doc "Changes the volume." $ - repeatable $ do - bind xK_h $ - justMod $ - doc "Decrease volume." - decreaseVolumeDoc - - bind xK_l $ - justMod $ - doc "Increase volume." - increaseVolumeDoc - - bind xK_v $ - justMod (return () :: X ()) - - bind xK_w $ do - justMod $ doc "Jump to a window (via rofi)" windowJump - - bind xK_x $ do - justMod $ - doc "Toggles respect for struts." $ - sendMessage ToggleStruts - - bind xK_z $ do - - justMod $ - doc "Less often used keybindings." $ - subkeys $ do - - bind xK_g $ do - (justMod -|- noMod) $ - doc "Copy a window to the given workspace" $ - mapNextString $ \_ s -> - case s of - [ch] | isAlphaNum ch -> windows (CopyWindow.copy s) - _ -> return () - - bind xK_p $ do - (justMod -|- noMod) $ - doc "Go to the prior window in the history" historyPrev - - bind xK_t $ do - (justMod -|- noMod) $ logs "Test Log" - - -- bind xK_n $ do - -- (justMod -|- noMod) $ - -- doc "Take a note" $ - -- spawnX (terminal config ++ " -t Notes -e notes new") - bind xK_n $ do - (justMod -|- noMod) $ - doc "Go to the next window in the history" historyNext - - bind xK_c $ do - shiftMod $ - doc "Kill all other copies of a window." - CopyWindow.killAllOtherCopies - - bind xK_e $ do - (justMod -|- noMod) $ - doc "Select an emoji" $ - spawnX "emoji-select.sh" - - (shiftMod -|- rawMask shiftMask) $ - doc "Select an emoticon" $ - spawnX "emoticon-select.sh" - - bind xK_a $ - (justMod -|- noMod) $ - doc "Move the audio sink for an application." $ - spawnX "set-sink.sh" - - bind xK_w $ - (justMod -|- noMod) $ - doc "Select a network to connect to." $ - spawnX "networkmanager_dmenu" - - bind xK_o $ - (justMod -|- noMod) $ - doc "Open a file from the library" $ - spawnX "library-view.sh" - - bind xK_s $ - (justMod -|- noMod) $ - doc "Toggle the ability for terminals to swallow child windows." - toggleSwallowEnabled - - bind xK_v $ do - (justMod -|- noMod) $ - doc "Set the volume via rofi." $ - spawnX "set-volume.sh" - (shiftMod -|- rawMask shiftMask) $ - doc "Set the volume of an application via rofi." $ - spawnX "set-volume.sh -a" - - -- Double-tap Z to toggle zoom. - bind xK_z $ do - noMod -|- justMod $ - doc "Toggle zoom on the current window." $ - sendMessage ToggleZoom - - -- Z is reserved to create sub keybindings to do various things. - -- I don't really use these at the moment. - bind xK_h $ noMod mediaPrevDoc - bind xK_j $ noMod playPauseDoc - bind xK_l $ noMod mediaNextDoc - - -- Centers the current focused window. i.e. toggles the Zoom layout - -- modifier. - shiftMod $ - doc "Toggle zoom on the current window." $ - sendMessage ToggleZoom - - bind xF86XK_Calculator $ do - noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" - - bind xF86XK_AudioLowerVolume $ do - noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%" - justMod mediaPrevDoc - - bind xF86XK_AudioRaiseVolume $ do - noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ +1%" - justMod mediaNextDoc - - bind xF86XK_AudioMute $ do - noMod $ spawnX "pactl set-sink-mute @DEFAULT_SINK@ toggle" - - bind xF86XK_AudioPlay $ do - noMod playPauseDoc - - bind xF86XK_AudioNext $ do - noMod mediaNextDoc - - bind xF86XK_AudioPrev $ do - noMod mediaPrevDoc - - bind xF86XK_AudioPrev $ do - noMod mediaPrevDoc - - bind xF86XK_MonBrightnessUp $ do - noMod $ spawnX "set-backlight.sh +0.05" - justMod $ spawnX "set-backlight.sh 1" - - bind xF86XK_MonBrightnessDown $ do - noMod $ spawnX "set-backlight.sh -0.05" - justMod $ spawnX "set-backlight.sh 0.01" - rawMask shiftMask $ spawnX "set-backlight.sh 0" - -mouseMap :: ButtonsMap l -mouseMap = runButtons $ do - config <- getConfig - - let x button = Map.lookup button (mouseMap config) - - let defaultButtons button = fromMaybe (\w -> return ()) $ - Map.lookup button (mouseMap config) - subMouse = submapButtonsWithKey defaultButtons . flip runButtons config - - - let continuous :: [(Button, X ())] -> Button -> Window -> X () - continuous actions button w = do - case find ((==button) . fst) actions of - Just (_, action) -> action - Nothing -> return () - - (subMouse $ - forM_ (map fst actions) $ \b -> - bind b $ noMod $ \w -> continuous actions b w) w - - bind button1 $ do - justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster - - bind button2 $ do - justMod $ windows . (W.shiftMaster .) . W.focusWindow - - bind button3 $ do - justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster - - bind button6 $ - justMod $ noWindow (withRelativeWorkspace prev W.greedyView) - - bind button7 $ - justMod $ noWindow (withRelativeWorkspace next W.greedyView) - - bind button8 $ - justMod $ noWindow mediaPrev - - bind button9 $ - justMod $ noWindow mediaNext - - bind button14 $ do - noMod $ subMouse $ do - - bind button3 $ - noMod $ noWindow (gotoWorkspace 's') - - bind button13 $ do - noMod $ noWindow $ click >> CopyWindow.kill1 - - bind button14 $ do - noMod $ noWindow $ click >> sendMessage ToggleZoom - - bind button15 $ do - noMod $ noWindow $ spawnX "pavucontrol" - - let mediaButtons = [ - (button4, increaseVolume), - (button5, decreaseVolume), - (button2, playPause), - (button9, historyNext), - (button8, historyPrev), - (button6, mediaPrev), - (button7, mediaNext) - ] - - forM_ (map fst mediaButtons) $ \b -> - bind b $ noMod $ continuous mediaButtons b - - bind button13 $ noMod $ subMouse $ do - bind button1 $ noMod mouseMoveWindow - bind button2 $ noMod $ windows . W.sink - bind button3 $ noMod mouseResizeWindow - - bind button13 $ noMod $ subMouse $ do - bind button13 $ noMod $ subMouse $ do - bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" - bind button1 $ noMod $ noWindow $ - spawnX "sudo -A systemctl suspend && xsecurelock" - - bind button15 $ do - - noMod $ subMouse $ do - bind button13 $ noMod $ noWindow gotoAccompaningWorkspace - - bind button15 $ do - noMod $ noWindow jumpToLast - - - let workspaceButtons = [ - (button2, swapMaster), - - (button9, withRelativeWorkspace next W.greedyView), - (button8, withRelativeWorkspace prev W.greedyView), - - (button4, windows W.focusUp), - (button5, windows W.focusDown), - - (button7, windows screenRotateForward), - (button6, windows screenRotateBackward) - ] - - forM_ (map fst workspaceButtons) $ \b -> - bind b $ noMod $ continuous workspaceButtons b - --- Bindings specific to a window. These are set similarly to th ekeymap above, --- but uses a Query monad to tell which windows the keys will apply to. --- --- This is useful to create hotkeys in applications where hot keys are not --- configurable, or to remove keybindings that are irritating (looking at you, --- ctrl+w in Chrome!!). -windowSpecificBindings :: - XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () -windowSpecificBindings config = do - - w <- lift ask - - let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) - emitKey = flip sendKey w - - configureIf (flip elem browsers <$> className) $ do - - -- if the window is a browser, configure these bindings. Lots of browsers - -- make up their own garbage bindings that are not standard across many - -- other applications. This alleviates the issue. - -- - -- Consistency with terminal: - -- - -- Ctrl+h is backspace - -- Ctrl+w is ctrl+backspace - -- Ctrl+u is ctrl+shift+backspace - -- - -- Consistency with Vim/Emacs-ish: - -- - -- Alt+{Shift,Ctrl,}+{h,j,k,l} -> {Shift,Ctrl,}+{Left,Down,Up,Right} - -- Ctrl+b -> Ctrl+Left - -- Ctrl+e -> Ctrl+Right - -- Ctrl+$ -> End - -- Ctrl+^ -> Home - -- - -- Ctrl+d -> Delete current tab. - - - let mods = permuteMods [shiftMask, controlMask, 0] - - bind xK_h $ do - rawMask controlMask $ emitKey (0, xK_BackSpace) - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Left) - - bind xK_j $ - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Down) - - bind xK_k $ - forM_ mods $ \mask -> - rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) - - bind xK_l $ - forM_ mods $ \mask -> - rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) - - bind xK_u $ - rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_BackSpace) - - bind xK_w $ - rawMask controlMask $ emitKey (controlMask, xK_BackSpace) - - bind xK_b $ do - rawMask controlMask $ emitKey (controlMask, xK_Left) - rawMask (controlMask .|. shiftMask) $ - emitKey (controlMask .|. shiftMask, xK_Left) - - bind xK_e $ do - rawMask controlMask $ emitKey (controlMask, xK_Right) - rawMask (controlMask .|. shiftMask) $ - emitKey (controlMask .|. shiftMask, xK_Right) - - bind xK_dollar $ - rawMask controlMask $ emitKey (0, xK_End) - - bind xK_at $ - rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) - - bind xK_d $ - rawMask controlMask $ emitKey (controlMask, xK_w) - - bind xK_F2 $ - -- Experimental. - noMod $ logs "This is a test" - - -- Add a binding to xev as a test. - configureIf (title =? "Event Tester") $ - bind xK_F2 $ - noMod $ emitKey (controlMask, xK_F2) - - where - browsers = ["Google-chrome", "Brave-browser", "firefox-default"] - - -- Create a permutation from a list of modifiers. - -- - -- i.e. permuteMods [C, S, M] will return - -- - -- [C, S, M, C + M, C + S, M + S, C + S + M, 0] - permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False]) - -windowBindings :: XConfig l -> XConfig l -windowBindings xconfig = - xconfig { - startupHook = do - forAllWindows (runQuery doQuery) - startupHook xconfig, - - manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig - } - - where - doQuery :: Query () - doQuery = do - map <- execWriterT $ windowSpecificBindings xconfig - w <- ask - - liftX $ logs $ printf "For Window: %s" (show w) - forM_ (Map.toList map) $ \(key, action) -> do - liftX $ logs $ printf " -- remap: %s" (show key) - remapKey key action - -applyKeys :: XConfig l -> IO (XConfig l) -applyKeys config = - return $ windowBindings $ config { keys = keyBindingToKeymap keymap, mouseBindings = mouseMap } - -click :: X () -click = do - (dpy, root) <- asks $ (,) <$> display <*> theRoot - (_, _, window, _, _, _, _, _) <- io $ queryPointer dpy root - focus window - -modifyWindowBorder :: Integer -> SpacingModifier -modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> - Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) - - where clip i | i < 0 = 0 - clip i = i diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs deleted file mode 100644 index e490b89..0000000 --- a/src/Internal/KeysM.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses, - FunctionalDependencies, FlexibleInstances, TypeFamilies, FlexibleContexts #-} -module Internal.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/Internal/Layout.hs b/src/Internal/Layout.hs deleted file mode 100644 index 229e958..0000000 --- a/src/Internal/Layout.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-} -module Internal.Layout where - -import GHC.TypeLits - -import Data.Proxy (Proxy(..)) -import Internal.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 Internal.LayoutList -import Internal.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/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs deleted file mode 100644 index a105c98..0000000 --- a/src/Internal/LayoutDraw.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, -ScopedTypeVariables, BangPatterns #-} -module Internal.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 Internal.Hash (quickHash) -import Internal.Layout (ZoomModifier(..)) -import System.Directory (createDirectoryIfMissing, doesFileExist) -import System.FilePath (()) -import Text.Printf (printf) -import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) - -import XMonad (X, - Rectangle(..), - Dimension, - LayoutClass, - Message, - Window, - SomeMessage(..)) - -import qualified XMonad as X -import qualified XMonad.StackSet as S - --- Draws and returns an XPM for the current layout. --- --- Returns --- - Bool - true if the xpm has already been written, and is thus cached. --- - String - description of the current layout --- - String - the text to send to XMobar --- --- This function actually runs the current layout's doLayout function to --- generate the XPM, so it's completely portable to all layouts. --- --- Note this function is impure and running the layout to create the XPM is also --- impure. While in-practice most layouts are pure, it should be kept in mind. -drawLayout :: X (Bool, String, String) -drawLayout = do - winset <- X.gets X.windowset - let layout = S.layout $ S.workspace $ S.current winset - - -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout [ - handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' Unzoom - ] - - (cached, xpm) <- drawXpmIO layout' - - return (cached , X.description layout, printf "" xpm) - --- Returns true if a point is inside a rectangle (inclusive). -pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool -pointInRect (x, y) (Rectangle x' y' w h) = - x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' - where - fi :: (Integral a, Num b) => a -> b - fi = fromIntegral - --- Scale factory. Scaling the rectangles before writing the XPM helps to reduce --- noise from things like AvoidStruts, as there is unfortunately no way to force --- avoid struts to be off, one can only toggle it. -sf :: (Integral a) => a -sf = 1024 - -handleMessage' :: - (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) -handleMessage' message layout = do - fromMaybe layout <$> X.handleMessage layout (SomeMessage message) - --- Creates the XPM for the given layout and returns the path to it. --- --- This function does run doLayout on the given layout, and that should be --- accounted for. -drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) -drawXpmIO l = do - dir <- X.getXMonadDir - - let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. - - let (w, h) = (56, 24) - let descr = X.description l - let iconCacheDir = dir "icons" "cache" - let iconPath = iconCacheDir (quickHash descr ++ ".xpm") - - let colors = [ - "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", - "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] - - (rects', _) <- - X.runLayout - (S.Workspace "0" l (S.differentiate [1 .. 5])) - (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) - - let rects = flip map rects' $ \(_, Rectangle x y w h) -> - Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) - - X.liftIO $ do - exists <- doesFileExist iconPath - createDirectoryIfMissing True iconCacheDir - - unless exists $ do - let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 - writeFile iconPath xpmText - - return (exists, iconPath) - --- --- Create's an XPM, purely. Returns a string with the XPM contents. --- Takes as arguments --- --- - dimensions of the icon. --- - list of (color, rectangle) pairs. --- - The amount to shrink the windows by for those pretty gaps. --- -drawXpm :: - (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String -drawXpm (w, h) rects' shrinkAmt = execWriter $ do - tell "/* XPM */\n" - tell "static char *out[] = {\n" - tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) - - let zipRects = zip ['A' .. 'Z'] rects - - forM_ zipRects $ \(char, (color, _)) -> do - tell $ printf "\"%c c %s\",\n" char color - tell "\"% c None\"a,\n" - - forM_ [0 .. h - 1] $ \y -> do - tell "\"" - forM_ [0 .. w - 1] $ \x -> - (case find (matches x y) zipRects of - Nothing -> tell "%" - Just (chr, _) -> tell [chr]) - tell "\"" - when (y /= h - 1 - shrinkAmt) (tell ",") - tell "\n" - tell "};\n" - - where - matches x y (_, (_, r)) = pointInRect (x, y) r - rects = map (second (shrink shrinkAmt)) rects' - guard a b = if a <= shrinkAmt then 1 else b - shrink amt (Rectangle x y w h) = - Rectangle - x - y - (guard w $ w - fromIntegral amt) - (guard h $ h - fromIntegral amt) diff --git a/src/Internal/LayoutList.hs b/src/Internal/LayoutList.hs deleted file mode 100644 index 2405f71..0000000 --- a/src/Internal/LayoutList.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes, FlexibleInsta