diff options
38 files changed, 1839 insertions, 1705 deletions
diff --git a/extras/HOME/.xmobarrc b/extras/HOME/.xmobarrc index 85e3cea..efd7865 100644 --- a/extras/HOME/.xmobarrc +++ b/extras/HOME/.xmobarrc @@ -1,13 +1,13 @@ Config { font = "xft:Monofur Nerd Font:size=12" , additionalFonts = [ - "xft:Monofur bold Nerd Font:style=bold:size=12", - "xft:Monofur bold Nerd Font:size=9", "xft:Monofur bold Nerd Font:style=bold:size=10", + "xft:Monofur bold Nerd Font:size=7", + "xft:Monofur bold Nerd Font:style=bold:size=8", "xft:Monofur Nerd Font:size=6", - "xft:Monofur bold Nerd Font:size=20", - "xft:Monofur Nerd Font:style=bold:size=10", - "xft:Noto Sans Mono CJK JP:style=bold:size=10" + "xft:Monofur bold Nerd Font:size=18", + "xft:Monofur Nerd Font:style=bold:size=8", + "xft:Noto Sans Mono CJK JP:style=bold:size=8" ] , borderColor = "black" , border = FullBM -1 @@ -30,12 +30,12 @@ Config , template = " %logo% <fc=#a0a0a0><fn=3>%uname%</fn></fc> \ \%UnsafeStdinReader%}{\ - \ %cpu% %memory% <fc=#404040>\ + \ %cpu% %memory% <fc=#404040>\ \<action=alacritty -t 'Floating Term' -e sh -c 'curl wttr.in ; read i'>\ - \%weather% \ + \%weather% \ \</action>\ - \</fc><fc=#a0a0a0>%media% </fc>\ - \%bluetooth% %bat%<fn=3><fc=#8888ff> %time%</fc></fn> " + \</fc><fc=#a0a0a0>%media% </fc>\ + \%bluetooth% %bat%<fn=3><fc=#8888ff> %time%</fc></fn> " , commands = [ Run UnsafeStdinReader, Run Date "%m/%d %H:%M:%S" "time" 10, diff --git a/package.yaml b/package.yaml index cd62c0e..11eabfa 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ ghc-options: - -XTupleSections - -XTypeFamilies - -XViewPatterns + - -XLambdaCase dependencies: - base >= 4.0.0 diff --git a/src/Main.hs b/src/Main.hs index a98e568..766716c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,33 +1,30 @@ -import XMonad - -import XMonad.Hooks.DynamicProperty -import Control.Monad.Trans.Class import Control.Monad.Reader -import XMonad.Hooks.ManageDocks (docks) -import System.Directory (getHomeDirectory) -import System.FilePath ((</>)) -import XMonad.Hooks.EwmhDesktops (ewmh) -import XMonad.Hooks.ManageHelpers (isFullscreen, doFullFloat) -import XMonad.Layout.Fullscreen (fullscreenEventHook) -import System.Environment (setEnv) -import Data.Monoid +import Control.Monad.Trans.Class import qualified Data.Map as Map -import Text.Printf - -import Rahm.Desktop.Swallow -import Rahm.Desktop.Marking +import Data.Monoid import Rahm.Desktop.Common -import Rahm.Desktop.XMobarLog +import Rahm.Desktop.DMenu (menuCommandString) +import Rahm.Desktop.History +import Rahm.Desktop.Hooks.WindowChange import Rahm.Desktop.Keys import Rahm.Desktop.Layout import Rahm.Desktop.Logger -import Rahm.Desktop.DMenu (menuCommandString) +import Rahm.Desktop.Marking import Rahm.Desktop.RebindKeys -import Rahm.Desktop.Hooks.WindowChange -import Rahm.Desktop.History - -import qualified XMonad as X import qualified Rahm.Desktop.StackSet as W +import Rahm.Desktop.Swallow +import Rahm.Desktop.XMobarLog +import System.Directory (getHomeDirectory) +import System.Environment (setEnv) +import System.FilePath ((</>)) +import Text.Printf +import XMonad +import qualified XMonad as X +import XMonad.Hooks.DynamicProperty +import XMonad.Hooks.EwmhDesktops (ewmh) +import XMonad.Hooks.ManageDocks (docks) +import XMonad.Hooks.ManageHelpers (doFullFloat, isFullscreen) +import XMonad.Layout.Fullscreen (fullscreenEventHook) main = do putStrLn "Welcome To RDE!" @@ -41,49 +38,56 @@ main = do xmobar <- spawnXMobar - (=<<) X.xmonad $ - applyKeys $ withLocationChangeHook historyHook $ ewmh $ docks $ def - { terminal = "alacritty" - , modMask = mod3Mask - , borderWidth = 2 - , keys = const mempty - , focusedBorderColor = "#ff6c00" - , normalBorderColor = "#404040" - , layoutHook = myLayout - , startupHook = spawn fp - , manageHook = composeAll [ - isFullscreen --> doFullFloat - , doLogWindow - , className =? "Tilda" --> doFloat - , className =? "yakuake" --> doFloat - , className =? "MPlayer" --> doFloat - , title =? "Event Tester" --> doFloat - , title =? "Floating Term" --> doCenterFloat - , title =? "Notes" --> doCenterFloat - , title =? "xmessage" --> doCenterFloat - , title =? "gxmessage" --> doCenterFloat - , title =? "Volume Control" --> doCenterFloat - , className =? "mpv" --> doFloat - , className =? "gnubby_ssh_prompt" --> doFloat - ] - -- This config uses dynamic workspaces, but I have to seed XMonad - -- with something. However, this configuration only supports 36 - -- monitors on boot. If you need more than 36 monitors, you'll have to - -- configure those ones after starting XMonad. - , workspaces = map return (['0'..'9'] ++ ['a'..'z']) - , handleEventHook = - composeAll [ - fullscreenEventHook, - remapHook, - swallowHook, - dynamicTitle (composeAll [ - title =? "Spotify" --> doMarkWindow "s" - ])] - , focusFollowsMouse = False - , clickJustFocuses = False - , logHook = xMobarLogHook xmobar - } - + (=<<) X.xmonad $ + applyKeys $ + withLocationChangeHook historyHook $ + ewmh $ + docks $ + def + { terminal = "alacritty", + modMask = mod3Mask, + borderWidth = 2, + keys = const mempty, + focusedBorderColor = "#ff6c00", + normalBorderColor = "#404040", + layoutHook = myLayout, + startupHook = spawn fp, + manageHook = + composeAll + [ isFullscreen --> doFullFloat, + doLogWindow, + className =? "Tilda" --> doFloat, + className =? "yakuake" --> doFloat, + className =? "MPlayer" --> doFloat, + title =? "Event Tester" --> doFloat, + title =? "Floating Term" --> doCenterFloat, + title =? "Notes" --> doCenterFloat, + title =? "xmessage" --> doCenterFloat, + title =? "gxmessage" --> doCenterFloat, + title =? "Volume Control" --> doCenterFloat, + className =? "mpv" --> doFloat, + className =? "gnubby_ssh_prompt" --> doFloat + ], + -- This config uses dynamic workspaces, but I have to seed XMonad + -- with something. However, this configuration only supports 36 + -- monitors on boot. If you need more than 36 monitors, you'll have to + -- configure those ones after starting XMonad. + workspaces = map return (['0' .. '9'] ++ ['a' .. 'z']), + handleEventHook = + composeAll + [ fullscreenEventHook, + remapHook, + swallowHook, + dynamicTitle + ( composeAll + [ title =? "Spotify" --> doMarkWindow "s" + ] + ) + ], + focusFollowsMouse = False, + clickJustFocuses = False, + logHook = xMobarLogHook xmobar + } changeHook :: Location -> Location -> X () changeHook l1 l2 = @@ -98,9 +102,16 @@ doLogWindow = do return (Endo id) doMarkWindow :: Mark -> ManageHook -doMarkWindow m = ask >>= (\w -> liftX (do - ws <- getCurrentWorkspace - markAllLocations m [Location ws (Just w)]) >> return (Endo id)) +doMarkWindow m = + ask + >>= ( \w -> + liftX + ( do + ws <- getCurrentWorkspace + markAllLocations m [Location ws (Just w)] + ) + >> return (Endo id) + ) doCenterFloat :: ManageHook doCenterFloat = @@ -109,14 +120,11 @@ doCenterFloat = centerRect :: W.RationalRect -> W.RationalRect centerRect (W.RationalRect x y w h) = W.RationalRect ((1 - w) / 2) ((1 - h) / 2) w h - windowHooks :: WindowHook -> XConfig l -> XConfig l windowHooks (Query readerT) config = do - - config { - startupHook = do - withWindowSet $ mapM_ (runReaderT readerT) . W.allWindows - startupHook config, - - manageHook = mappend (Query readerT >> return (Endo id)) (manageHook config) - } + config + { startupHook = do + withWindowSet $ mapM_ (runReaderT readerT) . W.allWindows + startupHook config, + manageHook = mappend (Query readerT >> return (Endo id)) (manageHook config) + } diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs index 3e6d54c..e012a8f 100644 --- a/src/Rahm/Desktop/Common.hs +++ b/src/Rahm/Desktop/Common.hs @@ -1,59 +1,61 @@ module Rahm.Desktop.Common where -import Prelude hiding ((!!)) - -import Control.Monad (void, when, forM_) +import Control.Monad (forM_, void, when) import Control.Monad.Trans.Maybe -import XMonad.Util.Run -import XMonad.Prompt -import XMonad.Prompt.Input -import XMonad.Prompt.Shell -import XMonad.Util.XUtils - -import Rahm.Desktop.PromptConfig - import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) -import Data.Maybe -import Text.Printf -import XMonad hiding (workspaces, Screen) import qualified Data.Map as Map -import Rahm.Desktop.DMenu +import Data.Maybe import Data.Ord (comparing) - +import Rahm.Desktop.DMenu +import Rahm.Desktop.PromptConfig import qualified Rahm.Desktop.StackSet as S +import Text.Printf +import XMonad hiding (Screen, workspaces) +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell +import XMonad.Util.Run +import XMonad.Util.XUtils +import Prelude hiding ((!!)) -- A location is a workspace and maybe a window with that workspace. -data Location = Location { - locationWorkspace :: WorkspaceId, +data Location = Location + { locationWorkspace :: WorkspaceId, locationWindow :: Maybe Window - } deriving (Read, Show, Eq, Ord) + } + deriving (Read, Show, Eq, Ord) focusLocation :: Location -> X () focusLocation (Location ws Nothing) = windows $ S.greedyView ws focusLocation (Location _ (Just win)) = windows $ S.focusWindow win masterWindow :: MaybeT X Window -masterWindow = MaybeT $ withWindowSet $ \ss -> - let windows = (S.integrate' . S.stack . S.workspace . S.current) ss - in case windows of - (a:_) -> return $ Just a - _ -> return Nothing +masterWindow = MaybeT $ + withWindowSet $ \ss -> + let windows = (S.integrate' . S.stack . S.workspace . S.current) ss + in case windows of + (a : _) -> return $ Just a + _ -> return Nothing windowsInWorkspace :: WorkspaceId -> X [Location] windowsInWorkspace wid = withWindowSet $ - return . concatMap (\ws -> - if S.tag ws == wid - then map (Location wid . Just) $ S.integrate' (S.stack ws) - else []) . S.workspaces + return + . concatMap + ( \ws -> + if S.tag ws == wid + then map (Location wid . Just) $ S.integrate' (S.stack ws) + else [] + ) + . S.workspaces data WinPrompt = WinPrompt instance XPrompt WinPrompt where - showXPrompt _ = "[Window] " - commandToComplete _ = id + showXPrompt _ = "[Window] " + commandToComplete _ = id getString :: Window -> X String getString = runQuery $ do @@ -107,7 +109,7 @@ withBorderWidth width ws fn = do forM_ ws $ \window -> io $ setWindowBorderWidth d window $ fromIntegral width - ret <- fn + ret <- fn forM_ ws $ \window -> io $ setWindowBorderWidth d window 2 @@ -119,7 +121,7 @@ withBorderWidth width ws fn = do gotoWorkspace :: WorkspaceId -> X () gotoWorkspace wid = windows $ S.greedyView wid -moveLocationToWorkspace :: Location -> WorkspaceId -> X () +moveLocationToWorkspace :: Location -> WorkspaceId -> X () moveLocationToWorkspace (Location _ (Just win)) wid = windows $ S.shiftWin wid win moveLocationToWorkspace _ _ = return () @@ -136,4 +138,4 @@ getCurrentLocation = do return (Location ws win) runMaybeT_ :: (Monad m) => MaybeT m a -> m () -runMaybeT_ = void . runMaybeT +runMaybeT_ = void . runMaybeT diff --git a/src/Rahm/Desktop/DMenu.hs b/src/Rahm/Desktop/DMenu.hs index d20d001..eeb0d5f 100644 --- a/src/Rahm/Desktop/DMenu.hs +++ b/src/Rahm/Desktop/DMenu.hs @@ -1,19 +1,20 @@ module Rahm.Desktop.DMenu where -import XMonad.Util.Dmenu -import XMonad import Control.Monad +import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map -import XMonad.Util.Run -import Data.List (intercalate) import Text.Printf (printf) +import XMonad +import XMonad.Util.Dmenu +import XMonad.Util.Run -data Colors = - Colors { - fg :: String, - bg :: String - } | DefaultColors +data Colors + = Colors + { fg :: String, + bg :: String + } + | DefaultColors menuCommand :: [String] menuCommand = ["rofi", "-monitor", "-4", "-i", "-dmenu", "-sort", "-levenshtein-sort"] @@ -22,24 +23,37 @@ menuCommandString :: String menuCommandString = unwords menuCommand runDMenu :: X () -runDMenu = void $ - safeSpawn - "rofi" - ["-monitor", "-4", "-display-run", "Execute", "-show", "run"] +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) - + 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 + 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/Desktop.hs b/src/Rahm/Desktop/Desktop.hs index 053b330..5466fd1 100644 --- a/src/Rahm/Desktop/Desktop.hs +++ b/src/Rahm/Desktop/Desktop.hs @@ -4,22 +4,24 @@ module Rahm.Desktop.Desktop where -- state of the current screen -> workspace and thus restore it. -- import XMonad.Operations -import Data.Maybe (fromMaybe) + import Control.Monad (forM_) -import XMonad (X(..)) -import qualified XMonad.StackSet as W -import qualified XMonad as X +import Data.Default import Data.Map (Map) import qualified Data.Map as Map -import Data.Default +import Data.Maybe (fromMaybe) +import XMonad (X (..)) +import qualified XMonad as X +import qualified XMonad.StackSet as W import qualified XMonad.Util.ExtensibleState as XS newtype Desktop si wi = Desktop (Map si wi) deriving (Read, Show) -newtype Desktops = Desktops { - theaters :: Map String (Desktop X.ScreenId X.WorkspaceId) -} deriving (Read, Show) +newtype Desktops = Desktops + { theaters :: Map String (Desktop X.ScreenId X.WorkspaceId) + } + deriving (Read, Show) instance Default Desktops where def = Desktops mempty @@ -32,9 +34,11 @@ saveCurrentDesktop :: String -> X () saveCurrentDesktop name = X.withWindowSet $ \windowSet -> XS.modify $ \(Desktops m) -> - Desktops $ flip (Map.insert name) m $ - Desktop $ Map.fromList $ - map (\(W.Screen ws sid _) -> (sid, W.tag ws)) $ W.screens windowSet + Desktops $ + flip (Map.insert name) m $ + Desktop $ + Map.fromList $ + map (\(W.Screen ws sid _) -> (sid, W.tag ws)) $ W.screens windowSet restoreDesktop :: String -> X () restoreDesktop name = do @@ -47,7 +51,7 @@ restoreDesktop name = do fromMaybe scr $ do wid <- Map.lookup (W.screen scr) screenToWorkspace workspace <- Map.lookup wid workspacesById - return $ scr { W.workspace = workspace } + return $ scr {W.workspace = workspace} newScreens = map newScreenWorkspace (cur : vis) newVisibleWorkspaces = map (W.tag . W.workspace) newScreens @@ -55,6 +59,5 @@ restoreDesktop name = do filter (\ws -> not (W.tag ws `elem` newVisibleWorkspaces)) $ W.workspaces ws - (newCur:newVisible) = newScreens - in - W.StackSet newCur newVisible newHiddenWorkspaces float + (newCur : newVisible) = newScreens + in W.StackSet newCur newVisible newHiddenWorkspaces float diff --git a/src/Rahm/Desktop/Hash.hs b/src/Rahm/Desktop/Hash.hs index dc58d96..abce660 100644 --- a/src/Rahm/Desktop/Hash.hs +++ b/src/Rahm/Desktop/Hash.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} + module Rahm.Desktop.Hash where -import Numeric (showHex) +import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BC -import qualified Crypto.Hash.SHA1 as SHA1 +import Numeric (showHex) quickHash :: String -> String quickHash str = - concatMap (`showHex` "") $ BS.unpack (SHA1.hash $ BC.pack str) + concatMap (`showHex` "") $ BS.unpack (SHA1.hash $ BC.pack str) diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs index 516cd94..c5bc72d 100644 --- a/src/Rahm/Desktop/History.hs +++ b/src/Rahm/Desktop/History.hs @@ -1,19 +1,18 @@ module Rahm.Desktop.History where -import XMonad -import Text.Printf -import qualified Rahm.Desktop.StackSet as W -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.Default -import qualified XMonad.Util.ExtensibleState as XS - import Data.Foldable (toList) -import Rahm.Desktop.Hooks.WindowChange +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq import Rahm.Desktop.Common +import Rahm.Desktop.Hooks.WindowChange import Rahm.Desktop.Logger -import Data.Sequence (Seq(..)) -import qualified Data.Sequence as Seq +import qualified Rahm.Desktop.StackSet as W +import Text.Printf +import XMonad +import qualified XMonad.Util.ExtensibleState as XS data BoundedSeqZipper a = BoundedSeqZipper Int (Seq a) (Seq a) deriving (Eq, Show, Ord, Read) @@ -24,15 +23,15 @@ instance Functor BoundedSeqZipper where zipperDbgPrint :: (Show a) => BoundedSeqZipper a -> String zipperDbgPrint (BoundedSeqZipper _ h (c :<| t)) = concat $ - map (printf " %s " . show) (toList h) ++ - [printf "[%s]" (show c)] ++ - map (printf " %s " . show) (toList t) + map (printf " %s " . show) (toList h) + ++ [printf "[%s]" (show c)] + ++ map (printf " %s " . show) (toList t) zipperDbgPrint _ = "<empty>" pushZipper :: a -> BoundedSeqZipper a -> BoundedSeqZipper a pushZipper e (BoundedSeqZipper maxSize _ (tail :|> _)) - | maxSize <= Seq.length tail = - BoundedSeqZipper maxSize mempty (e :<| tail) + | maxSize <= Seq.length tail = + BoundedSeqZipper maxSize mempty (e :<| tail) pushZipper e (BoundedSeqZipper maxSize _ tail) = BoundedSeqZipper maxSize mempty (e :<| tail) @@ -48,16 +47,18 @@ zipperForward :: BoundedSeqZipper a -> BoundedSeqZipper a zipperForward (BoundedSeqZipper s (e :<| h) t) = BoundedSeqZipper s h (e :<| t) zipperForward b = b -newtype History = History { - currentZipper :: BoundedSeqZipper Location -} deriving (Read, Show) +newtype History = History + { currentZipper :: BoundedSeqZipper Location + } + deriving (Read, Show) instance Default History where def = History (BoundedSeqZipper 1000 mempty mempty) instance ExtensionClass History where initialValue = def - -- extensionType = PersistentExtension + +-- extensionType = PersistentExtension pastHistory :: Int -> X (Maybe Location) pastHistory i = do @@ -72,7 +73,6 @@ getMostRecentLocationInHistory = do (BoundedSeqZipper _ _ (t :<| _)) -> return $ Just t _ -> return Nothing - historyBack :: X () historyBack = do History z <- XS.get @@ -101,5 +101,4 @@ historyHook Nothing loc = XS.modify $ \(History z) -> History (pushZipper loc z) historyHook (Just (Location ws _)) l@(Location ws' _) | ws /= ws' = do XS.modify $ \(History z) -> History (pushZipper l z) - historyHook _ _ = return () diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs index 3bc66a4..092fbf4 100644 --- a/src/Rahm/Desktop/Hooks/WindowChange.hs +++ b/src/Rahm/Desktop/Hooks/WindowChange.hs @@ -1,12 +1,11 @@ module Rahm.Desktop.Hooks.WindowChange where -import XMonad import Control.Monad -import qualified XMonad.Util.ExtensibleState as XS import Data.Default import Rahm.Desktop.Common - import qualified Rahm.Desktop.StackSet as W +import XMonad +import qualified XMonad.Util.ExtensibleState as XS newtype LastLocation = LastLocation (Maybe Location) deriving (Read, Show) @@ -17,7 +16,7 @@ instance Default LastLocation where instance ExtensionClass LastLocation where initialValue = def extensionType = PersistentExtension - + -- Creates a log hook from the function provided. -- -- The first argument to the function is the old window, the second argument in @@ -26,18 +25,18 @@ instance ExtensionClass LastLocation where -- If the first window is Nothing, this is the first time XMonad started. withLocationChangeHook :: (Maybe Location -> Location -> X ()) -> XConfig l -> XConfig l withLocationChangeHook fn config = - config { - logHook = do - logHook config + config + { logHook = do + logHook config - currentLocation <- - Location <$> getCurrentWorkspace <*> withWindowSet (return . W.peek) + currentLocation <- + Location <$> getCurrentWorkspace <*> withWindowSet (return . W.peek) - LastLocation last <- XS.get + LastLocation last <- XS.get - when (last /= Just currentLocation) $ - fn last currentLocation + when (last /= Just currentLocation) $ + fn last currentLocation - XS.put $ LastLocation $ Just currentLocation - return () - } + XS.put $ LastLocation $ Just currentLocation + return () + } diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index eae1c34..0ab868f 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -1,78 +1,75 @@ module Rahm.Desktop.Keys (applyKeys) where -import Control.Monad.Trans.Maybe import Control.Applicative import Control.Monad import Control.Monad.Fix (fix) import Control.Monad.Loops (iterateWhile) import Control.Monad.Reader import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe import Control.Monad.Writer import Data.Char import Data.List hiding ((!!)) import Data.List.Safe ((!!)) import Data.Map (Map) -import Data.Maybe (isJust, fromMaybe, mapMaybe) -import Data.Monoid (Endo(..)) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Monoid (Endo (..)) import Data.Proxy import Debug.Trace -import Graphics.X11.ExtraTypes.XF86; +import Graphics.X11.ExtraTypes.XF86 import Graphics.X11.ExtraTypes.XorgDefault -import Prelude hiding ((!!)) -import System.IO -import System.Process -import Text.Printf -import XMonad -import XMonad.Actions.CopyWindow as CopyWindow -import XMonad.Actions.RotSlaves -import XMonad.Actions.SpawnOn as SpawnOn -import XMonad.Actions.WindowNavigation -import XMonad.Hooks.ManageDocks -import XMonad.Layout.MosaicAlt -import XMonad.Layout.Spacing -import XMonad.Prompt -import XMonad.Prompt.Input -import XMonad.Prompt.Shell -import XMonad.Util.XUtils -import XMonad.Util.CustomKeys -import XMonad.Util.Run (safeSpawn) -import XMonad.Util.Scratchpad -import XMonad.Util.Ungrab import Prettyprinter - -import qualified Data.Map as Map - +import Rahm.Desktop.Common import Rahm.Desktop.DMenu +import Rahm.Desktop.Desktop +import Rahm.Desktop.History import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.Keys.Wml import Rahm.Desktop.Layout import Rahm.Desktop.Layout.Bordering import Rahm.Desktop.Layout.ConsistentMosaic import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Hole (toggleHole) -import Rahm.Desktop.Layout.List (toNextLayout, toPreviousLayout, toFirstLayout, toIndexedLayout) +import Rahm.Desktop.Layout.List (toFirstLayout, toIndexedLayout, toNextLayout, toPreviousLayout) import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Rotate (rotateLayout) -import Rahm.Desktop.Common import Rahm.Desktop.Logger import Rahm.Desktop.Marking -import Rahm.Desktop.Keys.Wml import Rahm.Desktop.MouseMotion import Rahm.Desktop.PassMenu import Rahm.Desktop.PromptConfig import Rahm.Desktop.RebindKeys +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.Submap import Rahm.Desktop.Swallow import Rahm.Desktop.SwapMaster (swapMaster) -import Rahm.Desktop.Workspaces -import Rahm.Desktop.Desktop import Rahm.Desktop.Theater - -import qualified Rahm.Desktop.StackSet as W -import Rahm.Desktop.History +import Rahm.Desktop.Workspaces +import System.IO +import System.Process +import Text.Printf +import XMonad +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Actions.RotSlaves +import XMonad.Actions.SpawnOn as SpawnOn +import XMonad.Actions.WindowNavigation +import XMonad.Hooks.ManageDocks +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Spacing +import XMonad.Prompt +import XMonad.Prompt.Input +import XMonad.Prompt.Shell +import XMonad.Util.CustomKeys +import XMonad.Util.Run (safeSpawn) +import XMonad.Util.Scratchpad +import XMonad.Util.Ungrab +import XMonad.Util.XUtils +import Prelude hiding ((!!)) type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) -type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) +type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ()) spawnX :: String -> X () spawnX = spawn @@ -84,17 +81,24 @@ 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 +mediaNextDoc = doc "Next media" mediaNext button6 :: Button button6 = 6 @@ -128,7 +132,6 @@ button15 = 15 keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config) - where bindingToX :: (KeyMask, KeySym) -> Documented KeyBinding -> X () bindingToX key b = @@ -151,11 +154,11 @@ keymap = runKeys $ do forM_ [xK_apostrophe, xK_w] $ \k -> bind k $ do justMod $ doc "Jumps between marks." $ - runMaybeT_ $ do - l <- readNextLocationSet - case l of - (h:_) -> lift (focusLocation h) - _ -> return () + runMaybeT_ $ do + l <- readNextLocationSet + case l of + (h : _) -> lift (focusLocation h) + _ -> return () bind xK_BackSpace $ do -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if @@ -163,12 +166,12 @@ keymap = runKeys $ do -- where dmenu/alacritty may not be installed. rawMask mod4Mask $ doc "Spawns XTerm as a fallback if xkb is messed up." $ - spawnX "xterm" + spawnX "xterm" -- Moves xmobar to different monitors. justMod $ doc "Move XMobar to another screen." $ - spawnX "pkill -SIGUSR1 xmobar" + spawnX "pkill -SIGUSR1 xmobar" bind xK_F1 $ do -- Experimental. Sends 'a' to all windows. @@ -178,21 +181,32 @@ keymap = runKeys $ do -- focused. It's pretty annoying because it keeps me from doing some cool -- things all for BS security theater, but I guess there might be some way -- to do this via XTest? - shiftMod $ withWindowSet $ mapM_ (\w -> do - logs Info "Try send to %s" (show w) - sendKey (0, xK_a) w) . W.allWindows + shiftMod $ + withWindowSet $ + mapM_ + ( \w -> do + logs Info "Try send to %s" (show w) + sendKey (0, xK_a) w + ) + . W.allWindows justMod $ - doc "Print this documentation" - (safeSpawn "gxmessage" [ - "-fn", "Source Code Pro", - documentation (keymap config)] :: X ()) + doc + "Print this documentation" + ( safeSpawn + "gxmessage" + [ "-fn", + "Source Code Pro", + documentation (keymap config) + ] :: + X () + ) bind xK_F7 $ - justMod $ - doc "Print this documentation." - (logs Info "%s" (documentation (keymap config)) :: X ()) + doc + "Print this documentation." + (logs Info "%s" (documentation (keymap config)) :: X ()) bind xK_F10 $ do justMod playPauseDoc @@ -207,25 +221,25 @@ keymap = runKeys $ do justMod swapMaster bind xK_Tab $ do - justMod $ windows W.focusDown + 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) -> + forM_ (zip [xK_a, xK_o, xK_e] [0 ..]) $ \(key, idx) -> bind key $ do -- Move focus to that screen. - justMod $ + justMod $ doc ("Switch focus to screen " ++ show idx) $ - withScreen W.view idx + withScreen W.view idx -- Swap the current screen with the one given - altMod $ + altMod $ doc ("Swap the current screen with screen " ++ show idx) $ - withScreen W.greedyView 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 + withScreen W.shift idx altgrMod (logs Info "Test altgr" :: X ()) @@ -233,12 +247,12 @@ keymap = runKeys $ do bind xK_bracketright $ do justMod $ doc "Increase the gaps between windows." $ - sendMessage $ modifyWindowBorder 5 + sendMessage $ modifyWindowBorder 5 bind xK_bracketleft $ do justMod $ doc "Decrease the gaps between windows." $ - sendMessage $ modifyWindowBorder (-5) + sendMessage $ modifyWindowBorder (-5) bind xK_b $ do justMod $ spawnX "bluetooth-select.sh" @@ -251,45 +265,43 @@ keymap = runKeys $ do doc "Kill the current window" CopyWindow.kill1 bind xK_f $ do - justMod $ + justMod $ doc "Flip the current layout vertically" $ - sendMessage flipVertically + sendMessage flipVertically shiftMod $ doc "Flip the current layout horizontally" $ - sendMessage flipHorizontally + sendMessage flipHorizontally bind xK_g $ do - justMod $ - doc "Goto/Send/Etc To a workspace\n\n\t\ - - \Workspaces are alphanumeric characters. So if the next key typed is an\n\t\ - \alphanumeric character, that's the workspace to operate on\n\n\ - - \\tThe following special characters can also reference workspaces:\n\t\t\ - \]: The next workspace, skipping those already visible.\n\t\t\ - \[: The previous workspace, skipping those already visible.\n\t\t\ - \): The next workspace.\n\t\t\ - \(: The previous workspace.\n\t\t\ - \}: The workspace on the screen to the right\n\t\t\ - \{: The workspace on the screen to the left\n\t\t\ - \<space>: The accompaningWorkspace (toggled case)\n\t\t\ - \/: Prompt to select a window, and reference that workspace\n\t\t\ - \^: The first populated workspace\n\t\t\ - \$: The last populated workspace\n\t\t\ - \*: The hidden workspace.\n\t\t\ - \_: Black hole. Sending a window here closes it.\n\n\t\ - \Other keybindings starting with H-g\n\t\t\ - \F1: display this help.\n\n\t" $ - runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace + doc + "Goto/Send/Etc To a workspace\n\n\t\ + \Workspaces are alphanumeric characters. So if the next key typed is an\n\t\ + \alphanumeric character, that's the workspace to operate on\n\n\ + \\tThe following special characters can also reference workspaces:\n\t\t\ + \]: The next workspace, skipping those already visible.\n\t\t\ + \[: The previous workspace, skipping those already visible.\n\t\t\ + \): The next workspace.\n\t\t\ + \(: The previous workspace.\n\t\t\ + \}: The workspace on the screen to the right\n\t\t\ + \{: The workspace on the screen to the left\n\t\t\ + \<space>: The accompaningWorkspace (toggled case)\n\t\t\ + \/: Prompt to select a window, and reference that workspace\n\t\t\ + \^: The first populated workspace\n\t\t\ + \$: The last populated workspace\n\t\t\ + \*: The hidden workspace.\n\t\t\ + \_: Black hole. Sending a window here closes it.\n\n\t\ + \Other keybindings starting with H-g\n\t\t\ + \F1: display this help.\n\n\t" + $ runMaybeT_ $ (lift . gotoWorkspaceFn) =<< readNextWorkspace controlMod $ doc "Restore the desktop marked with the next typed character." $ - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> restoreDesktop [ch] - _ -> return () + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> restoreDesktop [ch] + _ -> return () -- shiftMod $ -- doc "Swap a workspace with another workspace." $ @@ -299,12 +311,12 @@ keymap = runKeys $ do shiftMod $ doc "Restore a theater state" $ - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> restoreTheater (Just [ch]) - [' '] -> restoreTheater Nothing - _ -> return () + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> restoreTheater (Just [ch]) + [' '] -> restoreTheater Nothing + _ -> return () bind xK_n $ do justMod $ @@ -312,67 +324,66 @@ keymap = runKeys $ do withFocused $ sendMessage . toggleBanish shiftMod $ - doc "Rotate border windows" $ repeatable $ do - - bind xK_h $ do - - (justMod -|- noMod) $ - withFocused $ sendMessage . moveForward - - shiftMod $ - sendMessage (rotateBorderForward (Proxy :: Proxy Window)) - - bind xK_l $ do - - (justMod -|- noMod) $ - withFocused $ sendMessage . moveBackward - - shiftMod $ - sendMessage (rotateBorderBackward (Proxy :: Proxy Window)) - - bind xK_plus $ do - - (justMod -|- noMod) $ - sendMessage $ - changeWidth Proxy (1/24) <> - changeHeight (Proxy :: Proxy Window) (1/24) - - bind xK_minus $ do - - (justMod -|- noMod) $ - sendMessage $ - changeWidth Proxy (-1/24) <> - changeHeight (Proxy :: Proxy Window) (-1/24) + doc "Rotate border windows" $ + repeatable $ do + bind xK_h $ do + (justMod -|- noMod) $ + withFocused $ sendMessage . moveForward + + shiftMod $ + sendMessage (rotateBorderForward (Proxy :: Proxy Window)) + + bind xK_l $ do + (justMod -|- noMod) $ + withFocused $ sendMessage . moveBackward + + shiftMod $ + sendMessage (rotateBorderBackward (Proxy :: Proxy Window)) + + bind xK_plus $ do + (justMod -|- noMod) $ + sendMessage $ + changeWidth Proxy (1 / 24) + <> changeHeight (Proxy :: Proxy Window) (1 / 24) + + bind xK_minus $ do + (justMod -|- noMod) $ + sendMessage $ + changeWidth Proxy (-1 / 24) + <> changeHeight (Proxy :: Proxy Window) (-1 / 24) bind xK_d $ justMod $ - doc "Record (define) macros." $ - subkeys $ do - bind xK_w $ noMod $ - doc "Record a windowset macro" $ - runMaybeT_ readWindowsetMacro - - bind xK_t $ noMod $ - doc "Record a workspace macro" $ - runMaybeT_ readWorkspaceMacro + doc "Record (define) macros." $ + subkeys $ do + bind xK_w $ + noMod $ + doc "Record a windowset macro" $ + runMaybeT_ readWindowsetMacro + + bind xK_t $ + noMod $ + doc "Record a workspace macro" $ + runMaybeT_ readWorkspaceMacro bind xK_h $ do justMod $ doc "Focus on the next window down in the stack" $ - windows W.focusDown + windows W.focusDown shiftMod $ doc "Swap the current window with the next one down in the stack" $ - windows W.swapDown + windows W.swapDown controlMod $ - doc "Rotate all the windows down the stack" - rotAllDown + doc + "Rotate all the windows down the stack" + rotAllDown bind xK_j $ do justMod $ doc "Shrink the size of the master region" $ - sendMessage Shrink + sendMessage Shrink shiftMod $ doc "Go to the previous window in history." historyBack @@ -380,186 +391,201 @@ keymap = runKeys $ do bind xK_k $ do justMod $ doc "Expand the size of the master region" $ - sendMessage Expand + sendMessage Expand shiftMod $ doc "Go to the next window in history." historyForward bind xK_l $ do - justMod $ + justMod $ doc "Focus the next window in the stack" $ - windows W.focusUp + windows W.focusUp - shiftMod $ + shiftMod $ doc "Swap the currently focused window with the next window in the stack." $ - windows W.swapUp + windows W.swapUp controlMod $ - doc "Rotate the windows up." - rotAllUp + doc + "Rotate the windows up." + rotAllUp altMod $ doc "Lock the screen" $ - spawnX "xsecurelock" + spawnX "xsecurelock" bind xK_minus $ do - justMod $ + justMod $ doc "Decrease the number of windows in the master region." $ - sendMessage (IncMasterN (-1)) + sendMessage (IncMasterN (-1)) shiftMod $ doc "For mosaic layout, shrink the size-share of the current window" $ - sendMessage =<< shrinkPositionAlt + sendMessage =<< shrinkPositionAlt bind xK_m $ do justMod $ doc "Mark the current window with the next typed character." $ do - locs <- fromMaybe [] <$> runMaybeT readNextLocationSet - let wins = mapMaybe locationWindow locs - withBorderColor "#00ffff" wins $ do - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> markAllLocations str locs - _ -> return () + locs <- fromMaybe [] <$> runMaybeT readNextLocationSet + let wins = mapMaybe locationWindow locs + withBorderColor "#00ffff" wins $ do + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> markAllLocations str locs + _ -> return () shiftMod $ doc "Mark the current desktop with the next typed character." $ - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> saveCurrentDesktop str - _ -> return () + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> saveCurrentDesktop str + _ -> return () controlMod $ doc "Mark the current theater with the next typed character." $ - runMaybeT_ $ do - mapNextString $ \_ str -> lift $ - case str of - [ch] | isAlpha ch -> saveCurrentTheater (Just str) - _ -> return () + runMaybeT_ $ do + mapNextString $ \_ str -> lift $ + case str of + [ch] | isAlpha ch -> saveCurrentTheater (Just str) + _ -> return () bind xK_plus $ do justMod $ doc "Increase the number of windows in the master region." $ - sendMessage (IncMasterN 1) + sendMessage (IncMasterN 1) shiftMod $ doc "For mosaic layout, increase the size-share of the current window." $ - sendMessage =<< expandPositionAlt + sendMessage =<< expandPositionAlt bind xK_q $ do shiftMod $ doc "Recompile and restart XMonad" $ - spawnX "xmonad --recompile && xmonad --restart" + 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 Info "CW") (logs Info "CCW") + subkeys $ do + bind xK_q $ + (justMod -|- noMod) $ + doc "EXPERIMENTAL: Move mouse to control media." $ + mouseRotateMotion (logs Info "CW") (logs Info "CCW") bind xK_r $ do justMod $ doc "Run a command via Rofi" runDMenu shiftMod $ doc "Rotate the current layout. (flips x, y coordinates)" $ - sendMessage rotateLayout + sendMessage rotateLayout bind xK_s $ do forM_ [(False, justMod), (True, shiftMod)] $ \(doSwap, f) -> - f $ - doc (if doSwap - then "Swap a windowset with another windowset." - else "Shift a windowset to a workspace") $ do - locations <- fromMaybe [] <$> runMaybeT readNextLocationSet - let locationWindows = mapMaybe locationWindow locations - - withBorderColor "#00ffff" locationWindows $ do - runMaybeT_ $ do - if doSwap - then do - otherWindows <- - lift $ mapMaybe locationWindow . fromMaybe [] <$> - runMaybeT readNextLocationSet - lift $ windows $ - W.swapWindows (zip locationWindows otherWindows) - else do - workspace <- readNextWorkspace - mapM_ (lift . moveLocationToWorkspaceFn workspace) locations - - lift $ setAlternateWindows locationWindows - forM_ locations $ \loc -> - case locationWindow loc of - Nothing -> return () - Just win -> do - lift $ setAlternateWorkspace win (locationWorkspace loc) + f $ + doc + ( if doSwap + then "Swap a windowset with another windowset." + else "Shift a windowset to a workspace" + ) + $ do + locations <- fromMaybe [] <$> runMaybeT readNextLocationSet + let locationWindows = mapMaybe locationWindow locations + + withBorderColor "#00ffff" locationWindows $ do + runMaybeT_ $ do + if doSwap + then do + otherWindows <- + lift $ + mapMaybe locationWindow . fromMaybe [] + <$> runMaybeT readNextLocationSet + lift $ + windows $ + W.swapWindows (zip locationWindows otherWindows) + else do + workspace <- readNextWorkspace + mapM_ (lift . moveLocationToWorkspaceFn workspace) locations + + lift $ setAlternateWindows locationWindows + forM_ locations $ \loc -> + case locationWindow loc of + Nothing -> return () + Just win -> do + lift $ setAlternateWorkspace win (locationWorkspace loc) altMod $ spawnX "sudo -A systemctl suspend && xsecurelock" bind xK_space $ do - justMod $ doc "Layout-related bindings" $ subkeys $ do - - bind xK_n $ - (noMod -|- justMod) $ doc "Use the next layout in the layout list." $ - sendMessage toNextLayout - - bind xK_p $ - (noMod -|- justMod) $ doc "Use the previous layout in the layout list." $ - sendMessage toPreviousLayout - - bind xK_b $ - (noMod -|- justMod) $ doc "Go back to the first layout in the layout list." $ - sendMessage toFirstLayout - - bind xK_h $ - (noMod -|- justMod) $ doc "Flip the layout across the horizontal axis" $ - sendMessage flipVertically - - bind xK_v $ - (noMod -|- justMod) $ doc "Flip the layout across the vertical axis" $ - sendMessage flipHorizontally - - bind xK_r $ - (noMod -|- justMod) $ doc "Rotate the layout 90 degrees" $ - sendMessage rotateLayout - - bind xK_c $ - (noMod -|- justMod) $ doc "Toggle the pop window" $ - sendMessage togglePop - - bind xK_t $ - (noMod -|- justMod) $ doc "Jump to the middle layout." $ - sendMessage (toIndexedLayout (nLayouts `div` 2)) - - bind xK_x $ - (noMod -|- justMod) $ doc "Toggle the hole" $ - sendMessage toggleHole - - let spaceResize = repeatable $ do - bind xK_bracketright $ do - noMod $ - doc "Increase the gaps between windows." $ - sendMessage $ modifyWindowBorder 5 - - bind xK_bracketleft $ do - noMod $ - doc "Decrease the gaps between windows." $ - sendMessage $ modifyWindowBorder (-5) - - bind xK_bracketleft $ noMod spaceResize - bind xK_bracketright $ noMod spaceResize + justMod $ + doc "Layout-related bindings" $ + subkeys $ do + bind xK_n $ + (noMod -|- justMod) $ + doc "Use the next layout in the layout list." $ + sendMessage toNextLayout + + bind xK_p $ + (noMod -|- justMod) $ + doc "Use the previous layout in the layout list." $ + sendMessage toPreviousLayout + + bind xK_b $ + (noMod -|- justMod) $ + doc "Go back to the first layout in the layout list." $ + sendMessage toFirstLayout + + bind xK_h $ + (noMod -|- justMod) $ + doc "Flip the layout across the horizontal axis" $ + sendMessage flipVertically + + bind xK_v $ + (noMod -|- justMod) $ + doc "Flip the layout across the vertical axis" $ + sendMessage flipHorizontally + + bind xK_r $ + (noMod -|- justMod) $ + doc "Rotate the layout 90 degrees" $ + sendMessage rotateLayout + + bind xK_c $ + (noMod -|- justMod) $ + doc "Toggle the pop window" $ + sendMessage togglePop + + bind xK_t $ + (noMod -|- justMod) $ + doc "Jump to the middle layout." $ + sendMessage (toIndexedLayout (nLayouts `div` 2)) + + bind xK_x $ + (noMod -|- justMod) $ + doc "Toggle the hole" $ + sendMessage toggleHole + + let spaceResize = repeatable $ do + bind xK_bracketright $ do + noMod $ + doc "Increase the gaps between windows." $ + sendMessage $ modifyWindowBorder 5 + + bind xK_bracketleft $ do + noMod $ + doc "Decrease the gaps between windows." $ + sendMessage $ modifyWindowBorder (-5) + + bind xK_bracketleft $ noMod spaceResize + bind xK_bracketright $ noMod spaceResize bind xK_t $ do - justMod $ + justMod $ doc "Spawn a terminal." $ spawnX (terminal config) shiftMod $ doc "Sink the current window into the tiling." $ withFocused $ windows . W.sink - altMod $ + altMod $ doc "Spawn a floating terminal" $ spawnX (terminal config ++ " -t Floating\\ Term") bind xK_v $ @@ -567,136 +593,142 @@ keymap = runKeys $ do -- 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 ()) + 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_x $ do justMod $ doc "Toggles respect for struts." $ - sendMessage ToggleStruts + sendMessage ToggleStruts bind xK_z $ do - justMod $ doc "Less often used keybindings." $ - subkeys $ do - - bind xK_p $ do - (justMod -|- noMod) $ - doc "Go to the prior window in the history" historyBack - - bind xK_t $ do - (justMod -|- noMod) (logs Info "Test Log" :: X ()) - - -- 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" historyForward - - 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" - - let navigateHistory = repeatable $ do - bind xK_bracketright $ do - noMod $ - doc "Move forward in location history" historyForward - - bind xK_bracketleft $ do - noMod $ - doc "Move backward in location history" historyBack - - bind xK_bracketleft $ noMod $ - doc "Move forward in location history" navigateHistory - bind xK_bracketright $ noMod $ - doc "Move backward in location history" navigateHistory - - -- Double-tap Z to toggle zoom. - bind xK_z $ do - noMod -|- justMod $ - doc "Toggle zoom on the current window." $ - sendMessage togglePop - - -- 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 + subkeys $ do + bind xK_p $ do + (justMod -|- noMod) $ + doc "Go to the prior window in the history" historyBack + + bind xK_t $ do + (justMod -|- noMod) (logs Info "Test Log" :: X ()) + + -- 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" historyForward + + 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" + + let navigateHistory = repeatable $ do + bind xK_bracketright $ do + noMod $ + doc "Move forward in location history" historyForward + + bind xK_bracketleft $ do + noMod $ + doc "Move backward in location history" historyBack + + bind xK_bracketleft $ + noMod $ + doc "Move forward in location history" navigateHistory + bind xK_bracketright $ + noMod $ + doc "Move backward in location history" navigateHistory + + -- Double-tap Z to toggle zoom. + bind xK_z $ do + noMod -|- justMod $ + doc "Toggle zoom on the current window." $ + sendMessage togglePop + + -- 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 togglePop + sendMessage togglePop bind xK_F8 $ do justMod $ do ll <- getLogLevel let next = if minBound == ll then maxBound else pred ll - safeSpawnX "notify-send" + safeSpawnX + "notify-send" ["-t", "2000", printf "LogLevel set to %s" (show next)] setLogLevel next logs next "LogLevel set to %s." (show next) shiftMod $ do ss <- withWindowSet return - logs Info "Current Stack Set:%s" + logs + Info + "Current Stack Set:%s" (show $ viaShow $ W.mapLayout (const ()) ss) - bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" @@ -738,20 +770,22 @@ mouseMap = runButtons $ do let x button = Map.lookup button (mouseMap config) - let defaultButtons button = fromMaybe (\w -> return ()) $ + 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 + 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 + ( 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 @@ -777,80 +811,83 @@ mouseMap = runButtons $ do 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 togglePop - - bind button15 $ do - noMod $ noWindow $ spawnX "pavucontrol" - - let mediaButtons = [ - (button4, increaseVolume), - (button5, decreaseVolume), - (button2, playPause), - (button9, historyForward), - (button8, historyBack), - (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 - - let swapButtons = [ - (button6, windows W.swapDown), - (button7, windows W.swapUp) - ] - - forM_ (map fst swapButtons) $ \b -> - bind b $ noMod $ \w -> click >> continuous swapButtons b w - - bind button13 $ noMod $ subMouse $ do - bind button13 $ noMod $ subMouse $ do - bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" - bind button1 $ noMod $ noWindow $ - spawnX "sudo -A systemctl suspend && xsecurelock" + noMod $ + subMouse $ do + bind button3 $ + noMod $ noWindow (gotoWorkspace "s") + + bind button13 $ do + noMod $ noWindow $ click >> CopyWindow.kill1 + + bind button14 $ do + noMod $ noWindow $ click >> sendMessage togglePop + + bind button15 $ do + noMod $ noWindow $ spawnX "pavucontrol" + + let mediaButtons = + [ (button4, increaseVolume), + (button5, decreaseVolume), + (button2, playPause), + (button9, historyForward), + (button8, historyBack), + (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 + + let swapButtons = + [ (button6, windows W.swapDown), + (button7, windows W.swapUp) + ] + + forM_ (map fst swapButtons) $ \b -> + bind b $ noMod $ \w -> click >> continuous swapButtons b w + + bind button13 $ + noMod $ + subMouse $ do + bind button13 $ + noMod $ + subMouse $ do + bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" + bind button1 $ + noMod $ + noWindow $ + spawnX "sudo -A systemctl suspend && xsecurelock" bind button15 $ do - - noMod $ subMouse $ do - bind button13 $ - noMod $ - noWindow $ - gotoWorkspace . accompaningWorkspace =<< getCurrentWorkspace - - bind button15 $ do - noMod $ noWindow jumpToLastLocation - - - let workspaceButtons = [ - (button2, swapMaster), - - (button9, viewAdjacent next), - (button8, viewAdjacent prev), - - (button4, windows W.focusUp), - (button5, windows W.focusDown), - - (button7, windows W.screenRotateForward), - (button6, windows W.screenRotateBackward) - ] - - forM_ (map fst workspaceButtons) $ \b -> - bind b $ noMod $ continuous workspaceButtons b + noMod $ + subMouse $ do + bind button13 $ + noMod $ + noWindow $ + gotoWorkspace . accompaningWorkspace =<< getCurrentWorkspace + + bind button15 $ do + noMod $ noWindow jumpToLastLocation + + let workspaceButtons = + [ (button2, swapMaster), + (button9, viewAdjacent next), + (button8, viewAdjacent prev), + (button4, windows W.focusUp), + (button5, windows W.focusDown), + (button7, windows W.screenRotateForward), + (button6, windows W.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. @@ -861,7 +898,6 @@ mouseMap = runButtons $ do windowSpecificBindings :: XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () windowSpecificBindings config = do - w <- lift ask let mods = permuteMods [shiftMask, controlMask, 0] @@ -869,7 +905,6 @@ windowSpecificBindings config = do emitKey = flip sendKey w configureIf (flip elem (browsers ++ spotify) <$> className) $ do - bind xK_h $ do rawMask controlMask $ emitKey (0, xK_BackSpace) forM_ mods $ \mask -> @@ -881,14 +916,13 @@ windowSpecificBindings config = do bind xK_c $ forM_ mods $ \mask -> - rawMask (altMask .|.mask) $ emitKey (mask, xK_Up) + rawMask (altMask .|. mask) $ emitKey (mask, xK_Up) bind xK_n $ forM_ mods $ \mask -> rawMask (altMask .|. mask) $ emitKey (mask, xK_Right) configureIf (flip elem browsers <$> className) $ do - -- if the window is a browser, configure these bindings. Lots of browsers -- make up their own garbage bindings that are not standard across many -- other applications. This alleviates the issue. @@ -909,7 +943,6 @@ windowSpecificBindings config = do -- -- Ctrl+d -> Delete current tab. - bind xK_u $ rawMask controlMask $ emitKey (controlMask .|. shiftMask, xK_BackSpace) @@ -950,7 +983,6 @@ windowSpecificBindings config = do configureIf (title =? "Event Tester") $ bind xK_F2 $ noMod $ emitKey (controlMask, xK_F2) - where browsers = ["Google-chrome", "Brave-browser", "firefox-default"] spotify = ["Spotify"] @@ -964,14 +996,12 @@ windowSpecificBindings config = do windowBindings :: XConfig l -> XConfig l windowBindings xconfig = - xconfig { - startupHook = do - withWindowSet $ mapM_ (runQuery doQuery) . W.allWindows - startupHook xconfig, - - manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig - } - + xconfig + { startupHook = do + withWindowSet $ mapM_ (runQuery doQuery) . W.allWindows + startupHook xconfig, + manageHook = (doQuery >> return (Endo id)) <> manageHook xconfig + } where doQuery :: Query () doQuery = do @@ -985,7 +1015,7 @@ windowBindings xconfig = applyKeys :: XConfig l -> IO (XConfig l) applyKeys config = - return $ windowBindings $ config { keys = keyBindingToKeymap keymap, mouseBindings = mouseMap } + return $ windowBindings $ config {keys = keyBindingToKeymap keymap, mouseBindings = mouseMap} click :: X () click = do @@ -996,6 +1026,6 @@ click = do 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 + where + clip i | i < 0 = 0 + clip i = i diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs index 55912f8..adb2668 100644 --- a/src/Rahm/Desktop/Keys/Dsl.hs +++ b/src/Rahm/Desktop/Keys/Dsl.hs @@ -1,27 +1,28 @@ -- Domain-specific language for configuring key/button bindings. module Rahm.Desktop.Keys.Dsl where -import Data.List -import Data.Bits ((.&.)) -import Control.Monad.Writer -import Text.Printf -import Control.Arrow (second, first) +import Control.Arrow (first, second) import Control.Monad (void) -import Control.Monad.State (State(..), modify', get, execState) -import XMonad +import Control.Monad.State (State (..), execState, get, modify') +import Control.Monad.Writer +import Data.Bits ((.&.)) +import Data.List import Data.Map (Map) import qualified Data.Map as Map +import Text.Printf +import XMonad data Documented t = Documented String t -data KeyBinding = - Action (X ()) | - Submap KeyBindings | - Repeat KeyBindings +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. -} @@ -42,13 +43,14 @@ class Bindable k where type BindableMonad k :: (* -> *) -> * -> * bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l () - -- section :: String -> BindableMonad k l () -> 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):)) + rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :)) instance Binding (X ()) (Documented KeyBinding) where toB = Documented "" . Action @@ -112,9 +114,10 @@ instance Bindable KeySym where m <- modMask <$> getConfig let (_, values) = execState stM (m, []) - KeysM $ modify' $ second $ - flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) - + KeysM $ + modify' $ + second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) instance Bindable Button where type BindableValue Button = ButtonBinding @@ -125,8 +128,10 @@ instance Bindable Button where m <- modMask <$> getConfig let (_, values) = execState stM (m, []) - ButtonsM $ modify' $ second $ - flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) + ButtonsM $ + modify' $ + second $ + flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values)) shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b () shiftControlAltSuperHyperAltgrMod = @@ -376,10 +381,12 @@ 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 () +(-|-) :: + (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). -} @@ -392,63 +399,65 @@ mapNumbersAndAlpha km fn = do - 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') ] + 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') - ] - + 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' "" @@ -467,8 +476,8 @@ documentation = execWriter . document' "" keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)]) keyBindingsToList b = - (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) <$> - group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) + (\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) @@ -477,20 +486,17 @@ documentation = execWriter . document' "" 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 - + 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/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs index 7cff173..1c8d073 100644 --- a/src/Rahm/Desktop/Keys/Wml.hs +++ b/src/Rahm/Desktop/Keys/Wml.hs @@ -14,161 +14,159 @@ -- \%@s // All windows except those on workspace 's' module Rahm.Desktop.Keys.Wml where -import qualified XMonad.Util.ExtensibleState as XS +import Control.Monad (forM_, join, unless) +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.State as S -import Control.Monad.Trans.Class -import Control.Monad (join, forM_, unless) -import Data.List (sortOn, intercalate) -import Data.Ord (Down(..)) -import Data.Typeable (cast) -import XMonad.Prompt.ConfirmPrompt (confirmPrompt) -import System.Exit (exitWith, ExitCode(..)) - -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Char (isAlphaNum, isAlpha, isDigit, ord) -import Data.Maybe (fromMaybe, catMaybes) -import XMonad.Actions.CopyWindow as CopyWindow -import XMonad.Util.Run (safeSpawn) -import Prelude hiding (head, last) +import Data.Char (isAlpha, isAlphaNum, isDigit, ord) +import Data.List (intercalate, sortOn) import Data.List.Safe (head, last) -import qualified Rahm.Desktop.StackSet as W - +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.Ord (Down (..)) +import Data.Typeable (cast) import Rahm.Desktop.Common -import Rahm.Desktop.Keys.Dsl import Rahm.Desktop.History +import Rahm.Desktop.Keys.Dsl +import Rahm.Desktop.Logger import Rahm.Desktop.Marking -import Rahm.Desktop.Workspaces +import qualified Rahm.Desktop.StackSet as W import Rahm.Desktop.Submap -import Rahm.Desktop.Logger - +import Rahm.Desktop.Workspaces +import System.Exit (ExitCode (..), exitWith) import Text.Printf - import XMonad +import XMonad.Actions.CopyWindow as CopyWindow +import XMonad.Prompt.ConfirmPrompt (confirmPrompt) +import qualified XMonad.Util.ExtensibleState as XS +import XMonad.Util.Run (safeSpawn) +import Prelude hiding (head, last) type KeyString = [(KeyMask, KeySym, String)] -data Macros = Macros { - workspaceMacros :: Map (KeyMask, KeySym) KeyString -, windowsetMacros :: Map (KeyMask, KeySym) KeyString -} deriving (Read, Show) +data Macros = Macros + { workspaceMacros :: Map (KeyMask, KeySym) KeyString, + windowsetMacros :: Map (KeyMask, KeySym) KeyString + } + deriving (Read, Show) instance ExtensionClass Macros where initialValue = Macros Map.empty Map.empty extensionType = PersistentExtension -data Workspace = - forall a. (Typeable a) => Workspace { - moveLocationToWorkspaceFn :: Location -> X () - , gotoWorkspaceFn :: X () - , workspaceName :: Maybe String - , extraWorkspaceData :: a +data Workspace = forall a. + (Typeable a) => + Workspace + { moveLocationToWorkspaceFn :: Location -> X (), + gotoWorkspaceFn :: X (), + workspaceName :: Maybe String, + extraWorkspaceData :: a } readWorkspaceMacro :: MaybeT X () readWorkspaceMacro = mapNextStringWithKeysym $ \mask sym _ -> do macro <- readMacroString - lift $ XS.modify $ \m -> m { - workspaceMacros = Map.insert (mask, sym) macro (workspaceMacros m) } + lift $ + XS.modify $ \m -> + m + { workspaceMacros = Map.insert (mask, sym) macro (workspaceMacros m) + } readWindowsetMacro :: MaybeT X () readWindowsetMacro = mapNextStringWithKeysym $ \mask sym _ -> do macro <- readMacroString - lift $ XS.modify $ \m -> m { - windowsetMacros = Map.insert (mask, sym) macro (windowsetMacros m) } + lift $ + XS.modify $ \m -> + m + { windowsetMacros = Map.insert (mask, sym) macro (windowsetMacros m) + } readMacroString :: MaybeT X KeyString readMacroString = do mapNextStringWithKeysym $ \m k s -> case (m, k, s) of - _ | k == xK_Return -> return [] - _ | k == xK_Escape -> MaybeT $ return Nothing - r -> ([r]++) <$> readMacroString + _ | k == xK_Return -> return [] + _ | k == xK_Escape -> MaybeT $ return Nothing + r -> ([r] ++) <$> readMacroString justWorkspace :: String -> Workspace justWorkspace s = - Workspace { - moveLocationToWorkspaceFn = flip moveLocationToWorkspace s - , gotoWorkspaceFn = gotoWorkspace s - , workspaceName = Just s - , extraWorkspaceData = () - } + Workspace + { moveLocationToWorkspaceFn = flip moveLocationToWorkspace s, + gotoWorkspaceFn = gotoWorkspace s, + workspaceName = Just s, + extraWorkspaceData = () + } justWorkspaceWithPreferredWindow :: Window -> String -> Workspace justWorkspaceWithPreferredWindow w s = - Workspace { - moveLocationToWorkspaceFn = flip moveLocationToWorkspace s - , gotoWorkspaceFn = do - windows $ \ws' -> - let ws = W.greedyView s ws' - l = W.integrate' $ W.stack $ W.workspace $ W.current ws in - if w `elem` l - then W.focusWindow w ws - else ws - - , workspaceName = Just s - , extraWorkspaceData = () - } + Workspace + { moveLocationToWorkspaceFn = flip moveLocationToWorkspace s, + gotoWorkspaceFn = do + windows $ \ws' -> + let ws = W.greedyView s ws' + l = W.integrate' $ W.stack $ W.workspace $ W.current ws + in if w `elem` l + then W.focusWindow w ws + else ws, + workspaceName = Just s, + extraWorkspaceData = () + } blackHoleWorkspace :: Workspace blackHoleWorkspace = - Workspace { - moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow - , gotoWorkspaceFn = - confirmPrompt def "Do you want to exit xmonad" $ io (exitWith ExitSuccess) - , workspaceName = Nothing - , extraWorkspaceData = () - } + Workspace + { moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow, + gotoWorkspaceFn = + confirmPrompt def "Do you want to exit xmonad" $ io (exitWith ExitSuccess), + workspaceName = Nothing, + extraWorkspaceData = () + } alternateWorkspace :: Workspace alternateWorkspace = - Workspace { - moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do - logs Info "Moving Location: %s" (show l) - case maybeWin of - Nothing -> return () - Just win -> do - alter <- getAlternateWorkspace win - logs Info "Moving %s to %s" (show win) (show alter) - mapM_ (moveLocationToWorkspace l) alter - - , gotoWorkspaceFn = do - (Location _ maybeWin) <- getCurrentLocation - case maybeWin of - Nothing -> return () - Just win -> do - mapM_ gotoWorkspace =<< getAlternateWorkspace win - - , workspaceName = Nothing - , extraWorkspaceData = () - } + Workspace + { moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do + logs Info "Moving Location: %s" (show l) + case maybeWin of + Nothing -> return () + Just win -> do + alter <- getAlternateWorkspace win + logs Info "Moving %s to %s" (show win) (show alter) + mapM_ (moveLocationToWorkspace l) alter, + gotoWorkspaceFn = do + (Location _ maybeWin) <- getCurrentLocation + case maybeWin of + Nothing -> return () + Just win -> do + mapM_ gotoWorkspace =<< getAlternateWorkspace win, + workspaceName = Nothing, + extraWorkspaceData = () + } newtype FloatWorkspace = FloatWorkspace Workspace floatWorkspace :: Workspace -> Workspace -floatWorkspace ws@Workspace { extraWorkspaceData = d } = - Workspace { - moveLocationToWorkspaceFn = \location -> do - - forM_ (locationWindow location) $ \win -> do - case cast d of - Just (FloatWorkspace ws') -> do - windows $ W.sink win - moveLocationToWorkspaceFn ws' location - Nothing -> do - windows $ \ss -> - if win `Map.member` W.floating ss - then ss -- win is already floating - else W.float win (W.RationalRect (1/8) (1/8) (6/8) (6/8)) ss - moveLocationToWorkspaceFn ws location - - - , gotoWorkspaceFn = gotoWorkspaceFn ws - , workspaceName = workspaceName ws - , extraWorkspaceData = FloatWorkspace ws - } +floatWorkspace ws@Workspace {extraWorkspaceData = d} = + Workspace + { moveLocationToWorkspaceFn = \location -> do + forM_ (locationWindow location) $ \win -> do + case cast d of + Just (FloatWorkspace ws') -> do + windows $ W.sink win + moveLocationToWorkspaceFn ws' location + Nothing -> do + windows $ \ss -> + if win `Map.member` W.floating ss + then ss -- win is already floating + else W.float win (W.RationalRect (1 / 8) (1 / 8) (6 / 8) (6 / 8)) ss + moveLocationToWorkspaceFn ws location, + gotoWorkspaceFn = gotoWorkspaceFn ws, + workspaceName = workspaceName ws, + extraWorkspaceData = FloatWorkspace ws + } joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a joinMaybe (MaybeT ma) = MaybeT $ join <$> ma @@ -186,8 +184,8 @@ instance KeyFeeder X where fromX = id readNextKey = mapNextStringWithKeysym -newtype FeedKeys a = FeedKeys { unFeedKeys :: StateT KeyString X a } - deriving (Monad, Functor, Applicative) +newtype FeedKeys a = FeedKeys {unFeedKeys :: StateT KeyString X a} + deriving (Monad, Functor, Applicative) instance KeyFeeder FeedKeys where fromX = FeedKeys . lift @@ -195,7 +193,7 @@ instance KeyFeeder FeedKeys where readNextKey fn = do ls <- lift $ FeedKeys S.get case ls of - ((mask, sym, str):t) -> do + ((mask, sym, str) : t) -> do lift $ FeedKeys $ S.put t fn mask sym str _ -> MaybeT (return Nothing) @@ -234,32 +232,37 @@ readNextWorkspace = readNextKey $ \mask sym str -> case (mask, sym, str) of (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing - (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch] (_, _, "[") -> - justWorkspace <$> - (lift1 (adjacentWorkspaceNotVisible prev) =<< - readNextWorkspaceName) + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible prev) + =<< readNextWorkspaceName + ) (_, _, "]") -> - justWorkspace <$> - (lift1 (adjacentWorkspaceNotVisible next) =<< - readNextWorkspaceName) + justWorkspace + <$> ( lift1 (adjacentWorkspaceNotVisible next) + =<< readNextWorkspaceName + ) (_, _, "(") -> - justWorkspace <$> - (lift1 (adjacentWorkspace prev) =<< readNextWorkspaceName) + justWorkspace + <$> (lift1 (adjacentWorkspace prev) =<< readNextWorkspaceName) (_, _, ")") -> - justWorkspace <$> - (lift1 (adjacentWorkspace next) =<< readNextWorkspaceName) - (_, _, "^") -> mapMaybeT fromX $ MaybeT $ - withWindowSet $ \ws -> return $ - (fmap (justWorkspace . W.tag . W.workspace . snd) . head) - (getHorizontallyOrderedScreens ws) + justWorkspace + <$> (lift1 (adjacentWorkspace next) =<< readNextWorkspaceName) + (_, _, "^") -> mapMaybeT fromX $ + MaybeT $ + withWindowSet $ \ws -> + return $ + (fmap (justWorkspace . W.tag . W.workspace . snd) . head) + (getHorizontallyOrderedScreens ws) (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace - (_, _, "$") -> MaybeT $ fromX $ - withWindowSet $ \ws -> return $ - (fmap (justWorkspace . W.tag . W.workspace . snd) . last) - (getHorizontallyOrderedScreens ws) + (_, _, "$") -> MaybeT $ + fromX $ + withWindowSet $ \ws -> + return $ + (fmap (justWorkspace . W.tag . W.workspace . snd) . last) + (getHorizontallyOrderedScreens ws) (_, _, ":") -> floatWorkspace <$> readNextWorkspace (_, _, ",") -> do ws <- readNextWorkspace @@ -268,10 +271,9 @@ readNextWorkspace = map (W.tag . W.workspace . snd) <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (_, rest) = break ((==workspaceName ws) . Just) (screens ++ screens) + let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens) justWorkspace <$> MaybeT (return $ head $ tail rest) - (_, _, ";") -> do ws <- readNextWorkspace screens <- @@ -279,25 +281,24 @@ readNextWorkspace = map (W.tag . W.workspace . snd) <$> withWindowSet (return . getHorizontallyOrderedScreens) - let (front, _) = break ((==workspaceName ws) . Just) (screens ++ screens) + let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens) justWorkspace <$> MaybeT (return $ last front) - (_, _, "/") -> fromMaybeTX $ do - justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT ((head=<<) <$> askWindowId)) - + justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT ((head =<<) <$> askWindowId)) (_, _, "@") -> do loc <- readNextLocationSet - MaybeT $ fromX $ withWindowSet $ \ws -> return $ do - win <- locationWindow =<< head loc - winLocation <- W.findWindow ws win - (justWorkspaceWithPreferredWindow win . W.tag) <$> W.getLocationWorkspace winLocation - + MaybeT $ + fromX $ + withWindowSet $ \ws -> return $ do + win <- locationWindow =<< head loc + winLocation <- W.findWindow ws win + (justWorkspaceWithPreferredWindow win . W.tag) <$> W.getLocationWorkspace winLocation (_, _, "~") -> justWorkspace . accompaningWorkspace <$> readNextWorkspaceName - (_, _, " ") -> mt $ - justWorkspace . accompaningWorkspace <$> getCurrentWorkspace - + (_, _, " ") -> + mt $ + justWorkspace . accompaningWorkspace <$> getCurrentWorkspace (_, _, "_") -> return blackHoleWorkspace (_, _, "-") -> return alternateWorkspace (_, _, "=") -> do @@ -311,7 +312,6 @@ readNextWorkspace = if workspaceName ws1 == workspaceName ws2 then ws3 else ws4 - (_, _, "?") -> do l1 <- readNextLocationSet @@ -324,7 +324,6 @@ readNextWorkspace = if null l1 then ws2 else ws1 - (mask, keysym, _) -> do macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . workspaceMacros <$> XS.get) fromMaybeTX $ workspaceForKeysT macro @@ -337,41 +336,46 @@ readNextLocationSet = readNextKey $ \mask sym str -> case (mask, sym, str) of (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing - (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch] - (_, _, "0") -> (:[]) <$> MaybeT (fromX getMostRecentLocationInHistory) - (_, _, [ch]) | isDigit ch -> - (:[]) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30)) - (_, _, ".") -> (:[]) <$> mt getCurrentLocation - (_, _, "^") -> (:[]) <$> fromMaybeTX farLeftWindow - (_, _, "$") -> (:[]) <$> fromMaybeTX farRightWindow - (_, _, "\"") -> (:[]) <$> MaybeT (fromX nextLocation) - (_, _, "'") -> (:[]) <$> MaybeT (fromX lastLocation) - (_, _, "*") -> mt $ do -- All visible windows. - wins <- withWindowSet $ - return . concatMap (W.integrate' . W.stack . W.workspace) . W.screens + (_, _, "0") -> (: []) <$> MaybeT (fromX getMostRecentLocationInHistory) + (_, _, [ch]) + | isDigit ch -> + (: []) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30)) + (_, _, ".") -> (: []) <$> mt getCurrentLocation + (_, _, "^") -> (: []) <$> fromMaybeTX farLeftWindow + (_, _, "$") -> (: []) <$> fromMaybeTX farRightWindow + (_, _, "\"") -> (: []) <$> MaybeT (fromX nextLocation) + (_, _, "'") -> (: []) <$> MaybeT (fromX lastLocation) + (_, _, "*") -> mt $ do + -- All visible windows. + wins <- + withWindowSet $ + return . concatMap (W.integrate' . W.stack . W.workspace) . W.screens catMaybes <$> mapM (runMaybeT . windowLocation) wins - - (_, _, "-") -> fromMaybeTX $ - mapM windowLocation =<< lift getAlternateWindows - (_, _, "/") -> fromMaybeTX $ - mapM windowLocation =<< MaybeT askWindowId + (_, _, "-") -> + fromMaybeTX $ + mapM windowLocation =<< lift getAlternateWindows + (_, _, "/") -> + fromMaybeTX $ + mapM windowLocation =<< MaybeT askWindowId (_, _, "%") -> fromMaybeTX $ do ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows)) - lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret)) + lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret)) return ret - (_, _, s) | s == "\t" || s == "@" || s == "\n" -> - (mt . windowsInWorkspace) =<< readNextWorkspaceName - (_, _, "!") -> (:[]) <$> joinMaybe (head <$> readNextLocationSet) + (_, _, s) + | s == "\t" || s == "@" || s == "\n" -> + (mt . windowsInWorkspace) =<< readNextWorkspaceName + (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet) (_, _, ",") -> tail <$> readNextLocationSet (_, _, "~") -> reverse <$> readNextLocationSet - (_, _, ":") -> mt $ - withWindowSet $ - fmap catMaybes . - mapM (runMaybeT . windowLocation) . - Map.keys . - W.floating + (_, _, ":") -> + mt $ + withWindowSet $ + fmap catMaybes + . mapM (runMaybeT . windowLocation) + . Map.keys + . W.floating (_, _, "?") -> do l1 <- readNextLocationSet l2 <- readNextLocationSet @@ -385,7 +389,8 @@ readNextLocationSet = l1 <- readNextLocationSet l2 <- readNextLocationSet return $ filter (not . flip elem l2) l1 - (_, _, "&") -> do -- intersection + (_, _, "&") -> do + -- intersection l1 <- readNextLocationSet l2 <- readNextLocationSet return $ filter (`elem` l2) l1 diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index 08bd8d1..0bfc0a3 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -1,42 +1,39 @@ module Rahm.Desktop.Layout where -import GHC.TypeLits - -import Data.Proxy (Proxy(..)) -import Control.Arrow (second) -import XMonad.Hooks.ManageDocks -import XMonad.Layout.Circle -import XMonad.Layout.Accordion import Control.Applicative -import XMonad.Layout.Spacing +import Control.Arrow (second) import Data.List +import qualified Data.Map as M +import Data.Proxy (Proxy (..)) import Data.Typeable (cast) -import XMonad.Layout.Spiral -import XMonad.Layout.ThreeColumns -import XMonad.Layout.Grid -import XMonad.Layout.Dishes -import XMonad.Layout.MosaicAlt -import XMonad.Layout.Fullscreen -import qualified XMonad.Layout.Dwindle as D -import XMonad.Layout -import XMonad.Layout.LayoutModifier -import XMonad -import XMonad.Core -import XMonad.Layout.NoBorders (smartBorders, noBorders) - -import Rahm.Desktop.Layout.CornerLayout (Corner(..)) +import GHC.TypeLits +import Rahm.Desktop.Layout.Bordering +import Rahm.Desktop.Layout.ConsistentMosaic +import Rahm.Desktop.Layout.CornerLayout (Corner (..)) +import Rahm.Desktop.Layout.Flip +import Rahm.Desktop.Layout.Hole import Rahm.Desktop.Layout.List -import Rahm.Desktop.Layout.ReinterpretMessage import Rahm.Desktop.Layout.Pop -import Rahm.Desktop.Layout.Flip -import Rahm.Desktop.Layout.Rotate import Rahm.Desktop.Layout.Redescribe -import Rahm.Desktop.Layout.Hole -import Rahm.Desktop.Layout.ConsistentMosaic -import Rahm.Desktop.Layout.Bordering - -import qualified Data.Map as M +import Rahm.Desktop.Layout.ReinterpretMessage +import Rahm.Desktop.Layout.Rotate import qualified Rahm.Desktop.StackSet as W +import XMonad +import XMonad.Core +import XMonad.Hooks.ManageDocks +import XMonad.Layout +import XMonad.Layout.Accordion +import XMonad.Layout.Circle +import XMonad.Layout.Dishes +import qualified XMonad.Layout.Dwindle as D +import XMonad.Layout.Fullscreen +import XMonad.Layout.Grid +import XMonad.Layout.LayoutModifier +import XMonad.Layout.MosaicAlt +import XMonad.Layout.NoBorders (noBorders, smartBorders) +import XMonad.Layout.Spacing +import XMonad.Layout.Spiral +import XMonad.Layout.ThreeColumns myLayout = fullscreenFull $ @@ -44,21 +41,20 @@ myLayout = mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True - mods = bordering . mySpacing . poppable . flippable . rotateable . hole myLayoutList = - layoutList $ - mods (reinterpretIncMaster $ spiral (6/7)) |: - mods (MosaicWrap $ modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: - mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: - mods (Redescribe UsingTall (Tall 1 (3/100) (1/2))) |: - mods (Redescribe UsingThreeCol (ThreeCol 1 (3/100) (1/2))) |: - mods Grid |: - mods (Dishes 2 (1/6)) |: - mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |: - nil + layoutList $ + mods (reinterpretIncMaster $ spiral (6 / 7)) + |: mods (MosaicWrap $ modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) + |: mods (reinterpretIncMaster $ Corner (3 / 4) (3 / 100)) + |: mods (Redescribe UsingTall (Tall 1 (3 / 100) (1 / 2))) + |: mods (Redescribe UsingThreeCol (ThreeCol 1 (3 / 100) (1 / 2))) + |: mods Grid + |: mods (Dishes 2 (1 / 6)) + |: mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) + |: nil nLayouts :: Int nLayouts = layoutListLength myLayoutList @@ -70,30 +66,32 @@ nLayouts = layoutListLength myLayoutList -- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system -- hacking one can do in Haskell. instance DoReinterpret "ForMosaic" where - -- IncMaster message reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do - Just . SomeMessage <$> ( - if n > 0 - then expandPositionAlt - else shrinkPositionAlt) + Just . SomeMessage + <$> ( if n > 0 + then expandPositionAlt + else shrinkPositionAlt + ) -- ResizeMaster message reinterpretMessage _ (fromMessage -> Just m) = do - Just . SomeMessage <$> - (case m of - Expand -> expandPositionAlt - Shrink -> shrinkPositionAlt) + Just . SomeMessage + <$> ( case m of + Expand -> expandPositionAlt + Shrink -> shrinkPositionAlt + ) -- 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 + return $ + Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink reinterpretMessage _ m = return (Just m) modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a @@ -104,10 +102,12 @@ reinterpretIncMaster :: reinterpretIncMaster = ModifiedLayout ReinterpretMessage data UsingTall = UsingTall deriving (Read, Show) + instance Describer UsingTall Tall where newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")" data UsingThreeCol = UsingThreeCol deriving (Read, Show) + instance Describer UsingThreeCol ThreeCol where newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")" newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")" diff --git a/src/Rahm/Desktop/Layout/Bordering.hs b/src/Rahm/Desktop/Layout/Bordering.hs index 0a06319..5fb1259 100644 --- a/src/Rahm/Desktop/Layout/Bordering.hs +++ b/src/Rahm/Desktop/Layout/Bordering.hs @@ -1,45 +1,61 @@ {-# LANGUAGE DeriveAnyClass #-} -module Rahm.Desktop.Layout.Bordering - (Bordering(..), banishToBorder, unbanish, rotateBorderForward, - rotateBorderBackward, bordering, toggleBanish, - changeWidth, changeHeight, moveForward, moveBackward) where -import XMonad +module Rahm.Desktop.Layout.Bordering + ( Bordering (..), + banishToBorder, + unbanish, + rotateBorderForward, + rotateBorderBackward, + bordering, + toggleBanish, + changeWidth, + changeHeight, + moveForward, + moveBackward, + ) +where -import Control.Monad -import Data.Tuple (swap) import Control.Arrow +import Control.Monad +import Data.List (find, partition) import Data.Map (Map) -import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import Data.List (partition, find) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy) import qualified Data.Set as Set +import Data.Tuple (swap) import Data.Typeable (cast) -import Data.Proxy (Proxy) - import Rahm.Desktop.Logger import qualified Rahm.Desktop.StackSet as W +import XMonad -data BorderPosition = - North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest +data BorderPosition + = North + | NorthEast + | East + | SouthEast + | South + | SouthWest + | West + | NorthWest deriving (Eq, Show, Read, Ord, Enum, Bounded) -data BorderingData a = - BorderingData { - extraWindows :: Map BorderPosition a - , borderingWidth :: Rational - , borderingHeight :: Rational - , borderingPadding :: Int - } deriving (Eq, Ord, Show, Read) - -data Bordering (l :: * -> *) (a :: *) = - Bordering { - borderingData :: BorderingData a, +data BorderingData a = BorderingData + { extraWindows :: Map BorderPosition a, + borderingWidth :: Rational, + borderingHeight :: Rational, + borderingPadding :: Int + } + deriving (Eq, Ord, Show, Read) + +data Bordering (l :: * -> *) (a :: *) = Bordering + { borderingData :: BorderingData a, wrappedLayout :: l a - } deriving (Eq, Ord, Show, Read) + } + deriving (Eq, Ord, Show, Read) -data ModifyBordering a = - ModifyBordering (BorderingData a -> BorderingData a) +data ModifyBordering a + = ModifyBordering (BorderingData a -> BorderingData a) deriving (Message) enumNext :: (Eq a, Enum a, Bounded a) => a -> a @@ -53,40 +69,39 @@ enumPrev a | otherwise = pred a bordering :: l a -> Bordering l a -bordering = Bordering (BorderingData mempty (1/6) (1/6) 10) +bordering = Bordering (BorderingData mempty (1 / 6) (1 / 6) 10) banishToBorder :: a -> ModifyBordering a banishToBorder win = let allPositions = - (\(a, b) -> b ++ a) $ break (==SouthEast) [minBound .. maxBound] - in - ModifyBordering $ \dat -> + (\(a, b) -> b ++ a) $ break (== SouthEast) [minBound .. maxBound] + in ModifyBordering $ \dat -> maybe dat - (\pos -> - dat { extraWindows = Map.insert pos win (extraWindows dat)}) $ - find (not . (`Map.member`extraWindows dat)) allPositions + ( \pos -> + dat {extraWindows = Map.insert pos win (extraWindows dat)} + ) + $ find (not . (`Map.member` extraWindows dat)) allPositions toggleBanish :: (Eq a) => a -> ModifyBordering a toggleBanish win = ModifyBordering $ \dat -> - let (ModifyBordering fn) = + let (ModifyBordering fn) = if elem win $ Map.elems $ extraWindows dat then unbanish win else banishToBorder win - in fn dat - + in fn dat unbanish :: (Eq a) => a -> ModifyBordering a unbanish win = ModifyBordering $ \dat -> maybe dat - (\pos -> dat { extraWindows = Map.delete pos (extraWindows dat) }) $ - (fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat)) + (\pos -> dat {extraWindows = Map.delete pos (extraWindows dat)}) + $ (fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat)) rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a rotateBorder next = ModifyBordering $ \dat -> - dat { extraWindows = Map.mapKeys next (extraWindows dat) } + dat {extraWindows = Map.mapKeys next (extraWindows dat)} rotateBorderForward :: Proxy a -> ModifyBordering a rotateBorderForward _ = rotateBorder enumNext @@ -96,45 +111,48 @@ rotateBorderBackward _ = rotateBorder enumPrev changeWidth :: Proxy a -> Rational -> ModifyBordering a changeWidth _ amt = ModifyBordering $ \dat -> - dat { borderingWidth = guard $ borderingWidth dat + amt } - where guard x | x < 1/12 = 1/12 - | x > 4/12 = 4/12 - | otherwise = x + dat {borderingWidth = guard $ borderingWidth dat + amt} + where + guard x + | x < 1 / 12 = 1 / 12 + | x > 4 / 12 = 4 / 12 + | otherwise = x changeHeight :: Proxy a -> Rational -> ModifyBordering a changeHeight _ amt = ModifyBordering $ \dat -> - dat { borderingHeight = guard $ borderingHeight dat + amt } - where guard x | x < 1/12 = 1/12 - | x > 4/12 = 4/12 - | otherwise = x + dat {borderingHeight = guard $ borderingHeight dat + amt} + where + guard x + | x < 1 / 12 = 1 / 12 + | x > 4 / 12 = 4 / 12 + | otherwise = x instance Semigroup (ModifyBordering a) where (<>) = mappend instance Monoid (ModifyBordering a) where - mempty = ModifyBordering id mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1) - move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a move fn win = ModifyBordering $ \dat -> - let mKey = fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat) in - case mKey of - Nothing -> dat - Just key -> - let newKey = until (\k -> not (Map.member k (extraWindows dat) && k /= key)) - fn (fn key) - wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat - in - dat { extraWindows = wins' } + let mKey = fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat) + in case mKey of + Nothing -> dat + Just key -> + let newKey = + until + (\k -> not (Map.member k (extraWindows dat) && k /= key)) + fn + (fn key) + wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat + in dat {extraWindows = wins'} moveForward :: (Eq a) => a -> ModifyBordering a moveForward = move enumNext moveBackward :: (Eq a) => a -> ModifyBordering a moveBackward = move enumPrev - instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where runLayout (W.Workspace t (Bordering dat l) as) rect = do @@ -145,35 +163,33 @@ instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering filterStack Nothing = ([], Nothing) filterStack (Just (W.Stack f h t)) = do let elSet = Set.fromList (Map.elems $ extraWindows dat) - ((hp, h'), (tp, t')) = dbl (partition (`Set.member`elSet)) (h, t) - in case (Set.member f elSet, h', t', hp ++ tp) of - (False, _, _, r) -> (r, Just $ W.Stack f h' t') - (True, (a:h''), _, r) -> (f:r, Just $ W.Stack a h'' t') - (True, [], (a:t''), r) -> (f:r, Just $ W.Stack a [] t'') - (True, [], [], r) -> (f:r, Nothing) + ((hp, h'), (tp, t')) = dbl (partition (`Set.member` elSet)) (h, t) + in case (Set.member f elSet, h', t', hp ++ tp) of + (False, _, _, r) -> (r, Just $ W.Stack f h' t') + (True, (a : h''), _, r) -> (f : r, Just $ W.Stack a h'' t') + (True, [], (a : t''), r) -> (f : r, Just $ W.Stack a [] t'') + (True, [], [], r) -> (f : r, Nothing) layoutRest windows = map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $ - filter ((`elem`windows) . snd) $ + filter ((`elem` windows) . snd) $ Map.toList (extraWindows dat) padRect (Rectangle x y w h) = let p :: (Integral a) => a - p = fromIntegral (borderingPadding dat) in - Rectangle (x + p) (y + p) (w - p*2) (h - p*2) + p = fromIntegral (borderingPadding dat) + in Rectangle (x + p) (y + p) (w - p * 2) (h - p * 2) loc2Rect loc = case loc of - North -> W.RationalRect (1/2 - (bw / 2)) 0 bw bh + North -> W.RationalRect (1 / 2 - (bw / 2)) 0 bw bh NorthEast -> W.RationalRect (1 - bw) 0 bw bh - East -> W.RationalRect (1 - bw) (1/2 - (bh / 2)) bw bh + East -> W.RationalRect (1 - bw) (1 / 2 - (bh / 2)) bw bh SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh - South -> W.RationalRect (1/2 - (bw / 2)) (1 - bh) bw bh + South -> W.RationalRect (1 / 2 - (bw / 2)) (1 - bh) bw bh SouthWest -> W.RationalRect 0 (1 - bh) bw bh - West -> W.RationalRect 0 (1/2 - (bh / 2)) bw bh + West -> W.RationalRect 0 (1 / 2 - (bh / 2)) bw bh NorthWest -> W.RationalRect 0 0 bw bh - where - bw = borderingWidth dat bh = borderingHeight dat @@ -183,12 +199,10 @@ instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering maybeNewLayout <- handleMessage l m return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout) where - f e@BorderingData{ extraWindows = ws } = - e { extraWindows = Map.filter (maybe True (/=w) . cast) ws } - + f e@BorderingData {extraWindows = ws} = + e {extraWindows = Map.filter (maybe True (/= w) . cast) ws} handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) = return (Just $ Bordering (fn d) l) - handleMessage (Bordering d l) a = do maybeNewLayout <- handleMessage l a return (Bordering d <$> maybeNewLayout) diff --git a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs index 3dbc44c..0d95c8f 100644 --- a/src/Rahm/Desktop/Layout/ConsistentMosaic.hs +++ b/src/Rahm/Desktop/Layout/ConsistentMosaic.hs @@ -1,27 +1,23 @@ - -- This module provides a wrapper around the Mosaic layout to create a more -- consistent experience where instead of the windows being the ones it works -- on, it instead works on the window places so things like window swapping -- still work as expected. module Rahm.Desktop.Layout.ConsistentMosaic where -import XMonad -import qualified Rahm.Desktop.StackSet as W -import qualified Data.Map as Map import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (mapMaybe) - -import XMonad.Layout.MosaicAlt - import Rahm.Desktop.Logger - +import qualified Rahm.Desktop.StackSet as W +import XMonad +import XMonad.Layout.MosaicAlt newtype MosaicWrap l a = MosaicWrap (l a) deriving (Read, Show) doAlt :: (Window -> HandleWindowAlt) -> X HandleWindowAlt doAlt f = do - (W.StackSet (W.Screen (W.Workspace _ _ mStack) _ _) _ _ _) - <- windowset <$> get + (W.StackSet (W.Screen (W.Workspace _ _ mStack) _ _) _ _ _) <- + windowset <$> get return $ case mStack of @@ -34,11 +30,9 @@ expandPositionAlt = doAlt expandWindowAlt shrinkPositionAlt :: X HandleWindowAlt shrinkPositionAlt = doAlt shrinkWindowAlt - instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicWrap l) a where - runLayout (W.Workspace t (MosaicWrap l) (id -> Just s)) rect = do - let zs = zipStack [100..] s + let zs = zipStack [100 ..] s s' = fmap fst zs m = Map.fromList (W.integrate zs) @@ -48,18 +42,14 @@ instance (LayoutClass l a, Show a, Ord a, Enum a, Num a) => LayoutClass (MosaicW (,rect) <$> Map.lookup place m return (rects', MosaicWrap <$> maybeNewLayout) - where zipStack as (W.Stack b c d) = - let (cz, bz : dz) = splitAt (length c) as in - W.Stack (bz, b) (zip (reverse cz) c) (zip dz d) - - + let (cz, bz : dz) = splitAt (length c) as + in W.Stack (bz, b) (zip (reverse cz) c) (zip dz d) runLayout (W.Workspace t (MosaicWrap l) a) rect = do (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect return (rects, MosaicWrap <$> maybeNewLayout) - -- By default just pass the message to the underlying layout. handleMessage (MosaicWrap l) mess = do maybeNewLayout <- handleMessage l mess diff --git a/src/Rahm/Desktop/Layout/CornerLayout.hs b/src/Rahm/Desktop/Layout/CornerLayout.hs index 7cf4421..f87d9fa 100644 --- a/src/Rahm/Desktop/Layout/CornerLayout.hs +++ b/src/Rahm/Desktop/Layout/CornerLayout.hs @@ -3,8 +3,8 @@ module Rahm.Desktop.Layout.CornerLayout where import Data.Typeable (Typeable) -import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage) import qualified Rahm.Desktop.StackSet as S +import XMonad (LayoutClass (..), Rectangle (..), Resize (..), fromMessage) data Corner a = Corner Rational Rational deriving (Show, Typeable, Read) @@ -20,18 +20,20 @@ instance LayoutClass Corner a where vn = (length ws - 1) `div` 2 hn = (length ws - 1) - vn - in - case ws of + in case ws of [a] -> [(a, screen)] - [a, b] -> [ - (a, Rectangle x y w' h), - (b, Rectangle (x + fromIntegral w') y (w - w') h)] + [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 + 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 diff --git a/src/Rahm/Desktop/Layout/Draw.hs b/src/Rahm/Desktop/Layout/Draw.hs index ff90b9e..49921b0 100644 --- a/src/Rahm/Desktop/Layout/Draw.hs +++ b/src/Rahm/Desktop/Layout/Draw.hs @@ -1,33 +1,35 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Rahm.Desktop.Layout.Draw (drawLayout) where -import Control.Monad - import Control.Arrow (second) import Control.Concurrent (threadDelay) import Control.Exception (handle) +import Control.Monad import Control.Monad.Writer (execWriter, tell) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Rahm.Desktop.Hash (quickHash) import Rahm.Desktop.Layout.Pop (setPop) +import qualified Rahm.Desktop.StackSet as S import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath ((</>)) import Text.Printf (printf) -import XMonad.Layout.Spacing (SpacingModifier(..), Border(..)) -import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) - -import XMonad (X, - Rectangle(..), - Dimension, - LayoutClass, - Message, - Window, - SomeMessage(..)) - +import XMonad + ( Dimension, + LayoutClass, + Message, + Rectangle (..), + SomeMessage (..), + Window, + X, + ) import qualified XMonad as X -import qualified Rahm.Desktop.StackSet as S +import XMonad.Layout.MosaicAlt (expandWindowAlt, shrinkWindowAlt) +import XMonad.Layout.Spacing (Border (..), SpacingModifier (..)) -- Draws and returns an XPM for the current layout. -- @@ -43,23 +45,24 @@ import qualified Rahm.Desktop.StackSet as S -- impure. While in-practice most layouts are pure, it should be kept in mind. drawLayout :: X (Bool, String, String) drawLayout = do - winset <- X.gets X.windowset - let layout = S.layout $ S.workspace $ S.current winset - - -- Gotta reset the layout to a consistent state. - layout' <- foldM (flip ($)) layout $ [ - handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' $ setPop $ const False + winset <- X.gets X.windowset + let layout = S.layout $ S.workspace $ S.current winset + + -- Gotta reset the layout to a consistent state. + layout' <- + foldM (flip ($)) layout $ + [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, + handleMessage' $ setPop $ const False ] - -- Add some changes for the Mosaic layout to handle so it get's a - -- unique looking icon. (The default state is pretty boring). - ++ replicate 10 (handleMessage' (expandWindowAlt 1)) - ++ replicate 5 (handleMessage' (expandWindowAlt 4)) - ++ replicate 1 (handleMessage' (expandWindowAlt 3)) + -- Add some changes for the Mosaic layout to handle so it get's a + -- unique looking icon. (The default state is pretty boring). + ++ replicate 10 (handleMessage' (expandWindowAlt 1)) + ++ replicate 5 (handleMessage' (expandWindowAlt 4)) + ++ replicate 1 (handleMessage' (expandWindowAlt 3)) - (cached, xpm) <- drawXpmIO layout' + (cached, xpm) <- drawXpmIO layout' - return (cached , X.description layout, printf "<icon=%s/>" xpm) + return (cached, X.description layout, printf "<icon=%s/>" xpm) -- Returns true if a point is inside a rectangle (inclusive). pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool @@ -76,8 +79,8 @@ sf :: (Integral a) => a sf = 1024 handleMessage' :: - (LayoutClass layout a, Message m) => m -> layout a -> X (layout a) -handleMessage' message layout = do + (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. @@ -89,15 +92,21 @@ drawXpmIO l = do dir <- X.asks (X.cfgDir . X.directories) 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" ] + let colors = + [ "#cc9a9a", + "#cc9999", + "#cc8080", + "#cc6666", + "#cc4c4c", + "#cc3232", + "#cc1818", + "#cc0000" + ] (rects', _) <- X.runLayout @@ -105,7 +114,7 @@ drawXpmIO l = do (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) + Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf) X.liftIO $ do exists <- doesFileExist iconPath @@ -126,35 +135,35 @@ drawXpmIO l = do -- - The amount to shrink the windows by for those pretty gaps. -- drawXpm :: - (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String + (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 + 7) (h + 7) (length rects + 1) - - let zipRects = zip ['A' .. 'Z'] rects - - forM_ zipRects $ \(char, (color, _)) -> do - tell $ printf "\"%c c %s\",\n" char color - tell "\"% c #000000\",\n" - - forM_ [0..2] $ \_ -> do - tell "\"%%%" - forM_ [0 .. w] $ \_ -> tell "%" - tell "%%%\"\n" - forM_ [0 .. h] $ \y -> do - tell "\"%%%" - forM_ [0 .. w] $ \x -> - (case find (matches x y) zipRects of + tell "/* XPM */\n" + tell "static char *out[] = {\n" + tell $ printf "\"%d %d %d 1 \",\n" (w + 7) (h + 7) (length rects + 1) + + let zipRects = zip ['A' .. 'Z'] rects + + forM_ zipRects $ \(char, (color, _)) -> do + tell $ printf "\"%c c %s\",\n" char color + tell "\"% c #000000\",\n" + + forM_ [0 .. 2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" + forM_ [0 .. h] $ \y -> do + tell "\"%%%" + forM_ [0 .. w] $ \x -> + ( case find (matches x y) zipRects of Nothing -> tell "%" - Just (chr, _) -> tell [chr]) - tell "%%%\"\n" - forM_ [0..2] $ \_ -> do - tell "\"%%%" - forM_ [0 .. w] $ \_ -> tell "%" - tell "%%%\"\n" - tell "};\n" - + Just (chr, _) -> tell [chr] + ) + tell "%%%\"\n" + forM_ [0 .. 2] $ \_ -> do + tell "\"%%%" + forM_ [0 .. w] $ \_ -> tell "%" + tell "%%%\"\n" + tell "};\n" where matches x y (_, (_, r)) = pointInRect (x, y) r rects = map (second (shrink shrinkAmt)) rects' diff --git a/src/Rahm/Desktop/Layout/Flip.hs b/src/Rahm/Desktop/Layout/Flip.hs index fe425e9..5942a4a 100644 --- a/src/Rahm/Desktop/Layout/Flip.hs +++ b/src/Rahm/Desktop/Layout/Flip.hs @@ -1,27 +1,27 @@ {-# LANGUAGE DeriveAnyClass #-} -- Layout modifier to flip a layout either horizontally or vertically or both. -module Rahm.Desktop.Layout.Flip ( - Flip(..), +module Rahm.Desktop.Layout.Flip + ( Flip (..), flippable, flipVertically, flipHorizontally, - DoFlip - ) where - -import XMonad -import XMonad.Layout.LayoutModifier + DoFlip, + ) +where import Control.Arrow (second) +import Data.Default (Default (..)) import Data.List (intercalate) -import Data.Default (Default(..)) +import XMonad +import XMonad.Layout.LayoutModifier -- A flipped layout is either flipped horizontally or vertically. -data Flip a = - Flip { - horiz :: Bool - , vert :: Bool - } deriving (Eq, Show, Ord, Read) +data Flip a = Flip + { horiz :: Bool, + vert :: Bool + } + deriving (Eq, Show, Ord, Read) -- Default instance for Flip. Both are set to false. instance Default (Flip a) where @@ -31,11 +31,12 @@ instance Default (Flip a) where data DoFlip where -- Contains a function to modify Flip DoFlip :: (forall k (a :: k). Flip a -> Flip a) -> DoFlip - deriving Message + deriving (Message) -- DoFlip is a monoid. instance Semigroup DoFlip where - (<>) = mappend + (<>) = mappend + instance Monoid DoFlip where mempty = DoFlip id mappend (DoFlip a) (DoFlip b) = DoFlip (a . b) @@ -46,14 +47,13 @@ flippable = ModifiedLayout def -- Message to send a flipVertically message flipVertically :: DoFlip -flipVertically = DoFlip $ \f -> f { vert = not (vert f) } +flipVertically = DoFlip $ \f -> f {vert = not (vert f)} -- Message to send a flipHorizontally message. flipHorizontally :: DoFlip -flipHorizontally = DoFlip $ \f -> f { horiz = not (horiz f) } +flipHorizontally = DoFlip $ \f -> f {horiz = not (horiz f)} instance LayoutModifier Flip a where - -- Modifies the layout. For each rectangle returned from the underlying -- layout, flip it relative to the screen. pureModifier flip (Rectangle sx sy sw sh) stack returned = @@ -62,8 +62,8 @@ instance LayoutModifier Flip a where -- doFlip -- the composition of maybe flipping horizontally and -- vertically. doFlip = - (if horiz flip then flipHoriz else id) . - (if vert flip then flipVert else id) + (if horiz flip then flipHoriz else id) + . (if vert flip then flipVert else id) flipVert (Rectangle x y w h) = Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h @@ -78,10 +78,15 @@ instance LayoutModifier Flip a where modifyDescription flip (description -> descr) = (++) descr $ if horiz flip || vert flip - then intercalate " and " ( - map snd $ - filter fst [ - (horiz flip, "Horizontally"), - (vert flip, "Vertically")]) - ++ " Flipped" + then + intercalate + " and " + ( map snd $ + filter + fst + [ (horiz flip, "Horizontally"), + (vert flip, "Vertically") + ] + ) + ++ " Flipped" else "" diff --git a/src/Rahm/Desktop/Layout/Hole.hs b/src/Rahm/Desktop/Layout/Hole.hs index fe48340..42bac48 100644 --- a/src/Rahm/Desktop/Layout/Hole.hs +++ b/src/Rahm/Desktop/Layout/Hole.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE UndecidableInstances, DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} -- Delegates to a lower layout, but leaves a hole where the next window will go. module Rahm.Desktop.Layout.Hole (hole, toggleHole) where -import XMonad import Data.Maybe (mapMaybe) - import qualified Rahm.Desktop.StackSet as W +import XMonad data Hole (l :: * -> *) (a :: *) = Hole Bool (l a) deriving instance Show (l a) => Show (Hole l a) + deriving instance Read (l a) => Read (Hole l a) hole :: l a -> Hole l a @@ -26,7 +27,7 @@ data ManageHole where instance (LayoutClass l a, Eq a, Num a) => LayoutClass (Hole l) a where runLayout (W.Workspace t (Hole enabled l) a) rect = do (rects, maybeNewLayout) <- runLayout (app (-1) $ W.Workspace t l a) rect - return (filter ((/=(-1)) . fst) rects, fmap (Hole enabled) maybeNewLayout) + return (filter ((/= (-1)) . fst) rects, fmap (Hole enabled) maybeNewLayout) where app x w | not enabled = w app x (W.Workspace t l s) = diff --git a/src/Rahm/Desktop/Layout/List.hs b/src/Rahm/Desktop/Layout/List.hs index d6ab6ba..787697e 100644 --- a/src/Rahm/Desktop/Layout/List.hs +++ b/src/Rahm/Desktop/Layout/List.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE UndecidableInstances, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {- - This module provides a more powerful version of the "Choose" layout that can @@ -7,34 +8,36 @@ - The indexing uses a type-safe zipper to keep track of the currently-selected - layout. -} -module Rahm.Desktop.Layout.List ( - LayoutList, - layoutList, - LCons, - LNil, - toNextLayout, - toPreviousLayout, - toFirstLayout, - toIndexedLayout, - (|:), - nil, - layoutListLength, - layoutListLengthProxy - )where +module Rahm.Desktop.Layout.List + ( LayoutList, + layoutList, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + toIndexedLayout, + (|:), + nil, + layoutListLength, + layoutListLengthProxy, + ) +where import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) import Control.Monad.Identity (runIdentity) -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Proxy import Data.Void import GHC.TypeLits -import XMonad import qualified Rahm.Desktop.StackSet as W +import XMonad -- 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 @@ -55,20 +58,25 @@ data LCons l t a = LCons (l a) (t a) deriving (Read, Show) -- -- 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 +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 +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 @@ -118,7 +126,6 @@ instance (Selector t) => Selector (Sel t) where -- 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 @@ -155,9 +162,12 @@ intToSelector n = incrementCycle $ intToSelector (n - 1) data LayoutList l a where LayoutList :: (LayoutSelect l a, Selector (SelectorFor l)) => - SelectorFor l -> l a -> LayoutList l a + 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) -- Type family to get the LengthOf a ConsList. @@ -183,8 +193,10 @@ infixr 5 |: -- Constructs a LayoutList. This function enforces that the SelectorFor l -- is a 'Sel' type. Essentially this enforces that there must be at least one -- underlying layout, otherwise a LayoutList cannot be constructed. -layoutList :: (LayoutSelect l a, SelectorFor l ~ Sel n) => - l a -> LayoutList l a +layoutList :: + (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> + LayoutList l a layoutList = LayoutList Sel -- The termination of a layout zipper. @@ -193,11 +205,11 @@ 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) + -- 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 @@ -213,28 +225,34 @@ toFirstLayout = NavigateLayout (`fromMaybe` initial) -- NavigateLayout instance to go to an indexed layout. toIndexedLayout :: Int -> NavigateLayout -toIndexedLayout i = NavigateLayout $ - (`fromMaybe` initial) >>> addSelector (intToSelector i) +toIndexedLayout i = + NavigateLayout $ + (`fromMaybe` initial) >>> addSelector (intToSelector i) -instance Message NavigateLayout where +instance Message NavigateLayout -- 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 - +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) => + update :: + forall r m. + (Monad m) => -- The selector for this type. Determines which layout the function is -- applied to. SelectorFor l -> @@ -243,18 +261,19 @@ class (Show (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 - +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. @@ -278,19 +297,19 @@ instance LayoutSelect LNil a where -- 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 - +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 + runLayout (W.Workspace i layout ms) r case r of Nothing -> return ([], Nothing) Just (r, la) -> return (r, Just (LayoutList idx la)) handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = return $ Just (LayoutList (fn idx) l) - handleMessage (LayoutList idx l) m = do r <- update idx l $ \layout -> ((),) <$> handleMessage layout m return $ LayoutList idx . snd <$> r diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index a7e2762..b518ee8 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -4,33 +4,32 @@ -- frame in the middle of the screen, sort of like fullscreen, but only taking -- up a percentage of the screen rather than the whole screen so other windows -- are still visible, alebeit typically not usable. -module Rahm.Desktop.Layout.Pop ( - Poppable(..), - PopMessage(..), - poppable, - resizePop, - togglePop, - setPop) where - -import XMonad -import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) -import Data.Default (Default(..)) -import qualified Rahm.Desktop.StackSet as W - +module Rahm.Desktop.Layout.Pop + ( Poppable (..), + PopMessage (..), + poppable, + resizePop, + togglePop, + setPop, + ) +where + +import Data.Default (Default (..)) import Rahm.Desktop.Layout.ReinterpretMessage +import qualified Rahm.Desktop.StackSet as W +import XMonad +import XMonad.Layout.LayoutModifier (LayoutModifier (..), ModifiedLayout (..)) -data Poppable (l :: * -> *) (a :: *) = Poppable { - -- True if the current window is popped out or not. - isPopped :: Bool - +data Poppable (l :: * -> *) (a :: *) = Poppable + { -- True if the current window is popped out or not. + isPopped :: Bool, -- Fraction of the screen width around the window. - , xFrac :: Float - + xFrac :: Float, -- Fraction of the screen height around the window. - , yFrac :: Float - - , wrap :: l a - } deriving (Show, Read, Eq, Ord) + yFrac :: Float, + wrap :: l a + } + deriving (Show, Read, Eq, Ord) data PopMessage where PopMessage :: (forall l a. Poppable l a -> Poppable l a) -> PopMessage @@ -52,27 +51,30 @@ poppable :: l a -> Poppable l a poppable = Poppable False 0.05 0.05 instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where - -- If the current layout is not popped, then just return what the underlying -- layout returned. - runLayout (W.Workspace - t - (Poppable True xs ys l) - a@(Just (W.focus -> focused))) - rect@(Rectangle x y w h) = do - (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect - return - ((focused, newRect) : filter ((/=focused) . fst) returned, - Poppable True xs ys <$> maybeNewLayout) - where - wp = floor $ fromIntegral w * xs - hp = floor $ fromIntegral h * ys - newRect = Rectangle - (x + wp) - (y + hp) - (w - fromIntegral (wp * 2)) - (h - fromIntegral (hp * 2)) + runLayout + ( W.Workspace + t + (Poppable True xs ys l) + a@(Just (W.focus -> focused)) + ) + rect@(Rectangle x y w h) = do + (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return + ( (focused, newRect) : filter ((/= focused) . fst) returned, + Poppable True xs ys <$> maybeNewLayout + ) + where + wp = floor $ fromIntegral w * xs + hp = floor $ fromIntegral h * ys + newRect = + Rectangle + (x + wp) + (y + hp) + (w - fromIntegral (wp * 2)) + (h - fromIntegral (hp * 2)) -- If the pop is not active, just delegate to the underlying layout. runLayout (W.Workspace t (Poppable b x y l) a) rect = do @@ -82,14 +84,12 @@ instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where -- If the message is a PopMessage, handle that here. handleMessage p (fromMessage -> Just (PopMessage f)) = return $ Just $ f p - -- Intercept Shrink/Expand message if the pop is active, and resize the -- pop size. handleMessage p (fromMessage -> Just mess) | isPopped p = case mess of Shrink -> handleMessage p (SomeMessage $ resizePop 0.025) Expand -> handleMessage p (SomeMessage $ resizePop (-0.025)) - -- By default just pass the message to the underlying layout. handleMessage (Poppable b x y l) mess = do maybeNewLayout <- handleMessage l mess diff --git a/src/Rahm/Desktop/Layout/Redescribe.hs b/src/Rahm/Desktop/Layout/Redescribe.hs index 7f955d8..f5e51b7 100644 --- a/src/Rahm/Desktop/Layout/Redescribe.hs +++ b/src/Rahm/Desktop/Layout/Redescribe.hs @@ -1,17 +1,14 @@ - -- Module to enable redescribing layouts. Unlike LayoutModifiers though, this -- class is aware of the underlying type as it may need to access some internals -- to generate the new description. module Rahm.Desktop.Layout.Redescribe where -import XMonad - -import qualified Rahm.Desktop.StackSet as W import Data.Typeable (Typeable) +import qualified Rahm.Desktop.StackSet as W +import XMonad -- Type-class to modify the description of a layout. class Describer m l where - -- Returns the new description from the given description modifier, the layout -- and the existing description. newDescription :: m -> l a -> String -> String @@ -21,9 +18,10 @@ data Redescribe m l a = Redescribe m (l a) deriving (Show, Read) -- Delegates to the underlying Layout, except for the description -instance (Typeable m, Show m, Describer m l, LayoutClass l a) => - LayoutClass (Redescribe m l) a where - +instance + (Typeable m, Show m, Describer m l, LayoutClass l a) => + LayoutClass (Redescribe m l) a + where runLayout (W.Workspace t (Redescribe m l) a) rect = do (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect return (rects, fmap (Redescribe m) maybeNewLayout) diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs index e3434b1..fc3c447 100644 --- a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs +++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs @@ -1,8 +1,8 @@ module Rahm.Desktop.Layout.ReinterpretMessage where -import XMonad (SomeMessage, X) -import XMonad.Layout.LayoutModifier (LayoutModifier(..)) import Data.Proxy (Proxy (..)) +import XMonad (SomeMessage, X) +import XMonad.Layout.LayoutModifier (LayoutModifier (..)) -- 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 @@ -30,11 +30,11 @@ data ReinterpretMessage k a = ReinterpretMessage deriving (Show, Read) -- Instance for ReinterpretMessage as a Layout modifier. -instance (DoReinterpret k) => - LayoutModifier (ReinterpretMessage k) a where - +instance + (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a + where handleMessOrMaybeModifyIt self message = do - -- Delegates to the reinterpretMessage function associated with the -- type-variable k. newMessage <- reinterpretMessage (ofProxy self) message diff --git a/src/Rahm/Desktop/Layout/Rotate.hs b/src/Rahm/Desktop/Layout/Rotate.hs index 8a8583a..e6f9a64 100644 --- a/src/Rahm/Desktop/Layout/Rotate.hs +++ b/src/Rahm/Desktop/Layout/Rotate.hs @@ -3,15 +3,17 @@ -- Layout modifier which optionally rotates the underlying layout. This actually -- uses the mirrorRect, so it's not strictly rotating, but when combined with -- flipping it works. -module Rahm.Desktop.Layout.Rotate ( - rotateable, - rotateLayout, - Rotate) where +module Rahm.Desktop.Layout.Rotate + ( rotateable, + rotateLayout, + Rotate, + ) +where +import Control.Arrow (second) +import Data.Default (Default (..)) import XMonad import XMonad.Layout.LayoutModifier -import Data.Default (Default(..)) -import Control.Arrow (second) -- Just a wrapper over a Bool. newtype Rotate a = Rotate Bool @@ -44,19 +46,19 @@ instance (Eq a) => LayoutModifier Rotate a where 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) + Rectangle + (x * fi sw `div` fi sh) + (y * fi sh `div` fi sw) + (w * sw `div` sh) + (h * sh `div` sw) fi = fromIntegral - pureMess r (fromMessage -> Just (RotateMessage f)) = Just (f r) pureMess _ _ = Nothing modifyDescription (Rotate rot) underlying = - let descr = description underlying in - if rot - then descr ++ " Rotated" - else descr + let descr = description underlying + in if rot + then descr ++ " Rotated" + else descr diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs index 95a65ca..a99214e 100644 --- a/src/Rahm/Desktop/Logger.hs +++ b/src/Rahm/Desktop/Logger.hs @@ -1,21 +1,20 @@ module Rahm.Desktop.Logger where -import Control.Monad (when, forM_, join) -import XMonad -import qualified XMonad.Util.ExtensibleState as XS -import System.IO +import Control.Monad (forM_, join, when) import Data.Time.LocalTime (getZonedTime) - import Rahm.Desktop.NoPersist +import System.IO import Text.Printf +import XMonad +import qualified XMonad.Util.ExtensibleState as XS data LogLevel = Trace | Debug | Info | Warn | Error | Fatal deriving (Show, Read, Ord, Eq, Enum, Bounded) -newtype LoggerState = - LoggerState { - logLevel :: LogLevel - } deriving (Show, Read, Eq) +newtype LoggerState = LoggerState + { logLevel :: LogLevel + } + deriving (Show, Read, Eq) instance ExtensionClass LoggerState where initialValue = LoggerState Info diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs index f239399..f73193e 100644 --- a/src/Rahm/Desktop/Marking.hs +++ b/src/Rahm/Desktop/Marking.hs @@ -1,58 +1,57 @@ -module Rahm.Desktop.Marking ( - markCurrentWindow, - jumpToMark, - setAlternateWindows, - getAlternateWindows, - setAlternateWorkspace, - getAlternateWorkspace, - getMarkedLocations, - markAllLocations, - farLeftWindow, - farRightWindow, - windowLocation, - markWindow, - Mark - ) where +module Rahm.Desktop.Marking + ( markCurrentWindow, + jumpToMark, + setAlternateWindows, + getAlternateWindows, + setAlternateWorkspace, + getAlternateWorkspace, + getMarkedLocations, + markAllLocations, + farLeftWindow, + farRightWindow, + windowLocation, + markWindow, + Mark, + ) +where -import Prelude hiding (head) - -import Data.Maybe ( fromMaybe, catMaybes ) -import Control.Monad.Trans (lift) -import Data.Ord (Down(..)) import Control.Exception import Control.Monad (when, (<=<)) +import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe import Data.Char (isAlpha, isDigit, ord) import Data.IORef -import Data.List (sortOn, sort, sortBy, find) +import Data.List (find, sort, sortBy, sortOn) import Data.List.Safe (head) import Data.Map (Map) -import Data.Sequence (Seq(..)) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.Ord (Down (..)) +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq import Rahm.Desktop.Common -import Rahm.Desktop.Logger import Rahm.Desktop.History import Rahm.Desktop.Hooks.WindowChange +import Rahm.Desktop.Logger +import Rahm.Desktop.StackSet hiding (focus) import Rahm.Desktop.Workspaces import System.Environment import System.FilePath import System.IO import XMonad -import Rahm.Desktop.StackSet hiding (focus) -import qualified Data.Map as Map -import qualified Data.Sequence as Seq import qualified XMonad.Util.ExtensibleState as XS +import Prelude hiding (head) {- Submodule that handles marking windows so they can be jumped back to. -} type Mark = String -data MarkState = - MarkState { - markStateMap :: Map Mark [Location] - , alternateWindows :: [Window] - , alternateWorkspaces :: Map Window WorkspaceId - } deriving (Read, Show) - +data MarkState = MarkState + { markStateMap :: Map Mark [Location], + alternateWindows :: [Window], + alternateWorkspaces :: Map Window WorkspaceId + } + deriving (Read, Show) instance ExtensionClass MarkState where initialValue = MarkState Map.empty [] Map.empty @@ -68,16 +67,17 @@ instance ExtensionClass MarkState where setAlternateWorkspace :: Window -> WorkspaceId -> X () setAlternateWorkspace win wid = - XS.modify $ \m -> m { - alternateWorkspaces = Map.insert win wid (alternateWorkspaces m) - } + XS.modify $ \m -> + m + { alternateWorkspaces = Map.insert win wid (alternateWorkspaces m) + } getAlternateWorkspace :: Window -> X (Maybe WorkspaceId) getAlternateWorkspace window = Map.lookup window . alternateWorkspaces <$> XS.get setAlternateWindows :: [Window] -> X () -setAlternateWindows wins = XS.modify (\m -> m { alternateWindows = wins }) +setAlternateWindows wins = XS.modify (\m -> m {alternateWindows = wins}) getAlternateWindows :: X [Window] getAlternateWindows = alternateWindows <$> XS.get @@ -85,14 +85,14 @@ getAlternateWindows = alternateWindows <$> XS.get withMaybeFocused :: (Maybe Window -> X a) -> X a withMaybeFocused f = withWindowSet $ f . peek -markAllLocations :: Mark -> [Location] -> X () +markAllLocations :: Mark -> [Location] -> X () markAllLocations mark locs = do logs Debug "Marking locations %s as \"%s\"" (show locs) (show mark) XS.modify $ \m -> - m { - markStateMap = Map.insert mark locs (markStateMap m) - } + m + { markStateMap = Map.insert mark locs (markStateMap m) + } markWindow :: Mark -> Window -> X () markWindow mark window = do @@ -100,8 +100,8 @@ markWindow mark window = do ws <- getCurrentWorkspace XS.modify $ \state@MarkState {markStateMap = ms} -> - state { - markStateMap = Map.insertWith (++) mark [Location ws $ Just window] ms + state + { markStateMap = Map.insertWith (++) mark [Location ws $ Just window] ms } markCurrentWindow :: Mark -> X () @@ -124,28 +124,34 @@ setFocusedWindow 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 + 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 + setFocusedWindow winToSwap $ + mapWindows + ( \w -> if w == winToSwap then focused else w + ) + stackSet windowRect :: Window -> X (Maybe Rectangle) -windowRect win = withDisplay $ \dpy -> (do - (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win - return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw)) +windowRect win = withDisplay $ \dpy -> + ( do + (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win + return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw) + ) `catchX` return Nothing getWindowsAndRects :: X [(Window, Rectangle)] getWindowsAndRects = - catMaybes <$> (mapM (\w -> fmap (w,) <$> windowRect w) - =<< withWindowSet (return . allWindows)) + catMaybes + <$> ( mapM (\w -> fmap (w,) <$> windowRect w) + =<< withWindowSet (return . allWindows) + ) windowLocation :: Window -> MaybeT X Location windowLocation win = do diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs index cacb52f..7c71644 100644 --- a/src/Rahm/Desktop/MouseMotion.hs +++ b/src/Rahm/Desktop/MouseMotion.hs @@ -1,18 +1,19 @@ -module Rahm.Desktop.MouseMotion where +{-# LANGUAGE BangPatterns #-} -import XMonad +module Rahm.Desktop.MouseMotion where -import Control.Monad (void, forever) -import Text.Printf -import Rahm.Desktop.Submap -import Control.Monad.Loops (iterateWhile) +import Control.Monad (forever, void) import Control.Monad.Fix (fix) -import Rahm.Desktop.Logger - -import Linear.V2 +import Control.Monad.Loops (iterateWhile) import Linear.Metric +import Linear.V2 +import Rahm.Desktop.Logger +import Rahm.Desktop.Submap +import Text.Printf +import XMonad data Quadrant = NE | SE | SW | NW deriving (Enum, Show) + data Direction = CW | CCW deriving (Enum, Show) getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant @@ -21,16 +22,16 @@ 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 @@ -41,7 +42,6 @@ motion = MouseMotionM $ do Right button -> do logs Info "Button %s" (show button) return Nothing - Left motion -> return (Just $ uncurry V2 motion) motionSize :: Int -> MouseMotionM (V2 Int) diff --git a/src/Rahm/Desktop/NoPersist.hs b/src/Rahm/Desktop/NoPersist.hs index 66e52da..744f034 100644 --- a/src/Rahm/Desktop/NoPersist.hs +++ b/src/Rahm/Desktop/NoPersist.hs @@ -4,8 +4,7 @@ module Rahm.Desktop.NoPersist where import Data.Default (Default, def) import Data.Typeable - -import XMonad (ExtensionClass(..)) +import XMonad (ExtensionClass (..)) newtype NoPersist a = NoPersist a deriving (Typeable) diff --git a/src/Rahm/Desktop/PassMenu.hs b/src/Rahm/Desktop/PassMenu.hs index 4c0b4c5..86c2e8a 100644 --- a/src/Rahm/Desktop/PassMenu.hs +++ b/src/Rahm/Desktop/PassMenu.hs @@ -1,13 +1,16 @@ module Rahm.Desktop.PassMenu where +import Control.Monad import XMonad import XMonad.Util.Run -import Control.Monad runPassMenu :: X () -runPassMenu = void $ - safeSpawn "rofi-pass" [ - "-p", "Password ", - "-theme-str", - "* {theme-color: #f54245;}"] - +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 index ce45cb2..f53671d 100644 --- a/src/Rahm/Desktop/PromptConfig.hs +++ b/src/Rahm/Desktop/PromptConfig.hs @@ -3,10 +3,11 @@ 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 - } +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 index 0b4d768..aeca574 100644 --- a/src/Rahm/Desktop/RebindKeys.hs +++ b/src/Rahm/Desktop/RebindKeys.hs @@ -1,30 +1,27 @@ - -- 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 Control.Monad.Trans.Class (lift) 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 Data.Monoid (All (..)) import Rahm.Desktop.Logger import Rahm.Desktop.NoPersist +import Text.Printf +import XMonad +import qualified XMonad.Util.ExtensibleState as XS type WindowHook = Query () -newtype InterceptState = - InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) +newtype InterceptState + = InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) -newtype RemapState = - RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) +newtype RemapState + = RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) instance ExtensionClass InterceptState where initialValue = InterceptState def @@ -37,19 +34,16 @@ 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) - + 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] @@ -67,7 +61,6 @@ getKeyCodesForKeysym dpy keysym = do 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 @@ -83,12 +76,15 @@ 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 + 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 + XS.modify $ \(RemapState (NoPersist keyMap)) -> + RemapState $ + NoPersist $ + Map.insert (window, keyFrom) action keyMap -- sendKey, but as a query. sendKeyQ :: (KeyMask, KeySym) -> Query () @@ -98,20 +94,20 @@ sendKeyQ key = do sendKey :: (KeyMask, KeySym) -> Window -> X () sendKey (keymask, keysym) w = do - XConf { display = disp, theRoot = rootw } <- ask + 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 - + (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 diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs index 6b90fab..6c425aa 100644 --- a/src/Rahm/Desktop/StackSet.hs +++ b/src/Rahm/Desktop/StackSet.hs @@ -1,33 +1,35 @@ -module Rahm.Desktop.StackSet ( - masterWindow, - findWorkspace, - ensureWorkspace, - swapWorkspaces, - greedyView, - shiftWin, - screenRotateBackward, - screenRotateForward, - mapWindows, - swapWindows, - getLocationWorkspace, - WindowLocation(..), - windowMemberOfWorkspace, - findWindow, - module W) where +module Rahm.Desktop.StackSet + ( masterWindow, + findWorkspace, + ensureWorkspace, + swapWorkspaces, + greedyView, + shiftWin, + screenRotateBackward, + screenRotateForward, + mapWindows, + swapWindows, + getLocationWorkspace, + WindowLocation (..), + windowMemberOfWorkspace, + findWindow, + module W, + ) +where -import Prelude hiding (head) -import Data.List.Safe (head) +import Data.Default import Data.List (find) +import Data.List.Safe (head) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import XMonad.StackSet as W hiding (greedyView, shiftWin) import qualified XMonad.StackSet -import Data.Default -import Data.Maybe (fromMaybe, catMaybes, listToMaybe) -import qualified Data.Map as Map +import Prelude hiding (head) -data WindowLocation i l a s sd = - OnScreen (Screen i l a s sd) | - OnHiddenWorkspace (Workspace i l a) | - Floating +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 @@ -55,32 +57,43 @@ swapWindows toSwap = mapWindows $ \w -> masterWindow :: StackSet i l a s sd -> Maybe a masterWindow = head . integrate' . stack . workspace . current -findWorkspace :: (Eq i) => - i -> StackSet i l a s sd -> Maybe (Workspace i l a) -findWorkspace wid = find ((==wid) . tag) . workspaces +findWorkspace :: + (Eq i) => + i -> + StackSet i l a s sd -> + Maybe (Workspace i l a) +findWorkspace wid = find ((== wid) . tag) . workspaces -ensureWorkspace :: (Eq i) => - i -> StackSet i l a s sd -> (StackSet i l a s sd, Workspace i l a) +ensureWorkspace :: + (Eq i) => + i -> + StackSet i l a s sd -> + (StackSet i l a s sd, Workspace i l a) ensureWorkspace t ss = case findWorkspace t ss of Nothing -> - let ws = Workspace t (layout . workspace . current $ ss) Nothing in - (ss { hidden = ws : hidden ss }, ws) + let ws = Workspace t (layout . workspace . current $ ss) Nothing + in (ss {hidden = ws : hidden ss}, ws) Just ws -> (ss, ws) swapWorkspaces :: (Eq i) => - i -> i -> StackSet i l a s sd -> StackSet i l a s sd + i -> + i -> + StackSet i l a s sd -> + StackSet i l a s sd swapWorkspaces wid1 wid2 ss = let (ss', workspace1) = ensureWorkspace wid1 ss (ss'', workspace2) = ensureWorkspace wid2 ss' - in - mapWorkspace (\w -> - case () of - _ | tag w == wid1 -> workspace2 - _ | tag w == wid2 -> workspace1 - _ -> w) ss'' - + in mapWorkspace + ( \w -> + case () of + _ | tag w == wid1 -> workspace2 + _ | tag w == wid2 -> workspace1 + _ -> w + ) + ss'' + greedyView :: (Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd greedyView wid ss = swapWorkspaces (tag . workspace . current $ ss) wid ss @@ -91,17 +104,17 @@ 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 + (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 + (current' : visible') = zipWith (\s w -> s {workspace = w}) screens workspaces + in W.StackSet current' visible' others floating + where + rcycle l = last l : l {- Finds a Window and returns the screen its on and the workspace its on. - Returns nothing if the window doesn't exist. @@ -109,13 +122,12 @@ screenRotateForward (W.StackSet current visible others floating) = do - 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) + (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] - + listToMaybe . catMaybes $ + map findWindowScreen (cur : vis) + ++ map findWindowWorkspace hid + ++ [findWindowFloat] where findWindowScreen s@(Screen ws _ _) = if windowMemberOfWorkspace ws win diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 5a05f9e..aabc35b 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -1,5 +1,5 @@ -module Rahm.Desktop.Submap ( - mapNextString, +module Rahm.Desktop.Submap + ( mapNextString, mapNextStringWithKeysym, submapButtonsWithKey, nextButton, @@ -7,28 +7,27 @@ module Rahm.Desktop.Submap ( nextMotionOrButton, submap, submapDefault, - submapDefaultWithKey) where + submapDefaultWithKey, + ) +where -import Rahm.Desktop.Common -import Control.Monad.Trans.Maybe -import Control.Monad.Trans +import Control.Concurrent (threadDelay) import Control.Monad (void) -import XMonad hiding (keys) import Control.Monad.Fix (fix) -import qualified Data.Map as Map +import Control.Monad.Trans +import Control.Monad.Trans.Maybe import Data.Map (Map) -import Control.Concurrent (threadDelay) -import Data.Word (Word64) +import qualified Data.Map as Map import Data.Time.Clock.POSIX - +import Data.Word (Word64) +import Rahm.Desktop.Common +import XMonad hiding (keys) currentTimeMillis :: IO Int -currentTimeMillis = round . (*1000) <$> getPOSIXTime - +currentTimeMillis = round . (* 1000) <$> getPOSIXTime getMaskEventWithTimeout :: Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a) - getMaskEventWithTimeout timeout d mask fn = do curTime <- currentTimeMillis allocaXEvent $ \ptr -> do @@ -36,8 +35,6 @@ getMaskEventWithTimeout timeout d mask fn = do if val then Just <$> fn ptr else return Nothing - - where getMaskEventWithTimeout' ptr timeout = do curTime <- currentTimeMillis @@ -61,24 +58,24 @@ getMaskEventWithTimeout timeout d mask fn = do mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a mapNextStringWithKeysym fn = do - XConf { theRoot = root, display = d } <- ask + XConf {theRoot = root, display = d} <- ask io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime - ret <- io $ fix $ \nextkey -> do - ret <- - getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do - KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p - keysym <- keycodeToKeysym d code 0 - (_, str) <- lookupString (asKeyEvent p) - return (m, str, keysym) - - case ret of - Just (m, str, keysym) -> - if isModifierKey keysym + ret <- io $ + fix $ \nextkey -> do + ret <- + getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do + KeyEvent {ev_keycode = code, ev_state = m} <- getEvent p + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + return (m, str, keysym) + + case ret of + Just (m, str, keysym) -> + if isModifierKey keysym then nextkey else return ret - - Nothing -> return Nothing + Nothing -> return Nothing io $ ungrabKeyboard d currentTime @@ -92,7 +89,7 @@ mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () submapDefaultWithKey def m = runMaybeT_ $ mapNextStringWithKeysym $ \mask sym _ -> lift $ do - Map.findWithDefault (def (mask, sym)) (mask, sym) m + Map.findWithDefault (def (mask, sym)) (mask, sym) m submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X () submapDefault def = submapDefaultWithKey (const def) @@ -104,12 +101,13 @@ submap = submapDefault (return ()) -- next button is pressed. nextButton :: X (Maybe (ButtonMask, Button)) nextButton = do - XConf { theRoot = root, display = d } <- ask + XConf {theRoot = root, display = d} <- ask io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime - ret <- io $ getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do - ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv - return (m, button) + ret <- io $ + getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do + ButtonEvent {ev_button = button, ev_state = m} <- getEvent xEv + return (m, button) io $ ungrabPointer d currentTime @@ -118,13 +116,14 @@ nextButton = do {- Grabs the mouse and reports the next mouse motion. -} nextMotion :: X (Int, Int) nextMotion = do - XConf { theRoot = root, display = d } <- ask + 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) + 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 @@ -133,26 +132,31 @@ nextMotion = do {- 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 + 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) + 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 () + ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X () submapButtonsWithKey defaultAction actions window = do - maybe (return ()) (\arg -> - case Map.lookup arg actions of - Nothing -> defaultAction arg window - Just fn -> fn window) =<< nextButton + maybe + (return ()) + ( \arg -> + case Map.lookup arg actions of + Nothing -> defaultAction arg window + Just fn -> fn window + ) + =<< nextButton diff --git a/src/Rahm/Desktop/Swallow.hs b/src/Rahm/Desktop/Swallow.hs index a411b3f..2674232 100644 --- a/src/Rahm/Desktop/Swallow.hs +++ b/src/Rahm/Desktop/Swallow.hs @@ -1,8 +1,13 @@ -module Rahm.Desktop.Swallow ( - swallowHook, setSwallowEnabled, isSwallowEnabled, toggleSwallowEnabled) where +module Rahm.Desktop.Swallow + ( swallowHook, + setSwallowEnabled, + isSwallowEnabled, + toggleSwallowEnabled, + ) +where -import XMonad import Data.Monoid (All) +import XMonad import XMonad.Hooks.WindowSwallowing import XMonad.Util.ExtensibleState as XS diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs index cd47c01..7a86146 100644 --- a/src/Rahm/Desktop/SwapMaster.hs +++ b/src/Rahm/Desktop/SwapMaster.hs @@ -1,20 +1,19 @@ {- Swap window with the master, but save it. -} module Rahm.Desktop.SwapMaster (swapMaster) where -import qualified Rahm.Desktop.StackSet as W - -import Control.Monad.Trans.Maybe -import XMonad (Window, ExtensionClass(..), X(..), windows, windowset) import Control.Monad (void) +import Control.Monad.State (gets) import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe import Data.Maybe (fromMaybe) -import Control.Monad.State (gets) - +import qualified Rahm.Desktop.StackSet as W +import XMonad (ExtensionClass (..), Window, X (..), windows, windowset) import qualified XMonad.Util.ExtensibleState as XS -newtype LastWindow = LastWindow { - lastWindow :: Maybe Window - } deriving (Show, Read) +newtype LastWindow = LastWindow + { lastWindow :: Maybe Window + } + deriving (Show, Read) instance ExtensionClass LastWindow where initialValue = LastWindow Nothing @@ -23,17 +22,18 @@ hoist :: (Monad m) => Maybe a -> MaybeT m a hoist = MaybeT . return swapMaster :: X () -swapMaster = void $ runMaybeT $ do +swapMaster = void $ + runMaybeT $ do ss <- gets windowset focused <- hoist $ W.peek ss master <- hoist $ W.masterWindow ss if focused == master - then do - lw <- MaybeT $ lastWindow <$> XS.get - lift $ windows (W.swapWindows [(focused, lw)]) - else lift $ windows (W.swapWindows [(focused, master)]) + then do + lw <- MaybeT $ lastWindow <$> XS.get + lift $ windows (W.swapWindows [(focused, lw)]) + else lift $ windows (W.swapWindows [(focused, master)]) lift $ do XS.put (LastWindow $ Just master) diff --git a/src/Rahm/Desktop/Theater.hs b/src/Rahm/Desktop/Theater.hs index d000f75..7ec1cd4 100644 --- a/src/Rahm/Desktop/Theater.hs +++ b/src/Rahm/Desktop/Theater.hs @@ -1,25 +1,22 @@ module Rahm.Desktop.Theater where - -- A "Theater" is the state of a stackset. One can save the current stackset as -- a "theater" and then restore it later. If new windows were added, those new -- windows are put into the hidden workspace. -import qualified XMonad as X -import qualified XMonad.StackSet as W -import qualified XMonad.Util.ExtensibleState as XS - -import XMonad (X) -import Data.List ((\\), sortOn) -import Data.Typeable -import Data.Proxy -import Data.Maybe -import Data.Default import Control.Monad (forM_) +import Data.Default +import Data.List (sortOn, (\\)) import Data.Map (Map) import qualified Data.Map as Map - +import Data.Maybe +import Data.Proxy +import Data.Typeable import Rahm.Desktop.Logger +import XMonad (X) +import qualified XMonad as X +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS type WinSet = W.StackSet X.WorkspaceId String X.Window X.ScreenId X.ScreenDetail @@ -28,10 +25,11 @@ newtype Theater = Theater WinSet type TheaterName = Maybe String -data Theaters = Theaters { - currentTheater :: TheaterName - , theaters :: Map TheaterName Theater - } deriving (Read, Show) +data Theaters = Theaters + { currentTheater :: TheaterName, + theaters :: Map TheaterName Theater + } + deriving (Read, Show) instance Default Theaters where def = Theaters Nothing mempty @@ -59,7 +57,6 @@ saveTheater name ws = do if isStackSetEmpty "*" ws && not (name == cur) then Map.delete name map else Map.insert name (Theater $ unboxLayout ws) map - where unboxLayout = W.mapLayout show @@ -79,16 +76,20 @@ restoreTheater name = do case Map.lookup name mp of Nothing -> do ws <- X.windowset <$> X.get - return $ W.mapWorkspace ( - \(W.Workspace i l _) -> W.Workspace i l Nothing) ws - + return $ + W.mapWorkspace + ( \(W.Workspace i l _) -> W.Workspace i l Nothing + ) + ws Just (Theater ws) -> - return $ W.mapLayout ( - \serialized -> case [x | (x, "") <- X.readsLayout currentLayout serialized] of - [x] -> x - [] -> currentLayout - (_:_) -> currentLayout - ) ws + return $ + W.mapLayout + ( \serialized -> case [x | (x, "") <- X.readsLayout currentLayout serialized] of + [x] -> x + [] -> currentLayout + (_ : _) -> currentLayout + ) + ws let newStackSet = updateStateWithWindows (W.allWindows currentWindowset) "*" newStackSet' @@ -100,28 +101,33 @@ restoreTheater name = do isStackSetEmpty :: (Eq i, Eq a) => i -> W.StackSet i l a si sd -> Bool -isStackSetEmpty hiddenWorkspace = all ( - \(W.Workspace t l s) -> isNothing s || t == hiddenWorkspace ) . W.workspaces - +isStackSetEmpty hiddenWorkspace = + all + ( \(W.Workspace t l s) -> isNothing s || t == hiddenWorkspace + ) + . W.workspaces updateStateWithWindows :: (Eq i, Eq a) => [a] -> i -> W.StackSet i l a si sd -> W.StackSet i l a si sd updateStateWithWindows allWindows hiddenWorkspace ss = let missingWindows = allWindows \\ W.allWindows ss - layout = W.layout $ W.workspace $ W.current ss in - if null missingWindows - then ss - else - if not (W.tagMember hiddenWorkspace ss) - then - ss { W.hidden = - W.Workspace hiddenWorkspace layout (W.differentiate missingWindows) - : W.hidden ss} - - else - W.mapWorkspace (\(W.Workspace t l s') -> - let s = W.filter (`elem`allWindows) =<< s' in - if t == hiddenWorkspace - then - W.Workspace t l (W.differentiate $ W.integrate' s ++ missingWindows) - else W.Workspace t l s) ss + layout = W.layout $ W.workspace $ W.current ss + in if null missingWindows + then ss + else + if not (W.tagMember hiddenWorkspace ss) + then + ss + { W.hidden = + W.Workspace hiddenWorkspace layout (W.differentiate missingWindows) : + W.hidden ss + } + else + W.mapWorkspace + ( \(W.Workspace t l s') -> + let s = W.filter (`elem` allWindows) =<< s' + in if t == hiddenWorkspace + then W.Workspace t l (W.differentiate $ W.integrate' s ++ missingWindows) + else W.Workspace t l s + ) + ss diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs index 6c52f01..9ddafa5 100644 --- a/src/Rahm/Desktop/Workspaces.hs +++ b/src/Rahm/Desktop/Workspaces.hs @@ -1,21 +1,17 @@ - -- Common ways to select workspaces module Rahm.Desktop.Workspaces where -import Prelude hiding ((!!)) - -import Control.Monad.Trans.Maybe import Control.Arrow (second, (&&&)) -import qualified Rahm.Desktop.StackSet as W -import XMonad - +import Control.Monad.Trans.Maybe +import Data.Char (isAlphaNum, isUpper, toLower, toUpper) +import Data.List (find, sort, sortBy, sortOn) import Data.List.Safe ((!!)) - +import Data.Maybe (fromMaybe, mapMaybe) import Rahm.Desktop.Common import Rahm.Desktop.History -import Data.List (sortOn, sort, sortBy, find) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.Char (isUpper, toUpper, toLower, isAlphaNum) +import qualified Rahm.Desktop.StackSet as W +import XMonad +import Prelude hiding ((!!)) newtype Selector = Selector (forall a. (a -> Bool) -> [a] -> Maybe a) @@ -32,18 +28,19 @@ data WorkspaceState = Current | Hidden | Visible getPopulatedWorkspaces :: W.StackSet String l a sid sd -> [(WorkspaceState, W.Workspace String l a)] getPopulatedWorkspaces (W.StackSet (W.Screen cur _ _) vis hi _) = - filter ((/="*") . W.tag . snd) $ + filter ((/= "*") . W.tag . snd) $ sortOn (W.tag . snd) $ - mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi ++ - map (\(W.Screen w _ _) -> (Visible, w)) vis ++ - [(Current, cur)] + mapMaybe (\w@(W.Workspace _ _ s) -> fmap (const (Hidden, w)) s) hi + ++ map (\(W.Screen w _ _) -> (Visible, w)) vis + ++ [(Current, cur)] next :: Selector next = Selector $ \f l -> select f l l - where select f (x:y:xs) _ | f x = Just y - select f [x] (y:_) | f x = Just y - select f (x:xs) orig = select f xs orig - select f _ _ = Nothing + where + select f (x : y : xs) _ | f x = Just y + select f [x] (y : _) | f x = Just y + select f (x : xs) orig = select f xs orig + select f _ _ = Nothing prev :: Selector prev = Selector $ \f l -> @@ -64,18 +61,19 @@ windowsInCurrentWorkspace = withWindowSet $ getHorizontallyOrderedScreens :: W.StackSet wid l a ScreenId ScreenDetail -> - [(Bool, W.Screen wid l a ScreenId ScreenDetail)] + [(Bool, W.Screen wid l a ScreenId ScreenDetail)] -- ^ Returns a list of screens ordered from leftmost to rightmost. getHorizontallyOrderedScreens windowSet = - flip sortBy screens $ \sc1 sc2 -> - let (SD (Rectangle x1 _ _ _)) = W.screenDetail (snd sc1) - (SD (Rectangle x2 _ _ _)) = W.screenDetail (snd sc2) - in x1 `compare` x2 - where - screens = (True, W.current windowSet) : map (False,) (W.visible windowSet) + flip sortBy screens $ \sc1 sc2 -> + let (SD (Rectangle x1 _ _ _)) = W.screenDetail (snd sc1) + (SD (Rectangle x2 _ _ _)) = W.screenDetail (snd sc2) + in x1 `compare` x2 + where + screens = (True, W.current windowSet) : map (False,) (W.visible windowSet) accompaningWorkspace :: WorkspaceId -> WorkspaceId -accompaningWorkspace [s] = return $ +accompaningWorkspace [s] = + return $ if isUpper s then toLower s else toUpper s @@ -84,18 +82,20 @@ accompaningWorkspace s = s adjacentWorkspaceNotVisible :: Selector -> WorkspaceId -> X WorkspaceId adjacentWorkspaceNotVisible (Selector selector) from = withWindowSet $ \ss -> - let tags = sort $ - W.tag . snd <$> filter (\x -> fst x /= Visible) ( - getPopulatedWorkspaces ss) - in - return $ fromMaybe from $ selector (==from) tags + let tags = + sort $ + W.tag . snd + <$> filter + (\x -> fst x /= Visible) + ( getPopulatedWorkspaces ss + ) + in return $ fromMaybe from $ selector (== from) tags adjacentWorkspace :: Selector -> WorkspaceId -> X WorkspaceId adjacentWorkspace (Selector selector) from = withWindowSet $ \ss -> - let tags = sort $ W.tag . snd <$> getPopulatedWorkspaces ss - in - return $ fromMaybe from $ selector (==from) tags + let tags = sort $ W.tag . snd <$> getPopulatedWorkspaces ss + in return $ fromMaybe from $ selector (== from) tags viewAdjacent :: Selector -> X () viewAdjacent sel = @@ -115,10 +115,10 @@ withScreen fn n = do Nothing -> windowSet Just screen -> fn (W.tag $ W.workspace screen) windowSet - workspaceWithWindow :: Window -> X (Maybe WorkspaceId) workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) -> return $ - W.tag <$> - find (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) + W.tag + <$> find + (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack) (map W.workspace (c : v) ++ h) diff --git a/src/Rahm/Desktop/XMobarLog.hs b/src/Rahm/Desktop/XMobarLog.hs index 6cf4364..dbe4808 100644 --- a/src/Rahm/Desktop/XMobarLog.hs +++ b/src/Rahm/Desktop/XMobarLog.hs @@ -1,26 +1,25 @@ -module Rahm.Desktop.XMobarLog ( XMobarLog, spawnXMobar, xMobarLogHook ) where +module Rahm.Desktop.XMobarLog (XMobarLog, spawnXMobar, xMobarLogHook) where import Control.Arrow (second) -import Control.Monad (forM_) -import Control.Monad.Writer (tell, execWriter) +import Control.Monad (forM_, unless) +import Control.Monad.Writer (execWriter, tell) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.List (sortBy) -import Data.Maybe (mapMaybe, isJust) +import Data.Maybe (isJust, mapMaybe) import Data.Ord (comparing) -import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Rahm.Desktop.Layout.Draw (drawLayout) -import System.IO (Handle, hSetEncoding, hPutStrLn, utf8) -import XMonad.Util.NamedWindows (getName) -import XMonad.Util.Run (spawnPipe) -import XMonad (X) -import Rahm.Desktop.Workspaces (getPopulatedWorkspaces, WorkspaceState(..)) -import Text.Printf import Rahm.Desktop.Logger +import qualified Rahm.Desktop.StackSet as S import Rahm.Desktop.Theater (getTheaters) - +import Rahm.Desktop.Workspaces (WorkspaceState (..), getPopulatedWorkspaces) +import System.IO (Handle, hPutStrLn, hSetEncoding, utf8) +import Text.Printf +import XMonad (X) import qualified XMonad as X -import qualified Rahm.Desktop.StackSet as S +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Run (spawnPipe) -data XMobarLog = XMobarLog Handle +newtype 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. @@ -35,7 +34,6 @@ spawnXMobar = do 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 @@ -48,66 +46,64 @@ xMobarLogHook (XMobarLog xmproc) = do title <- maybe (pure "") (fmap show . getName) . S.peek $ winset let wss = getPopulatedWorkspaces winset - let log = trunc 80 $ execWriter $ do - tell " " - tell (toChangeLayoutAction layoutXpm) - tell " " - tell $ logLevelToXMobar loglevel - - forM_ theaters $ \theater -> case theater of - (Just n, _, True) -> do - tell "<fn=1><fc=#ffffff>" - tell $ toTheaterAction n - tell " </fc></fn>" - - (Just n, _, False) -> do - tell "<fn=2><fc=#888888>" - tell $ toTheaterAction n - tell " </fc></fn>" - - _ -> return () - - if not (null theaters) - then tell "<fc=#888888>| </fc>" - else return () - - forM_ wss $ \(t, ws) -> do - case t of - Current -> tell "<fn=1><fc=#ff8888>" - Visible -> tell "<fn=6><fc=#8888ff>" - Hidden -> tell "<fn=2><fc=#888888>" - - tell $ toAction $ S.tag ws - tell " </fc></fn>" - - tell " <fc=#ff8888><fn=3>" - tell title - tell "</fn></fc>" + let log = trunc 80 $ + execWriter $ do + tell " " + tell (toChangeLayoutAction layoutXpm) + tell " " + tell $ logLevelToXMobar loglevel + + forM_ theaters $ \theater -> case theater of + (Just n, _, True) -> do + tell "<fn=1><fc=#ffffff>" + tell $ toTheaterAction n + tell " </fc></fn>" + (Just n, _, False) -> do + tell "<fn=2><fc=#888888>" + tell $ toTheaterAction n + tell " </fc></fn>" + + unless (null theaters) $ do + tell "<fc=#888888>| </fc>" + + forM_ wss $ \(t, ws) -> do + case t of + Current -> tell "<fn=1><fc=#ff8888>" + Visible -> tell "<fn=6><fc=#8888ff>" + Hidden -> tell "<fn=2><fc=#888888>" + tell $ toAction $ S.tag ws + tell " </fc></fn>" + + tell " <fc=#ff8888><fn=3>" + tell title + tell "</fn></fc>" logs Trace "XMobar: %s" log X.io $ hPutStrLn xmproc log - where - toAction [ch] | isAsciiUpper ch || - isAsciiLower ch || - isDigit ch = - printf "<action=`xdotool key 'Hyper_L+g' '%s'` button=1><action=`xdotool key 'Hyper_L+Shift_L+g' '%s'` button=3>%s</action></action>" [ch] [ch] [ch] + toAction [ch] + | isAsciiUpper ch + || isAsciiLower ch + || isDigit ch = + printf "<action=`xdotool key 'Hyper_L+g' '%s'` button=1><action=`xdotool key 'Hyper_L+Shift_L+g' '%s'` button=3>%s</action></action>" [ch] [ch] [ch] toAction ch = ch - toTheaterAction [ch] | isAsciiUpper ch || - isAsciiLower ch || - isDigit ch = - printf "<action=`xdotool key 'Hyper_L+Shift_L+g' '%s'` button=1>%s</action>" [ch] [ch] + toTheaterAction [ch] + | isAsciiUpper ch + || isAsciiLower ch + || isDigit ch = + printf "<action=`xdotool key 'Hyper_L+Shift_L+g' '%s'` button=1>%s</action>" [ch] [ch] toTheaterAction ch = ch toChangeLayoutAction :: String -> String toChangeLayoutAction = - printf "<action=`xdotool key Hyper_L+space n` button=1>\ + printf + "<action=`xdotool key Hyper_L+space n` button=1>\ \<action=`xdotool key p` button=3>%s</action></action>" logLevelToXMobar Trace = "<fn=3><fc=#88ffff>[Trace]</fc></fn> " logLevelToXMobar Debug = "<fn=3><fc=#ff88ff>[Debug]</fc></fn> " - logLevelToXMobar Warn = "<fn=3><fc=#ffff88>[Warn] </fc></fn> " + logLevelToXMobar Warn = "<fn=3><fc=#ffff88>[Warn] </fc></fn> " logLevelToXMobar Error = "<fn=3><fc=#ff8888>[Error]</fc></fn> " logLevelToXMobar Fatal = "<fn=3><fc=#888888>[Fatal]</fc></fn> " logLevelToXMobar _ = "" @@ -118,15 +114,14 @@ trunc :: Int -> String -> String trunc amt str = reverse $ trunc' False amt str [] where trunc' _ _ [] acc = acc - trunc' ignore amt (a:as) 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) + else case amt of + 0 -> trunc' False 0 as acc + 3 -> trunc' False 0 as ("..." ++ acc) + _ -> trunc' False (amt - 1) as (a : acc) |