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 ---- src/Main.hs | 18 +- src/Rahm/Desktop/CornerLayout.hs | 58 +++ src/Rahm/Desktop/DMenu.hs | 45 +++ src/Rahm/Desktop/Hash.hs | 11 + src/Rahm/Desktop/Keys.hs | 820 +++++++++++++++++++++++++++++++++++++++ src/Rahm/Desktop/KeysM.hs | 497 ++++++++++++++++++++++++ src/Rahm/Desktop/Layout.hs | 326 ++++++++++++++++ src/Rahm/Desktop/LayoutDraw.hs | 155 ++++++++ src/Rahm/Desktop/LayoutList.hs | 297 ++++++++++++++ src/Rahm/Desktop/Lib.hs | 160 ++++++++ src/Rahm/Desktop/Logger.hs | 32 ++ src/Rahm/Desktop/Marking.hs | 204 ++++++++++ src/Rahm/Desktop/MouseMotion.hs | 97 +++++ src/Rahm/Desktop/NoPersist.hs | 23 ++ src/Rahm/Desktop/PassMenu.hs | 13 + src/Rahm/Desktop/PromptConfig.hs | 12 + src/Rahm/Desktop/RebindKeys.hs | 119 ++++++ src/Rahm/Desktop/ScreenRotate.hs | 19 + src/Rahm/Desktop/Submap.hs | 104 +++++ src/Rahm/Desktop/Swallow.hs | 29 ++ src/Rahm/Desktop/SwapMaster.hs | 41 ++ src/Rahm/Desktop/Windows.hs | 86 ++++ src/Rahm/Desktop/XMobarLog.hs | 78 ++++ 45 files changed, 3235 insertions(+), 3235 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 create mode 100644 src/Rahm/Desktop/CornerLayout.hs create mode 100644 src/Rahm/Desktop/DMenu.hs create mode 100644 src/Rahm/Desktop/Hash.hs create mode 100644 src/Rahm/Desktop/Keys.hs create mode 100644 src/Rahm/Desktop/KeysM.hs create mode 100644 src/Rahm/Desktop/Layout.hs create mode 100644 src/Rahm/Desktop/LayoutDraw.hs create mode 100644 src/Rahm/Desktop/LayoutList.hs create mode 100644 src/Rahm/Desktop/Lib.hs create mode 100644 src/Rahm/Desktop/Logger.hs create mode 100644 src/Rahm/Desktop/Marking.hs create mode 100644 src/Rahm/Desktop/MouseMotion.hs create mode 100644 src/Rahm/Desktop/NoPersist.hs create mode 100644 src/Rahm/Desktop/PassMenu.hs create mode 100644 src/Rahm/Desktop/PromptConfig.hs create mode 100644 src/Rahm/Desktop/RebindKeys.hs create mode 100644 src/Rahm/Desktop/ScreenRotate.hs create mode 100644 src/Rahm/Desktop/Submap.hs create mode 100644 src/Rahm/Desktop/Swallow.hs create mode 100644 src/Rahm/Desktop/SwapMaster.hs create mode 100644 src/Rahm/Desktop/Windows.hs create mode 100644 src/Rahm/Desktop/XMobarLog.hs (limited to 'src') 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, 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 Internal.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/Internal/Lib.hs b/src/Internal/Lib.hs deleted file mode 100644 index fdbc9a5..0000000 --- a/src/Internal/Lib.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module Internal.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 Internal.PromptConfig - -import Data.Char -import Data.List hiding ((!!)) -import Data.List.Safe ((!!)) -import Data.Maybe -import Internal.Marking -import Text.Printf -import XMonad hiding (workspaces, Screen) -import XMonad.StackSet hiding (filter, focus) -import qualified Data.Map as Map -import Internal.DMenu -import Data.Ord (comparing) - -import qualified XMonad.StackSet as S -import Internal.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/Internal/Logger.hs b/src/Internal/Logger.hs deleted file mode 100644 index e5824a4..0000000 --- a/src/Internal/Logger.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Internal.Logger where - -import XMonad -import qualified XMonad.Util.ExtensibleState as XS -import System.IO - -import Internal.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/Internal/Marking.hs b/src/Internal/Marking.hs deleted file mode 100644 index 3ffb411..0000000 --- a/src/Internal/Marking.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Internal.Marking ( - historyNext, historyPrev, - markCurrentWindow, pushHistory, - jumpToMark, jumpToLast, swapWithLastMark, - swapWithMark - ) where - -import Internal.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/Internal/MouseMotion.hs b/src/Internal/MouseMotion.hs deleted file mode 100644 index c72c824..0000000 --- a/src/Internal/MouseMotion.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE ViewPatterns, BangPatterns #-} -module Internal.MouseMotion where - -import XMonad - -import Control.Monad (void, forever) -import Text.Printf -import Internal.Submap -import Control.Monad.Loops (iterateWhile) -import Control.Monad.Fix (fix) -import Internal.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/Internal/NoPersist.hs b/src/Internal/NoPersist.hs deleted file mode 100644 index a67e649..0000000 --- a/src/Internal/NoPersist.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Module for not persisting XMonad state. To be used with ExtensibleState --- for data types that cannot be persisted. -module Internal.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/Internal/PassMenu.hs b/src/Internal/PassMenu.hs deleted file mode 100644 index 5b031c0..0000000 --- a/src/Internal/PassMenu.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Internal.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/Internal/PromptConfig.hs b/src/Internal/PromptConfig.hs deleted file mode 100644 index 0db3027..0000000 --- a/src/Internal/PromptConfig.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Internal.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/Internal/RebindKeys.hs b/src/Internal/RebindKeys.hs deleted file mode 100644 index 38af754..0000000 --- a/src/Internal/RebindKeys.hs +++ /dev/null @@ -1,119 +0,0 @@ - --- 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 Internal.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 Internal.Logger -import Internal.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/Internal/ScreenRotate.hs b/src/Internal/ScreenRotate.hs deleted file mode 100644 index 8108381..0000000 --- a/src/Internal/ScreenRotate.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Internal.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/Internal/Submap.hs b/src/Internal/Submap.hs deleted file mode 100644 index 0e54c43..0000000 --- a/src/Internal/Submap.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Internal.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/Internal/Swallow.hs b/src/Internal/Swallow.hs deleted file mode 100644 index 3e4112f..0000000 --- a/src/Internal/Swallow.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Internal.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/Internal/SwapMaster.hs b/src/Internal/SwapMaster.hs deleted file mode 100644 index e7ade19..0000000 --- a/src/Internal/SwapMaster.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- Swap window with the master, but save it. -} -module Internal.SwapMaster (swapMaster) where - -import qualified XMonad.StackSet as W - -import Internal.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/Internal/Windows.hs b/src/Internal/Windows.hs deleted file mode 100644 index 35f093c..0000000 --- a/src/Internal/Windows.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Internal.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/Internal/XMobarLog.hs b/src/Internal/XMobarLog.hs deleted file mode 100644 index c0aa2a7..0000000 --- a/src/Internal/XMobarLog.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Internal.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 Internal.LayoutDraw (drawLayout) -import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) -import XMonad.Util.NamedWindows (getName) -import XMonad.Util.Run (spawnPipe) -import XMonad (X) -import Internal.Lib (getPopulatedWorkspaces, WorkspaceState(..)) - -import qualified XMonad as X -import qualified XMonad.StackSet as S - -data XMobarLog = XMobarLog Handle - --- The log hook for XMobar. This is a custom log hook that does not use any --- of the Xmonad dynamic log libraries. --- --- This is because the given dynamic log libraries don't handle unicode properly --- and this has been causing issues. It is also more flexible and frankly easier --- to just DIY. - -spawnXMobar :: IO XMobarLog -spawnXMobar = do - pipe <- spawnPipe "xmobar" - hSetEncoding pipe utf8 - return (XMobarLog pipe) - - --- XMonad Log Hook meant to be used with the XMonad config logHook. -xMobarLogHook :: XMobarLog -> X () -xMobarLogHook (XMobarLog xmproc) = do - (_, _, layoutXpm) <- drawLayout - - winset <- X.gets X.windowset - title <- maybe (pure "") (fmap show . getName) . S.peek $ winset - let wss = getPopulatedWorkspaces winset - - X.liftIO $ do - hPutStrLn xmproc $ trunc 80 $ execWriter $ do - tell layoutXpm - tell $ " │ " - - forM_ wss $ \(t, ws) -> do - case t of - Current -> tell "" - Visible -> tell "" - Hidden -> tell "" - tell (S.tag ws) - tell " " - - tell $ "│ " - tell $ title - tell $ "" - --- Truncate an XMobar string to the provided number of _visible_ characters. --- This is to keep long window titles from overrunning the whole bar. -trunc :: Int -> String -> String -trunc amt str = reverse $ trunc' False amt str [] - where - trunc' _ _ [] acc = acc - trunc' ignore amt (a:as) acc = - case a of - '<' -> trunc' True amt as (a : acc) - '>' -> trunc' False amt as (a : acc) - _ -> - if ignore - then trunc' True amt as (a : acc) - else - case amt of - 0 -> trunc' False 0 as acc - 3 -> trunc' False 0 as ("..." ++ acc) - _ -> trunc' False (amt - 1) as (a : acc) diff --git a/src/Main.hs b/src/Main.hs index 0b4a181..c8cdd19 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,15 +12,15 @@ import System.Environment (setEnv) import Data.Monoid import qualified Data.Map as Map -import Internal.Swallow -import Internal.Windows -import Internal.XMobarLog -import Internal.Keys -import Internal.Layout -import Internal.Logger -import Internal.DMenu (menuCommandString) -import Internal.RebindKeys -import Internal.KeysM +import Rahm.Desktop.Swallow +import Rahm.Desktop.Windows +import Rahm.Desktop.XMobarLog +import Rahm.Desktop.Keys +import Rahm.Desktop.Layout +import Rahm.Desktop.Logger +import Rahm.Desktop.DMenu (menuCommandString) +import Rahm.Desktop.RebindKeys +import Rahm.Desktop.KeysM import qualified XMonad as X import qualified XMonad.StackSet as W diff --git a/src/Rahm/Desktop/CornerLayout.hs b/src/Rahm/Desktop/CornerLayout.hs new file mode 100644 index 0000000..33f439e --- /dev/null +++ b/src/Rahm/Desktop/CornerLayout.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +-- Creates a layout, the "corner layout" that keeps the master window in the +-- corner and the other windows go around it. +module Rahm.Desktop.CornerLayout where + +import Data.Typeable (Typeable) +import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) +import qualified XMonad.StackSet as S + +data Corner a = Corner Rational Rational + deriving (Show, Typeable, Read) + +instance LayoutClass Corner a where + pureLayout (Corner frac _) screen@(Rectangle x y w h) ss = + let w' = floor $ fromIntegral w * frac + h' = floor $ fromIntegral h * frac + corner = Rectangle 0 0 w' h' + vertRect = Rectangle (fromIntegral w') 0 (w - w') h + horizRect = Rectangle 0 (fromIntegral h') w' (h - h') + ws = S.integrate ss + + vn = (length ws - 1) `div` 2 + hn = (length ws - 1) - vn + in + case ws of + [a] -> [(a, screen)] + [a, b] -> [ + (a, Rectangle x y w' h), + (b, Rectangle (x + fromIntegral w') y (w - w') h)] + _ -> + zip ws $ map ( + \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $ + corner : + splitVert vertRect vn ++ + splitHoriz horizRect hn + + pureMessage (Corner frac delta) m = fmap resize (fromMessage m) + where + resize Shrink = Corner (frac - delta) delta + resize Expand = Corner (frac + delta) delta + +splitVert :: Rectangle -> Int -> [Rectangle] +splitVert (Rectangle x y w h) i' = + map + (\i -> Rectangle x (y + fromIntegral (step * i)) w step) + [0 .. i - 1] + where + i = fromIntegral i' + step = h `div` i + +splitHoriz :: Rectangle -> Int -> [Rectangle] +splitHoriz (Rectangle x y w h) i' = + map + (\i -> Rectangle (x + fromIntegral (step * i)) y step h) + [0 .. i - 1] + where + step = w `div` i + i = fromIntegral i' diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs new file mode 100644 index 0000000..62ecdd3 --- /dev/null +++ b/src/Rahm/Desktop/DMenu.hs @@ -0,0 +1,45 @@ +module Rahm.Desktop.DMenu where + +import XMonad.Util.Dmenu +import XMonad +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import XMonad.Util.Run +import Data.List (intercalate) +import Text.Printf (printf) + +data Colors = + Colors { + fg :: String, + bg :: String + } | DefaultColors + +menuCommand :: [String] +menuCommand = ["rofi", "-monitor", "-4", "-dmenu", "-sort", "-levenshtein-sort"] + +menuCommandString :: String +menuCommandString = unwords menuCommand + +runDMenu :: X () +runDMenu = void $ + safeSpawn + "rofi" + ["-monitor", "-4", "-display-run", "Execute", "-show", "run"] + +runDMenuPrompt :: String -> Maybe String -> [String] -> X String +runDMenuPrompt prompt color select = + let realColor = maybe [] (\c -> ["-sb", c, "-nf", c]) color + in + runProcessWithInput "/home/rahm/.local/bin/dmenu_debug.sh" ([ + "-p", prompt, + "-l", "12", + "-dim", "0.4" ] ++ realColor) (intercalate "\n" select) + + +runDMenuPromptWithMap :: String -> Maybe String -> Map String a -> X (Maybe a) +runDMenuPromptWithMap prompt color map = do + let realColor = maybe [] ( + \c -> ["-theme-str", printf "* {theme-color: %s;}" c]) color + menuMapArgs (head menuCommand) + (tail menuCommand ++ ["-p", prompt] ++ realColor) map diff --git a/src/Rahm/Desktop/Hash.hs b/src/Rahm/Desktop/Hash.hs new file mode 100644 index 0000000..dc58d96 --- /dev/null +++ b/src/Rahm/Desktop/Hash.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Rahm.Desktop.Hash where + +import Numeric (showHex) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import qualified Crypto.Hash.SHA1 as SHA1 + +quickHash :: String -> String +quickHash str = + concatMap (`showHex` "") $ BS.unpack (SHA1.hash $ BC.pack str) diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs new file mode 100644 index 0000000..9712f84 --- /dev/null +++ b/src/Rahm/Desktop/Keys.hs @@ -0,0 +1,820 @@ +{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-} +module Rahm.Desktop.Keys (applyKeys) where + +import XMonad.Util.Run (safeSpawn) +import Data.Monoid (Endo(..)) +import Control.Monad.Trans.Class +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Loops (iterateWhile) +import Control.Monad.Fix (fix) +import Graphics.X11.ExtraTypes.XF86; +import Rahm.Desktop.KeysM +import Rahm.Desktop.SwapMaster (swapMaster) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.MosaicAlt +import Graphics.X11.ExtraTypes.XorgDefault +import System.Process +import XMonad.Util.Ungrab +import XMonad.Layout.Spacing +import Data.Maybe (isJust, fromMaybe) +import Debug.Trace +import Control.Applicative +import Prelude hiding ((!!)) +import Control.Monad +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Map (Map) +import Rahm.Desktop.Layout +import Rahm.Desktop.Marking +import Rahm.Desktop.PromptConfig +import System.IO +import Text.Printf +import XMonad +import Rahm.Desktop.Submap +import XMonad.Actions.WindowNavigation +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell +import XMonad.Util.CustomKeys +import XMonad.Util.Scratchpad +import XMonad.Actions.RotSlaves +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Actions.SpawnOn as SpawnOn + +import qualified Data.Map as Map +import qualified XMonad.StackSet as W + +import Rahm.Desktop.LayoutList +import Rahm.Desktop.MouseMotion +import Rahm.Desktop.Windows +import Rahm.Desktop.Lib +import Rahm.Desktop.DMenu +import Rahm.Desktop.PassMenu +import Rahm.Desktop.Logger +import Rahm.Desktop.RebindKeys +import Rahm.Desktop.Swallow +import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) + +type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) +type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) + + +spawnX :: String -> X () +spawnX = spawn + +noWindow :: b -> Window -> b +noWindow = const + +decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%" +increaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ +5%" +playPause = spawnX "spotify-control play" +mediaPrev = spawnX "spotify-control prev" +mediaNext = spawnX "spotify-control next" + +decreaseVolumeDoc = doc "Decrease volume" decreaseVolume +increaseVolumeDoc = doc "Increase volume" increaseVolume +playPauseDoc = doc "Play/Pause current media" playPause +mediaPrevDoc = doc "Previous media" mediaPrev +mediaNextDoc = doc "Next media" mediaNext + + +button6 :: Button +button6 = 6 + +button7 :: Button +button7 = 7 + +button8 :: Button +button8 = 8 + +button9 :: Button +button9 = 9 + +button10 :: Button +button10 = 10 + +button11 :: Button +button11 = 11 + +button12 :: Button +button12 = 12 + +button13 :: Button +button13 = 13 + +button14 :: Button +button14 = 14 + +button15 :: Button +button15 = 15 + +keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l +keyBindingToKeymap bindings config = fmap bindingToX (bindings config) + + where + bindingToX b = + case b of + Documented _ (Action x) -> x + Documented _ (Submap mapping) -> + submap (fmap bindingToX mapping) + Documented _ (Repeat mapping) -> + fix $ \recur -> + submap (fmap (\b -> bindingToX b >> recur) mapping) + +keymap :: XConfig l -> KeyBindings +keymap = runKeys $ do + config <- getConfig + + let subkeys keysM = Submap (runKeys keysM config) + repeatable keysM = Repeat (runKeys keysM config) + + bind xK_apostrophe $ do + justMod $ + doc "Jumps between marks." $ + mapNextString $ \_ str -> + case str of + ['\''] -> jumpToLast + [ch] | isAlphaNum ch -> jumpToMark ch + "[" -> historyPrev + "]" -> historyNext + _ -> return () + + shiftMod $ + doc "Swap the current window with a mark." $ + mapNextString $ \_ str -> + case str of + ['\''] -> swapWithLastMark + [ch] | isAlphaNum ch -> swapWithMark ch + _ -> return () + + bind xK_BackSpace $ do + -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if + -- something goes wrong with the keyboard layout and for first-time boots + -- where dmenu/alacritty may not be installed. + rawMask mod4Mask $ + doc "Spawns XTerm as a fallback if xkb is messed up." $ + spawnX "xterm" + + -- Moves xmobar to different monitors. + justMod $ + doc "Move XMobar to another screen." $ + spawnX "pkill -SIGUSR1 xmobar" + + bind xK_F1 $ do + -- Experimental. Sends 'a' to all windows. + -- + -- I've discovered that many clients ignore such synthetic events, including + -- Spotify, Chrome and Gedit. Some, like Chrome, seem to honor them if it's + -- focused. It's pretty annoying because it keeps me from doing some cool + -- things all for BS security theater, but I guess there might be some way + -- to do this via XTest? + shiftMod $ forAllWindows $ \w -> do + logs $ "Try send to " ++ show w + sendKey (0, xK_a) w + + justMod $ + doc "Print this documentation" + (safeSpawn "gxmessage" [ + "-fn", "Source Code Pro", + documentation (keymap config)] :: X ()) + + bind xK_F7 $ + + justMod $ + doc "Print this documentation." $ + logs (documentation (keymap config)) + + bind xK_F10 $ do + justMod playPauseDoc + + bind xK_F11 $ do + justMod mediaPrevDoc + + bind xK_F12 $ do + justMod mediaNextDoc + + bind xK_Return $ do + justMod swapMaster + + bind xK_Tab $ do + justMod $ windows W.focusDown + shiftMod $ windows W.focusUp + + -- Switch between different screens. These are the leftmost keys on the home + -- row in a Dvorak layout. One might want to switch these to ASD for QWERTY. + forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) -> + bind key $ do + -- Move focus to that screen. + justMod $ + doc ("Switch focus to screen " ++ show idx) $ + withScreen W.view idx + -- Swap the current screen with the one given + altMod $ + doc ("Swap the current screen with screen " ++ show idx) $ + withScreen W.greedyView idx + -- Move the current window to the select screen. + shiftMod $ + doc ("Move the current window to screne " ++ show idx) $ + withScreen W.shift idx + + altgrMod $ + logs "Test altgr" + + bind xK_bracketright $ do + justMod $ + doc "Increase the gaps between windows." $ + sendMessage $ modifyWindowBorder 5 + + bind xK_bracketleft $ do + justMod $ + doc "Decrease the gaps between windows." $ + sendMessage $ modifyWindowBorder (-5) + + bind xK_b $ do + justMod $ spawnX "bluetooth-select.sh" + + bind xK_c $ do + justMod $ + doc "Run PassMenu" runPassMenu + + shiftMod $ + doc "Kill the current window" CopyWindow.kill1 + + bind xK_f $ do + justMod $ + doc "Flip the current layout vertically" $ + sendMessage FlipLayout + shiftMod $ + doc "Flip the current layout horizontally" $ + sendMessage HFlipLayout + + bind xK_g $ do + justMod $ + doc "Goto a workspace\n\n\t\ + + \If the second character typed is alpha-numberic, jump to that\n\t\ + \workspace. The workspace is created on-the-fly if such a workspace\n\t\ + \does not exist.\n\n\t\ + + \If the second character typed is:\n\t\t\ + \]: go to the next workspace\n\t\t\ + \[: go to the previous workspace\n\t\t\ + \}: cycle the workspaces on the screens to the right\n\t\t\ + \{: cycle the workspaces on the screens to the left\n\t\t\ + \: Jump to the accompaning workspace.\n\t\t\ + \F1: display this help.\n" $ + mapNextStringWithKeysym $ \_ keysym str -> + case (keysym, str) of + (_, [ch]) | isAlphaNum ch -> gotoWorkspace ch + (_, "]") -> pushHistory $ withRelativeWorkspace next W.greedyView + (_, "[") -> pushHistory $ withRelativeWorkspace prev W.greedyView + (_, "}") -> windows screenRotateForward + (_, "{") -> windows screenRotateBackward + (_, " ") -> gotoAccompaningWorkspace + + -- Test binding. Tests that I can still submap keysyms alone (keys + -- where XLookupString won't return anything helpful.) + (f, _) | f == xK_F1 -> + (safeSpawn "gxmessage" [ + "-fn", "Source Code Pro", + documentation (keymap config)] :: X ()) + + _ -> return () + shiftMod $ + doc "Move the currently focused window to another workspace" $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> shiftToWorkspace ch + "]" -> withRelativeWorkspace next W.shift + "[" -> withRelativeWorkspace prev W.shift + _ -> return () + shiftAltMod $ + doc "Swap this workspace with another workspace (rename)." $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> swapWorkspace ch + _ -> return () + + bind xK_h $ do + justMod $ + doc "Focus on the next window down in the stack" $ + windows W.focusDown + + shiftMod $ + doc "Swap the current window with the next one down in the stack" $ + windows W.swapDown + + controlMod $ + doc "Rotate all the windows down the stack" + rotAllDown + + bind xK_j $ do + justMod $ + doc "Shrink the size of the zoom region" $ + sendMessage ShrinkZoom + + shiftMod $ + doc "Go to the previous window in history." historyPrev + + bind xK_k $ do + justMod $ + doc "Expand the size of the zoom region" $ + sendMessage ExpandZoom + + shiftMod $ + doc "Go to the next window in history." historyNext + + bind xK_l $ do + justMod $ + doc "Focus the next window in the stack" $ + windows W.focusUp + + shiftMod $ + doc "Swap the currently focused window with the next window in the stack." $ + windows W.swapUp + + controlMod $ + doc "Rotate the windows up." + rotAllUp + + altMod $ + doc "Lock the screen" $ + spawnX "xsecurelock" + + bind xK_minus $ do + justMod $ + doc "Decrease the number of windows in the master region." $ + sendMessage (IncMasterN (-1)) + + shiftMod $ + doc "For mosaic layout, shrink the size-share of the current window" $ + withFocused $ sendMessage . shrinkWindowAlt + + bind xK_m $ do + justMod $ + doc "Mark the current window with the next typed character." $ + mapNextString $ \_ str -> + case str of + [ch] | isAlphaNum ch -> markCurrentWindow ch + _ -> return () + + bind xK_n $ do + justMod $ + doc "Shift to the next workspace." $ + withRelativeWorkspace next W.greedyView + + bind xK_p $ do + justMod $ + doc "Shift to the previous workspace." $ + withRelativeWorkspace prev W.greedyView + + bind xK_plus $ do + justMod $ + doc "Increase the number of windows in the master region." $ + sendMessage (IncMasterN 1) + + shiftMod $ + doc "For mosaic layout, increase the size-share of the current window." $ + withFocused $ sendMessage . expandWindowAlt + + bind xK_q $ do + shiftMod $ + doc "Recompile and restart XMonad" $ + spawnX "xmonad --recompile && xmonad --restart" + + justMod $ + doc "Experimental Bindings" $ + subkeys $ do + + bind xK_q $ + (justMod -|- noMod) $ + doc "EXPERIMENTAL: Move mouse to control media." $ + mouseRotateMotion (logs "CW") (logs "CCW") + + bind xK_r $ do + justMod $ doc "Run a command via Rofi" runDMenu + shiftMod $ + doc "Rotate the current layout. (flips x, y coordinates)" $ + sendMessage DoRotate + + bind xK_s $ do + altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" + + bind xK_space $ do + justMod $ + doc "Use the next layout in the layout list." $ sendMessage toNextLayout + + altMod $ + doc "Reset the layout to the default layout." $ sendMessage toFirstLayout + + shiftMod $ + doc "Use the previous layout in the layout list." $ + sendMessage toPreviousLayout + + bind xK_t $ do + justMod $ + doc "Spawn a terminal." $ spawnX (terminal config) + + shiftMod $ + doc "Sink the current window into the tiling." $ withFocused $ windows . W.sink + + altMod $ + doc "Spawn a floating terminal" $ spawnX (terminal config ++ " -t Floating\\ Term") + + bind xK_v $ + -- Allows repeated strokes of M-h and M-l to reduce and increase volume + -- respectively. + justMod $ + doc "Changes the volume." $ + repeatable $ do + bind xK_h $ + justMod $ + doc "Decrease volume." + decreaseVolumeDoc + + bind xK_l $ + justMod $ + doc "Increase volume." + increaseVolumeDoc + + bind xK_v $ + justMod (return () :: X ()) + + bind xK_w $ do + justMod $ doc "Jump to a window (via rofi)" windowJump + + bind xK_x $ do + justMod $ + doc "Toggles respect for struts." $ + sendMessage ToggleStruts + + bind xK_z $ do + + justMod $ + doc "Less often used keybindings." $ + subkeys $ do + + bind xK_g $ do + (justMod -|- noMod) $ + doc "Copy a window to the given workspace" $ + mapNextString $ \_ s -> + case s of + [ch] | isAlphaNum ch -> windows (CopyWindow.copy s) + _ -> return () + + bind xK_p $ do + (justMod -|- noMod) $ + doc "Go to the prior window in the history" historyPrev + + bind xK_t $ do + (justMod -|- noMod) $ logs "Test Log" + + -- bind xK_n $ do + -- (justMod -|- noMod) $ + -- doc "Take a note" $ + -- spawnX (terminal config ++ " -t Notes -e notes new") + bind xK_n $ do + (justMod -|- noMod) $ + doc "Go to the next window in the history" historyNext + + bind xK_c $ do + shiftMod $ + doc "Kill all other copies of a window." + CopyWindow.killAllOtherCopies + + bind xK_e $ do + (justMod -|- noMod) $ + doc "Select an emoji" $ + spawnX "emoji-select.sh" + + (shiftMod -|- rawMask shiftMask) $ + doc "Select an emoticon" $ + spawnX "emoticon-select.sh" + + bind xK_a $ + (justMod -|- noMod) $ + doc "Move the audio sink for an application." $ + spawnX "set-sink.sh" + + bind xK_w $ + (justMod -|- noMod) $ + doc "Select a network to connect to." $ + spawnX "networkmanager_dmenu" + + bind xK_o $ + (justMod -|- noMod) $ + doc "Open a file from the library" $ + spawnX "library-view.sh" + + bind xK_s $ + (justMod -|- noMod) $ + doc "Toggle the ability for terminals to swallow child windows." + toggleSwallowEnabled + + bind xK_v $ do + (justMod -|- noMod) $ + doc "Set the volume via rofi." $ + spawnX "set-volume.sh" + (shiftMod -|- rawMask shiftMask) $ + doc "Set the volume of an application via rofi." $ + spawnX "set-volume.sh -a" + + -- Double-tap Z to toggle zoom. + bind xK_z $ do + noMod -|- justMod $ + doc "Toggle zoom on the current window." $ + sendMessage ToggleZoom + + -- Z is reserved to create sub keybindings to do various things. + -- I don't really use these at the moment. + bind xK_h $ noMod mediaPrevDoc + bind xK_j $ noMod playPauseDoc + bind xK_l $ noMod mediaNextDoc + + -- Centers the current focused window. i.e. toggles the Zoom layout + -- modifier. + shiftMod $ + doc "Toggle zoom on the current window." $ + sendMessage ToggleZoom + + bind xF86XK_Calculator $ do + noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" + + bind xF86XK_AudioLowerVolume $ do + noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%" + justMod mediaPrevDoc + + bind xF86XK_AudioRaiseVolume $ do + noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ +1%" + justMod mediaNextDoc + + bind xF86XK_AudioMute $ do + noMod $ spawnX "pactl set-sink-mute @DEFAULT_SINK@ toggle" + + bind xF86XK_AudioPlay $ do + noMod playPauseDoc + + bind xF86XK_AudioNext $ do + noMod mediaNextDoc + + bind xF86XK_AudioPrev $ do + noMod mediaPrevDoc + + bind xF86XK_AudioPrev $ do + noMod mediaPrevDoc + + bind xF86XK_MonBrightnessUp $ do + noMod $ spawnX "set-backlight.sh +0.05" + justMod $ spawnX "set-backlight.sh 1" + + bind xF86XK_MonBrightnessDown $ do + noMod $ spawnX "set-backlight.sh -0.05" + justMod $ spawnX "set-backlight.sh 0.01" + rawMask shiftMask $ spawnX "set-backlight.sh 0" + +mouseMap :: ButtonsMap l +mouseMap = runButtons $ do + config <- getConfig + + let x button = Map.lookup button (mouseMap config) + + let defaultButtons button = fromMaybe (\w -> return ()) $ + Map.lookup button (mouseMap config) + subMouse = submapButtonsWithKey defaultButtons . flip runButtons config + + + let continuous :: [(Button, X ())] -> Button -> Window -> X () + continuous actions button w = do + case find ((==button) . fst) actions of + Just (_, action) -> action + Nothing -> return () + + (subMouse $ + forM_ (map fst actions) $ \b -> + bind b $ noMod $ \w -> continuous actions b w) w + + bind button1 $ do + justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster + + bind button2 $ do + justMod $ windows . (W.shiftMaster .) . W.focusWindow + + bind button3 $ do + justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster + + bind button6 $ + justMod $ noWindow (withRelativeWorkspace prev W.greedyView) + + bind button7 $ + justMod $ noWindow (withRelativeWorkspace next W.greedyView) + + bind button8 $ + justMod $ noWindow mediaPrev + + bind button9 $ + justMod $ noWindow mediaNext + + bind button14 $ do + noMod $ subMouse $ do + + bind button3 $ + noMod $ noWindow (gotoWorkspace 's') + + bind button13 $ do + noMod $ noWindow $ click >> CopyWindow.kill1 + + bind button14 $ do + noMod $ noWindow $ click >> sendMessage ToggleZoom + + bind button15 $ do + noMod $ noWindow $ spawnX "pavucontrol" + + let mediaButtons = [ + (button4, increaseVolume), + (button5, decreaseVolume), + (button2, playPause), + (button9, historyNext), + (button8, historyPrev), + (button6, mediaPrev), + (button7, mediaNext) + ] + + forM_ (map fst mediaButtons) $ \b -> + bind b $ noMod $ continuous mediaButtons b + + bind button13 $ noMod $ subMouse $ do + bind button1 $ noMod mouseMoveWindow + bind button2 $ noMod $ windows . W.sink + bind button3 $ noMod mouseResizeWindow + + bind button13 $ noMod $ subMouse $ do + bind button13 $ noMod $ subMouse $ do + bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" + bind button1 $ noMod $ noWindow $ + spawnX "sudo -A systemctl suspend && xsecurelock" + + bind button15 $ do + + noMod $ subMouse $ do + bind button13 $ noMod $ noWindow gotoAccompaningWorkspace + + bind button15 $ do + noMod $ noWindow jumpToLast + + + let workspaceButtons = [ + (button2, swapMaster), + + (button9, withRelativeWorkspace next W.greedyView), + (button8, withRelativeWorkspace prev W.greedyView), + + (button4, windows W.focusUp), + (button5, windows W.focusDown), + + (button7, windows screenRotateForward), + (button6, windows screenRotateBackward) + ] + + forM_ (map fst workspaceButtons) $ \b -> + bind b $ noMod $ continuous workspaceButtons b + +-- Bindings specific to a window. These are set similarly to th ekeymap above, +-- but uses a Query monad to tell which windows the keys will apply to. +-- +-- This is useful to create hotkeys in applications where hot keys are not +-- configurable, or to remove keybindings that are irritating (looking at you, +-- ctrl+w in Chrome!!). +windowSpecificBindings :: + XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () +windowSpecificBindings config = do + + w <- lift ask + + let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) + emitKey = flip sendKey w + + configureIf (flip elem browsers <$> className) $ do + + -- if the window is a browser, configure these bindings. Lots of browsers + -- make up their own garbage bindings that are not standard across many + -- other applications. This alleviates the issue. + -- + -- Consistency with terminal: + -- + -- Ctrl+h is backspace + -- Ctrl+w is ctrl+backspace + -- Ctrl+u is ctrl+shift+backspace + -- + -- Consistency with Vim/Emacs-ish: + -- + -- Alt+{Shift,Ctrl,}+{h,j,k,l} -> {Shift,Ctrl,}+{Left,Down,Up,Right} + -- Ctrl+b -> Ctrl+Left + -- Ctrl+e -> Ctrl+Right + -- Ctrl+$ -> End + -- Ctrl+^ -> Home + -- + -- Ctrl+d -> Delete current tab. + + + let mods = permuteMods [shiftMask, controlMask, 0] + + bind xK_h $ do + rawMask controlMask $ emitKey (0, xK_BackSpace) + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Left) + + bind xK_j $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Down) + + bind xK_k $ + forM_ mods $ \mask -> + rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) + + bind xK_l $ + forM_ mods $ \mask -> + rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) + + bind xK_u $ + rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_BackSpace) + + bind xK_w $ + rawMask controlMask $ emitKey (controlMask, xK_BackSpace) + + bind xK_b $ do + rawMask controlMask $ emitKey (controlMask, xK_Left) + rawMask (controlMask .|. shiftMask) $ + emitKey (controlMask .|. shiftMask, xK_Left) + + bind xK_e $ do + rawMask controlMask $ emitKey (controlMask, xK_Right) + rawMask (controlMask .|. shiftMask) $ + emitKey (controlMask .|. shiftMask, xK_Right) + + bind xK_dollar $ + rawMask controlMask $ emitKey (0, xK_End) + + bind xK_at $ + rawMask (controlMask .|. shiftMask) $ emitKey (0, xK_Home) + + bind xK_d $ + rawMask controlMask $ emitKey (controlMask, xK_w) + + bind xK_F2 $ + -- Experimental. + noMod $ logs "This is a test" + + -- Add a binding to xev as a test. + configureIf (title =? "Event Tester") $ + bind xK_F2 $ + noMod $ emitKey (controlMask, xK_F2) + + where + browsers = ["Google-chrome", "Brave-browser", "firefox-default"] + + -- Create a permutation from a list of modifiers. + -- + -- i.e. permuteMods [C, S, M] will return + -- + -- [C, S, M, C + M, C + S, M + S, C + S + M, 0] + permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False]) + +windowBindings :: XConfig l -> XConfig l +windowBindings xconfig = + xconfig { + startupHook = do + forAllWindows (runQuery doQuery) + startupHook xconfig, + + manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig + } + + where + doQuery :: Query () + doQuery = do + map <- execWriterT $ windowSpecificBindings xconfig + w <- ask + + liftX $ logs $ printf "For Window: %s" (show w) + forM_ (Map.toList map) $ \(key, action) -> do + liftX $ logs $ printf " -- remap: %s" (show key) + remapKey key action + +applyKeys :: XConfig l -> IO (XConfig l) +applyKeys config = + return $ windowBindings $ config { keys = keyBindingToKeymap keymap, mouseBindings = mouseMap } + +click :: X () +click = do + (dpy, root) <- asks $ (,) <$> display <*> theRoot + (_, _, window, _, _, _, _, _) <- io $ queryPointer dpy root + focus window + +modifyWindowBorder :: Integer -> SpacingModifier +modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> + Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) + + where clip i | i < 0 = 0 + clip i = i diff --git a/src/Rahm/Desktop/KeysM.hs b/src/Rahm/Desktop/KeysM.hs new file mode 100644 index 0000000..ef52c24 --- /dev/null +++ b/src/Rahm/Desktop/KeysM.hs @@ -0,0 +1,497 @@ +{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances, TypeFamilies, FlexibleContexts #-} +module Rahm.Desktop.KeysM where + +import Data.List +import Data.Bits ((.&.)) +import Control.Monad.Writer +import Text.Printf +import Control.Arrow (second, first) +import Control.Monad (void) +import Control.Monad.State (State(..), modify', get, execState) +import XMonad +import Data.Map (Map) +import qualified Data.Map as Map + +data Documented t = Documented String t + +data KeyBinding = + Action (X ()) | + Submap KeyBindings | + Repeat KeyBindings + +type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding) + +type ButtonBinding = Window -> X () +type ButtonBindings = Map (KeyMask, Button) ButtonBinding + +{- Module that defines a DSL for binding keys. -} +newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) + deriving (Functor, Applicative, Monad) + +newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a) + deriving (Functor, Applicative, Monad) + +newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a) + deriving (Functor, Applicative, Monad) + +class HasConfig m where + getConfig :: m l (XConfig l) + +class Bindable k where + type BindableValue k :: * + type BindableMonad k :: (* -> *) -> * -> * + + bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l () + -- section :: String -> BindableMonad k l () -> BindableMonad k l () + +class Binding k b where + toB :: k -> b + + rawMask :: KeyMask -> k -> BindingBuilder b () + rawMask m x = BindingBuilder $ modify' (second ((m, toB x):)) + +instance Binding (X ()) (Documented KeyBinding) where + toB = Documented "" . Action + +instance Binding KeyBindings (Documented KeyBinding) where + toB = Documented "" . Submap + +instance Binding a (Documented a) where + toB = Documented "" + +instance Binding a a where + toB = id + +doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding +doc str k = let (Documented _ t) = toB k in Documented str t + +runKeys :: KeysM l a -> XConfig l -> KeyBindings +runKeys (KeysM stateM) config = + snd $ execState stateM (config, Map.empty) + +runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings +runButtons (ButtonsM stateM) config = + snd $ execState stateM (config, Map.empty) + +instance HasConfig KeysM where + getConfig = fst <$> KeysM get + +instance HasConfig ButtonsM where + getConfig = fst <$> ButtonsM get + +{- Generally it is assumed that the mod key shoud be pressed, but not always. -} +noMod :: (Binding k b) => k -> BindingBuilder b () +noMod = rawMask 0 + +maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b () +maskMod mask action = do + modMask <- fst <$> BindingBuilder get + rawMask (modMask .|. mask) action + +altMask :: KeyMask +altMask = mod1Mask + +hyperMask :: KeyMask +hyperMask = mod3Mask + +altgrMask :: KeyMask +altgrMask = 0x80 + +superMask :: KeyMask +superMask = mod4Mask + +justMod :: (Binding k b) => k -> BindingBuilder b () +justMod = maskMod 0 + +instance Bindable KeySym where + type BindableValue KeySym = Documented KeyBinding + type BindableMonad KeySym = KeysM + + -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l () + bind key (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + KeysM $ modify' $ second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) + + +instance Bindable Button where + type BindableValue Button = ButtonBinding + type BindableMonad Button = ButtonsM + + -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () + bind button (BindingBuilder stM) = do + m <- modMask <$> getConfig + let (_, values) = execState stM (m, []) + + ButtonsM $ modify' $ second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) + +shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask) + +shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask) + +shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltSuperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. superMask) + +shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltHyperMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask) + +shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltAltgrMod = + maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask) + +shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltMod = + maskMod (shiftMask .|. controlMask .|. altMask) + +shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperHyperMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask) + +shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperAltgrMod = + maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask) + +shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlSuperMod = + maskMod (shiftMask .|. controlMask .|. superMask) + +shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperAltgrMod = + maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask) + +shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlHyperMod = + maskMod (shiftMask .|. controlMask .|. hyperMask) + +shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlAltgrMod = + maskMod (shiftMask .|. controlMask .|. altgrMask) + +shiftControlMod :: (Binding k b) => k -> BindingBuilder b () +shiftControlMod = + maskMod (shiftMask .|. controlMask) + +shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperHyperMod = + maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask) + +shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperAltgrMod = + maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask) + +shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltSuperMod = + maskMod (shiftMask .|. altMask .|. superMask) + +shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperAltgrMod = + maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask) + +shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltHyperMod = + maskMod (shiftMask .|. altMask .|. hyperMask) + +shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltAltgrMod = + maskMod (shiftMask .|. altMask .|. altgrMask) + +shiftAltMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltMod = + maskMod (shiftMask .|. altMask) + +shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperAltgrMod = + maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask) + +shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperHyperMod = + maskMod (shiftMask .|. superMask .|. hyperMask) + +shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperAltgrMod = + maskMod (shiftMask .|. superMask .|. altgrMask) + +shiftSuperMod :: (Binding k b) => k -> BindingBuilder b () +shiftSuperMod = + maskMod (shiftMask .|. superMask) + +shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperAltgrMod = + maskMod (shiftMask .|. hyperMask .|. altgrMask) + +shiftHyperMod :: (Binding k b) => k -> BindingBuilder b () +shiftHyperMod = + maskMod (shiftMask .|. hyperMask) + +shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b () +shiftAltgrMod = + maskMod (shiftMask .|. altgrMask) + +shiftMod :: (Binding k b) => k -> BindingBuilder b () +shiftMod = maskMod shiftMask + +controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask) + +controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperHyperMod = + maskMod (controlMask .|. altMask .|. superMask .|. hyperMask) + +controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperAltgrMod = + maskMod (controlMask .|. altMask .|. superMask .|. altgrMask) + +controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltSuperMod = + maskMod (controlMask .|. altMask .|. superMask) + +controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperAltgrMod = + maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask) + +controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlAltHyperMod = + maskMod (controlMask .|. altMask .|. hyperMask) + +controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltAltgrMod = + maskMod (controlMask .|. altMask .|. altgrMask) + +controlAltMod :: (Binding k b) => k -> BindingBuilder b () +controlAltMod = + maskMod (controlMask .|. altMask) + +controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperAltgrMod = + maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask) + +controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperHyperMod = + maskMod (controlMask .|. superMask .|. hyperMask) + +controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperAltgrMod = + maskMod (controlMask .|. superMask .|. altgrMask) + +controlSuperMod :: (Binding k b) => k -> BindingBuilder b () +controlSuperMod = + maskMod (controlMask .|. superMask) + +controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperAltgrMod = + maskMod (controlMask .|. hyperMask .|. altgrMask) + +controlHyperMod :: (Binding k b) => k -> BindingBuilder b () +controlHyperMod = + maskMod (controlMask .|. hyperMask) + +controlAltgrMod :: (Binding k b) => k -> BindingBuilder b () +controlAltgrMod = + maskMod (controlMask .|. altgrMask) + +controlMod :: (Binding k b) => k -> BindingBuilder b () +controlMod = maskMod controlMask + +altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperAltgrMod = + maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask) + +altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperHyperMod = + maskMod (altMask .|. superMask .|. hyperMask) + +altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altSuperAltgrMod = + maskMod (altMask .|. superMask .|. altgrMask) + +altSuperMod :: (Binding k b) => k -> BindingBuilder b () +altSuperMod = + maskMod (altMask .|. superMask) + +altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altHyperAltgrMod = + maskMod (altMask .|. hyperMask .|. altgrMask) + +altHyperMod :: (Binding k b) => k -> BindingBuilder b () +altHyperMod = + maskMod (altMask .|. hyperMask) + +altAltgrMod :: (Binding k b) => k -> BindingBuilder b () +altAltgrMod = + maskMod (altMask .|. altgrMask) + +altMod :: (Binding k b) => k -> BindingBuilder b () +altMod = maskMod altMask + +superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superHyperAltgrMod = + maskMod (superMask .|. hyperMask .|. altgrMask) + +superHyperMod :: (Binding k b) => k -> BindingBuilder b () +superHyperMod = + maskMod (superMask .|. hyperMask) + +superAltgrMod :: (Binding k b) => k -> BindingBuilder b () +superAltgrMod = + maskMod (superMask .|. altgrMask) + +superMod :: (Binding k b) => k -> BindingBuilder b () +superMod = maskMod superMask + +hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () +hyperAltgrMod = + maskMod (hyperMask .|. altgrMask) + +hyperMod :: (Binding k b) => k -> BindingBuilder b () +hyperMod = maskMod hyperMask + +altgrMod :: (Binding k b) => k -> BindingBuilder b () +altgrMod = maskMod altgrMask + +{- Can combine two or more of the functions above to apply the same action to + - multiple masks. -} +(-|-) :: (Binding k b) => + (k -> BindingBuilder b ()) -> + (k -> BindingBuilder b ()) -> + k -> BindingBuilder b () +(-|-) fn1 fn2 f = fn1 f >> fn2 f + +{- Meant for submapping, binds all alphanumeric charactes to (fn c). -} +mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbersAndAlpha km fn = do + mapNumbers km fn + mapAlpha km fn + +{- Meant for submapping. This binds all numbers to (fn x) where x is the number + - pressed and fn is the function provided. -} +mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l () +mapNumbers km fn = do + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) + [ (xK_0, '0') + , (xK_1, '1') + , (xK_2, '2') + , (xK_3, '3') + , (xK_4, '4') + , (xK_5, '5') + , (xK_6, '6') + , (xK_7, '7') + , (xK_8, '8') + , (xK_9, '9') + -- Programmer Dvorak shifts the numbers so I have to map to their unshifted + -- form. + , (xK_bracketright, '6') + , (xK_exclam, '8') + , (xK_bracketleft, '7') + , (xK_braceleft, '5') + , (xK_braceright, '3') + , (xK_parenleft, '1') + , (xK_equal, '9') + , (xK_asterisk, '0') + , (xK_parenright, '2') + , (xK_plus, '4') ] + +{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the + - character pressed and fn is the function provided. -} +mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () +mapAlpha km fn = + mapM_ (\(key, ch) -> bind key $ rawMask km (fn ch)) [ + (xK_a, 'a') + , (xK_b, 'b') + , (xK_c, 'c') + , (xK_d, 'd') + , (xK_e, 'e') + , (xK_f, 'f') + , (xK_g, 'g') + , (xK_h, 'h') + , (xK_i, 'i') + , (xK_j, 'j') + , (xK_k, 'k') + , (xK_l, 'l') + , (xK_m, 'm') + , (xK_n, 'n') + , (xK_o, 'o') + , (xK_p, 'p') + , (xK_q, 'q') + , (xK_r, 'r') + , (xK_s, 's') + , (xK_t, 't') + , (xK_u, 'u') + , (xK_v, 'v') + , (xK_w, 'w') + , (xK_x, 'x') + , (xK_y, 'y') + , (xK_z, 'z') + ] + + +documentation :: KeyBindings -> String +documentation = execWriter . document' "" + where + document' pref keybindings = + forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do + when ((not $ null doc) || hasSubmap thing) $ + tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc + case thing of + Action _ -> return () + Submap submap -> document' (pref ++ " ") submap + Repeat submap -> do + tell pref + tell " (repeatable):\n" + document' (pref ++ " ") submap + + keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)]) + keyBindingsToList b = + fmap (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) $ + group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) + + prettyShow :: (KeyMask, KeySym) -> String + prettyShow (mask, key) = printf "<%s%s>" (showMask mask) (keysymToString key) + + hasSubmap b = case b of + Action _ -> False + _ -> True + + + showMask :: KeyMask -> String + showMask mask = + let masks = [(shiftMask, "S"), + (altMask, "A"), + (mod3Mask, "H"), + (mod4Mask, "M"), + (altgrMask, "AGr"), + (controlMask, "C")] in + + concatMap ((++"-") . snd) $ filter ((/=0) . (.&.mask) . fst) masks + + + group :: (Ord b) => (a -> b) -> [a] -> (Map b [a]) + group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) + + diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs new file mode 100644 index 0000000..95854b8 --- /dev/null +++ b/src/Rahm/Desktop/Layout.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-} +module Rahm.Desktop.Layout where + +import GHC.TypeLits + +import Data.Proxy (Proxy(..)) +import Rahm.Desktop.CornerLayout (Corner(..)) +import Control.Arrow (second) +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Circle +import XMonad.Layout.Accordion +import Control.Applicative +import XMonad.Layout.Spacing +import Data.List +import XMonad.Layout.Spiral +import XMonad.Layout.ThreeColumns +import XMonad.Layout.Grid +import XMonad.Layout.Dishes +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Fullscreen +import qualified XMonad.Layout.Dwindle as D +import XMonad.Layout +import XMonad.Layout.LayoutModifier +import XMonad +import XMonad.Core +import XMonad.Layout.NoBorders (smartBorders, noBorders) + +import Rahm.Desktop.LayoutList +import Rahm.Desktop.Windows + +import qualified Data.Map as M +import qualified XMonad.StackSet as W + +myLayout = + fullscreenFull $ + avoidStruts $ + spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ + layoutZipper $ + mods (reinterpretIncMaster $ spiral (6/7)) |: + mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: + mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: + mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: + mods Grid |: + mods (Dishes 2 (1/6)) |: + mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: + nil + +-- This is a type class that defines how to reinterpret a message. One can think +-- of this as a kind of type-level function. It lets one associate a function +-- (reinterpretMessage) with a type construct, which for the case below is a +-- Symbol. +-- +-- It would be nice to attach this function to the LayoutModifier directly as a +-- value, however LayoutModifiers must be Show-able and Read-able and functions +-- are not. However encoding in the typesystem itsef which function is to be +-- called is the best alternative I have. +class DoReinterpret (k :: t) where + reinterpretMessage :: + Proxy k -> SomeMessage -> X (Maybe SomeMessage) + +-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages +-- intended to modify the master space and instead have those messages expand +-- and shrink the current window. +-- +-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system +-- hacking one can do in Haskell. +instance DoReinterpret "ForMosaic" where + + -- IncMaster message + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do + fmap (SomeMessage . + (if n > 0 + then expandWindowAlt + else shrinkWindowAlt)) <$> getFocusedWindow + + -- ResizeMaster message + reinterpretMessage _ (fromMessage -> Just m) = do + fmap (SomeMessage . + (case m of + Expand -> expandWindowAlt + Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + + -- Messages that don't match the above, just leave it unmodified. + reinterpretMessage _ m = return (Just m) + +instance DoReinterpret "IncMasterToResizeMaster" where + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = + return $ Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink + reinterpretMessage _ m = return (Just m) + +-- Data construct for association a DoReinterpret function with a concrete +-- construct that can be used in the LayoutModifier instance. +-- +-- It wolud be nice to have ReinterpretMessage hold the function as a value +-- rather than delegate to this kind-instance, however, it won't work because +-- LayoutModifiers have to be Read-able and Show-able, and functions are neither +-- of those, so a value-level function may not be a member of a LayoutModifier, +-- thus I have to settle for delegating to a hard-coded instance using +-- type-classes. +data ReinterpretMessage k a = ReinterpretMessage + deriving (Show, Read) + +-- Instance for ReinterpretMessage as a Layout modifier. +instance (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a where + + handleMessOrMaybeModifyIt self message = do + + -- Delegates to the reinterpretMessage function associatied with the + -- type-variable k. + newMessage <- reinterpretMessage (ofProxy self) message + case newMessage of + Just m -> return $ Just $ Right m + Nothing -> return $ Just $ Left self + where + -- ofProxy just provides reifies the phantom type k so the type system can + -- figure out what instance to go to. + ofProxy :: ReinterpretMessage k a -> Proxy k + ofProxy _ = Proxy + +modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a +modifyMosaic = ModifiedLayout ReinterpretMessage + +reinterpretIncMaster :: + l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a +reinterpretIncMaster = ModifiedLayout ReinterpretMessage + +mods = + ModifiedLayout (Zoomable False 0.05 0.05) . + ModifiedLayout (Flippable False) . + ModifiedLayout (HFlippable False) . + ModifiedLayout (Rotateable False) + + +data ModifyDescription m l a = ModifyDescription m (l a) + deriving (Show, Read) + +data TallDescriptionModifier = TallDescriptionModifier + deriving (Show, Read) + +data ThreeColDescMod = ThreeColDescMod + deriving (Show, Read) + +class DescriptionModifier m l where + newDescription :: m -> l a -> String -> String + +instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where + runLayout (W.Workspace t (ModifyDescription m l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + doLayout (ModifyDescription m l) a s = do + (rects, maybeNewLayout) <- doLayout l a s + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + pureLayout (ModifyDescription m l) a s = pureLayout l a s + + emptyLayout (ModifyDescription m l) a = do + (rects, maybeNewLayout) <- emptyLayout l a + return (rects, fmap (ModifyDescription m) maybeNewLayout) + + handleMessage (ModifyDescription m l) a = do + maybeNewLayout <- handleMessage l a + return (ModifyDescription m <$> maybeNewLayout) + + pureMessage (ModifyDescription m l) a = + let maybeNewLayout = pureMessage l a in + ModifyDescription m <$> maybeNewLayout + + description (ModifyDescription m l) = newDescription m l (description l) + +instance DescriptionModifier TallDescriptionModifier Tall where + newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" + +instance DescriptionModifier ThreeColDescMod ThreeCol where + newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" + newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" + +data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable) + +instance Message ResizeZoom where + +newtype Flippable a = Flippable Bool -- True if flipped + deriving (Show, Read) + +newtype HFlippable a = HFlippable Bool -- True if flipped + deriving (Show, Read) + +newtype Rotateable a = Rotateable Bool -- True if rotated + deriving (Show, Read) + +data FlipLayout = FlipLayout deriving (Typeable) + +data HFlipLayout = HFlipLayout deriving (Typeable) + +data DoRotate = DoRotate deriving (Typeable) + +data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window. + deriving (Show, Read) + +-- Toggles if the current window should be zoomed or not. Set the boolean +-- to set the zoom.mhar +data ZoomModifier = + ToggleZoom | + Zoom | + Unzoom + deriving (Typeable) + +instance Message FlipLayout where + +instance Message HFlipLayout where + +instance Message ZoomModifier where + +instance Message DoRotate where + +instance (Eq a) => LayoutModifier Rotateable a where + pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned = + if rotate + then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing) + else (returned, Nothing) + where + zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h + unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h + + scaleRect (Rectangle x y w h) = + Rectangle (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) + + fi = fromIntegral + + + pureMess (Rotateable rot) mess = + fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess) + + modifyDescription (Rotateable rot) underlying = + let descr = description underlying in + if rot + then descr ++ " Rotated" + else descr + +instance (Eq a) => LayoutModifier Flippable a where + pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h + + pureMess (Flippable flip) message = + case fromMessage message of + Just FlipLayout -> Just (Flippable (not flip)) + Nothing -> Nothing + + modifyDescription (Flippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " Flipped" + else descr + +instance (Eq a) => LayoutModifier HFlippable a where + pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned = + if flip + then (map (second doFlip) returned, Nothing) + else (returned, Nothing) + where + doFlip (Rectangle x y w h) = + Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h + + pureMess (HFlippable flip) message = + case fromMessage message of + Just HFlipLayout -> Just (HFlippable (not flip)) + Nothing -> Nothing + + modifyDescription (HFlippable flipped) underlying = + let descr = description underlying in + if flipped + then descr ++ " HFlipped" + else descr + + +instance (Eq a) => LayoutModifier Zoomable a where + redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned = + if doit + then + let focused = W.focus <$> stack + (zoomed, rest) = partition ((==focused) . Just . fst) returned + in case zoomed of + [] -> return (rest, Nothing) + ((fwin, _):_) -> return ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing) + + else return (returned, Nothing) + where + wp = floor $ fromIntegral w * ws + hp = floor $ fromIntegral h * hs + + handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess = + return $ + (handleResize <$> fromMessage mess) + <|> (Left . handleZoom <$> fromMessage mess) + where + handleResize r = + if showing + then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d) + else Right $ case r of + ShrinkZoom -> SomeMessage Shrink + ExpandZoom -> SomeMessage Expand + + where d = (case r of + ShrinkZoom -> -1 + ExpandZoom -> 1) * 0.02 + + handleZoom ToggleZoom = Zoomable (not showing) sw sh + handleZoom Zoom = Zoomable True sw sh + handleZoom Unzoom = Zoomable False sw sh + + guard f | f > 1 = 1 + | f < 0 = 0 + | otherwise = f diff --git a/src/Rahm/Desktop/LayoutDraw.hs b/src/Rahm/Desktop/LayoutDraw.hs new file mode 100644 index 0000000..c3d8c9e --- /dev/null +++ b/src/Rahm/Desktop/LayoutDraw.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, +ScopedTypeVariables, BangPatterns #-} +module Rahm.Desktop.LayoutDraw (drawLayout) where + +import Control.Monad + +import Control.Arrow (second) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Control.Monad.Writer (execWriter, tell) +import Data.Foldable (find) +import Data.Maybe (fromMaybe) +import Rahm.Desktop.Hash (quickHash) +import Rahm.Desktop.Layout (ZoomModifier(..)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (()) +import Text.Printf (printf) +import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) + +import XMonad (X, + Rectangle(..), + Dimension, + LayoutClass, + Message, + Window, + SomeMessage(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +-- Draws and returns an XPM for the current layout. +-- +-- Returns +-- - Bool - true if the xpm has already been written, and is thus cached. +-- - String - description of the current layout +-- - String - the text to send to XMobar +-- +-- This function actually runs the current layout's doLayout function to +-- generate the XPM, so it's completely portable to all layouts. +-- +-- Note this function is impure and running the layout to create the XPM is also +-- impure. While in-practice most layouts are pure, it should be kept in mind. +drawLayout :: X (Bool, String, String) +drawLayout = do + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- foldM (flip ($)) layout [ + handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' Unzoom + ] + + (cached, xpm) <- drawXpmIO layout' + + return (cached , X.description layout, printf "" xpm) + +-- Returns true if a point is inside a rectangle (inclusive). +pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool +pointInRect (x, y) (Rectangle x' y' w h) = + x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y' + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce +-- noise from things like AvoidStruts, as there is unfortunately no way to force +-- avoid struts to be off, one can only toggle it. +sf :: (Integral a) => a +sf = 1024 + +handleMessage' :: + (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) +handleMessage' message layout = do + fromMaybe layout <$> X.handleMessage layout (SomeMessage message) + +-- Creates the XPM for the given layout and returns the path to it. +-- +-- This function does run doLayout on the given layout, and that should be +-- accounted for. +drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String) +drawXpmIO l = do + dir <- X.getXMonadDir + + let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps. + + let (w, h) = (56, 24) + let descr = X.description l + let iconCacheDir = dir "icons" "cache" + let iconPath = iconCacheDir (quickHash descr ++ ".xpm") + + let colors = [ + "#cc9a9a", "#cc9999", "#cc8080", "#cc6666", + "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ] + + (rects', _) <- + X.runLayout + (S.Workspace "0" l (S.differentiate [1 .. 5])) + (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * sf)) + + let rects = flip map rects' $ \(_, Rectangle x y w h) -> + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) + + X.liftIO $ do + exists <- doesFileExist iconPath + createDirectoryIfMissing True iconCacheDir + + unless exists $ do + let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4 + writeFile iconPath xpmText + + return (exists, iconPath) + +-- +-- Create's an XPM, purely. Returns a string with the XPM contents. +-- Takes as arguments +-- +-- - dimensions of the icon. +-- - list of (color, rectangle) pairs. +-- - The amount to shrink the windows by for those pretty gaps. +-- +drawXpm :: + (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String +drawXpm (w, h) rects' shrinkAmt = execWriter $ do + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c None\"a,\n" + + forM_ [0 .. h - 1] $ \y -> do + tell "\"" + forM_ [0 .. w - 1] $ \x -> + (case find (matches x y) zipRects of + Nothing -> tell "%" + Just (chr, _) -> tell [chr]) + tell "\"" + when (y /= h - 1 - shrinkAmt) (tell ",") + tell "\n" + tell "};\n" + + where + matches x y (_, (_, r)) = pointInRect (x, y) r + rects = map (second (shrink shrinkAmt)) rects' + guard a b = if a <= shrinkAmt then 1 else b + shrink amt (Rectangle x y w h) = + Rectangle + x + y + (guard w $ w - fromIntegral amt) + (guard h $ h - fromIntegral amt) diff --git a/src/Rahm/Desktop/LayoutList.hs b/src/Rahm/Desktop/LayoutList.hs new file mode 100644 index 0000000..3bc09d3 --- /dev/null +++ b/src/Rahm/Desktop/LayoutList.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, + FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, + RankNTypes, TupleSections, TypeFamilies #-} + +{- + - This module provides a more powerful version of the "Choose" layout that can + - be bidirectionally navigated. + - + - The indexing uses a type-safe zipper to keep track of the currently-selected + - layout. + -} +module Rahm.Desktop.LayoutList ( + LayoutList, + layoutZipper, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + (|:), + nil + )where + +import Control.Applicative ((<|>)) +import Data.Void +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe, fromJust) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +-- Type-level lists. LNil is the final of the list. LCons contains a layout and a +-- tail. +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +-- Sel - This defines a structure where either this selected, or some +-- other element is selected. +-- +-- These types can be composed to create what is effectively a bounded integer. +-- I.e. there can be a type like +-- +-- Sel (Sel (Sel (Sel End))) +-- +-- Such a type is equivalent to an integer bounded at 4, because this type can +-- exist in no more than 4 states: +-- +-- Sel +-- Skip Sel +-- Skip (Skip Sel) +-- Skip (Skip (Skip Sel)) +-- +-- Note that a type (Sel End) can only be in the Sel as End may not be +-- construted (without using undefined). +data Sel l = + Sel | + (Selector l) => Skip l +deriving instance (Read l, Selector l) => Read (Sel l) +deriving instance (Show l, Selector l) => Show (Sel l) +deriving instance (Eq l, Selector l) => Eq (Sel l) + +-- Reimplement Void as End, just to keep the two separate, but End is for all +-- intents and purposes Void. +data End +deriving instance Read End +deriving instance Show End +deriving instance Eq End + + +-- Types that constitute a selection. Selections can be moved to the next +-- selection, moved to the previous selection, optionally there could be a +-- previous selection and they may be currently selected. +class (Eq c) => Selector c where + -- Increments the selection to the next state + -- + -- Returns Nothing if the selection class is in the final state and cannot be + -- incremented any farther. (This is helpful to facilitate modular + -- arithmatic) + increment :: c -> Maybe c + + -- Decrements the selection to the previous state. Returns Nothing if the + -- state is already in its initial setting. + decrement :: c -> Maybe c + + -- The initial state. + initial :: Maybe c + + -- The final state. + final :: Maybe c + +-- +-- Is selelected can be in two states: +-- +-- 1. The current element is selected +-- 2. The current element is not selected and another element deeper in the +-- structure is selected. +instance (Selector t) => Selector (Sel t) where + -- If the current element is not selected, increment the tail. + increment (Skip l) = Skip <$> increment l + -- If the current element is selected, the increment is just the initial of + -- the tail. + increment Sel = Skip <$> initial + + -- For a selection, the initial is just this in the Sel state. + initial = Just Sel + + -- Looks ahead at the tail, sees if it is selected, if so, select this one + -- instead, if the one ahead isn't selected, then decrement that one. + decrement (Skip t) = Just $ maybe Sel Skip (decrement t) + decrement Sel = Nothing + + -- Navigates to the end of the structure to find the final form. + final = Just $ maybe Sel Skip final + +-- The End structure (which is equivalent to Void) is the "null" selector; the +-- basecase that the Sel selector terminates at. +instance Selector End where + + -- Incrementing the End Selector doesn't do anything. + increment = const Nothing + + -- Decrementing the End Selector doesn't do anythig + decrement = const Nothing + + -- There is no initial value for the End selector. + initial = Nothing + + -- There is not final state for the End selector. + final = Nothing + +-- Increment a selector, but cyclicly +incrementCycle :: (Selector c) => c -> c +incrementCycle c = + case increment c of + Nothing -> fromMaybe c initial + Just x -> x + +-- Add two selectors together, incrementing the first until the second cannot be +-- incremented anymore. +addSelector :: (Selector c) => c -> c -> c +addSelector c1 c2 = addSel c1 (decrement c2) + where + addSel c1 Nothing = c1 + addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) + +-- Turn an int into a selector by repeatably incrementing. +intToSelector :: (Selector c) => Int -> c +intToSelector 0 = fromJust initial +intToSelector n = incrementCycle $ intToSelector (n - 1) + +-- A LayoutList consists of a LayoutSelect type and a corresponding Selector. +data LayoutList l a where + LayoutList :: + (LayoutSelect l a, Selector (SelectorFor l)) => + SelectorFor l -> l a -> LayoutList l a + +deriving instance (LayoutSelect l a) => Show (LayoutList l a) +deriving instance (LayoutSelect l a) => Read (LayoutList l a) + +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons + +infixr 5 |: + +-- Constructs a LayoutList. This function enforces that the SelectorFor l +-- is a 'Sel' type. Essentially this enforces that there must be at least one +-- underlying layout, otherwise a LayoutList cannot be constructed. +layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> LayoutList l a +layoutZipper = LayoutList Sel + +-- The termination of a layout zipper. +nil :: LNil a +nil = LNil + +-- Message to navigate to a layout. +newtype NavigateLayout = + -- Sets the layout based on the given function. + NavigateLayout { + changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) + +-- NavigateLayout instance to move to the next layout, circularly. +toNextLayout :: NavigateLayout +toNextLayout = NavigateLayout $ addSelector (intToSelector 1) + +-- NavigateLayout instance to move to the previous layout, circularly. +toPreviousLayout :: NavigateLayout +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) + +-- NavigateLayotu instance to move to the first layout. +toFirstLayout :: NavigateLayout +toFirstLayout = NavigateLayout (`fromMaybe` initial) + +instance Message NavigateLayout where + +-- LayoutSelect class Describes a type that can be used to select a layout using +-- the associated type SelectorFor. +-- +-- Instances of this class are LCons and LNil. +class (Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l)) => LayoutSelect l a where + + -- The selector that is used to update the layout corresponding to the + -- selector. This selector must be an instance of the Selector class. + type SelectorFor l :: * + + -- Update applies a functor to the selected layout and maybe returns a result + -- and an updated layout. + update :: forall r m. (Monad m) => + -- The selector for this type. Determines which layout the function is + -- applied to. + SelectorFor l -> + -- The LayoutSelect being modified. + l a -> + -- Higher-ordered function to generically apply to the Layout associated + -- with the Selector. Works on all LayoutClass's. + (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> + + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) + +-- Instance for LayoutSelect for cons +instance (Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t)) => + LayoutSelect (LCons l t) a where + + -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure + -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the + -- number of Cons in this structure enforcing safe selection. + type SelectorFor (LCons l t) = Sel (SelectorFor t) + + -- The current layout in this Cons-list is selected. + update Sel (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + -- The current layout is not selected. Move on to another layout. + update (Skip s) (LCons l t) fn = + fmap (second $ \t' -> LCons l t') <$> update s t fn + +-- LNil is a layout select. It doesn't do anything. Indeed update really can't +-- be called on on this because that would require instantiating a End type. +instance LayoutSelect LNil a where + type SelectorFor LNil = End -- LNil cannot be selected. + update _ _ _ = return Nothing + +-- Instance of layout class for LayoutList. The implementation for this +-- just delegates to the underlying LayoutSelect class using the generic +-- update method. +instance (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a where + + runLayout (W.Workspace i (LayoutList idx l) ms) r = do + r <- update idx l $ \layout -> + runLayout (W.Workspace i layout ms) r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + pureLayout (LayoutList idx l) r s = runIdentity $ do + r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) + case r of + Nothing -> return [] + Just (r, a) -> return r + + emptyLayout (LayoutList idx l) r = do + r <- update idx l $ \layout -> emptyLayout layout r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = + return $ Just (LayoutList (fn idx) l) + + handleMessage (LayoutList idx l) m = do + r <- update idx l $ \layout -> ((),) <$> handleMessage layout m + return $ LayoutList idx . snd <$> r + + pureMessage (LayoutList idx l) m = runIdentity $ do + r <- update idx l $ \layout -> return ((), pureMessage layout m) + return $ LayoutList idx . snd <$> r + + description (LayoutList idx l) = runIdentity $ do + r <- update idx l $ \l -> return (description l, Nothing) + return $ + case r of + Nothing -> "No Layout" + Just (descr, _) -> descr diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs new file mode 100644 index 0000000..c90a5d7 --- /dev/null +++ b/src/Rahm/Desktop/Lib.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RankNTypes #-} +module Rahm.Desktop.Lib where + +import Prelude hiding ((!!)) + +import XMonad.Actions.DynamicWorkspaces +import XMonad.Util.Run +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell + +import Rahm.Desktop.PromptConfig + +import Data.Char +import Data.List hiding ((!!)) +import Data.List.Safe ((!!)) +import Data.Maybe +import Rahm.Desktop.Marking +import Text.Printf +import XMonad hiding (workspaces, Screen) +import XMonad.StackSet hiding (filter, focus) +import qualified Data.Map as Map +import Rahm.Desktop.DMenu +import Data.Ord (comparing) + +import qualified XMonad.StackSet as S +import Rahm.Desktop.Windows + +type WorkspaceName = Char +newtype Selector = Selector (forall a. (Eq a) => a -> [a] -> a) + +data WinPrompt = WinPrompt + +instance XPrompt WinPrompt where + showXPrompt _ = "[Window] " + commandToComplete _ = id + +data WorkspaceState = Current | Hidden | Visible + deriving (Ord, Eq, Enum) + +-- Returns all the workspaces that are either visible, current or Hidden but +-- have windows and that workspace's state. +-- +-- In other words, filters out workspaces that have no windows and are not +-- visible. +-- +-- This function will sort the result by the workspace tag. +getPopulatedWorkspaces :: + (Ord i) => S.StackSet i l a sid sd -> [(WorkspaceState, S.Workspace i l a)] +getPopulatedWorkspaces (S.StackSet (S.Screen cur _ _) vis hi _) = + sortOn (tag . snd) $ + mapMaybe (\w@(S.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ + map (\(S.Screen w _ _) -> (Visible, w)) vis ++ + [(Current, cur)] + +getHorizontallyOrderedScreens :: + StackSet wid l a ScreenId ScreenDetail -> + [Screen wid l a ScreenId ScreenDetail] +-- ^ Returns a list of screens ordered from leftmost to rightmost. +getHorizontallyOrderedScreens windowSet = + flip sortBy screens $ \sc1 sc2 -> + let (SD (Rectangle x1 _ _ _)) = screenDetail sc1 + (SD (Rectangle x2 _ _ _)) = screenDetail sc2 + in x1 `compare` x2 + where + screens = current windowSet : visible windowSet + +getCurrentWorkspace :: X WorkspaceName +getCurrentWorkspace = withWindowSet $ + \(StackSet (Screen (Workspace t _ _) _ _) _ _ _) -> do + return (head t) + +gotoAccompaningWorkspace :: X () +gotoAccompaningWorkspace = do + cur <- getCurrentWorkspace + if isUpper cur + then gotoWorkspace (toLower cur) + else gotoWorkspace (toUpper cur) + +gotoWorkspace :: WorkspaceName -> X () +gotoWorkspace ch = pushHistory $ do + addHiddenWorkspace [ch] + windows $ greedyView $ return ch + +shiftToWorkspace :: WorkspaceName -> X () +shiftToWorkspace ch = do + addHiddenWorkspace [ch] + (windows . shift . return) ch + +swapWorkspace :: WorkspaceName -> X () +swapWorkspace toWorkspaceName = do + addHiddenWorkspace [toWorkspaceName] + windows $ \ss -> do + let fromWorkspace = tag $ workspace $ current ss + toWorkspace = [toWorkspaceName] in + StackSet (swapSc fromWorkspace toWorkspace $ current ss) + (map (swapSc fromWorkspace toWorkspace) $ visible ss) + (map (swapWs fromWorkspace toWorkspace) $ hidden ss) + (floating ss) + where + swapSc fromWorkspace toWorkspace (Screen ws a b) = + Screen (swapWs fromWorkspace toWorkspace ws) a b + + swapWs fromWorkspace toWorkspace ws@(Workspace t' l s) + | t' == fromWorkspace = Workspace toWorkspace l s + | t' == toWorkspace = Workspace fromWorkspace l s + | otherwise = ws + +fuzzyCompletion :: String -> String -> Bool +fuzzyCompletion str0 str1 = + all (`isInfixOf`l0) ws + where + ws = filter (not . all isSpace) $ words (map toLower str0) + l0 = map toLower str1 + +getString :: Window -> X String +getString = runQuery $ do + t <- title + a <- appName + return $ + if map toLower a `isInfixOf` map toLower t + then t + else printf "%s - %s" t a + +withRelativeWorkspace :: Selector -> (WorkspaceId -> WindowSet -> WindowSet) -> X () +withRelativeWorkspace (Selector selector) fn = + windows $ \ss -> + let tags = sort (tag . snd <$> filter (\x -> fst x /= Visible ) (getPopulatedWorkspaces ss)) + from = tag $ workspace $ current ss + to = selector from tags + in fn to ss + +next :: Selector +next = Selector $ \a l -> select a l l + where select n (x:y:xs) _ | n == x = y + select n [x] (y:_) | n == x = y + select n (x:xs) orig = select n xs orig + select n _ _ = n + +prev :: Selector +prev = Selector $ \a l -> + let (Selector fn) = next in fn a (reverse l) + +withScreen :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X () +withScreen fn n = do + windows $ \windowSet -> + case getHorizontallyOrderedScreens windowSet !! n of + Nothing -> windowSet + Just screen -> fn (tag $ workspace screen) windowSet + +windowJump :: X () +windowJump = pushHistory $ do + windowTitlesToWinId <- withWindowSet $ \ss -> + Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss) + + windowId <- runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId + + case windowId of + Nothing -> return () + Just wid -> focus wid diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs new file mode 100644 index 0000000..c73942f --- /dev/null +++ b/src/Rahm/Desktop/Logger.hs @@ -0,0 +1,32 @@ +module Rahm.Desktop.Logger where + +import XMonad +import qualified XMonad.Util.ExtensibleState as XS +import System.IO + +import Rahm.Desktop.NoPersist + +newtype LoggerState = + LoggerState { + logHandle :: Maybe (NoPersist Handle) + } + +instance ExtensionClass LoggerState where + initialValue = LoggerState Nothing + +logs :: String -> X () +logs s = do + LoggerState handle' <- XS.get + + handle <- + case handle' of + Nothing -> do + handle <- io $ openFile "/tmp/xmonad.log" AppendMode + XS.put $ LoggerState $ Just $ NoPersist handle + return handle + + Just (NoPersist h) -> return h + + io $ do + hPutStrLn handle s + hFlush handle diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs new file mode 100644 index 0000000..8e9867d --- /dev/null +++ b/src/Rahm/Desktop/Marking.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Rahm.Desktop.Marking ( + historyNext, historyPrev, + markCurrentWindow, pushHistory, + jumpToMark, jumpToLast, swapWithLastMark, + swapWithMark + ) where + +import Rahm.Desktop.Windows (mapWindows, findWindow, getLocationWorkspace) +import XMonad +import XMonad.StackSet hiding (focus) +import Data.IORef +import Data.Map (Map) +import Control.Monad (when) + +import System.FilePath +import System.IO +import Control.Exception +import System.Environment +import qualified Data.Sequence as Seq +import Data.Sequence (Seq(..)) + +import qualified XMonad.Util.ExtensibleState as XS + +import qualified Data.Map as Map + +{- Submodule that handles marking windows so they can be jumped back to. -} + +type Mark = Char + +historySize = 100 -- max number of history elements the tail. + +data History a = History [a] (Seq a) + deriving (Read, Show) + +instance Default (History a) where + + def = History [] Seq.empty + +seqPush :: a -> Seq a -> Seq a +seqPush elem s@(seq :|> _) | Seq.length s >= historySize = elem :<| seq +seqPush elem s = elem :<| s + +historyForward :: History a -> History a +historyForward (History (a:as) tail) = History as (seqPush a tail) +historyForward z = z + +historyBackward :: History a -> History a +historyBackward (History head (a :<| as)) = History (a : head) as +historyBackward z = z + +historyCurrent :: History a -> Maybe a +historyCurrent (History (a:_) _) = Just a +historyCurrent _ = Nothing + +historyPush :: (Eq a) => a -> History a -> History a +historyPush a h@(History (w : _) _) | a == w = h +historyPush a (History (w : _) tail) = History [a] (seqPush w tail) +historyPush a (History _ tail) = History [a] tail + +historySwap :: History a -> History a +historySwap (History (a:as) (t :<| ts)) = History (t : as) (seqPush a ts) +historySwap z = z + +historyLast :: History a -> Maybe a +historyLast (History _ (t :<| _)) = Just t +historyLast _ = Nothing + +data Spot = + WindowSpot Window | -- Focus is on a window. + TagSpot String -- Focus is on an (empty) tag + deriving (Read, Show, Eq, Ord) + +greedyFocus :: Spot -> X () +greedyFocus (WindowSpot win) = do + ws <- withWindowSet $ \ss -> + return $ getLocationWorkspace =<< findWindow ss win + + mapM_ (windows . greedyView . tag) ws + focus win +greedyFocus (TagSpot tag) = + windows $ greedyView tag + +data MarkState = + MarkState { + markStateMap :: Map Mark Window + , windowHistory :: History Spot + } deriving (Read, Show) + + +instance ExtensionClass MarkState where + initialValue = MarkState Map.empty def + extensionType = PersistentExtension + +changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState) +changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)} + +withMaybeFocused :: (Maybe Window -> X ()) -> X () +withMaybeFocused f = withWindowSet $ f . peek + +normalizeWindows :: X () +normalizeWindows = do + MarkState { windowHistory = h } <- XS.get + mapM_ greedyFocus (historyCurrent h) + +-- greedyFocus :: Window -> X () +-- greedyFocus win = do +-- ws <- withWindowSet $ \ss -> +-- return $ getLocationWorkspace =<< findWindow ss win +-- +-- mapM_ (windows . greedyView . tag) ws +-- focus win + +markCurrentWindow :: Mark -> X () +markCurrentWindow mark = do + withFocused $ \win -> + XS.modify $ \state@MarkState {markStateMap = ms} -> + state { + markStateMap = Map.insert mark win ms + } + +pushHistory :: X () -> X () +pushHistory fn = do + withMaybeFocused $ \maybeWindowBefore -> do + case maybeWindowBefore of + (Just windowBefore) -> + XS.modify $ changeHistory (historyPush (WindowSpot windowBefore)) + Nothing -> + withWindowSet $ \ws -> + XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws))) + + fn + + withMaybeFocused $ \maybeWindowAfter -> + case maybeWindowAfter of + Just windowAfter -> + XS.modify $ changeHistory (historyPush $ WindowSpot windowAfter) + Nothing -> + withWindowSet $ \ws -> + XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws) + +withHistory :: (History Spot -> X ()) -> X () +withHistory fn = do + MarkState { windowHistory = w } <- XS.get + fn w + +jumpToLast :: X () +jumpToLast = do + XS.modify (changeHistory historySwap) + normalizeWindows + +jumpToMark :: Mark -> X () +jumpToMark mark = do + MarkState {markStateMap = m} <- XS.get + case Map.lookup mark m of + Nothing -> return () + Just w -> pushHistory $ + greedyFocus (WindowSpot w) + +setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd +setFocusedWindow + window + (StackSet (Screen (Workspace t l stack) a b) vis hid float) = + let newStack = + case stack of + Nothing -> Nothing + Just (Stack _ up down) -> Just (Stack window up down) in + StackSet (Screen (Workspace t l newStack) a b) vis hid float + +swapWithFocused :: (Ord a) => a -> StackSet i l a s sd -> StackSet i l a s sd +swapWithFocused winToSwap stackSet = + case peek stackSet of + Nothing -> stackSet + Just focused -> do + setFocusedWindow winToSwap $ + mapWindows ( + \w -> if w == winToSwap then focused else w) stackSet + +swapWithLastMark :: X () +swapWithLastMark = pushHistory $ withHistory $ \hist -> do + + case historyLast hist of + Just (WindowSpot win) -> + windows $ swapWithFocused win + Nothing -> return () + +swapWithMark :: Mark -> X () +swapWithMark mark = pushHistory $ do + MarkState {markStateMap = m} <- XS.get + + case Map.lookup mark m of + Nothing -> return () + Just winToSwap -> do + windows $ swapWithFocused winToSwap + +historyPrev :: X () +historyPrev = do + XS.modify $ changeHistory historyBackward + normalizeWindows + +historyNext :: X () +historyNext = do + XS.modify $ changeHistory historyForward + normalizeWindows diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs new file mode 100644 index 0000000..488f06a --- /dev/null +++ b/src/Rahm/Desktop/MouseMotion.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ViewPatterns, BangPatterns #-} +module Rahm.Desktop.MouseMotion where + +import XMonad + +import Control.Monad (void, forever) +import Text.Printf +import Rahm.Desktop.Submap +import Control.Monad.Loops (iterateWhile) +import Control.Monad.Fix (fix) +import Rahm.Desktop.Logger + +import Linear.V2 +import Linear.Metric + +data Quadrant = NE | SE | SW | NW deriving (Enum, Show) +data Direction = CW | CCW deriving (Enum, Show) + +getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant +getQuadrant (x, y) | x >= 0 && y >= 0 = NE +getQuadrant (x, y) | x < 0 && y >= 0 = SE +getQuadrant (x, y) | x < 0 && y < 0 = SW +getQuadrant (x, y) = NW + + +getDirection :: Quadrant -> Quadrant -> Maybe Direction +getDirectory a b | a == b = Nothing +getDirection SW SE = Just CCW +getDirection SE NE = Just CCW +getDirection NE NW = Just CCW +getDirection NW SW = Just CCW +getDirection _ _ = Just CW + + +liftMouseMotionM :: X a -> MouseMotionM a +liftMouseMotionM = MouseMotionM . fmap Just + +motion :: MouseMotionM (V2 Int) +motion = MouseMotionM $ do + ev <- nextMotionOrButton + case ev of + Right button -> do + logs ("Button " ++ show button) + return Nothing + + Left motion -> return (Just $ uncurry V2 motion) + +motionSize :: Int -> MouseMotionM (V2 Int) +motionSize size = do + let fsize = fromIntegral size + + !firstmotion <- fmap fromIntegral <$> motion + + let get = do + !next <- motion + if distance (fmap fromIntegral next) firstmotion >= fsize + then return next + else get + + get + +runMouseMotionM :: MouseMotionM a -> X (Maybe a) +runMouseMotionM (MouseMotionM a) = a + +execMouseMotionM :: MouseMotionM () -> X () +execMouseMotionM = void . runMouseMotionM + +-- Monad for capturing mouse motion. Terminates and holds Nothing when a +-- button is pressed. +newtype MouseMotionM a = MouseMotionM (X (Maybe a)) + +instance Functor MouseMotionM where + fmap fn (MouseMotionM xma) = MouseMotionM (fmap (fmap fn) xma) + +instance Applicative MouseMotionM where + mf <*> ma = do + !f <- mf + !a <- ma + return (f a) + + pure = return + +instance Monad MouseMotionM where + return a = MouseMotionM (return (Just a)) + (MouseMotionM !xa) >>= fn = MouseMotionM $ do + !ma <- xa + case ma of + Just !a -> + let (MouseMotionM !xb) = fn a in xb + Nothing -> return Nothing + +mouseRotateMotion :: X () -> X () -> X () +mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse + where + doMouse = forever $ do + v <- motion + liftMouseMotionM $ logs $ "Motion: " ++ show v diff --git a/src/Rahm/Desktop/NoPersist.hs b/src/Rahm/Desktop/NoPersist.hs new file mode 100644 index 0000000..66e52da --- /dev/null +++ b/src/Rahm/Desktop/NoPersist.hs @@ -0,0 +1,23 @@ +-- Module for not persisting XMonad state. To be used with ExtensibleState +-- for data types that cannot be persisted. +module Rahm.Desktop.NoPersist where + +import Data.Default (Default, def) +import Data.Typeable + +import XMonad (ExtensionClass(..)) + +newtype NoPersist a = NoPersist a + deriving (Typeable) + +instance Show (NoPersist a) where + show (NoPersist _) = show () + +instance (Default a) => Read (NoPersist a) where + readsPrec i s = map (\(_, s) -> (NoPersist def, s)) (readsPrec i s :: [((), String)]) + +instance (Default a) => Default (NoPersist a) where + def = NoPersist def + +instance (Default a, Typeable a) => ExtensionClass (NoPersist a) where + initialValue = NoPersist def diff --git a/src/Rahm/Desktop/PassMenu.hs b/src/Rahm/Desktop/PassMenu.hs new file mode 100644 index 0000000..4c0b4c5 --- /dev/null +++ b/src/Rahm/Desktop/PassMenu.hs @@ -0,0 +1,13 @@ +module Rahm.Desktop.PassMenu where + +import XMonad +import XMonad.Util.Run +import Control.Monad + +runPassMenu :: X () +runPassMenu = void $ + safeSpawn "rofi-pass" [ + "-p", "Password ", + "-theme-str", + "* {theme-color: #f54245;}"] + diff --git a/src/Rahm/Desktop/PromptConfig.hs b/src/Rahm/Desktop/PromptConfig.hs new file mode 100644 index 0000000..ce45cb2 --- /dev/null +++ b/src/Rahm/Desktop/PromptConfig.hs @@ -0,0 +1,12 @@ +module Rahm.Desktop.PromptConfig where + +import XMonad.Prompt + +xpConfig :: XPConfig +xpConfig = def { + font = "xft:Source Code Pro:size=10" + , bgColor = "#404040" + , fgColor = "#8888ff" + , promptBorderWidth = 0 + , height = 40 + } diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs new file mode 100644 index 0000000..0b4d768 --- /dev/null +++ b/src/Rahm/Desktop/RebindKeys.hs @@ -0,0 +1,119 @@ + +-- Module for intercepting key presses not explicity mapped in the key bindings. +-- This uses some deep magic with grabKey and windows and everything else, but +-- it makes window-specific key bindings awesome! +module Rahm.Desktop.RebindKeys where + +import XMonad + +import Text.Printf +import Control.Monad.Trans.Class (lift) +import Control.Monad (forM, forM_) +import Data.Default (Default, def) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified XMonad.Util.ExtensibleState as XS +import Data.Monoid (All(..)) + +import Rahm.Desktop.Logger +import Rahm.Desktop.NoPersist + +type WindowHook = Query () + +newtype InterceptState = + InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) + +newtype RemapState = + RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) + +instance ExtensionClass InterceptState where + initialValue = InterceptState def + +instance ExtensionClass RemapState where + initialValue = RemapState def + +remapHook :: Event -> X All +remapHook event = do + RemapState (NoPersist map) <- XS.get + + case event of + KeyEvent { ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m } + | typ == keyPress-> do + XConf {display = dpy, theRoot = rootw} <- ask + keysym <- io $ keycodeToKeysym dpy code 0 + + case Map.lookup (win, (m, keysym)) map of + + Just xdo -> do + xdo + return (All False) + + Nothing -> return (All True) + + _ -> return (All True) + +getKeyCodesForKeysym :: Display -> KeySym -> IO [KeyCode] +getKeyCodesForKeysym dpy keysym = do + let (minCode, maxCode) = displayKeycodes dpy + allCodes = [fromIntegral minCode .. fromIntegral maxCode] + + syms <- forM allCodes $ \code -> keycodeToKeysym dpy code 0 + let keysymMap' = Map.fromListWith (++) (zip syms [[code] | code <- allCodes]) + + -- keycodeToKeysym returns noSymbol for all unbound keycodes, and we don't + -- want to grab those whenever someone accidentally uses def :: KeySym + let keysymMap = Map.delete noSymbol keysymMap' + let keysymToKeycodes sym = Map.findWithDefault [] keysym keysymMap + + return $ keysymToKeycodes keysym + + +doGrab :: Display -> Window -> (KeyMask, KeySym) -> X () +doGrab dpy win (keyMask, keysym) = do + let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync + + codes <- io $ getKeyCodesForKeysym dpy keysym + + forM_ codes $ \kc -> + mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers + +disableKey :: (KeyMask, KeySym) -> WindowHook +disableKey key = remapKey key (return ()) + +remapKey :: (KeyMask, KeySym) -> X () -> WindowHook +remapKey keyFrom action = do + window <- ask + Query $ lift $ do + XConf { display = disp, theRoot = rootw } <- ask + doGrab disp window keyFrom + + XS.modify $ \(RemapState (NoPersist keyMap)) -> RemapState $ NoPersist $ + Map.insert (window, keyFrom) action keyMap + +-- sendKey, but as a query. +sendKeyQ :: (KeyMask, KeySym) -> Query () +sendKeyQ key = do + win <- ask + liftX (sendKey key win) + +sendKey :: (KeyMask, KeySym) -> Window -> X () +sendKey (keymask, keysym) w = do + XConf { display = disp, theRoot = rootw } <- ask + + codes <- io $ getKeyCodesForKeysym disp keysym + + case codes of + (keycode:_) -> + io $ allocaXEvent $ \xEv -> do + setEventType xEv keyPress + setKeyEvent xEv w rootw none keymask keycode True + sendEvent disp w True keyPressMask xEv + + setEventType xEv keyRelease + sendEvent disp w True keyReleaseMask xEv + + _ -> return () + +rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook +rebindKey keyFrom keyTo = + (remapKey keyFrom . sendKey keyTo) =<< ask diff --git a/src/Rahm/Desktop/ScreenRotate.hs b/src/Rahm/Desktop/ScreenRotate.hs new file mode 100644 index 0000000..1f238b1 --- /dev/null +++ b/src/Rahm/Desktop/ScreenRotate.hs @@ -0,0 +1,19 @@ +module Rahm.Desktop.ScreenRotate where + +import XMonad.StackSet as W + +screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateBackward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = tail $ cycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + +screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateForward (W.StackSet current visible others floating) = do + let screens = current : visible + workspaces = rcycle $ map W.workspace screens + (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces + in W.StackSet current' visible' others floating + + where rcycle l = last l : l diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs new file mode 100644 index 0000000..f3b9e23 --- /dev/null +++ b/src/Rahm/Desktop/Submap.hs @@ -0,0 +1,104 @@ +module Rahm.Desktop.Submap ( + mapNextString, + mapNextStringWithKeysym, + submapButtonsWithKey, + nextButton, + nextMotion, + nextMotionOrButton, + module X) where + +import XMonad hiding (keys) +import Control.Monad.Fix (fix) +import qualified Data.Map as Map +import Data.Map (Map) + +import XMonad.Actions.Submap as X + +{- + - Like submap fram XMonad.Actions.Submap, but sends the string from + - XLookupString to the function along side the keysym. + - + - This function allows mappings where the mapped string might be important, + - but also allows submappings for keys that may not have a character associated + - with them (for example, the function keys). + -} +mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X a) -> X a +mapNextStringWithKeysym fn = do + XConf { theRoot = root, display = d } <- ask + io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime + + (m, str, keysym) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do + maskEvent d keyPressMask p + KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + + if isModifierKey keysym + then nextkey + else return (m, str, keysym) + + io $ ungrabKeyboard d currentTime + + fn m keysym str + +{- Like submap, but on the character typed rather than the kysym. -} +mapNextString :: (KeyMask -> String -> X a) -> X a +mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) + +{- Grabs the mouse and returns the next button press. -} +nextButton :: X (ButtonMask, Button) +nextButton = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d buttonPressMask xEv + ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv + return (m, button) + + io $ ungrabPointer d currentTime + + return ret + +{- Grabs the mouse and reports the next mouse motion. -} +nextMotion :: X (Int, Int) +nextMotion = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d pointerMotionMask xEv + MotionEvent { ev_x = x, ev_y = y } <- getEvent xEv + return (fromIntegral x, fromIntegral y) + + io $ ungrabPointer d currentTime + + return ret + +{- Grabs the mouse and reports the next mouse motion or button press. -} +nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button)) +nextMotionOrButton = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime + + ret <- io $ allocaXEvent $ \xEv -> do + maskEvent d (pointerMotionMask .|. buttonPressMask) xEv + ev <- getEvent xEv + case ev of + MotionEvent { ev_x = x, ev_y = y } -> + return $ Left (fromIntegral x, fromIntegral y) + ButtonEvent { ev_button = button, ev_state = m } -> + return $ Right (m, button) + + io $ ungrabPointer d currentTime + + return ret + +submapButtonsWithKey :: + ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X () +submapButtonsWithKey defaultAction actions window = do + arg <- nextButton + + case Map.lookup arg actions of + Nothing -> defaultAction arg window + Just fn -> fn window diff --git a/src/Rahm/Desktop/Swallow.hs b/src/Rahm/Desktop/Swallow.hs new file mode 100644 index 0000000..1939c58 --- /dev/null +++ b/src/Rahm/Desktop/Swallow.hs @@ -0,0 +1,29 @@ +module Rahm.Desktop.Swallow ( + swallowHook, setSwallowEnabled, isSwallowEnabled, toggleSwallowEnabled) where + +import XMonad +import Data.Monoid (All) +import XMonad.Hooks.WindowSwallowing +import XMonad.Util.ExtensibleState as XS + +data DisableSwallow = DisableSwallow Bool deriving (Show) + +swallowHook :: Event -> X All +swallowHook = swallowEventHook (className =? "Alacritty") $ + liftX $ do + (DisableSwallow disable) <- XS.get + return (not disable) + +isSwallowEnabled :: X Bool +isSwallowEnabled = do + (DisableSwallow b) <- XS.get + return (not b) + +setSwallowEnabled :: Bool -> X () +setSwallowEnabled enable = XS.modify $ const $ DisableSwallow $ not enable + +toggleSwallowEnabled :: X () +toggleSwallowEnabled = (setSwallowEnabled . not) =<< isSwallowEnabled + +instance ExtensionClass DisableSwallow where + initialValue = DisableSwallow False diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs new file mode 100644 index 0000000..b039fdb --- /dev/null +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -0,0 +1,41 @@ +{- Swap window with the master, but save it. -} +module Rahm.Desktop.SwapMaster (swapMaster) where + +import qualified XMonad.StackSet as W + +import Rahm.Desktop.Windows (mapWindows, getMaster, swapWindows) +import Control.Monad.Trans.Maybe +import XMonad (Window, ExtensionClass(..), X(..), windows, windowset) +import Control.Monad (void) +import Control.Monad.Trans (lift) +import Data.Maybe (fromMaybe) +import Control.Monad.State (gets) + +import qualified XMonad.Util.ExtensibleState as XS + +newtype LastWindow = LastWindow { + lastWindow :: Maybe Window + } deriving (Show, Read) + +instance ExtensionClass LastWindow where + initialValue = LastWindow Nothing + +hoist :: (Monad m) => Maybe a -> MaybeT m a +hoist = MaybeT . return + +swapMaster :: X () +swapMaster = void $ runMaybeT $ do + ss <- gets windowset + + focused <- hoist $ W.peek ss + master <- hoist $ getMaster ss + + if focused == master + then do + lw <- MaybeT $ lastWindow <$> XS.get + lift $ windows (swapWindows focused lw) + else lift $ windows (swapWindows focused master) + + lift $ do + XS.put (LastWindow $ Just master) + windows W.focusMaster diff --git a/src/Rahm/Desktop/Windows.hs b/src/Rahm/Desktop/Windows.hs new file mode 100644 index 0000000..d525aac --- /dev/null +++ b/src/Rahm/Desktop/Windows.hs @@ -0,0 +1,86 @@ +module Rahm.Desktop.Windows where + +import XMonad (windowset, X, Window, get) + +import Control.Applicative ((<|>)) +import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) +import Data.Maybe (listToMaybe, catMaybes) +import qualified Data.Map as Map + +mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd +mapWindows fn (StackSet cur vis hid float) = + StackSet + (mapWindowsScreen cur) + (map mapWindowsScreen vis) + (map mapWindowsWorkspace hid) + (Map.mapKeys fn float) + where + mapWindowsScreen (Screen work a b) = Screen (mapWindowsWorkspace work) a b + mapWindowsWorkspace (Workspace t l stack) = + Workspace t l (fmap (mapStack fn) stack) + +-- | What genius decided to hide the instances for the Stack type!!??? +mapStack :: (a -> b) -> Stack a -> Stack b +mapStack fn (Stack focus up down) = Stack (fn focus) (map fn up) (map fn down) + +getMaster :: StackSet i l a s sd -> Maybe a +getMaster (StackSet (Screen (Workspace _ _ ss) _ _) _ _ _) = + head . integrate <$> ss + +swapWindows :: (Ord a) => a -> a -> StackSet i l a s d -> StackSet i l a s d +swapWindows wa wb = mapWindows $ \w -> + case w of + _ | w == wa -> wb + _ | w == wb -> wa + _ -> w + +data WindowLocation i l a s sd = + OnScreen (Screen i l a s sd) | + OnHiddenWorkspace (Workspace i l a) | + Floating + +getLocationWorkspace :: WindowLocation i l a s sd -> Maybe (Workspace i l a) +getLocationWorkspace (OnScreen (Screen w _ _)) = Just w +getLocationWorkspace (OnHiddenWorkspace w) = Just w +getLocationWorkspace _ = Nothing + +workspaceMember :: (Eq a) => Workspace i l a -> a -> Bool +workspaceMember (Workspace _ _ s) w = w `elem` integrate' s + +forAllWindows :: (Window -> X ()) -> X () +forAllWindows fn = do + stackSet <- windowset <$> get + mapM_ fn (allWindows stackSet) + +getFocusedWindow :: X (Maybe Window) +getFocusedWindow = do + peek . windowset <$> get + +{- Finds a Window and returns the screen its on and the workspace its on. + - Returns nothing if the window doesn't exist. + - + - If the window is not a screen Just (Nothing, workspace) is returned. + - If the window is a floating window Just (Nothing, Nothing) is returned. -} +findWindow :: + (Eq a) => StackSet i l a s sd -> a -> Maybe (WindowLocation i l a s sd) +findWindow (StackSet cur vis hid float) win = + listToMaybe . catMaybes $ + map findWindowScreen (cur : vis) ++ + map findWindowWorkspace hid ++ + [findWindowFloat] + + where + findWindowScreen s@(Screen ws _ _) = + if workspaceMember ws win + then Just (OnScreen s) + else Nothing + + findWindowWorkspace w = + if workspaceMember w win + then Just (OnHiddenWorkspace w) + else Nothing + + findWindowFloat = + if win `elem` Map.keys float + then Just Floating + else Nothing diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs new file mode 100644 index 0000000..f3beb86 --- /dev/null +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -0,0 +1,78 @@ +module Rahm.Desktop.XMobarLog ( XMobarLog, spawnXMobar, xMobarLogHook ) where + +import Control.Arrow (second) +import Control.Monad (forM_) +import Control.Monad.Writer (tell, execWriter) +import Data.List (sortBy) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Rahm.Desktop.LayoutDraw (drawLayout) +import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Run (spawnPipe) +import XMonad (X) +import Rahm.Desktop.Lib (getPopulatedWorkspaces, WorkspaceState(..)) + +import qualified XMonad as X +import qualified XMonad.StackSet as S + +data XMobarLog = XMobarLog Handle + +-- The log hook for XMobar. This is a custom log hook that does not use any +-- of the Xmonad dynamic log libraries. +-- +-- This is because the given dynamic log libraries don't handle unicode properly +-- and this has been causing issues. It is also more flexible and frankly easier +-- to just DIY. + +spawnXMobar :: IO XMobarLog +spawnXMobar = do + pipe <- spawnPipe "xmobar" + hSetEncoding pipe utf8 + return (XMobarLog pipe) + + +-- XMonad Log Hook meant to be used with the XMonad config logHook. +xMobarLogHook :: XMobarLog -> X () +xMobarLogHook (XMobarLog xmproc) = do + (_, _, layoutXpm) <- drawLayout + + winset <- X.gets X.windowset + title <- maybe (pure "") (fmap show . getName) . S.peek $ winset + let wss = getPopulatedWorkspaces winset + + X.liftIO $ do + hPutStrLn xmproc $ trunc 80 $ execWriter $ do + tell layoutXpm + tell $ " │ " + + forM_ wss $ \(t, ws) -> do + case t of + Current -> tell "" + Visible -> tell "" + Hidden -> tell "" + tell (S.tag ws) + tell " " + + tell $ "│ " + tell $ title + tell $ "" + +-- Truncate an XMobar string to the provided number of _visible_ characters. +-- This is to keep long window titles from overrunning the whole bar. +trunc :: Int -> String -> String +trunc amt str = reverse $ trunc' False amt str [] + where + trunc' _ _ [] acc = acc + trunc' ignore amt (a:as) acc = + case a of + '<' -> trunc' True amt as (a : acc) + '>' -> trunc' False amt as (a : acc) + _ -> + if ignore + then trunc' True amt as (a : acc) + else + case amt of + 0 -> trunc' False 0 as acc + 3 -> trunc' False 0 as ("..." ++ acc) + _ -> trunc' False (amt - 1) as (a : acc) -- cgit