diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,106 @@ # Change Log / Release Notes +## _unreleased_ + +## 0.18.1 (August 20, 2024) + +### Breaking Changes + + * `XMonad.Hooks.StatusBars` + + - Move status bar functions from the `IO` to the `X` monad to + allow them to look up information from `X`, like the screen + width. Existing configurations may need to use `io` from + `XMonad.Core` or `liftIO` from `Control.Monad.IO.Class` in + order to lift any existing `IO StatusBarConfig` values into + `X StatusBarConfig` values. + + * `XMonad.Prompt` + + - Added an additional `XPConfig` argument to `historyCompletion` and + `historyCompletionP`. Calls along the lines of `historyCompletionP + myFunc` should be changed to `historyCompletionP myConf myFunc`. + If not `myConf` is lying around, `def` can be used instead. + + * `XMonad.Actions.GridSelect` + + - Added the `gs_cancelOnEmptyClick` field to `GSConfig`, which makes + mouse clicks into "empty space" cancel the current grid-select. + Users explicitly defining their own `GSConfig` record will have to + add this to their definitions. Additionally, the field defaults to + `True`—to retain the old behaviour, set it to `False`. + +### New Modules + + * `XMonad.Actions.Profiles` + + - Group workspaces by similarity. Useful when one has lots + of workspaces and uses only a couple per unit of work. + + * `XMonad.Hooks.FloatConfigureReq` + + - Customize handling of floating windows' move/resize/restack requests + (ConfigureRequest). Useful as a workaround for some misbehaving client + applications (Steam, rxvt-unicode, anything that tries to restore + absolute position of floats). + + * `XMonad.Layout.Columns` + + - Organize windows in columns. This layout allows to move/resize windows in + every directions. + + * `XMonad.Prompt.WindowBringer` + + - Added `copyMenu`, a convenient way to copy a window to the current workspace. + +### Bug Fixes and Minor Changes + + * Fix build-with-cabal.sh when XDG_CONFIG_HOME is defined. + + * `XMonad.Util.EZConfig` + + - Fixed `checkKeymap` warning that all keybindings are duplicates. + + * `XMonad.Hooks.ManageHelpers` + + - Added `isNotification` predicate to check for windows with + `_NET_WM_WINDOW_TYPE` property of `_NET_WM_WINDOW_TYPE_NOTIFICATION`. + + * `XMonad.Prompt.OrgMode` + + - Added `HH:MM-HH:MM` and `HH:MM+HH` syntax to specify time spans. + + * `XMonad.Prompt` + + - The history file is not extraneously read and written anymore if + the `historySize` is set to 0. + + * `XMonad.Hooks.EwmhDesktops` + + - Requests for unmanaged windows no longer cause a refresh. This avoids + flicker and also fixes disappearing menus in the Steam client and + possibly a few other client applications. + + (See also `XMonad.Hooks.FloatConfigureReq` and/or `XMonad.Util.Hacks` + for additional Steam client workarounds.) + + * `XMonad.Actions.Submap` + + - Added `visualSubmapSorted` to enable sorting of the keymap + descriptions. + + * `XMonad.Hooks.ScreenCorners` + + - Added screen edge support with `SCTop`, `SCBottom`, `SCLeft` and + `SCRight`. Now both corners and edges are supported. + + * `XMonad.Actions.WindowNavigation` + + - Improve navigation in presence of floating windows. + - Handle window switching when in `Full` layout. + +### Other changes + ## 0.18.0 (February 3, 2024) ### Breaking Changes @@ -306,8 +407,6 @@ - Added `zipperFocusedAtFirstOf` to differentiate two lists into a zipper. - -### Other changes ## 0.17.1 (September 3, 2022) diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs --- a/XMonad/Actions/GridSelect.hs +++ b/XMonad/Actions/GridSelect.hs @@ -203,10 +203,13 @@ gs_colorizer :: a -> Bool -> X (String, String), gs_font :: String, gs_navigate :: TwoD a (Maybe a), + -- ^ Customize key bindings for a GridSelect gs_rearranger :: Rearranger a, gs_originFractX :: Double, gs_originFractY :: Double, - gs_bordercolor :: String + gs_bordercolor :: String, + gs_cancelOnEmptyClick :: Bool + -- ^ When True, click on empty space will cancel GridSelect } -- | That is 'fromClassName' if you are selecting a 'Window', or @@ -386,13 +389,20 @@ stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a) stdHandle ButtonEvent{ ev_event_type = t, ev_x = x, ev_y = y } contEventloop | t == buttonRelease = do - s@TwoDState { td_paneX = px, td_paneY = py, - td_gsconfig = (GSConfig ch cw _ _ _ _ _ _ _ _) } <- get + s@TwoDState{ td_paneX = px + , td_paneY = py + , td_gsconfig = GSConfig{ gs_cellheight = ch + , gs_cellwidth = cw + , gs_cancelOnEmptyClick = cancelOnEmptyClick + } + } <- get let gridX = (fi x - (px - cw) `div` 2) `div` cw gridY = (fi y - (py - ch) `div` 2) `div` ch case lookup (gridX,gridY) (td_elementmap s) of Just (_,el) -> return (Just el) - Nothing -> contEventloop + Nothing -> if cancelOnEmptyClick + then return Nothing + else contEventloop | otherwise = contEventloop stdHandle ExposeEvent{} contEventloop = updateAllElements >> contEventloop @@ -648,7 +658,7 @@ liftIO $ mapWindow dpy win liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask) status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime - io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime + void $ io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime font <- initXMF (gs_font gsconfig) let screenWidth = toInteger $ rect_width scr screenHeight = toInteger $ rect_height scr @@ -706,7 +716,7 @@ -- | Builds a default gs config from a colorizer function. buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a -buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation noRearranger (1/2) (1/2) "white" +buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation noRearranger (1/2) (1/2) "white" True -- | Brings selected window to the current workspace. bringSelected :: GSConfig Window -> X () diff --git a/XMonad/Actions/Profiles.hs b/XMonad/Actions/Profiles.hs new file mode 100644 --- /dev/null +++ b/XMonad/Actions/Profiles.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DerivingVia #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.Profiles +-- Description : Group your workspaces by similarity. +-- Copyright : (c) Mislav Zanic +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Mislav Zanic +-- Stability : experimental +-- Portability : unportable +-- +-------------------------------------------------------------------------------- + +module XMonad.Actions.Profiles + ( -- * Overview + -- $overview + + -- * Usage + -- $usage + + -- * Types + ProfileId + , Profile(..) + , ProfileConfig(..) + + -- * Hooks + , addProfiles + , addProfilesWithHistory + + -- * Switching profiles + , switchToProfile + + -- * Workspace navigation and keybindings + , wsFilter + , bindOn + + -- * Loggers and pretty printers + , excludeWSPP + , profileLogger + + -- * Prompts + , switchProfilePrompt + , addWSToProfilePrompt + , removeWSFromProfilePrompt + , switchProfileWSPrompt + , shiftProfileWSPrompt + + -- * Utilities + , currentProfile + , profileIds + , previousProfile + , profileHistory + , allProfileWindows + , profileWorkspaces + )where + +-------------------------------------------------------------------------------- +import Data.Map.Strict (Map) +import Data.List +import qualified Data.Map.Strict as Map + +import Control.DeepSeq + +import XMonad +import XMonad.Prelude +import qualified XMonad.StackSet as W + +import XMonad.Actions.CycleWS + +import qualified XMonad.Util.ExtensibleState as XS +import XMonad.Util.Loggers (Logger) +import XMonad.Prompt.Window (XWindowMap) +import XMonad.Actions.WindowBringer (WindowBringerConfig(..)) +import XMonad.Actions.OnScreen (greedyViewOnScreen) +import XMonad.Hooks.Rescreen (addAfterRescreenHook) +import XMonad.Hooks.DynamicLog (PP(ppRename)) +import XMonad.Prompt + +-------------------------------------------------------------------------------- +-- $overview +-- This module allows you to group your workspaces into 'Profile's based on certain similarities. +-- The idea is to expand upon the philosophy set by "XMonad.Actions.TopicSpace" +-- which states that you can look at a topic/workspace as a +-- single unit of work instead of multiple related units of work. +-- This comes in handy if you have lots of workspaces with windows open and need only to +-- work with a few of them at a time. With 'Profile's, you can focus on those few workspaces that +-- require your attention by not displaying, or allowing you to switch to the rest of the workspaces. +-- The best example is having a profile for development and a profile for leisure activities. + +-------------------------------------------------------------------------------- +-- $usage +-- To use @Profiles@ you need to add it to your XMonad configuration +-- and configure your profiles. +-- +-- First you'll need to handle the imports. +-- +-- > import XMonad.Actions.Profiles +-- > import XMonad.Util.EZConfig -- for keybindings +-- > import qualified XMonad.StackSet as W +-- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO -- for workspace navigation +-- +-- Next you'll need to define your profiles. +-- +-- > myStartingProfile :: ProfileId +-- > myStartingProfile = "Work" +-- > +-- > myProfiles :: [Profile] +-- > myProfiles = +-- > [ Profile { profileId = "Home" +-- > , profileWS = [ "www" +-- > , "rss" +-- > , "vid" +-- > , "vms" +-- > , "writing" +-- > , "notes" +-- > ] +-- > } +-- > , Profile { profileId = "Work" +-- > , profileWS = [ "www" +-- > , "slack" +-- > , "dev" +-- > , "k8s" +-- > , "notes" +-- > ] +-- > } +-- > ] +-- +-- So, while using @Home@ 'Profile', you'll only be able to see, navigate to and +-- do actions with @["www", "rss", "vid", "vms", "writing", "notes"]@ workspaces. +-- +-- You may also need to define some keybindings. Since @M-1@ .. @M-9@ are +-- sensible keybindings for switching workspaces, you'll need to use +-- 'bindOn' to have different keybindings per profile. +-- Here, we'll use "XMonad.Util.EZConfig" syntax: +-- +-- > myKeys :: [(String, X())] +-- > myKeys = +-- > [ ("M-p", switchProfilePrompt xpConfig) +-- > , ("M-g", switchProfileWSPrompt xpConfig) +-- > , ("M1-j", DO.moveTo Next wsFilter) +-- > , ("M1-k", DO.moveTo Prev wsFilter) +-- > ] +-- > <> +-- > [ ("M-" ++ m ++ k, bindOn $ map (\x -> (fst x, f $ snd x)) i) +-- > | (i, k) <- map (\(x:xs) -> (map fst (x:xs), snd x)) $ sortGroupBy snd tupleList +-- > , (f, m) <- [(mby $ windows . W.greedyView, ""), (mby $ windows . W.shift, "S-")] +-- > ] +-- > where +-- > mby f wid = if wid == "" then return () else f wid +-- > sortGroupBy f = groupBy (\ x y -> f x == f y) . sortBy (\x y -> compare (f x) (f y)) +-- > tupleList = concatMap (\p -> zip (map (\wid -> (profileId p, wid)) (profileWS p <> repeat "")) (map show [1..9 :: Int])) myProfiles +-- +-- After that, you'll need to hook @Profiles@ into your XMonad config: +-- +-- > main = xmonad $ addProfiles def { profiles = myProfiles +-- > , startingProfile = myStartingProfile +-- > } +-- > $ def `additionalKeysP` myKeys +-- + +-------------------------------------------------------------------------------- +type ProfileId = String +type ProfileMap = Map ProfileId Profile + +-------------------------------------------------------------------------------- +-- | Profile representation. +data Profile = Profile + { profileId :: !ProfileId -- ^ Profile name. + , profileWS :: ![WorkspaceId] -- ^ A list of workspaces contained within a profile. + } + +-------------------------------------------------------------------------------- +-- | Internal profile state. +data ProfileState = ProfileState + { profilesMap :: !ProfileMap + , current :: !(Maybe Profile) + , previous :: !(Maybe ProfileId) + } + +-------------------------------------------------------------------------------- +-- | User config for profiles. +data ProfileConfig = ProfileConfig + { workspaceExcludes :: ![WorkspaceId] -- ^ A list of workspaces to exclude from the @profileHistoryHook@. + , profiles :: ![Profile] -- ^ A list of user-defined profiles. + , startingProfile :: !ProfileId -- ^ Profile shown on startup. + } + +-------------------------------------------------------------------------------- +instance Default ProfileConfig where + def = ProfileConfig { workspaceExcludes = [] + , profiles = [] + , startingProfile = "" + } + +-------------------------------------------------------------------------------- +instance ExtensionClass ProfileState where + initialValue = ProfileState Map.empty Nothing Nothing + +-------------------------------------------------------------------------------- +-- Internal type for history tracking. +-- Main problem with @XMonad.Hooks.HistoryHook@ is that it isn't profile aware. +-- Because of that, when switching to a previous workspace, you might switch to +-- a workspace +newtype ProfileHistory = ProfileHistory + { history :: Map ProfileId [(ScreenId, WorkspaceId)] + } + deriving (Read, Show) + deriving NFData via Map ProfileId [(Int, WorkspaceId)] + +-------------------------------------------------------------------------------- +instance ExtensionClass ProfileHistory where + extensionType = PersistentExtension + initialValue = ProfileHistory Map.empty + +-------------------------------------------------------------------------------- +newtype ProfilePrompt = ProfilePrompt String + +-------------------------------------------------------------------------------- +instance XPrompt ProfilePrompt where + showXPrompt (ProfilePrompt x) = x + +-------------------------------------------------------------------------------- +defaultProfile :: Profile +defaultProfile = defaultProfile + +-------------------------------------------------------------------------------- +-- | Returns current profile. +currentProfile :: X ProfileId +currentProfile = profileId . fromMaybe defaultProfile . current <$> XS.get + +-------------------------------------------------------------------------------- +-- | Returns previous profile. +previousProfile :: X (Maybe ProfileId) +previousProfile = XS.gets previous + +-------------------------------------------------------------------------------- +-- | Returns the history of viewed workspaces per profile. +profileHistory :: X (Map ProfileId [(ScreenId, WorkspaceId)]) +profileHistory = XS.gets history + +-------------------------------------------------------------------------------- +profileMap :: X ProfileMap +profileMap = XS.gets profilesMap + +-------------------------------------------------------------------------------- +-- | Returns ids of all profiles. +profileIds :: X [ProfileId] +profileIds = Map.keys <$> XS.gets profilesMap + +-------------------------------------------------------------------------------- +currentProfileWorkspaces :: X [WorkspaceId] +currentProfileWorkspaces = XS.gets current <&> profileWS . fromMaybe defaultProfile + +-------------------------------------------------------------------------------- +-- | Hook profiles into XMonad. This function adds a startup hook that +-- sets up ProfileState. Also adds an afterRescreenHook for viewing correct +-- workspaces when adding new screens. +addProfiles :: ProfileConfig -> XConfig a -> XConfig a +addProfiles profConf conf = addAfterRescreenHook hook $ conf + { startupHook = profileStartupHook' <> startupHook conf + } + where + profileStartupHook' :: X() + profileStartupHook' = profilesStartupHook (profiles profConf) (startingProfile profConf) + hook = currentProfile >>= switchWSOnScreens + +-------------------------------------------------------------------------------- +-- | Hooks profiles into XMonad and enables Profile history logging. +addProfilesWithHistory :: ProfileConfig -> XConfig a -> XConfig a +addProfilesWithHistory profConf conf = conf' + { logHook = profileHistoryHookExclude (workspaceExcludes profConf) <> logHook conf + } + where + conf' = addProfiles profConf conf + +-------------------------------------------------------------------------------- +profileHistoryHookExclude :: [WorkspaceId] -> X() +profileHistoryHookExclude ews = do + cur <- gets $ W.current . windowset + vis <- gets $ W.visible . windowset + pws <- currentProfileWorkspaces + p <- currentProfile + + updateHist p $ workspaceScreenPairs $ filterWS pws $ cur:vis + where + workspaceScreenPairs wins = zip (W.screen <$> wins) (W.tag . W.workspace <$> wins) + filterWS pws = filter ((\wid -> (wid `elem` pws) && (wid `notElem` ews)) . W.tag . W.workspace) + +-------------------------------------------------------------------------------- +updateHist :: ProfileId -> [(ScreenId, WorkspaceId)] -> X() +updateHist pid xs = profileWorkspaces pid >>= XS.modify' . update + where + update pws hs = force $ hs { history = doUpdate pws $ history hs } + + doUpdate pws hist = foldl (\acc (sid, wid) -> Map.alter (f pws sid wid) pid acc) hist xs + + f pws sid wid val = case val of + Nothing -> pure [(sid, wid)] + Just hs -> pure $ let new = (sid, wid) in new:filterWS pws new hs + + filterWS :: [WorkspaceId] -> (ScreenId, WorkspaceId) -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)] + filterWS pws new = filter (\x -> snd x `elem` pws && x /= new) + +-------------------------------------------------------------------------------- +-- | Adds profiles to ProfileState and sets current profile using . + +profilesStartupHook :: [Profile] -> ProfileId -> X () +profilesStartupHook ps pid = XS.modify go >> switchWSOnScreens pid + where + go :: ProfileState -> ProfileState + go s = s {profilesMap = update $ profilesMap s, current = setCurrentProfile $ Map.fromList $ map entry ps} + + update :: ProfileMap -> ProfileMap + update = Map.union (Map.fromList $ map entry ps) + + entry :: Profile -> (ProfileId, Profile) + entry p = (profileId p, p) + + setCurrentProfile :: ProfileMap -> Maybe Profile + setCurrentProfile s = case Map.lookup pid s of + Nothing -> Just $ Profile pid [] + Just pn -> Just pn + +-------------------------------------------------------------------------------- +setPrevious :: ProfileId -> X() +setPrevious name = XS.modify update + where + update ps = ps { previous = doUpdate ps } + doUpdate ps = case Map.lookup name $ profilesMap ps of + Nothing -> previous ps + Just p -> Just $ profileId p + +-------------------------------------------------------------------------------- +setProfile :: ProfileId -> X () +setProfile p = currentProfile >>= setPrevious >> setProfile' p + +-------------------------------------------------------------------------------- +setProfile' :: ProfileId -> X () +setProfile' name = XS.modify update + where + update ps = ps { current = doUpdate ps } + doUpdate ps = case Map.lookup name $ profilesMap ps of + Nothing -> current ps + Just p -> Just p + +-------------------------------------------------------------------------------- +-- | Switch to a profile. +switchToProfile :: ProfileId -> X() +switchToProfile pid = setProfile pid >> switchWSOnScreens pid + +-------------------------------------------------------------------------------- +-- | Returns the workspace ids associated with a profile id. +profileWorkspaces :: ProfileId -> X [WorkspaceId] +profileWorkspaces pid = profileMap >>= findPWs + where + findPWs pm = return . profileWS . fromMaybe defaultProfile $ Map.lookup pid pm + +-------------------------------------------------------------------------------- +-- | Prompt for adding a workspace id to a profile. +addWSToProfilePrompt :: XPConfig -> X() +addWSToProfilePrompt c = do + ps <- profileIds + mkXPrompt (ProfilePrompt "Add ws to profile:") c (mkComplFunFromList' c ps) f + where + f :: String -> X() + f p = do + vis <- gets $ fmap (W.tag . W.workspace) . W.visible . windowset + cur <- gets $ W.tag . W.workspace . W.current . windowset + hid <- gets $ fmap W.tag . W.hidden . windowset + let + arr = cur:(vis <> hid) + in mkXPrompt (ProfilePrompt "Ws to add to profile:") c (mkComplFunFromList' c arr) (`addWSToProfile` p) + +-------------------------------------------------------------------------------- +-- | Prompt for switching profiles. +switchProfilePrompt :: XPConfig -> X() +switchProfilePrompt c = do + ps <- profileIds + mkXPrompt (ProfilePrompt "Profile: ") c (mkComplFunFromList' c ps) switchToProfile + +-------------------------------------------------------------------------------- +-- | Prompt for switching workspaces. +switchProfileWSPrompt :: XPConfig -> X () +switchProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces + where + mkPrompt pws = mkXPrompt (ProfilePrompt "Switch to workspace:") c (mkComplFunFromList' c pws) mbygoto + mbygoto wid = do + pw <- profileWorkspaces =<< currentProfile + unless (wid `notElem` pw) (windows . W.greedyView $ wid) + +-------------------------------------------------------------------------------- +-- | Prompt for shifting windows to a different workspace. +shiftProfileWSPrompt :: XPConfig -> X () +shiftProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces + where + mkPrompt pws = mkXPrompt (ProfilePrompt "Send window to workspace:") c (mkComplFunFromList' c pws) mbyshift + mbyshift wid = do + pw <- profileWorkspaces =<< currentProfile + unless (wid `notElem` pw) (windows . W.shift $ wid) + +-------------------------------------------------------------------------------- +addWSToProfile :: WorkspaceId -> ProfileId -> X() +addWSToProfile wid pid = XS.modify go + where + go :: ProfileState -> ProfileState + go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps} + + update :: ProfileMap -> ProfileMap + update mp = case Map.lookup pid mp of + Nothing -> mp + Just p -> if wid `elem` profileWS p then mp else Map.adjust f pid mp + + f :: Profile -> Profile + f p = Profile pid (wid : profileWS p) + + update' :: Profile -> Maybe Profile + update' cp = if profileId cp == pid && wid `notElem` profileWS cp then Just (Profile pid $ wid:profileWS cp) else Just cp + +-------------------------------------------------------------------------------- +-- | Prompt for removing a workspace from a profile. +removeWSFromProfilePrompt :: XPConfig -> X() +removeWSFromProfilePrompt c = do + ps <- profileIds + mkXPrompt (ProfilePrompt "Remove ws from profile:") c (mkComplFunFromList' c ps) f + where + f :: String -> X() + f p = do + arr <- profileWorkspaces p + mkXPrompt (ProfilePrompt "Ws to remove from profile:") c (mkComplFunFromList' c arr) $ + \ws -> do + cp <- currentProfile + ws `removeWSFromProfile` p + when (cp == p) $ currentProfile >>= switchWSOnScreens + +-------------------------------------------------------------------------------- +removeWSFromProfile :: WorkspaceId -> ProfileId -> X() +removeWSFromProfile wid pid = XS.modify go + where + go :: ProfileState -> ProfileState + go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps} + + update :: ProfileMap -> ProfileMap + update mp = case Map.lookup pid mp of + Nothing -> mp + Just p -> if wid `elem` profileWS p then Map.adjust f pid mp else mp + + f :: Profile -> Profile + f p = Profile pid (delete wid $ profileWS p) + + update' :: Profile -> Maybe Profile + update' cp = if profileId cp == pid && wid `elem` profileWS cp then Just (Profile pid $ delete wid $ profileWS cp) else Just cp + +-------------------------------------------------------------------------------- +-- | Pretty printer for a bar. Prints workspace ids of current profile. +excludeWSPP :: PP -> X PP +excludeWSPP pp = modifyPP <$> currentProfileWorkspaces + where + modifyPP pws = pp { ppRename = ppRename pp . printTag pws } + printTag pws tag = if tag `elem` pws then tag else "" + +-------------------------------------------------------------------------------- +-- | For cycling through workspaces associated with the current. +wsFilter :: WSType +wsFilter = WSIs $ currentProfileWorkspaces >>= (\ws -> return $ (`elem` ws) . W.tag) + +-------------------------------------------------------------------------------- +-- Takes care of placing correct workspaces on their respective screens. +-- It does this by reducing the history of a Profile until it gets an array of length +-- equal to the number of screens with pairs that have unique workspace ids. +switchWSOnScreens :: ProfileId -> X() +switchWSOnScreens pid = do + hist <- profileHistory + vis <- gets $ W.visible . windowset + cur <- gets $ W.current . windowset + pws <- profileMap <&> (profileWS . fromMaybe (Profile pid []) . Map.lookup pid) + case Map.lookup pid hist of + Nothing -> switchScreens $ zip (W.screen <$> (cur:vis)) pws + Just xs -> compareAndSwitch (f (W.screen <$> cur:vis) xs) (cur:vis) pws + where + f :: [ScreenId] -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)] + f sids = reorderUniq . reorderUniq . reverse . filter ((`elem` sids) . fst) + + reorderUniq :: (Ord k, Ord v) => [(k,v)] -> [(v,k)] + reorderUniq = map (\(x,y) -> (y,x)) . uniq + + uniq :: (Ord k, Ord v) => [(k,v)] -> [(k,v)] + uniq = Map.toList . Map.fromList + + viewWS fview sid wid = windows $ fview sid wid + + switchScreens = mapM_ (uncurry $ viewWS greedyViewOnScreen) + + compareAndSwitch hist wins pws | length hist < length wins = switchScreens $ hist <> populateScreens hist wins pws + | otherwise = switchScreens hist + + populateScreens hist wins pws = zip (filter (`notElem` map fst hist) $ W.screen <$> wins) (filter (`notElem` map snd hist) pws) + +-------------------------------------------------------------------------------- +chooseAction :: (String -> X ()) -> X () +chooseAction f = XS.gets current <&> (profileId . fromMaybe defaultProfile) >>= f + +-------------------------------------------------------------------------------- +-- | Create keybindings per profile. +bindOn :: [(String, X ())] -> X () +bindOn bindings = chooseAction chooser + where + chooser profile = case lookup profile bindings of + Just action -> action + Nothing -> case lookup "" bindings of + Just action -> action + Nothing -> return () + +-------------------------------------------------------------------------------- +-- | Loggs currentProfile and all profiles with hidden workspaces +-- (workspaces that aren't shown on a screen but have windows). +profileLogger :: (String -> String) -> (String -> String) -> Logger +profileLogger formatFocused formatUnfocused = do + hws <- gets $ W.hidden . windowset + p <- currentProfile + hm <- map fst + . filter (\(p', xs) -> any ((`elem` htags hws) . snd) xs || p' == p) + . Map.toList <$> profileHistory + return $ Just $ foldl (\a b -> a ++ " " ++ b) "" $ format p <$> hm + where + format p a = if a == p then formatFocused a else formatUnfocused a + htags wins = W.tag <$> filter (isJust . W.stack) wins + +-------------------------------------------------------------------------------- +-- | @XWindowMap@ of all windows contained in a profile. +allProfileWindows :: XWindowMap +allProfileWindows = allProfileWindows' def + +-------------------------------------------------------------------------------- +allProfileWindows' :: WindowBringerConfig -> XWindowMap +allProfileWindows' WindowBringerConfig{ windowTitler = titler, windowFilter = include } = do + pws <- currentProfileWorkspaces + windowSet <- gets windowset + Map.fromList . concat <$> mapM keyValuePairs (filter ((`elem` pws) . W.tag) $ W.workspaces windowSet) + where keyValuePairs ws = let wins = W.integrate' (W.stack ws) + in mapM (keyValuePair ws) =<< filterM include wins + keyValuePair ws w = (, w) <$> titler ws w diff --git a/XMonad/Actions/Search.hs b/XMonad/Actions/Search.hs --- a/XMonad/Actions/Search.hs +++ b/XMonad/Actions/Search.hs @@ -437,14 +437,14 @@ browser. -} promptSearchBrowser :: XPConfig -> Browser -> SearchEngine -> X () promptSearchBrowser config browser (SearchEngine name site) = do - hc <- historyCompletionP ("Search [" `isPrefixOf`) + hc <- historyCompletionP config ("Search [" `isPrefixOf`) mkXPrompt (Search name) config hc $ search browser site {- | Like 'promptSearchBrowser', but only suggest previous searches for the given 'SearchEngine' in the prompt. -} promptSearchBrowser' :: XPConfig -> Browser -> SearchEngine -> X () promptSearchBrowser' config browser (SearchEngine name site) = do - hc <- historyCompletionP (searchName `isPrefixOf`) + hc <- historyCompletionP config (searchName `isPrefixOf`) mkXPrompt (Search name) config hc $ search browser site where searchName = showXPrompt (Search name) diff --git a/XMonad/Actions/Submap.hs b/XMonad/Actions/Submap.hs --- a/XMonad/Actions/Submap.hs +++ b/XMonad/Actions/Submap.hs @@ -18,6 +18,7 @@ -- $usage submap, visualSubmap, + visualSubmapSorted, submapDefault, submapDefaultWithKey, @@ -88,15 +89,32 @@ -> M.Map (KeyMask, KeySym) (String, X ()) -- ^ A map @keybinding -> (description, action)@. -> X () -visualSubmap wc keys = +visualSubmap = visualSubmapSorted id + +-- | Like 'visualSubmap', but is able to sort the descriptions. +-- For example, +-- +-- > import Data.Ord (comparing, Down) +-- > +-- > visualSubmapSorted (sortBy (comparing Down)) def +-- +-- would sort the @(key, description)@ pairs by their keys in descending +-- order. +visualSubmapSorted :: ([((KeyMask, KeySym), String)] -> [((KeyMask, KeySym), String)]) + -- ^ A function to resort the descriptions + -> WindowConfig -- ^ The config for the spawned window. + -> M.Map (KeyMask, KeySym) (String, X ()) + -- ^ A map @keybinding -> (description, action)@. + -> X () +visualSubmapSorted sorted wc keys = withSimpleWindow wc descriptions waitForKeyPress >>= \(m', s) -> maybe (pure ()) snd (M.lookup (m', s) keys) where descriptions :: [String] descriptions = - zipWith (\key desc -> keyToString key <> ": " <> desc) - (M.keys keys) - (map fst (M.elems keys)) + map (\(key, desc) -> keyToString key <> ": " <> desc) + . sorted + $ zip (M.keys keys) (map fst (M.elems keys)) -- | Give a name to an action. subName :: String -> X () -> (String, X ()) diff --git a/XMonad/Actions/WindowBringer.hs b/XMonad/Actions/WindowBringer.hs --- a/XMonad/Actions/WindowBringer.hs +++ b/XMonad/Actions/WindowBringer.hs @@ -22,6 +22,7 @@ WindowBringerConfig(..), gotoMenu, gotoMenuConfig, gotoMenu', gotoMenuArgs, gotoMenuArgs', bringMenu, bringMenuConfig, bringMenu', bringMenuArgs, bringMenuArgs', + copyMenu, copyMenuConfig, copyMenu', copyMenuArgs, copyMenuArgs', windowMap, windowAppMap, windowMap', bringWindow, actionMenu ) where @@ -33,6 +34,7 @@ import qualified XMonad as X import XMonad.Util.Dmenu (menuMapArgs) import XMonad.Util.NamedWindows (getName, getNameWMClass) +import XMonad.Actions.CopyWindow (copyWindow) -- $usage -- @@ -44,6 +46,7 @@ -- -- > , ((modm .|. shiftMask, xK_g ), gotoMenu) -- > , ((modm .|. shiftMask, xK_b ), bringMenu) +-- > , ((modm .|. shiftMask, xK_y ), copyMenu) -- -- For detailed instructions on editing your key bindings, see -- . @@ -90,7 +93,38 @@ gotoMenuArgs' :: String -> [String] -> X () gotoMenuArgs' cmd args = gotoMenuConfig def { menuCommand = cmd, menuArgs = args } +-- | Pops open a dmenu with window titles. Choose one, and it will be copied into your current workspace. +copyMenu :: X () +copyMenu = copyMenuArgs def + -- | Pops open a dmenu with window titles. Choose one, and it will be +-- copied into your current workspace. This version +-- accepts a configuration object. +copyMenuConfig :: WindowBringerConfig -> X () +copyMenuConfig wbConfig = actionMenu wbConfig copyBringWindow + +-- | Pops open a dmenu with window titles. Choose one, and it will be +-- copied into your current workspace. This version +-- takes a list of arguments to pass to dmenu. +copyMenuArgs :: [String] -> X () +copyMenuArgs args = copyMenuConfig def { menuArgs = args } + +-- | Pops open an application with window titles given over stdin. Choose one, +-- and it will be copied into your current workspace. +copyMenu' :: String -> X () +copyMenu' cmd = copyMenuConfig def { menuArgs = [], menuCommand = cmd } + +-- | Pops open an application with window titles given over stdin. Choose one, +-- and it will be copied into your current +-- workspace. This version allows arguments to the chooser to be specified. +copyMenuArgs' :: String -> [String] -> X () +copyMenuArgs' cmd args = copyMenuConfig def { menuArgs = args, menuCommand = cmd } + +-- | Brings a copy of the specified window into the current workspace. +copyBringWindow :: Window -> X.WindowSet -> X.WindowSet +copyBringWindow w ws = copyWindow w (W.currentTag ws) ws + +-- | Pops open a dmenu with window titles. Choose one, and it will be -- dragged, kicking and screaming, into your current workspace. bringMenu :: X () bringMenu = bringMenuArgs def @@ -159,7 +193,7 @@ return $ name ++ " [" ++ W.tag ws ++ "]" -- | Returns the window name as will be listed in dmenu. This will --- return the executable name of the window along with it's workspace +-- return the executable name of the window along with its workspace -- ID. decorateAppName :: X.WindowSpace -> Window -> X String decorateAppName ws w = do diff --git a/XMonad/Actions/WindowNavigation.hs b/XMonad/Actions/WindowNavigation.hs --- a/XMonad/Actions/WindowNavigation.hs +++ b/XMonad/Actions/WindowNavigation.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE TupleSections #-} -- I didn't want this, it's hlint's "suggestion" and it's apparently non-negotiable ----------------------------------------------------------------------------- -- | -- Module : XMonad.Actions.WindowNavigation -- Description : Experimental rewrite of "XMonad.Layout.WindowNavigation". -- Copyright : (c) 2007 David Roundy , -- Devin Mullins --- Maintainer : Devin Mullins +-- Maintainer : Devin Mullins , +-- Platon Pronko -- License : BSD3-style (see LICENSE) -- Stability : unstable -- Portability : unportable @@ -37,17 +39,19 @@ withWindowNavigationKeys, WNAction(..), go, swap, + goPure, swapPure, Direction2D(..), WNState, ) where -import XMonad -import XMonad.Prelude (catMaybes, fromMaybe, listToMaybe, sortOn) +import XMonad hiding (state) +import XMonad.Prelude (catMaybes, fromMaybe, sortOn) import XMonad.Util.Types (Direction2D(..)) import qualified XMonad.StackSet as W import Control.Arrow (second) import Data.IORef import Data.Map (Map()) +import Data.List (partition, find) import qualified Data.Map as M import qualified Data.Set as S @@ -101,27 +105,60 @@ withWindowNavigationKeys :: [((KeyMask, KeySym), WNAction)] -> XConfig l -> IO (XConfig l) withWindowNavigationKeys wnKeys conf = do - posRef <- newIORef M.empty - return conf { keys = \cnf -> M.fromList (map (second (fromWNAction posRef)) wnKeys) + stateRef <- newIORef M.empty + return conf { keys = \cnf -> M.fromList (map (second (fromWNAction stateRef)) wnKeys) `M.union` keys conf cnf, - logHook = logHook conf >> trackMovement posRef } - where fromWNAction posRef (WNGo dir) = go posRef dir - fromWNAction posRef (WNSwap dir) = swap posRef dir + logHook = logHook conf >> trackMovement stateRef } + where fromWNAction stateRef (WNGo dir) = go stateRef dir + fromWNAction stateRef (WNSwap dir) = swap stateRef dir data WNAction = WNGo Direction2D | WNSwap Direction2D type WNState = Map WorkspaceId Point --- go: --- 1. get current position, verifying it matches the current window --- 2. get target windowrect --- 3. focus window --- 4. set new position +-- | Focus window in the given direction. go :: IORef WNState -> Direction2D -> X () -go = withTargetWindow W.focusWindow +go stateRef dir = runPureAction stateRef (goPure dir) +-- | Swap current window with the window in the given direction. +-- Note: doesn't work with floating windows (don't think it makes much sense to swap floating windows). swap :: IORef WNState -> Direction2D -> X () -swap = withTargetWindow swapWithFocused +swap stateRef dir = runPureAction stateRef (swapPure dir) + +type WindowRectFn x = (Window -> x (Maybe Rectangle)) +-- | (state, oldWindowSet, mappedWindows, windowRect) +type WNInput x = (WNState, WindowSet, S.Set Window, WindowRectFn x) +type WNOutput = (WNState, WindowSet) + +-- | Run the pure action inside X monad. +runPureAction :: IORef WNState -> (WNInput X -> X WNOutput) -> X () +runPureAction stateRef action = do + oldState <- io (readIORef stateRef) + oldWindowSet <- gets windowset + mappedWindows <- gets mapped + (newState, newWindowSet) <- action (oldState, oldWindowSet, mappedWindows, windowRectX) + windows (const newWindowSet) + io $ writeIORef stateRef newState + +-- | Version of `go` not dependent on X monad (needed for testing). +goPure :: Monad x => Direction2D -> WNInput x -> x WNOutput +goPure dir input@(oldState, oldWindowSet, mappedWindows, _) = + if length (filter (`S.member` mappedWindows) $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet) == 1 + then + -- Handle the special case of Full layout, when there's only one mapped window on a screen. + return ( oldState + , case dir of + U -> W.focusUp oldWindowSet + L -> W.focusDown oldWindowSet + D -> W.focusDown oldWindowSet + R -> W.focusUp oldWindowSet + ) + else + withTargetWindow W.focusWindow dir input + +-- | Version of `swap` not dependent on X monad (needed for testing). +swapPure :: Monad x => Direction2D -> WNInput x -> x WNOutput +swapPure = withTargetWindow swapWithFocused where swapWithFocused targetWin winSet = case W.peek winSet of Just currentWin -> W.focusWindow currentWin $ @@ -135,87 +172,249 @@ | win == win2 = win1 | otherwise = win -withTargetWindow :: (Window -> WindowSet -> WindowSet) -> IORef WNState -> Direction2D -> X () -withTargetWindow adj posRef dir = fromCurrentPoint posRef $ \win pos -> do - targets <- filter ((/= win) . fst) <$> navigableTargets pos dir - whenJust (listToMaybe targets) $ \(targetWin, targetRect) -> do - windows (adj targetWin) - setPosition posRef pos targetRect +-- | Select a target window in the given direction and modify the WindowSet. +-- 1. Get current position, verifying it matches the current window (exit if no focused window). +-- 2. Get the target window. +-- 3. Execute an action on the target window and windowset. +-- 4. Set the new position. +withTargetWindow :: Monad x => (Window -> WindowSet -> WindowSet) -> Direction2D -> WNInput x -> x WNOutput +withTargetWindow adj dir input@(oldState, oldWindowSet, _, _) = do + whenJust' (getCurrentWindow input) (oldState, oldWindowSet) $ \(win, winRect, pos) -> do + targetMaybe <- find ((/= win) . fst) <$> navigableTargets input dir winRect pos + whenJust' (pure targetMaybe) (oldState, oldWindowSet) $ \(targetWin, newPos) -> + let newWindowSet = adj targetWin oldWindowSet + in return (modifyState newWindowSet newPos oldState, newWindowSet) +-- | Update position on outside changes in windows. trackMovement :: IORef WNState -> X () -trackMovement posRef = fromCurrentPoint posRef $ \win pos -> - windowRect win >>= flip whenJust (setPosition posRef pos . snd) +trackMovement stateRef = do + oldState <- io (readIORef stateRef) + oldWindowSet <- gets windowset + mappedWindows <- gets mapped + whenJust' (getCurrentWindow (oldState, oldWindowSet, mappedWindows, windowRectX)) () $ \(_, _, pos) -> do + io $ writeIORef stateRef $ modifyState oldWindowSet pos oldState -fromCurrentPoint :: IORef WNState -> (Window -> Point -> X ()) -> X () -fromCurrentPoint posRef f = withFocused $ \win -> - currentPosition posRef >>= f win +-- | Get focused window and current position. +getCurrentWindow :: Monad x => WNInput x -> x (Maybe (Window, Rectangle, Point)) +getCurrentWindow input@(_, oldWindowSet, _, _) = + whenJust' (pure $ W.peek oldWindowSet) Nothing $ \window -> do + (pos, rect) <- currentPosition input + return $ Just (window, rect, pos) --- Gets the current position from the IORef passed in, or if nothing (say, from --- a restart), derives the current position from the current window. Also, --- verifies that the position is congruent with the current window (say, if you --- used mod-j/k or mouse or something). -currentPosition :: IORef WNState -> X Point -currentPosition posRef = do - root <- asks theRoot - currentWindow <- gets (W.peek . windowset) - currentRect <- maybe (Rectangle 0 0 0 0) snd <$> windowRect (fromMaybe root currentWindow) +-- | Gets the current position from the state passed in, or if nothing +-- (say, from a restart), derives the current position from the current window. +-- Also, verifies that the position is congruent with the current window +-- (say, if you moved focus using mouse or something). +-- Returns the window rectangle for convenience, since we'll need it later anyway. +currentPosition :: Monad x => WNInput x -> x (Point, Rectangle) +currentPosition (state, oldWindowSet, _, windowRect) = do + currentRect <- fromMaybe (Rectangle 0 0 0 0) <$> maybe (pure Nothing) windowRect (W.peek oldWindowSet) + let posMaybe = M.lookup (W.currentTag oldWindowSet) state + middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h) + return $ case posMaybe of + Nothing -> (middleOf currentRect, currentRect) + Just pos -> (centerPosition currentRect pos, currentRect) - wsid <- gets (W.currentTag . windowset) - mp <- M.lookup wsid <$> io (readIORef posRef) +-- | Inserts new position into the state. +modifyState :: WindowSet -> Point -> WNState -> WNState +modifyState oldWindowSet = + M.insert (W.currentTag oldWindowSet) - return $ maybe (middleOf currentRect) (`inside` currentRect) mp +-- | "Jumps" the current position into the middle of target rectangle. +-- (keeps the position as-is if it is already inside the target rectangle) +centerPosition :: Rectangle -> Point -> Point +centerPosition r@(Rectangle rx ry rw rh) pos@(Point x y) = do + if pointWithin x y r + then pos + else Point (midPoint rx rw) (midPoint ry rh) - where middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h) +midPoint :: Position -> Dimension -> Position +midPoint pos dim = pos + fromIntegral dim `div` 2 -setPosition :: IORef WNState -> Point -> Rectangle -> X () -setPosition posRef oldPos newRect = do - wsid <- gets (W.currentTag . windowset) - io $ modifyIORef posRef $ M.insert wsid (oldPos `inside` newRect) +-- | Make a list of target windows we can navigate to, +-- sorted by desirability of navigation. +navigableTargets :: Monad x => WNInput x -> Direction2D -> Rectangle -> Point -> x [(Window, Point)] +navigableTargets input@(_, oldWindowSet, _, _) dir currentRect currentPos = do + allScreensWindowsAndRectangles <- mapSnd (rectTransform dir) <$> windowRects input + let + screenWindows = S.fromList $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet + (thisScreenWindowsAndRectangles, otherScreensWindowsAndRectangles) = partition (\(w, _) -> S.member w screenWindows) allScreensWindowsAndRectangles -inside :: Point -> Rectangle -> Point -Point x y `inside` Rectangle rx ry rw rh = - Point (x `within` (rx, rw)) (y `within` (ry, rh)) - where pos `within` (lower, dim) = if pos >= lower && pos < lower + fromIntegral dim - then pos - else midPoint lower dim + pos = pointTransform dir currentPos + wr = rectTransform dir currentRect -midPoint :: Position -> Dimension -> Position -midPoint pos dim = pos + fromIntegral dim `div` 2 + rectInside r = (rect_p1 r >= rect_p1 wr && rect_p1 r < rect_p2 wr && rect_p2 r > rect_p1 wr && rect_p2 r <= rect_p2 wr) && + ((rect_o1 r >= rect_o1 wr && rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr && rect_o2 r <= rect_o2 wr) || + (rect_o1 r <= rect_o1 wr && rect_o2 r >= rect_o2 wr)) -- include windows that fully overlaps current on the orthogonal axis + sortByP2 = sortOn (rect_p2 . snd) + posBeforeEdge r = point_p pos < rect_p2 r -navigableTargets :: Point -> Direction2D -> X [(Window, Rectangle)] -navigableTargets point dir = navigable dir point <$> windowRects + rectOverlapsEdge r = rect_p1 r <= rect_p2 wr && rect_p2 r > rect_p2 wr && + rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr + rectOverlapsOneEdge r = rectOverlapsEdge r && rect_p1 r > rect_p1 wr + rectOverlapsBothEdges r = rectOverlapsEdge r && + rect_o1 r > rect_o1 wr && rect_o2 r < rect_o2 wr && point_o pos >= rect_o1 r && point_o pos < rect_o2 r + distanceToRectEdge r = max (max 0 (rect_o1 r - point_o pos)) (max 0 (point_o pos + 1 - rect_o2 r)) + distanceToRectCenter r = + let distance = (rect_o1 r + rect_o2 r) `div` 2 - point_o pos + in if distance <= 0 + then distance + 1 + else distance + sortByPosDistance = sortOn ((\r -> (rect_p1 r, distanceToRectEdge r, distanceToRectCenter r)) . snd) --- Filters and sorts the windows in terms of what is closest from the Point in --- the Direction2D. -navigable :: Direction2D -> Point -> [(Window, Rectangle)] -> [(Window, Rectangle)] -navigable d pt = sortby d . filter (inr d pt . snd) + rectOutside r = rect_p1 r < rect_p1 wr && rect_p2 r > rect_p2 wr && + rect_o1 r < rect_o1 wr && rect_o2 r > rect_o2 wr + sortByLength = sortOn (rect_psize . snd) --- Produces a list of normal-state windows, on any screen. Rectangles are --- adjusted based on screen position relative to the current screen, because I'm --- bad like that. -windowRects :: X [(Window, Rectangle)] -windowRects = fmap catMaybes . mapM windowRect . S.toList =<< gets mapped + rectAfterEdge r = rect_p1 r > rect_p2 wr -windowRect :: Window -> X (Maybe (Window, Rectangle)) -windowRect win = withDisplay $ \dpy -> do + -- Modified from David Roundy and Devin Mullins original implementation of WindowNavigation: + inr r = point_p pos < rect_p2 r && point_o pos >= rect_o1 r && point_o pos < rect_o2 r + + clamp v v1 v2 | v < v1 = v1 + | v >= v2 = v2 - 1 + | otherwise = v + dragPos r = DirPoint (max (point_p pos) (rect_p1 r)) (clamp (point_o pos) (rect_o1 r) (rect_o2 r)) + + return $ mapSnd (inversePointTransform dir) $ concat + [ + -- First, navigate to windows that are fully inside current window + -- and have higher coordinate bigger than current position. + -- ┌──────────────────┐ + -- │ current │ (all examples assume direction=R) + -- │ ┌──────────┐ │ + -- │ ──┼─► inside │ │ + -- │ └──────────┘ │ + -- └──────────────────┘ + -- Also include windows fully overlapping current on the orthogonal axis: + -- ┌──────────────┐ + -- │ overlapping │ + -- ┌───────────┤ ├────┐ + -- │ current ──┼─► │ │ + -- └───────────┤ ├────┘ + -- └──────────────┘ + mapSnd dragPos $ sortByP2 $ filterSnd posBeforeEdge $ filterSnd rectInside thisScreenWindowsAndRectangles + + -- Then navigate to windows that touch or overlap the edge of current window in the chosen direction. + -- ┌──────────────┬─────────────┐ ┌───────────┐ ┌─────────────┐ + -- │ current │ adjacent │ │ current │ │ current │ + -- │ ──┼─► │ │ ┌───┴───────────────┐ │ ┌───┴─────────────┐ + -- │ │ │ │ ──┼─► │ overlapping │ │ ──┼─► │ + -- │ ├─────────────┘ │ └───┬───────────────┘ └─────────┤ overlapping │ + -- │ │ │ │ │ │ + -- └──────────────┘ └───────────┘ └─────────────────┘ + , mapSnd dragPos $ sortByPosDistance $ filterSnd rectOverlapsOneEdge thisScreenWindowsAndRectangles + + -- Windows fully overlapping current window "in the middle" on the parallel axis are also included, + -- if position is inside them: + -- ┌───────────┐ + -- │ current │ + -- ┌───┤-----------├────────────────┐ + -- │ │ * ──┼─► overlapping │ + -- └───┤-----------├────────────────┘ + -- └───────────┘ + , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByPosDistance $ filterSnd rectOverlapsBothEdges thisScreenWindowsAndRectangles + + -- Then navigate to windows that fully encompass the current window. + -- ┌─────────────────────┐ + -- │ outer │ + -- │ ┌─────────────┐ │ + -- │ │ current ──┼─► │ + -- │ └─────────────┘ │ + -- └─────────────────────┘ + , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByLength $ filterSnd rectOutside thisScreenWindowsAndRectangles + + -- Then navigate to windows that are fully after current window in the chosen direction. + -- ┌──────────────┐ + -- │ current │ ┌────────────────┐ + -- │ │ │ │ + -- │ ──┼──┼─► not adjacent │ + -- │ │ │ │ + -- │ │ └────────────────┘ + -- └──────────────┘ + , mapSnd dragPos $ sortByPosDistance $ filterSnd rectAfterEdge thisScreenWindowsAndRectangles + + -- Cast a ray from the current position, jump to the first window (on another screen) that intersects this ray. + , mapSnd dragPos $ sortByPosDistance $ filterSnd inr otherScreensWindowsAndRectangles + + -- If everything else fails, then navigate to the window that is fully inside current window, + -- but is before the current position. + -- This can happen when we are at the last window on a screen, and attempt to navigate even further. + -- In this case it seems okay to jump to the remaining inner windows, since we don't have any other choice anyway, + -- and user is probably not so fully aware of the precise position anyway. + , mapSnd (\r -> DirPoint (rect_p2 r - 1) (clamp (point_o pos) (rect_o1 r) (rect_o2 r))) $ + sortByP2 $ filterSnd (not . posBeforeEdge) $ filterSnd rectInside thisScreenWindowsAndRectangles + ] + +-- Structs for direction-independent space - equivalent to rotating points and rectangles such that +-- navigation direction points to the right. +-- Allows us to abstract over direction in the navigation functions. +data DirPoint = DirPoint + { point_p :: Position -- coordinate parallel to the direction + , point_o :: Position -- coordinate orthogonal to the direction + } +data DirRectangle = DirRectangle + { rect_p1 :: Position -- lower rectangle coordinate parallel to the direction + , rect_p2 :: Position -- higher rectangle coordinate parallel to the direction + , rect_o1 :: Position -- lower rectangle coordinate orthogonal to the direction + , rect_o2 :: Position -- higher rectangle coordinate orthogonal to the direction + } +{- HLINT ignore "Use camelCase" -} +rect_psize :: DirRectangle -> Dimension +rect_psize r = fromIntegral (rect_p2 r - rect_p1 r) + +-- | Transform a point from screen space into direction-independent space. +pointTransform :: Direction2D -> Point -> DirPoint +pointTransform dir (Point x y) = case dir of + U -> DirPoint (negate y - 1) x + L -> DirPoint (negate x - 1) (negate y - 1) + D -> DirPoint y (negate x - 1) + R -> DirPoint x y + +-- | Transform a point from direction-independent space back into screen space. +inversePointTransform :: Direction2D -> DirPoint -> Point +inversePointTransform dir p = case dir of + U -> Point (point_o p) (negate $ point_p p + 1) + L -> Point (negate $ point_p p + 1) (negate $ point_o p + 1) + D -> Point (negate $ point_o p + 1) (point_p p) + R -> Point (point_p p) (point_o p) + +-- | Transform a rectangle from screen space into direction-independent space. +rectTransform :: Direction2D -> Rectangle -> DirRectangle +rectTransform dir (Rectangle x y w h) = case dir of + U -> DirRectangle (negate $ y + fromIntegral h) (negate y) x (x + fromIntegral w) + L -> DirRectangle (negate $ x + fromIntegral w) (negate x) (negate $ y + fromIntegral h) (negate y) + D -> DirRectangle y (y + fromIntegral h) (negate $ x + fromIntegral w) (negate x) + R -> DirRectangle x (x + fromIntegral w) y (y + fromIntegral h) + +-- | Produces a list of normal-state windows on all screens, excluding currently focused window. +windowRects :: Monad x => WNInput x -> x [(Window, Rectangle)] +windowRects (_, oldWindowSet, mappedWindows, windowRect) = + let + allWindows = filter (\w -> w `notElem` W.peek oldWindowSet) $ S.toList mappedWindows + windowRect2 w = fmap (w,) <$> windowRect w + in catMaybes <$> mapM windowRect2 allWindows + +windowRectX :: Window -> X (Maybe Rectangle) +windowRectX win = withDisplay $ \dpy -> do (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win - return $ Just (win, Rectangle x y (w + 2 * bw) (h + 2 * bw)) + return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw) `catchX` return Nothing --- Modified from droundy's implementation of WindowNavigation: +-- Maybe below functions can be replaced with some standard helper functions? -inr :: Direction2D -> Point -> Rectangle -> Bool -inr D (Point px py) (Rectangle rx ry w h) = px >= rx && px < rx + fromIntegral w && - py < ry + fromIntegral h -inr U (Point px py) (Rectangle rx ry w _) = px >= rx && px < rx + fromIntegral w && - py > ry -inr R (Point px py) (Rectangle rx ry w h) = px < rx + fromIntegral w && - py >= ry && py < ry + fromIntegral h -inr L (Point px py) (Rectangle rx ry _ h) = px > rx && - py >= ry && py < ry + fromIntegral h +-- | Execute a monadic action on the contents if Just, otherwise wrap default value and return it. +whenJust' :: Monad x => x (Maybe a) -> b -> (a -> x b) -> x b +whenJust' monadMaybeValue deflt f = do + maybeValue <- monadMaybeValue + case maybeValue of + Nothing -> return deflt + Just value -> f value -sortby :: Direction2D -> [(a,Rectangle)] -> [(a,Rectangle)] -sortby D = sortOn (rect_y . snd) -sortby R = sortOn (rect_x . snd) -sortby U = reverse . sortby D -sortby L = reverse . sortby R +-- | Filter a list of tuples on the second tuple member. +filterSnd :: (b -> Bool) -> [(a, b)] -> [(a, b)] +filterSnd f = filter (f . snd) + +-- | Map a second tuple member in a list of tuples. +mapSnd :: (b -> b') -> [(a, b)] -> [(a, b')] +mapSnd f = map (second f) diff --git a/XMonad/Actions/WorkspaceNames.hs b/XMonad/Actions/WorkspaceNames.hs --- a/XMonad/Actions/WorkspaceNames.hs +++ b/XMonad/Actions/WorkspaceNames.hs @@ -138,7 +138,7 @@ -- | Prompt for a new name for the current workspace and set it. renameWorkspace :: XPConfig -> X () renameWorkspace conf = do - completion <- historyCompletionP (prompt ==) + completion <- historyCompletionP conf (prompt ==) mkXPrompt (Wor prompt) conf completion setCurrentWorkspaceName where prompt = "Workspace name: " diff --git a/XMonad/Hooks/EwmhDesktops.hs b/XMonad/Hooks/EwmhDesktops.hs --- a/XMonad/Hooks/EwmhDesktops.hs +++ b/XMonad/Hooks/EwmhDesktops.hs @@ -459,10 +459,17 @@ a_aw <- getAtom "_NET_ACTIVE_WINDOW" a_cw <- getAtom "_NET_CLOSE_WINDOW" - if | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n -> + if | mt == a_cw -> + killWindow w + | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n -> if W.currentTag s == W.tag ww then mempty else windows $ W.view (W.tag ww) | mt == a_cd -> trace $ "Bad _NET_CURRENT_DESKTOP with data=" ++ show d + | not (w `W.member` s) -> + -- do nothing for unmanaged windows; it'd be just a useless + -- refresh which breaks menus/popups of misbehaving apps that + -- send _NET_ACTIVE_WINDOW requests for override-redirect wins + mempty | mt == a_d, n : _ <- d, Just ww <- ws !? fi n -> if W.findTag w s == Just (W.tag ww) then mempty else windows $ W.shiftWin (W.tag ww) w | mt == a_d -> @@ -473,8 +480,6 @@ if W.peek s == Just w then mempty else windows $ W.focusWindow w | mt == a_aw -> do if W.peek s == Just w then mempty else windows . appEndo =<< runQuery activateHook w - | mt == a_cw -> - killWindow w | otherwise -> -- The Message is unknown to us, but that is ok, not all are meant -- to be handled by the window manager diff --git a/XMonad/Hooks/FloatConfigureReq.hs b/XMonad/Hooks/FloatConfigureReq.hs new file mode 100644 --- /dev/null +++ b/XMonad/Hooks/FloatConfigureReq.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE LambdaCase #-} +-- | +-- Module : XMonad.Hooks.FloatConfigureReq +-- Description : Customize handling of floating windows' move\/resize\/restack requests (ConfigureRequest). +-- Copyright : (c) 2024 Tomáš Janoušek +-- License : BSD3 +-- Maintainer : Tomáš Janoušek +-- +-- xmonad normally honours those requests by doing exactly what the client +-- application asked, and refreshing. There are some misbehaving clients, +-- however, that: +-- +-- * try to move their window to the last known absolute position regardless +-- of the current xrandr/xinerama layout +-- +-- * move their window to 0, 0 for no particular reason (e.g. rxvt-unicode) +-- +-- * issue lots of no-op requests causing flickering (e.g. Steam) +-- +-- This module provides a replacement handler for 'ConfigureRequestEvent' to +-- work around such misbehaviours. +-- +module XMonad.Hooks.FloatConfigureReq ( + -- * Usage + -- $usage + MaybeMaybeManageHook, + floatConfReqHook, + + -- * Known workarounds + fixSteamFlicker, + fixSteamFlickerMMMH, + ) where + +import qualified Data.Map.Strict as M +import XMonad +import XMonad.Hooks.ManageHelpers +import XMonad.Prelude +import qualified XMonad.StackSet as W + +-- $usage +-- To use this, include the following in your @xmonad.hs@: +-- +-- > import XMonad.Hooks.FloatConfigureReq +-- > import XMonad.Hooks.ManageHelpers +-- +-- > myFloatConfReqHook :: MaybeMaybeManageHook +-- > myFloatConfReqHook = composeAll +-- > [ … ] +-- +-- > myEventHook :: Event -> X All +-- > myEventHook = mconcat +-- > [ … +-- > , floatConfReqHook myFloatConfReqHook +-- > , … ] +-- +-- > main = xmonad $ … +-- > $ def{ handleEventHook = myEventHook +-- > , … } +-- +-- Then fill the @myFloatConfReqHook@ with whatever custom rules you need. +-- +-- As an example, the following will prevent rxvt-unicode from moving its +-- (floating) window to 0, 0 after a font change but still ensure its size +-- increment hints are respected: +-- +-- > className =? "URxvt" -?> pure <$> doFloat +-- +-- Another example that avoids flickering and xmonad slowdowns caused by the +-- Steam client (completely ignore all its requests, none of which are +-- meaningful in the context of a tiling WM): +-- +-- > map toLower `fmap` className =? "steam" -?> mempty +-- +-- (this example is also available as 'fixSteamFlickerMMMH' to be added to +-- one's @myFloatConfReqHook@ and also 'fixSteamFlicker' to be added directly +-- to one's 'handleEventHook') + +-- | A variant of 'MaybeManageHook' that additionally may or may not make +-- changes to the 'WindowSet'. +type MaybeMaybeManageHook = Query (Maybe (Maybe (Endo WindowSet))) + +-- | Customizable handler for a 'ConfigureRequestEvent'. If the event's +-- 'ev_window' is a managed floating window, the provided +-- 'MaybeMaybeManageHook' is consulted and its result interpreted as follows: +-- +-- * @Nothing@ - no match, fall back to the default handler +-- +-- * @Just Nothing@ - match but ignore, no refresh, just send ConfigureNotify +-- +-- * @Just (Just a)@ - match, modify 'WindowSet', refresh, send ConfigureNotify +floatConfReqHook :: MaybeMaybeManageHook -> Event -> X All +floatConfReqHook mh ConfigureRequestEvent{ev_window = w} = + runQuery (join <$> (isFloatQ -?> mh)) w >>= \case + Nothing -> mempty + Just e -> do + whenJust e (windows . appEndo) + sendConfEvent + pure (All False) + where + sendConfEvent = withDisplay $ \dpy -> + withWindowAttributes dpy w $ \wa -> do + io . allocaXEvent $ \ev -> do + -- We may have made no changes to the window size/position + -- and thus the X server didn't emit any ConfigureNotify, + -- so we need to send the ConfigureNotify ourselves to make + -- sure there is a reply to this ConfigureRequestEvent and the + -- window knows we (possibly) ignored its request. + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (wa_border_width wa) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev +floatConfReqHook _ _ = mempty + +-- | A 'Query' to determine if a window is floating. +isFloatQ :: Query Bool +isFloatQ = ask >>= \w -> liftX . gets $ M.member w . W.floating . windowset + +-- | A pre-packaged 'floatConfReqHook' that fixes flickering of the Steam client by ignoring 'ConfigureRequestEvent's on any of its floating windows. +-- +-- To use this, add 'fixSteamFlicker' to your 'handleEventHook'. +fixSteamFlicker :: Event -> X All +fixSteamFlicker = floatConfReqHook fixSteamFlickerMMMH + +fixSteamFlickerMMMH :: MaybeMaybeManageHook +fixSteamFlickerMMMH = map toLower `fmap` className =? "steam" -?> mempty diff --git a/XMonad/Hooks/ManageHelpers.hs b/XMonad/Hooks/ManageHelpers.hs --- a/XMonad/Hooks/ManageHelpers.hs +++ b/XMonad/Hooks/ManageHelpers.hs @@ -51,6 +51,7 @@ isFullscreen, isMinimized, isDialog, + isNotification, pid, desktop, transientTo, @@ -191,8 +192,17 @@ isMinimized = isInProperty "_NET_WM_STATE" "_NET_WM_STATE_HIDDEN" -- | A predicate to check whether a window is a dialog. +-- +-- See . isDialog :: Query Bool isDialog = isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_DIALOG" + +-- | A predicate to check whether a window is a notification. +-- +-- See . +isNotification :: Query Bool +isNotification = + isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_NOTIFICATION" -- | This function returns 'Just' the @_NET_WM_PID@ property for a -- particular window if set, 'Nothing' otherwise. diff --git a/XMonad/Hooks/OnPropertyChange.hs b/XMonad/Hooks/OnPropertyChange.hs --- a/XMonad/Hooks/OnPropertyChange.hs +++ b/XMonad/Hooks/OnPropertyChange.hs @@ -41,13 +41,13 @@ -- $usage -- You can use this module with the following in your @xmonad.hs@: -- --- > import XMonad.Hooks.DynamicProperty +-- > import XMonad.Hooks.OnPropertyChange -- -- Enable it by including in you handleEventHook definition: -- -- > main = xmonad $ def -- > { ... --- > , handleEventHook = onXPropertyChange "WM_NAME" (title =? "Spotify" --> doShift "5")) +-- > , handleEventHook = onXPropertyChange "WM_NAME" (title =? "Spotify" --> doShift "5") -- > , ... -- > } -- diff --git a/XMonad/Hooks/ScreenCorners.hs b/XMonad/Hooks/ScreenCorners.hs --- a/XMonad/Hooks/ScreenCorners.hs +++ b/XMonad/Hooks/ScreenCorners.hs @@ -3,7 +3,7 @@ -- | -- Module : XMonad.Hooks.ScreenCorners -- Description : Run X () actions by touching the edge of your screen with your mouse. --- Copyright : (c) 2009 Nils Schweinsberg, 2015 Evgeny Kurnevsky +-- Copyright : (c) 2009 Nils Schweinsberg, 2015 Evgeny Kurnevsky, 2024 Yuanle Song -- License : BSD3-style (see LICENSE) -- -- Maintainer : Nils Schweinsberg @@ -42,6 +42,10 @@ | SCUpperRight | SCLowerLeft | SCLowerRight + | SCTop + | SCBottom + | SCLeft + | SCRight deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- @@ -74,26 +78,50 @@ -- Xlib functions -------------------------------------------------------------------------------- --- "Translate" a ScreenCorner to real (x,y) Positions +-- "Translate" a ScreenCorner to real (x,y) Positions with proper width and +-- height. createWindowAt :: ScreenCorner -> X Window -createWindowAt SCUpperLeft = createWindowAt' 0 0 +createWindowAt SCUpperLeft = createWindowAt' 0 0 1 1 createWindowAt SCUpperRight = withDisplay $ \dpy -> let w = displayWidth dpy (defaultScreen dpy) - 1 - in createWindowAt' (fi w) 0 + in createWindowAt' (fi w) 0 1 1 createWindowAt SCLowerLeft = withDisplay $ \dpy -> let h = displayHeight dpy (defaultScreen dpy) - 1 - in createWindowAt' 0 (fi h) + in createWindowAt' 0 (fi h) 1 1 createWindowAt SCLowerRight = withDisplay $ \dpy -> let w = displayWidth dpy (defaultScreen dpy) - 1 h = displayHeight dpy (defaultScreen dpy) - 1 - in createWindowAt' (fi w) (fi h) + in createWindowAt' (fi w) (fi h) 1 1 --- Create a new X window at a (x,y) Position -createWindowAt' :: Position -> Position -> X Window -createWindowAt' x y = withDisplay $ \dpy -> io $ do +createWindowAt SCTop = withDisplay $ \dpy -> + let w = displayWidth dpy (defaultScreen dpy) - 1 + -- leave some gap so corner and edge can work nicely when they overlap + threshold = 150 + in createWindowAt' threshold 0 (fi $ fi w - threshold * 2) 1 +createWindowAt SCBottom = withDisplay $ \dpy -> + let w = displayWidth dpy (defaultScreen dpy) - 1 + h = displayHeight dpy (defaultScreen dpy) - 1 + threshold = 150 + in createWindowAt' threshold (fi h) (fi $ fi w - threshold * 2) 1 + +createWindowAt SCLeft = withDisplay $ \dpy -> + let h = displayHeight dpy (defaultScreen dpy) - 1 + threshold = 150 + in createWindowAt' 0 threshold 1 (fi $ fi h - threshold * 2) + +createWindowAt SCRight = withDisplay $ \dpy -> + let w = displayWidth dpy (defaultScreen dpy) - 1 + h = displayHeight dpy (defaultScreen dpy) - 1 + threshold = 150 + in createWindowAt' (fi w) threshold 1 (fi $ fi h - threshold * 2) + +-- Create a new X window at a (x,y) Position, with given width and height. +createWindowAt' :: Position -> Position -> Dimension -> Dimension -> X Window +createWindowAt' x y width height = withDisplay $ \dpy -> io $ do + rootw <- rootWindow dpy (defaultScreen dpy) let @@ -107,8 +135,8 @@ rootw -- parent window x -- x y -- y - 1 -- width - 1 -- height + width -- width + height -- height 0 -- border width 0 -- depth inputOnly -- class @@ -122,7 +150,6 @@ sync dpy False return w - -------------------------------------------------------------------------------- -- Event hook -------------------------------------------------------------------------------- @@ -162,9 +189,10 @@ -------------------------------------------------------------------------------- -- $usage -- --- This extension adds KDE-like screen corners to XMonad. By moving your cursor --- into one of your screen corners you can trigger an @X ()@ action, for --- example @"XMonad.Actions.GridSelect".goToSelected@ or +-- This extension adds KDE-like screen corners and GNOME Hot Edge like +-- features to XMonad. By moving your cursor into one of your screen corners +-- or edges, you can trigger an @X ()@ action, for example +-- @"XMonad.Actions.GridSelect".goToSelected@ or -- @"XMonad.Actions.CycleWS".nextWS@ etc. -- -- To use it, import it on top of your @xmonad.hs@: @@ -176,6 +204,7 @@ -- > myStartupHook = do -- > ... -- > addScreenCorner SCUpperRight (goToSelected def { gs_cellwidth = 200}) +-- > addScreenCorner SCBottom (goToSelected def) -- > addScreenCorners [ (SCLowerRight, nextWS) -- > , (SCLowerLeft, prevWS) -- > ] diff --git a/XMonad/Hooks/StatusBar.hs b/XMonad/Hooks/StatusBar.hs --- a/XMonad/Hooks/StatusBar.hs +++ b/XMonad/Hooks/StatusBar.hs @@ -452,7 +452,7 @@ -- 'avoidStruts', check 'dynamicEasySBs'. -- -- Heavily inspired by "XMonad.Hooks.DynamicBars" -dynamicSBs :: (ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l +dynamicSBs :: (ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l dynamicSBs f conf = addAfterRescreenHook (updateSBs f) $ conf { startupHook = startupHook conf >> killAllStatusBars >> updateSBs f , logHook = logHook conf >> logSBs @@ -462,7 +462,7 @@ -- resulting config and adds 'avoidStruts' to the -- layout. dynamicEasySBs :: LayoutClass l Window - => (ScreenId -> IO StatusBarConfig) + => (ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig (ModifiedLayout AvoidStruts l) dynamicEasySBs f conf = @@ -471,7 +471,7 @@ -- | Given the function to create status bars, update -- the status bars by killing those that shouldn't be -- visible anymore and creates any missing status bars -updateSBs :: (ScreenId -> IO StatusBarConfig) -> X () +updateSBs :: (ScreenId -> X StatusBarConfig) -> X () updateSBs f = do actualScreens <- withWindowSet $ return . map W.screen . W.screens (toKeep, toKill) <- @@ -480,7 +480,7 @@ cleanSBs (map snd toKill) -- Create new status bars if needed let missing = actualScreens \\ map fst toKeep - added <- io $ traverse (\s -> (s,) <$> f s) missing + added <- traverse (\s -> (s,) <$> f s) missing traverse_ (sbStartupHook . snd) added XS.put (ASB (toKeep ++ added)) diff --git a/XMonad/Layout/AutoMaster.hs b/XMonad/Layout/AutoMaster.hs --- a/XMonad/Layout/AutoMaster.hs +++ b/XMonad/Layout/AutoMaster.hs @@ -35,7 +35,7 @@ -- in one row, in slave area underlying layout is run. Size of slave area -- automatically increases when number of slave windows is increasing. -- --- You can use this module by adding folowing in your @xmonad.hs@: +-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.AutoMaster -- diff --git a/XMonad/Layout/CenteredMaster.hs b/XMonad/Layout/CenteredMaster.hs --- a/XMonad/Layout/CenteredMaster.hs +++ b/XMonad/Layout/CenteredMaster.hs @@ -38,7 +38,7 @@ -- All other windows in background are managed by base layout. -- topRightMaster is like centerMaster, but places master window in top right corner instead of center. -- --- Yo can use this module by adding folowing in your @xmonad.hs@: +-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.CenteredMaster -- diff --git a/XMonad/Layout/Column.hs b/XMonad/Layout/Column.hs --- a/XMonad/Layout/Column.hs +++ b/XMonad/Layout/Column.hs @@ -11,7 +11,7 @@ -- Portability : unportable -- -- Provides Column layout that places all windows in one column. Windows --- heights are calculated from equation: H1/H2 = H2/H3 = ... = q, where q is +-- heights are calculated from the equation: H1/H2 = H2/H3 = ... = q, where q is -- given. With Shrink/Expand messages you can change the q value. -- ----------------------------------------------------------------------------- @@ -25,12 +25,12 @@ import qualified XMonad.StackSet as W -- $usage --- This module defines layot named Column. It places all windows in one --- column. Windows heights are calculated from equation: H1/H2 = H2/H3 = ... = +-- This module defines layout named Column. It places all windows in one +-- column. Windows heights are calculated from the equation: H1/H2 = H2/H3 = ... = -- q, where `q' is given (thus, windows heights are members of geometric -- progression). With Shrink/Expand messages one can change the `q' value. -- --- You can use this module by adding folowing in your @xmonad.hs@: +-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.Column -- diff --git a/XMonad/Layout/Columns.hs b/XMonad/Layout/Columns.hs new file mode 100644 --- /dev/null +++ b/XMonad/Layout/Columns.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module: XMonad.Layout.Columns +-- Description: A layout which tiles the windows in columns. +-- Copyright: Jean-Charles Quillet +-- License: BSD-style (see LICENSE) +-- +-- Maintainer: none +-- Stability: unstable +-- Portability: unportable +-- +-- A layout which tiles the windows in columns. The windows can be moved and +-- resized in every directions. +-- +-- The first window appears in a single column in the center of the screen. Its +-- width is configurable (See 'coOneWindowWidth'). +-- +-- The second window appears in a second column. Starting with two columns, they +-- fill up the screen. +-- +-- Subsequent windows appear on the bottom of the last columns. +module XMonad.Layout.Columns + ( -- * Usage + -- $usage + ColumnsLayout (..), + + -- * Messages + Focus (..), + Move (..), + Resize (..), + + -- * Tools + focusDown, + focusUp, + ) +where + +import Control.Applicative ((<|>)) +import Control.Arrow (Arrow (first), second) +import Control.Monad (guard) +import Control.Monad.State (modify) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Foldable (Foldable (..)) +import Data.List (scanl') +import Data.Maybe (listToMaybe) +import Data.Ratio ((%)) +import XMonad + ( LayoutClass (..), + Message, + Rectangle (..), + SomeMessage, + Window, + WindowSet, + X, + XState (..), + fromMessage, + gets, + scaleRationalRect, + sendMessage, + ) +import qualified XMonad.Operations as O +import XMonad.StackSet + ( RationalRect (..), + Screen (..), + Stack (..), + StackSet (..), + integrate, + peek, + ) +import qualified XMonad.StackSet as StackSet + +-- $usage +-- Add 'Columns' to your @layoutHook@ with an initial empty state: +-- +-- > myLayout = Full ||| Columns 1 [] +-- +-- Here is an example of keybindings: +-- +-- > -- Focus up/down +-- > ((modm, xK_Tab), focusDown), +-- > ((modm .|. shiftMask, xK_Tab), focusUp), +-- > -- Move windows around +-- > ((modm .|. shiftMask, xK_l), sendMessage MoveRight), +-- > ((modm .|. shiftMask, xK_h), sendMessage MoveLeft), +-- > ((modm .|. shiftMask, xK_k), sendMessage MoveUp), +-- > ((modm .|. shiftMask, xK_j), sendMessage MoveDown), +-- > -- Resize them +-- > ((modm .|. controlMask, xK_l), sendMessage HorizontalExpand), +-- > ((modm .|. controlMask, xK_h), sendMessage HorizontalShrink), +-- > ((modm .|. controlMask, xK_k), sendMessage VerticalExpand), +-- > ((modm .|. controlMask, xK_j), sendMessage VerticalShrink), +-- +-- This layout is known to work with: +-- +-- * "XMonad.Layout.WindowNavigation" for changing focus with a direction using +-- 'XMonad.Layout.WindowNavigation.Go' messages. +-- * 'XMonad.Layout.SubLayouts.subTabbed' for docking windows together with +-- tabs. Note that sometimes when undocking windows, the layout is reset. This is +-- a minor annoyance caused by the difficulty to track windows in the sublayout. + +-- | The windows can be moved in every directions. +-- +-- Horizontally, a window alone in its column cannot be moved before the first +-- or after the last column. If not alone, moving the window outside those +-- limits will create a new column. +-- The windows can also be moved vertically in their column. +data Move = MoveLeft | MoveRight | MoveUp | MoveDown deriving (Show, Read) + +instance Message Move + +-- | The windows can be resized in every directions. +-- +-- When resizing horizontally: +-- +-- * if the window to be resized is not in the last column +-- +-- * then the right side of the window will be moved +-- * the last column will compensate the size change +-- +-- * if the window is in the last column +-- +-- * then the left side of the window will be moved +-- * the column on the left of the current one will compensate the size change +-- +-- The same applies when resizing vertically using the bottom side of the +-- window unless it is the last window in the column in which case we use the +-- top side. +data Resize + = VerticalShrink + | VerticalExpand + | HorizontalShrink + | HorizontalExpand + deriving (Show, Read) + +instance Message Resize + +-- | The layout handles focus change messages. +-- +-- Built-in focus cannot be used here because @XMonad@ does not make it easy to +-- change the order of windows in the focus list. See also 'focusUp' and +-- 'focusDown' functions. +data Focus = FocusUp | FocusDown + deriving (Show, Read) + +instance Message Focus + +-- | A column is a list of windows with their relative vertical dimensions. +type Column = [(Rational, Window)] + +-- | The layout is a list of 'Column' with their relative horizontal dimensions. +type Columns = [(Rational, Column)] + +data ColumnsLayout a = Columns + { -- | With of the first column when there is only one window. Usefull on wide + -- screens. + coOneWindowWidth :: Rational, + -- | The current state + coColumns :: Columns + } + deriving (Show, Read) + +instance LayoutClass ColumnsLayout Window where + description _ = layoutDescription + + doLayout (Columns oneWindowWidth columns) rectangle stack = + pure (rectangles, Just (Columns oneWindowWidth columns')) + where + hackedColumns = hackForTabs columns stack + columns' = updateWindowList hackedColumns stack + rectangles = toRectangles rectangle' columns' + -- If there is only one window, we set the destination rectangle according + -- to the width in the layout setting. + rectangle' + | (length . toList $ stack) == 1 = + scaleRationalRect rectangle singleColumnRR + | otherwise = rectangle + singleColumnOffset = (1 - oneWindowWidth) / 2 + singleColumnRR = RationalRect singleColumnOffset 0 oneWindowWidth 1 + + handleMessage layout@(Columns oneWindowWidth columns) message = do + mbStack <- runMaybeT $ handleFocus' =<< getStack + changedFocus <- traverse updateStack' mbStack + + movedOrResized <- + runMaybeT $ + Columns oneWindowWidth + <$> (handleMoveOrResize' =<< peekFocus) + + pure $ movedOrResized <|> changedFocus + where + getStack = MaybeT . gets $ StackSet.stack . workspace . current . windowset + handleFocus' = hoistMaybe . handleFocus columns message + -- A 'Just' needs to be return for the new stack to be taken into account + updateStack' s = modify (setStack s) >> pure layout + peekFocus = MaybeT . gets $ peek . windowset + handleMoveOrResize' = hoistMaybe . handleMoveOrResize columns message + hoistMaybe = MaybeT . pure + +layoutDescription :: String +layoutDescription = "Columns" + +-- | Change the keyboard focus to the previous window +focusUp :: X () +focusUp = + sendMsgOrOnWindowsSet FocusUp StackSet.focusUp + =<< getCurrentLayoutDescription + +-- | Change the keyboard focus to the next window +focusDown :: X () +focusDown = + sendMsgOrOnWindowsSet FocusDown StackSet.focusDown + =<< getCurrentLayoutDescription + +sendMsgOrOnWindowsSet :: (Message a) => a -> (WindowSet -> WindowSet) -> String -> X () +sendMsgOrOnWindowsSet message f description' + | description' == layoutDescription = sendMessage message + | otherwise = O.windows f + +getCurrentLayoutDescription :: X String +getCurrentLayoutDescription = + gets + ( description + . StackSet.layout + . workspace + . current + . windowset + ) + +setStack :: Stack Window -> XState -> XState +setStack stack state = + state + { windowset = + (windowset state) + { current = + (current $ windowset state) + { workspace = + (workspace . current $ windowset state) + { StackSet.stack = Just stack + } + } + } + } + +handleFocus :: Columns -> SomeMessage -> Stack Window -> Maybe (Stack Window) +handleFocus columns message stack + | Just FocusDown <- fromMessage message = setFocus' stack <$> mbNext + | Just FocusUp <- fromMessage message = setFocus' stack <$> mbPrevious + | otherwise = Nothing + where + focused = focus stack + windows = columnsToWindows columns + exists = focused `elem` windows + mbNext = guard exists >> next focused windows + mbPrevious = guard exists >> previous focused windows + setFocus' = flip setFocus + previous a = next a . reverse + setFocus w = until ((==) w . focus) StackSet.focusDown' + next _ [] = Nothing + next a (x : xs) + | a == x = listToMaybe xs + | otherwise = next a (xs <> [x]) + +oldNewWindows :: Columns -> Stack Window -> ([Window], [Window]) +oldNewWindows columns stack = (old, new) + where + old = filter (`notElem` stackList) windows + new = filter (`notElem` windows) stackList + stackList = toList stack + windows = columnsToWindows columns + +-- | Add the new windows to the layout and remove the old ones. +updateWindowList :: Columns -> Stack Window -> Columns +updateWindowList columns stack = addWindows newWindows (removeWindows oldWindows columns) + where + (oldWindows, newWindows) = oldNewWindows columns stack + +-- | If one window disappeared and another appeared, we assume that the sublayout +-- tabs just changed focused. +hackForTabs :: Columns -> Stack Window -> Columns +hackForTabs columns stack = mapWindow replace columns + where + replace window + | (w1 : _, [w2]) <- oldNewWindows columns stack = + if window == w1 + then w2 + else window + | otherwise = window + +toRectangles :: Rectangle -> [(Rational, [(Rational, a)])] -> [(a, Rectangle)] +toRectangles rectangle columns = + second (scaleRationalRect rectangle) <$> windowsAndRectangles + where + offsetsAndRatios = toOffsetRatio (second toOffsetRatio <$> columns) + windowsAndRectangles = foldMap toWindowAndRectangle offsetsAndRatios + toWindowAndRectangle (x, w, cs) = (\(y, h, ws) -> (ws, RationalRect x y w h)) <$> cs + +onFocused :: (a -> a) -> Stack a -> Stack a +onFocused f (Stack a before after) = Stack (f a) before after + +onFocusedM :: (Monad m) => (a -> m a) -> Stack a -> m (Stack a) +onFocusedM f (Stack a before after) = Stack <$> f a <*> pure before <*> pure after + +onFocusedOrPrevious :: (a -> a) -> Stack a -> Stack a +onFocusedOrPrevious f (Stack a (a' : others) []) = Stack a (f a' : others) [] +onFocusedOrPrevious f stack = onFocused f stack + +handleMoveOrResize :: Columns -> SomeMessage -> Window -> Maybe Columns +handleMoveOrResize columns message window + | Just msg <- fromMessage message = move msg window columns + | Just HorizontalShrink <- fromMessage message = + onFocusedOrPrevious' shrink <$> findInColumns window columns + | Just HorizontalExpand <- fromMessage message = + onFocusedOrPrevious' expand <$> findInColumns window columns + | Just VerticalExpand <- fromMessage message = + onFocusedM' + (fmap (onFocusedOrPrevious' shrink) . findInColumn window) + =<< findInColumns window columns + | Just VerticalShrink <- fromMessage message = + onFocusedM' + (fmap (onFocusedOrPrevious' expand) . findInColumn window) + =<< findInColumns window columns + | otherwise = Nothing + where + expand = first $ flip (+) (3 / 100) + shrink = first $ flip (-) (3 / 100) + onFocusedM' f = fmap integrate . onFocusedM (sequence . second f) + onFocusedOrPrevious' f = sanitize . integrate . onFocusedOrPrevious f + +move :: Move -> Window -> Columns -> Maybe Columns +move direction window columns = + case (direction, findInColumns window columns) of + (MoveRight, Just (Stack (_, [(_, _)]) _ [])) -> Nothing + (MoveLeft, Just (Stack (_, [(_, _)]) [] _)) -> Nothing + (MoveRight, Just (Stack column@(_, [(_, _)]) before (next : others))) -> + let (column', next') = swapWindowBetween window column next + in Just . integrate $ Stack column' before (next' : others) + (MoveLeft, Just (Stack column@(_, [(_, _)]) (previous : others) after)) -> + let (column', previous') = swapWindowBetween window column previous + in Just . integrate $ Stack column' (previous' : others) after + (MoveRight, Just stack) -> + let (newColumns', Stack column before after) = rationalize newColumns stack + windows = removeWindow window column + in Just . integrate $ Stack windows before (newColumns' <> after) + (MoveLeft, Just stack) -> + let (newColumns', Stack column before after) = rationalize newColumns stack + windows = removeWindow window column + in Just . integrate $ Stack windows (newColumns' <> before) after + (MoveUp, Just stack) -> integrate <$> onFocusedM (swapWindowUp window) stack + (MoveDown, Just stack) -> integrate <$> onFocusedM (swapWindowDown window) stack + _ -> Nothing + where + newColumns = [[(1, window)]] + +mapWindow :: (Window -> Window) -> Columns -> Columns +mapWindow = fmap . fmap . fmap . fmap + +columnsToWindows :: Columns -> [Window] +columnsToWindows = foldMap ((: []) . snd) . foldMap snd + +swapWindowBetween :: + Window -> + (Rational, Column) -> + (Rational, Column) -> + ((Rational, Column), (Rational, Column)) +swapWindowBetween window from to = (removed, added) + where + removed = removeWindow window from + added = appendWindows [window] to + +swapWindowUp :: Window -> (Rational, Column) -> Maybe (Rational, Column) +swapWindowUp window (width, column) + | Just (Stack (height, _) (previous : before') after) <- findInColumn window column = + Just (width, integrate $ Stack previous ((height, window) : before') after) + | otherwise = Nothing + +swapWindowDown :: Window -> (Rational, Column) -> Maybe (Rational, Column) +swapWindowDown window (width, column) + | Just (Stack (height, _) before (next : others)) <- findInColumn window column = + Just (width, integrate $ Stack next before ((height, window) : others)) + | otherwise = Nothing + +-- | Adjust the ratio of a list or a stack of elts so that when adding new +-- elements: +-- - the new elements are distributed according to the total number of elements +-- - the existing elements keep their proportion in the remaining space +rationalize :: + (Functor f, Foldable f) => + [a] -> + f (Rational, a) -> + ([(Rational, a)], f (Rational, a)) +rationalize new existing = (new', existing') + where + nbNew = fromIntegral $ length new + nbInColumn = fromIntegral $ length existing + newRatio = nbNew % (nbNew + nbInColumn) + existingRatio = 1 - newRatio + new' = fitElements newRatio new + existing' = first (* existingRatio) <$> existing + +append :: [a] -> [(Rational, a)] -> [(Rational, a)] +append new existing = uncurry (flip mappend) (rationalize new existing) + +appendWindows :: + [Window] -> + (Rational, [(Rational, Window)]) -> + (Rational, [(Rational, Window)]) +appendWindows windows = second (append windows) + +fitElements :: Rational -> [a] -> [(Rational, a)] +fitElements dimension elts = (dimension',) <$> elts + where + dimension' = dimension / fromIntegral (length elts) + +singleColumn :: Rational -> Rational -> [Window] -> Columns +singleColumn width height windows = [(width, fitElements height windows)] + +findElement' :: (a -> Bool) -> [(Rational, a)] -> Maybe (Stack (Rational, a)) +findElement' predicate list + | (before, c : after) <- break (predicate . snd) list = + Just $ Stack c (reverse before) after + | otherwise = Nothing + +findInColumns :: Window -> Columns -> Maybe (Stack (Rational, Column)) +findInColumns window = findElement' (any ((== window) . snd)) + +findInColumn :: Window -> Column -> Maybe (Stack (Rational, Window)) +findInColumn window = findElement' (== window) + +removeWindows :: [Window] -> Columns -> Columns +removeWindows windows = removeEmptyColumns . fmap (second removeWindows') + where + inWindows (_, window) = window `notElem` windows + removeWindows' = normalize . filter inWindows + removeEmptyColumns = normalize . filter (not . null . snd) + +removeWindow :: Window -> (Rational, Column) -> (Rational, Column) +removeWindow window = second (normalize . filter ((/= window) . snd)) + +addWindows :: [Window] -> Columns -> Columns +addWindows [] columns = columns +-- When there is only one column, create a new one on the right +addWindows windows [(_, windows')] = (1 % 2, windows') : singleColumn (1 % 2) 1 windows +-- When there is more, append the windows to the last column +addWindows windows columns + | Just (columns', column) <- unsnoc columns = + sanitizeColumns $ columns' <> [appendWindows windows column] + | otherwise = singleColumn 1 1 windows + +-- | Make sure the sum of all dimensions is 1 +normalize :: [(Rational, a)] -> [(Rational, a)] +normalize elts = fmap (first (/ total)) elts + where + total = sum (fst <$> elts) + +-- | Update the last dimension so that the sum of all dimensions is 1 +sanitize :: [(Rational, a)] -> [(Rational, a)] +sanitize list + | Just (elts, (_, a)) <- unsnoc list = elts <> [(1 - sum (fst <$> elts), a)] + | otherwise = [] + +-- | Same on the whole layout +sanitizeColumns :: Columns -> Columns +sanitizeColumns = sanitize . fmap (second sanitize) + +toOffsetRatio :: [(Rational, a)] -> [(Rational, Rational, a)] +toOffsetRatio ra = zipWith toTruple ra positions + where + toTruple (dimension, a) position = (position, dimension, a) + positions = scanl' (\position (dimension, _) -> position + dimension) 0 ra + +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x : xs) + | Just (is, l) <- unsnoc xs = Just (x : is, l) + | otherwise = Just ([], x) diff --git a/XMonad/Layout/Hidden.hs b/XMonad/Layout/Hidden.hs --- a/XMonad/Layout/Hidden.hs +++ b/XMonad/Layout/Hidden.hs @@ -118,7 +118,7 @@ -------------------------------------------------------------------------------- hideWindowMsg :: HiddenWindows a -> Window -> X (Maybe (HiddenWindows a)) hideWindowMsg (HiddenWindows hidden) win = do - modify (\s -> s { windowset = W.delete' win $ windowset s }) + modifyWindowSet $ W.delete' win return . Just . HiddenWindows $ hidden ++ [win] -------------------------------------------------------------------------------- diff --git a/XMonad/Layout/IfMax.hs b/XMonad/Layout/IfMax.hs --- a/XMonad/Layout/IfMax.hs +++ b/XMonad/Layout/IfMax.hs @@ -36,7 +36,7 @@ -- IfMax layout will run one layout if number of windows on workspace is as -- maximum N, and else will run another layout. -- --- You can use this module by adding folowing in your @xmonad.hs@: +-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.IfMax -- diff --git a/XMonad/Layout/TabBarDecoration.hs b/XMonad/Layout/TabBarDecoration.hs --- a/XMonad/Layout/TabBarDecoration.hs +++ b/XMonad/Layout/TabBarDecoration.hs @@ -46,8 +46,8 @@ -- 'tabBar' will give you the possibility of setting a custom shrinker -- and a custom theme. -- --- The deafult theme can be dynamically change with the xmonad theme --- selector. See "XMonad.Prompt.Theme". For more themse, look at +-- The default theme can be dynamically changed with the xmonad theme +-- selector. See "XMonad.Prompt.Theme". For more themes, look at -- "XMonad.Util.Themes" -- | Add, on the top of the screen, a simple bar of tabs to a given diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs --- a/XMonad/Prompt.hs +++ b/XMonad/Prompt.hs @@ -562,7 +562,7 @@ s <- gets $ screenRect . W.screenDetail . W.current . windowset cleanMask <- cleanKeyMask cachedir <- asks (cacheDir . directories) - hist <- io $ readHistory cachedir + hist <- io $ readHistory conf cachedir fs <- initXMF (font conf) let width = getWinWidth s (position conf) st' <- io $ @@ -582,7 +582,7 @@ releaseXMF fs when (successful st') $ do let prune = take (historySize conf) - io $ writeHistory cachedir $ + io $ writeHistory conf cachedir $ M.insertWith (\xs ys -> prune . historyFilter conf $ xs ++ ys) historyKey @@ -1690,16 +1690,18 @@ getHistoryFile :: FilePath -> FilePath getHistoryFile cachedir = cachedir ++ "/prompt-history" -readHistory :: FilePath -> IO History -readHistory cachedir = readHist `E.catch` \(SomeException _) -> return emptyHistory +readHistory :: XPConfig -> FilePath -> IO History +readHistory (XPC { historySize = 0 }) _ = return emptyHistory +readHistory _ cachedir = readHist `E.catch` \(SomeException _) -> return emptyHistory where readHist = do let path = getHistoryFile cachedir xs <- withFile path ReadMode hGetLine readIO xs -writeHistory :: FilePath -> History -> IO () -writeHistory cachedir hist = do +writeHistory :: XPConfig -> FilePath -> History -> IO () +writeHistory (XPC { historySize = 0 }) _ _ = return () +writeHistory _ cachedir hist = do let path = getHistoryFile cachedir filtered = M.filter (not . null) hist writeFile path (show filtered) `E.catch` \(SomeException e) -> @@ -1793,17 +1795,17 @@ -- | 'historyCompletion' provides a canned completion function much like -- 'getShellCompl'; you pass it to mkXPrompt, and it will make completions work -- from the query history stored in the XMonad cache directory. -historyCompletion :: X ComplFunction -historyCompletion = historyCompletionP (const True) +historyCompletion :: XPConfig -> X ComplFunction +historyCompletion conf = historyCompletionP conf (const True) -- | Like 'historyCompletion' but only uses history data from Prompts whose -- name satisfies the given predicate. -historyCompletionP :: (String -> Bool) -> X ComplFunction -historyCompletionP p = do +historyCompletionP :: XPConfig -> (String -> Bool) -> X ComplFunction +historyCompletionP conf p = do cd <- asks (cacheDir . directories) pure $ \x -> let toComplList = deleteConsecutive . filter (isInfixOf x) . M.foldr (++) [] - in toComplList . M.filterWithKey (const . p) <$> readHistory cd + in toComplList . M.filterWithKey (const . p) <$> readHistory conf cd -- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off -- laziness and stability for efficiency. diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -53,6 +53,7 @@ Date (..), Time (..), TimeOfDay (..), + OrgTime (..), DayOfWeek (..), #endif @@ -122,7 +123,9 @@ it for the /next/ Monday (the one in seven days). The time is specified in the @HH:MM@ or @HHMM@ format. The minutes may -be omitted, in which case we assume a full hour is specified. +be omitted, in which case we assume a full hour is specified. It is also +possible to enter a time span using the syntax @HH:MM-HH:MM@ or @HH:MM+HH@. +In the former case, minutes may be omitted. A few examples are probably in order. Suppose we have bound the key above, pressed it, and are now confronted with a prompt: @@ -137,6 +140,10 @@ - @hello +d today 12:30@ works just like above, but creates a deadline. + - @hello +d today 12:30-14:30@ works like the above, but gives the + event a duration of two hours. An alternative way to specify + this would be @hello +d today 12:30+2@. + - @hello +s thu@ would schedule the note for next thursday. - @hello +s 11@ would schedule it for the 11th of this month and this @@ -356,21 +363,30 @@ -- @HH:MM@ time. data Time = Time { date :: Date - , tod :: Maybe TimeOfDay + , tod :: Maybe OrgTime } deriving (Eq, Show) -- | The time in HH:MM. -data TimeOfDay = TimeOfDay Int Int +data TimeOfDay = HHMM Int Int deriving (Eq) instance Show TimeOfDay where show :: TimeOfDay -> String - show (TimeOfDay h m) = pad h <> ":" <> pad m + show (HHMM h m) = pad h <> ":" <> pad m where pad :: Int -> String pad n = (if n <= 9 then "0" else "") <> show n +-- | The time—possibly as a span—in HH:MM format. +data OrgTime = MomentInTime TimeOfDay | TimeSpan TimeOfDay TimeOfDay + deriving (Eq) + +instance Show OrgTime where + show :: OrgTime -> String + show (MomentInTime tod) = show tod + show (TimeSpan tod tod') = show tod <> "-" <> show tod' + -- | Type for specifying exactly which day one wants. data Date = Today @@ -383,7 +399,7 @@ -- ^ Manual date entry in the format DD [MM] [YYYY] deriving (Eq, Ord, Show) -toOrgFmt :: Maybe TimeOfDay -> Day -> String +toOrgFmt :: Maybe OrgTime -> Day -> String toOrgFmt tod day = mconcat ["<", isoDay, " ", take 3 $ show (dayOfWeek day), time, ">"] where @@ -498,8 +514,8 @@ -- | Parse the given string into a 'Note'. pInput :: String -> Maybe Note pInput inp = (`runParser` inp) . choice $ - [ Scheduled <$> getLast "+s" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority - , Deadline <$> getLast "+d" <*> (Time <$> pDate <*> pTimeOfDay) <*> pPriority + [ Scheduled <$> (getLast "+s" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority + , Deadline <$> (getLast "+d" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority , do s <- munch1 (pure True) let (s', p) = splitAt (length s - 3) s pure $ case tryPrio p of @@ -507,6 +523,12 @@ Nothing -> NormalMsg s NoPriority ] where + fixTime :: Maybe Date -> Maybe OrgTime -> Parser Time + fixTime d tod = case (d, tod) of + (Nothing, Nothing) -> mempty -- no day and no time + (Nothing, Just{}) -> pure (Time Today tod) -- no day, but a time + (Just d', _) -> pure (Time d' tod) -- day given + tryPrio :: String -> Maybe Priority tryPrio [' ', '#', x] | x `elem` ("Aa" :: String) = Just A @@ -533,21 +555,33 @@ -- | Parse a 'Priority'. pPriority :: Parser Priority pPriority = option NoPriority $ - " " *> skipSpaces *> choice + skipSpaces *> choice [ "#" *> foldCase "a" $> A , "#" *> foldCase "b" $> B , "#" *> foldCase "c" $> C ] -- | Try to parse a 'Time'. -pTimeOfDay :: Parser (Maybe TimeOfDay) -pTimeOfDay = option Nothing $ - skipSpaces >> Just <$> choice - [ TimeOfDay <$> pHour <* ":" <*> pMinute -- HH:MM - , pHHMM -- HHMM - , TimeOfDay <$> pHour <*> pure 0 -- HH - ] +pOrgTime :: Parser (Maybe OrgTime) +pOrgTime = option Nothing $ + between skipSpaces (void " " <|> eof) $ + Just <$> choice + [ TimeSpan <$> (pTimeOfDay <* ("--" <|> "-" <|> "–")) <*> pTimeOfDay + -- Org is not super smart around times with this syntax, so + -- we pretend not to be as well. + , do from@(HHMM h m) <- pTimeOfDay <* "+" + off <- pHour + pure $ TimeSpan from (HHMM (h + off) m) + , MomentInTime <$> pTimeOfDay + ] where + pTimeOfDay :: Parser TimeOfDay + pTimeOfDay = choice + [ HHMM <$> pHour <* ":" <*> pMinute -- HH:MM + , pHHMM -- HHMM + , HHMM <$> pHour <*> pure 0 -- HH + ] + pHHMM :: Parser TimeOfDay pHHMM = do let getTwo = count 2 (satisfy isDigit) @@ -555,18 +589,19 @@ guard (hh >= 0 && hh <= 23) mm <- read <$> getTwo guard (mm >= 0 && mm <= 59) - pure $ TimeOfDay hh mm + pure $ HHMM hh mm + pHour :: Parser Int = pNumBetween 0 23 pMinute :: Parser Int = pNumBetween 0 59 --- | Parse a 'Date'. -pDate :: Parser Date -pDate = skipSpaces *> choice +-- | Try to parse a 'Date'. +pDate :: Parser (Maybe Date) +pDate = skipSpaces *> optional (choice [ pPrefix "tod" "ay" Today , pPrefix "tom" "orrow" Tomorrow , Next <$> pNext , Date <$> pDate' - ] + ]) where pNext :: Parser DayOfWeek = choice [ pPrefix "m" "onday" Monday , pPrefix "tu" "esday" Tuesday @@ -585,7 +620,7 @@ pDate' :: Parser (Int, Maybe Int, Maybe Integer) pDate' = - (,,) <$> pNumBetween 1 31 -- day + (,,) <$> (pNumBetween 1 31 <* (void " " <|> eof)) -- day <*> optional (skipSpaces *> choice [ pPrefix "ja" "nuary" 1 , pPrefix "f" "ebruary" 2 , pPrefix "mar" "ch" 3 , pPrefix "ap" "ril" 4 diff --git a/XMonad/Util/EZConfig.hs b/XMonad/Util/EZConfig.hs --- a/XMonad/Util/EZConfig.hs +++ b/XMonad/Util/EZConfig.hs @@ -552,8 +552,8 @@ doKeymapCheck conf km = (bad,dups) where ks = map ((readKeySequence conf &&& id) . fst) km bad = nub . map snd . filter (isNothing . fst) $ ks - dups = map (snd . NE.head) - . mapMaybe nonEmpty + dups = map (snd . NE.head . notEmpty) + . filter ((>1) . length) . groupBy ((==) `on` fst) . sortBy (comparing fst) . map (first fromJust) diff --git a/XMonad/Util/Grab.hs b/XMonad/Util/Grab.hs --- a/XMonad/Util/Grab.hs +++ b/XMonad/Util/Grab.hs @@ -29,15 +29,12 @@ ) where -- core -import XMonad hiding (mkGrabs) +import XMonad import Control.Monad ( when ) -import Data.Bits ( setBit ) import Data.Foldable ( traverse_ ) -- base -import qualified Data.Map.Strict as M import Data.Semigroup ( All(..) ) -import Data.Traversable ( for ) -- }}} @@ -70,9 +67,8 @@ -> [(KeyMask, KeySym)] -- ^ Keys to ungrab -> X () grabUngrab gr ugr = do - f <- mkGrabs - traverse_ (uncurry ungrabKP) (f ugr) - traverse_ (uncurry grabKP) (f gr) + traverse_ (uncurry ungrabKP) =<< mkGrabs ugr + traverse_ (uncurry grabKP) =<< mkGrabs gr -- | A convenience function to grab keys. This also ungrabs all -- previously grabbed keys. @@ -88,49 +84,9 @@ e@MappingNotifyEvent{} -> do io (refreshKeyboardMapping e) when (ev_request e `elem` [mappingKeyboard, mappingModifier]) - $ setNumlockMask + $ cacheNumlockMask >> regr pure (All False) _ -> pure (All True) -- }}} - --- --< Private Utils >-- {{{ - --- | Private action shamelessly copied and restyled from XMonad.Main source. -setNumlockMask :: X () -setNumlockMask = withDisplay $ \dpy -> do - ms <- io (getModifierMapping dpy) - xs <- sequence - [ do - ks <- io (keycodeToKeysym dpy kc 0) - pure $ if ks == xK_Num_Lock - then setBit 0 (fromIntegral m) - else 0 :: KeyMask - | (m, kcs) <- ms - , kc <- kcs - , kc /= 0 - ] - modify $ \s -> s { numberlockMask = foldr (.|.) 0 xs } - --- | Private function shamelessly copied and refactored from XMonad.Main source. -mkGrabs :: X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]) -mkGrabs = withDisplay $ \dpy -> do - let (minCode, maxCode) = displayKeycodes dpy - allCodes = [fromIntegral minCode .. fromIntegral maxCode] - syms <- io . for allCodes $ \code -> keycodeToKeysym dpy code 0 - let keysymMap = M.fromListWith (++) (zip syms $ pure <$> allCodes) - keysymToKeycodes sym = M.findWithDefault [] sym keysymMap - extraMods <- extraModifiers - pure $ \ks -> do - (mask, sym) <- ks - keycode <- keysymToKeycodes sym - extraMod <- extraMods - pure (mask .|. extraMod, keycode) - --- }}} - - --- NOTE: there is some duplication between this module and core. The --- latter probably will never change, but this needs to be kept in sync --- with any potential bugs that might arise. diff --git a/XMonad/Util/Hacks.hs b/XMonad/Util/Hacks.hs --- a/XMonad/Util/Hacks.hs +++ b/XMonad/Util/Hacks.hs @@ -40,10 +40,14 @@ trayerPaddingXmobarEventHook, trayPaddingXmobarEventHook, trayPaddingEventHook, + + -- * Steam flickering fix + fixSteamFlicker, ) where import XMonad +import XMonad.Hooks.FloatConfigureReq (fixSteamFlicker) import XMonad.Hooks.StatusBar (xmonadPropLog') import XMonad.Prelude (All (All), fi, filterM, when) import System.Posix.Env (putEnv) diff --git a/XMonad/Util/Rectangle.hs b/XMonad/Util/Rectangle.hs --- a/XMonad/Util/Rectangle.hs +++ b/XMonad/Util/Rectangle.hs @@ -67,7 +67,7 @@ -- @[N,N+1]@, as though each real-valued coordinate had been rounded (either -- down or up) to the nearest integers. So each pixel, from zero, is listed as: -- @[0,0]@, @[1,1]@, @[2,2]@, and so on. Rather than a coordinate system, this --- considers pixels as row/colum indices. While easiest to reason with, +-- considers pixels as row/column indices. While easiest to reason with, -- indices are unable to represent zero-dimension rectangles. -- -- Consider pixels as indices. Do not use this on empty rectangles. diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -14,6 +14,7 @@ import qualified OrgMode import qualified GridSelect import qualified EZConfig +import qualified WindowNavigation main :: IO () main = hspec $ do @@ -53,3 +54,4 @@ context "OrgMode" OrgMode.spec context "GridSelect" GridSelect.spec context "EZConfig" EZConfig.spec + context "WindowNavigation" WindowNavigation.spec diff --git a/tests/OrgMode.hs b/tests/OrgMode.hs --- a/tests/OrgMode.hs +++ b/tests/OrgMode.hs @@ -45,7 +45,7 @@ `shouldBe` Just ( Deadline "todo" - (Time {date = Date (1, Nothing, Nothing), tod = Just $ TimeOfDay 1 1}) + (Time {date = Date (1, Nothing, Nothing), tod = Just $ MomentInTime(HHMM 1 1)}) NoPriority ) it "works with todo +d 22 jan 2021 01:01 #b" $ do @@ -53,9 +53,23 @@ `shouldBe` Just ( Deadline "todo" - (Time {date = Date (22, Just 1, Just 2021), tod = Just $ TimeOfDay 1 1}) + (Time {date = Date (22, Just 1, Just 2021), tod = Just $ MomentInTime(HHMM 1 1)}) B ) + it "parses no day as today when given a time" $ do + pInput "todo +s 12:00" + `shouldBe` Just (Scheduled "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 12 0)}) NoPriority) + pInput "todo +d 14:05 #B" + `shouldBe` Just (Deadline "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 14 5)}) B) + it "parses `blah+d`, `blah +d`, `blah +d `, and `blah +d #B` as normal messages" $ do + pInput "blah+d" + `shouldBe` Just (NormalMsg "blah+d" NoPriority) + pInput "blah +d" + `shouldBe` Just (NormalMsg "blah +d" NoPriority) + pInput "blah +d " + `shouldBe` Just (NormalMsg "blah +d " NoPriority) + pInput "blah +d #B" + `shouldBe` Just (NormalMsg "blah +d" B) context "no priority#b" $ do it "parses to the correct thing" $ @@ -100,10 +114,10 @@ prio -> " #" <> show prio ppTime :: Time -> String -ppTime (Time d t) = ppDate d <> ppTOD t +ppTime (Time d t) = ppDate d <> ppOrgTime t where - ppTOD :: Maybe TimeOfDay -> String - ppTOD = maybe "" ((' ' :) . show) + ppOrgTime :: Maybe OrgTime -> String + ppOrgTime = maybe "" ((' ' :) . show) ppDate :: Date -> String ppDate dte = case days !? dte of @@ -179,7 +193,7 @@ [ pure Today , pure Tomorrow , Next . toEnum <$> choose (0, 6) - , do d <- posInt + , do d <- posInt `suchThat` (<= 31) m <- mbPos `suchThat` (<= Just 12) Date . (d, m, ) <$> if isNothing m then pure Nothing @@ -188,7 +202,14 @@ instance Arbitrary TimeOfDay where arbitrary :: Gen TimeOfDay - arbitrary = TimeOfDay <$> hourInt <*> minuteInt + arbitrary = HHMM <$> hourInt <*> minuteInt + +instance Arbitrary OrgTime where + arbitrary :: Gen OrgTime + arbitrary = oneof + [ MomentInTime <$> arbitrary + , TimeSpan <$> arbitrary <*> arbitrary + ] ------------------------------------------------------------------------ -- Util diff --git a/tests/WindowNavigation.hs b/tests/WindowNavigation.hs new file mode 100644 --- /dev/null +++ b/tests/WindowNavigation.hs @@ -0,0 +1,635 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module WindowNavigation where + +import Test.Hspec + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Functor.Identity + +import XMonad +import XMonad.Util.Types (Direction2D(..)) +import XMonad.Actions.WindowNavigation (goPure, swapPure, WNState) +import qualified XMonad.StackSet as W + +spec :: Spec +spec = do + it "two-window adjacent go right (empty state)" $ do + -- Simplest case - just move the focus once. + -- ┌─────┬──────┐ + -- │ 1 ──┼─► 2 │ + -- └─────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect) + runNav R M.empty (mkws 1 [] [2]) + `shouldBe` (mkstate 960 640, mkws 2 [1] []) + + it "two-window adjacent go right (populated state)" $ do + -- Like the previous test, but this time internal stat is already populated with a position. + -- ┌─────┬──────┐ + -- │ 1 ──┼─► 2 │ + -- └─────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect) + runNav R (mkstate 100 100) (mkws 1 [] [2]) + `shouldBe` (mkstate 960 100, mkws 2 [1] []) + + it "two-window adjacent go right (incorrectly-populated state)" $ do + -- This time we set the position incorrectly, testing if it will be reset to the center of focused window. + -- ┌─────┬──────┐ + -- │ 1 ──┼─► 2 │ + -- └─────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect) + runNav R (mkstate 1000 100) (mkws 1 [] [2]) + `shouldBe` (mkstate 960 640, mkws 2 [1] []) + + it "swap windows" $ do + -- Swap windows around. + -- ┌─────┬──────┐ + -- │ 1 ◄─┼─► 2 │ + -- └─────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + ] + runIdentity (swapPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect)) + `shouldBe` (mkstate 960 640, mkws 1 [2] []) + + it "tall layout, go up" $ do + -- ┌─────┬─────┐ + -- │ │ 2 ▲ │ + -- │ 1 ├───┼─┤ + -- │ │ 3 │ │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 640) + , (3, Rectangle 960 640 960 640) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2, 3], windowRect) + runNav U M.empty (mkws 3 [] [1, 2]) + `shouldBe` (mkstate 1440 639, mkws 2 [1, 3] []) + + it "tall layout, go down" $ do + -- ┌─────┬─────┐ + -- │ │ 2 │ + -- │ ├─────┤ + -- │ 1 │ 3 │ │ + -- │ ├───┼─┤ + -- │ │ 4 ▼ │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + runNav D M.empty (mkws 3 [] [1, 2, 4]) + `shouldBe` (mkstate 1440 800, mkws 4 [2, 1, 3] []) + + it "tall layout, go left" $ do + -- ┌─────┬─────┐ + -- │ ◄─┼── 2 │ + -- │ ├─────┤ + -- │ 1 │ 3 │ + -- │ ├─────┤ + -- │ │ 4 │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + runNav L M.empty (mkws 2 [] [1, 3, 4]) + `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4]) + + it "tall layout, go left and then right (window 2)" $ do + -- ┌─────┬─────┐ + -- │ ◄─┼── 2 │ + -- │ ──┼─► │ + -- │ ├─────┤ + -- │ 1 │ 3 │ + -- │ ├─────┤ + -- │ │ 4 │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav L M.empty (mkws 2 [] [1, 3, 4]) + (st2, ws2) `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4]) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 200, mkws 2 [] [1, 3, 4]) + + it "tall layout, go left and then right (window 3)" $ do + -- ┌─────┬─────┐ + -- │ │ 2 │ + -- │ ├─────┤ + -- │ 1 ◄─┼── 3 │ + -- │ ──┼─► │ + -- │ ├─────┤ + -- │ │ 4 │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav L M.empty (mkws 3 [] [1, 2, 4]) + (st2, ws2) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4]) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 600, mkws 3 [] [1, 2, 4]) + + it "tall layout, go left and then right (window 4)" $ do + -- ┌─────┬─────┐ + -- │ │ 2 │ + -- │ ├─────┤ + -- │ 1 │ 3 │ + -- │ ├─────┤ + -- │ ◄─┼── 4 │ + -- │ ──┼─► │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav L M.empty (mkws 4 [] [1, 2, 3]) + (st2, ws2) `shouldBe` (mkstate 959 1040, mkws 1 [4] [2, 3]) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 1040, mkws 4 [] [1, 2, 3]) + + it "grid layout, go in a circle" $ do + -- ┌─────┬─────┐ + -- │ 1 ──┼─► 2 │ + -- │ │ │ + -- │ ▲ │ │ │ + -- ├─┼───┼───┼─┤ + -- │ │ │ ▼ │ + -- │ │ │ + -- │ 3 ◄─┼── 4 │ + -- └─────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 640) + , (2, Rectangle 960 0 960 640) + , (3, Rectangle 0 640 960 640) + , (4, Rectangle 960 640 960 640) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3, 4]) + (st2, ws2) `shouldBe` (mkstate 960 320, mkws 2 [1] [3, 4]) + let (st3, ws3) = runNav D st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [3, 2, 1] []) + let (st4, ws4) = runNav L st3 ws3 + (st4, ws4) `shouldBe` (mkstate 959 640, mkws 3 [2, 1] [4]) + let (st5, ws5) = runNav U st4 ws4 + (st5, ws5) `shouldBe` (mkstate 959 639, mkws 1 [] [2, 3, 4]) + + it "ignore window that fully overlaps the current window in parallel direction when pos is outside it" $ do + -- ┌─────┬──────┬──────┐ + -- │ ┌───┴──────┴────┐ │ + -- │ │ | 4 | │ │ + -- │ └───┬──────┬────┘ │ + -- │ 1 │ 2 ──┼─► 3 │ + -- └─────┴──────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 600 1280) + , (2, Rectangle 600 0 600 1280) + , (3, Rectangle 1200 0 720 1280) + , (4, Rectangle 200 200 1520 400) + ] + runIdentity (goPure R (mkstate 900 900, mkws 2 [] [1, 3, 4], S.fromList [1..4], windowRect)) + `shouldBe` (mkstate 1200 900, mkws 3 [1,2] [4]) + + it "go to window that fully overlaps the current window in parallel direction when pos is inside it" $ do + -- ┌─────────────────┐ + -- │ ┌──────┐ │ + -- │ 1 │ │ │ + -- ├─────┤------├────┤ + -- │ │ │ │ + -- │ 2 │ 4 ──┼─► │ + -- │ │ │ │ + -- ├─────┤------├────┤ + -- │ 3 │ │ │ + -- │ └──────┘ │ + -- └─────────────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 1920 400) + , (2, Rectangle 0 400 1920 400) + , (3, Rectangle 0 800 1920 480) + , (4, Rectangle 800 200 400 880) + ] + runIdentity (goPure R (mkstate 1000 600, mkws 4 [] [1, 2, 3], S.fromList [1..4], windowRect)) + `shouldBe` (mkstate 1200 600, mkws 2 [1,4] [3]) + + it "go from inner window to outer" $ do + -- ┌───────────────┐ + -- │ ┌──────┐ │ + -- │ 1 ◄─┼── 2 │ │ + -- │ └──────┘ │ + -- └───────────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 1920 1280) + , (2, Rectangle 600 600 600 600) + ] + runIdentity (goPure L (M.empty, mkws 2 [] [1], S.fromList [1, 2], windowRect)) + `shouldBe` (mkstate 599 900, mkws 1 [2] []) + + it "if there are multiple outer windows, go to the smaller one" $ do + -- ┌────────────────────────┐ + -- │ ┌───────────────┐ │ + -- │ │ ┌──────┐ │ │ + -- │ │ 2 ◄─┼── 3 │ │ 1 │ + -- │ │ └──────┘ │ │ + -- │ └───────────────┘ │ + -- └────────────────────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 1920 1280) + , (2, Rectangle 200 200 1520 880) + , (3, Rectangle 400 400 400 400) + ] + runIdentity (goPure L (M.empty, mkws 3 [] [1, 2], S.fromList [1..3], windowRect)) + `shouldBe` (mkstate 399 600, mkws 2 [1, 3] []) + + it "two tiled and one floating, floating fully inside" $ do + -- ┌───────────────────┬─────┐ + -- │ ┌───────┐ │ │ + -- │ ──┼─► ──┼─► ──┼─► │ + -- │ │ 3 │ 1 │ 2 │ + -- │ │ ◄─┼── ◄─┼── │ + -- │ └───────┘ │ │ + -- └───────────────────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + , (3, Rectangle 400 400 400 400) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect) + let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3]) + (st2, ws2) `shouldBe` (mkstate 400 400, mkws 3 [2, 1] []) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 800 400, mkws 1 [] [2, 3]) + let (st4, ws4) = runNav R st3 ws3 + (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1] [3]) + let (st5, ws5) = runNav L st4 ws4 + (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [] [2, 3]) + let (st6, ws6) = runNav L st5 ws5 + (st6, ws6) `shouldBe` (mkstate 799 400, mkws 3 [2, 1] []) + + it "two floating windows inside one big tiled one" $ do + -- ┌─────────┐ + -- │ │ │ + -- │ ┌──┼──┐ │ + -- │ │ ▼ │ │ + -- │ │ 3 │ │ + -- │ └──┼──┘ │ + -- │ ▼ │ + -- │ 1 │ + -- │ ┌──┼──┐ │ + -- │ │ ▼ │ │ + -- │ │ 4 │ │ + -- │ └──┼──┘ │ + -- │ ▼ │ + -- ├────┼────┤ + -- │ ▼ │ + -- │ 2 │ + -- └─────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 1920 640) + , (2, Rectangle 0 640 1920 640) + , (3, Rectangle 200 200 100 100) + , (4, Rectangle 1000 400 100 100) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav D (mkstate 1000 250) (mkws 1 [] [2, 3, 4]) + (st2, ws2) `shouldBe` (mkstate 299 250, mkws 3 [2, 1] [4]) + let (st3, ws3) = runNav D st2 ws2 + (st3, ws3) `shouldBe` (mkstate 299 300, mkws 1 [] [2, 3, 4]) + let (st4, ws4) = runNav D st3 ws3 + (st4, ws4) `shouldBe` (mkstate 1000 400, mkws 4 [3, 2, 1] []) + let (st5, ws5) = runNav D st4 ws4 + (st5, ws5) `shouldBe` (mkstate 1000 500, mkws 1 [] [2, 3, 4]) + let (st6, ws6) = runNav D st5 ws5 + (st6, ws6) `shouldBe` (mkstate 1000 640, mkws 2 [1] [3, 4]) + + it "floating window between two tiled ones" $ do + -- ┌───────┬────────┐ + -- │ 1 ┌───┴───┐ 2 │ + -- │ ──┼─► 3 ──┼─► │ + -- │ └───┬───┘ │ + -- └───────┴────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + , (3, Rectangle 860 540 200 200) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect) + let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3]) + (st2, ws2) `shouldBe` (mkstate 860 640, mkws 3 [2, 1] []) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 640, mkws 2 [1] [3]) + + it "floating window overlapping four tiled ones" $ do + -- ┌───────┬───────┐ + -- │ ┌───┴───┐ │ + -- │ 1 │ │ 2 │ + -- ├───┤ ├───┤ + -- │ ──┼─► 5 ──┼─► │ + -- │ 3 └───┬───┘ 4 │ + -- └───────┴───────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 640) + , (2, Rectangle 960 0 960 640) + , (3, Rectangle 0 640 960 640) + , (4, Rectangle 960 640 960 640) + , (5, Rectangle 760 440 400 400) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect) + let (st2, ws2) = runNav R (mkstate 480 640) (mkws 3 [] [1, 2, 4, 5]) + (st2, ws2) `shouldBe` (mkstate 760 640, mkws 5 [4, 2, 1, 3] []) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [2, 1, 3] [5]) + + it "sequential inner floating windows" $ do + -- ┌───────────────────────────────────┬──────┐ + -- │ ┌───────┐ │ │ + -- │ │ │ ┌───────┐ │ │ + -- │ ──┼─► 3 ──┼─► 1 ──┼─► 4 ──┼─► ──┼─► 2 │ + -- │ ◄─┼── ◄─┼── ◄─┼── ◄─┼── ◄─┼── │ + -- │ └───────┘ │ │ │ │ + -- │ └───────┘ │ │ + -- └───────────────────────────────────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + , (3, Rectangle 200 200 200 200) + , (4, Rectangle 600 600 200 200) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3, 4]) + (st2, ws2) `shouldBe` (mkstate 200 200, mkws 3 [2,1] [4]) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 400 200, mkws 1 [] [2, 3, 4]) + let (st4, ws4) = runNav R st3 ws3 + (st4, ws4) `shouldBe` (mkstate 600 600, mkws 4 [3, 2, 1] []) + let (st5, ws5) = runNav R st4 ws4 + (st5, ws5) `shouldBe` (mkstate 800 600, mkws 1 [] [2, 3, 4]) + let (st6, ws6) = runNav R st5 ws5 + (st6, ws6) `shouldBe` (mkstate 960 600, mkws 2 [1] [3, 4]) + let (st7, ws7) = runNav L st6 ws6 + (st7, ws7) `shouldBe` (mkstate 959 600, mkws 1 [] [2, 3, 4]) + let (st8, ws8) = runNav L st7 ws7 + (st8, ws8) `shouldBe` (mkstate 799 600, mkws 4 [3, 2, 1] []) + let (st9, ws9) = runNav L st8 ws8 + (st9, ws9) `shouldBe` (mkstate 599 600, mkws 1 [] [2, 3, 4]) + let (st10, ws10) = runNav L st9 ws9 + (st10, ws10) `shouldBe` (mkstate 399 399, mkws 3 [2, 1] [4]) + let (st11, ws11) = runNav L st10 ws10 + (st11, ws11) `shouldBe` (mkstate 199 399, mkws 1 [] [2, 3, 4]) + + it "overlapping inner floating windows" $ do + -- ┌─────────────────────┬──────┐ + -- │ ┌─────────┐ │ │ + -- │ │ 3 ┌────┴─┐ │ │ + -- │ │ ──┼─► ──┼─► 1 ──┼─► 2 │ + -- │ │ ◄─┼── ◄─┼── ◄─┼── │ + -- │ │ │ 4 │ │ │ + -- │ └────┤ │ │ │ + -- │ └──────┘ │ │ + -- └─────────────────────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + , (3, Rectangle 200 200 400 400) + , (4, Rectangle 300 300 400 400) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect) + let (st2, ws2) = runNav R M.empty (mkws 3 [] [1, 2, 4]) + (st2, ws2) `shouldBe` (mkstate 400 400, mkws 4 [2, 1, 3] []) + let (st3, ws3) = runNav R st2 ws2 + (st3, ws3) `shouldBe` (mkstate 700 400, mkws 1 [3] [2, 4]) + let (st4, ws4) = runNav R st3 ws3 + (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1, 3] [4]) + let (st5, ws5) = runNav L st4 ws4 + (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [3] [2, 4]) + let (st6, ws6) = runNav L st5 ws5 + (st6, ws6) `shouldBe` (mkstate 699 400, mkws 4 [2, 1, 3] []) + let (st7, ws7) = runNav L st6 ws6 + (st7, ws7) `shouldBe` (mkstate 599 400, mkws 3 [] [1, 2, 4]) + + it "bounce back from the wall to the floating window" $ do + -- ┌────────────────┬─────┐ + -- │ 1 ┌──────┐ │ │ + -- │ ┌───┼─► 3 │ │ 2 │ + -- │ └── │ │ │ │ + -- │ └──────┘ │ │ + -- └────────────────┴─────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 1280) + , (3, Rectangle 400 400 200 200) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect) + runNav L (mkstate 100 640) (mkws 1 [] [2, 3]) + `shouldBe` (mkstate 400 599, mkws 3 [2, 1] []) + + it "jump between screens" $ do + -- ┌─────┬──────┐ ┌────────┐ + -- │ │ 2 │ │ 5 │ + -- │ ├──────┤ ├────────┤ + -- │ 1 │ 3 ──┼──┼─► 6 │ + -- │ ├──────┤ └────────┘ + -- │ │ 4 │ + -- └─────┴──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + , (5, Rectangle 1920 0 1280 384) + , (6, Rectangle 1920 384 1280 384) + ] + initWindowSet = + W.StackSet + { W.current = + W.Screen + { W.workspace = + W.Workspace + { W.tag = "A" + , W.layout = Layout NullLayout + , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] } + } + , W.screen = 1 + , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 } + } + , W.visible = + [ W.Screen + { W.workspace = + W.Workspace + { W.tag = "B" + , W.layout = Layout NullLayout + , W.stack = Just $ W.Stack { W.focus = 5, W.up = [], W.down = [6] } + } + , W.screen = 2 + , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 } + } + ] + , W.hidden = [] + , W.floating = M.empty + } + expectedWindowSet = + W.StackSet + { W.current = + W.Screen + { W.workspace = + W.Workspace + { W.tag = "B" + , W.layout = Layout NullLayout + , W.stack = Just $ W.Stack { W.focus = 6, W.up = [5], W.down = [] } + } + , W.screen = 2 + , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 } + } + , W.visible = + [ W.Screen + { W.workspace = + W.Workspace + { W.tag = "A" + , W.layout = Layout NullLayout + , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] } + } + , W.screen = 1 + , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 } + } + ] + , W.hidden = [] + , W.floating = M.empty + } + + runIdentity (goPure R (M.empty, initWindowSet, S.fromList [1..6], windowRect)) + `shouldBe` (M.fromList [("B", Point 1920 600)], expectedWindowSet) + + it "floating window overlapping fully in the orthogonal direction" $ do + -- ┌─────┬──────────────────┐ + -- │ │ ┌───────┐ │ + -- │ │ 2 │ │ │ + -- │ ├──────┤-------├───┤ + -- │ 1 │ 3 │ │ 3 │ + -- │ ◄─┼── ◄─┼── 5 ◄─┼── │ + -- │ ├──────┤-------├───┤ + -- │ │ 4 │ │ │ + -- │ │ └───────┘ │ + -- └─────┴──────────────────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 960 0 960 400) + , (3, Rectangle 960 400 960 400) + , (4, Rectangle 960 800 960 480) + , (5, Rectangle 1360 200 200 800) + ] + runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect) + let (st2, ws2) = runNav L (mkstate 1800 600) (mkws 3 [] [1, 2, 4, 5]) + (st2, ws2) `shouldBe` (mkstate 1559 600, mkws 5 [4, 2, 1, 3] []) + let (st3, ws3) = runNav L st2 ws2 + (st3, ws3) `shouldBe` (mkstate 1359 600, mkws 3 [] [1, 2, 4, 5]) + let (st4, ws4) = runNav L st3 ws3 + (st4, ws4) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4, 5]) + + it "navigation to free-floating windows on the same screen" $ do + -- ┌──────┐ + -- │ │ ┌──────┐ + -- │ │ │ │ + -- │ ──┼──┼─► 2 │ + -- │ │ │ │ + -- │ 1 │ └──────┘ + -- │ │ + -- │ │ + -- └──────┘ + let windowRect w = + Identity $ M.lookup w $ M.fromList + [ (1, Rectangle 0 0 960 1280) + , (2, Rectangle 1200 400 400 400) + ] + runIdentity (goPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect)) + `shouldBe` (mkstate 1200 640, mkws 2 [1] []) + + it "switch between windows in Full layout" $ do + let windowRect w = Identity $ M.lookup w $ M.fromList [(1, Rectangle 0 0 1920 1280)] + runIdentity (goPure D (M.empty, mkws 1 [] [2, 3], S.fromList [1], windowRect)) + `shouldBe` (M.empty, mkws 2 [1] [3]) + +data NullLayout a = NullLayout deriving (Show, Read, Eq) +instance LayoutClass NullLayout a + +-- to make WindowSets comparable +instance Eq (Layout w) where + (==) a b = show a == show b + (/=) a b = show a /= show b + +-- make a state with a position for a single workspace +mkstate :: Position -> Position -> WNState +mkstate px py = M.fromList [("A", Point px py)] + +-- make a single-workspace WindowSet +mkws :: Window -> [Window] -> [Window] -> WindowSet +mkws focusedWindow upWindows downWindows = W.StackSet + { W.current = W.Screen + { W.workspace = W.Workspace + { W.tag = "A" + , W.layout = Layout NullLayout + , W.stack = Just $ W.Stack { W.focus = focusedWindow, W.up = upWindows, W.down = downWindows } + } + , W.screen = 1 + , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 } + } + , W.visible = [] + , W.hidden = [] + , W.floating = M.empty + } diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -1,5 +1,5 @@ name: xmonad-contrib -version: 0.18.0 +version: 0.18.1 -- ^ also update cpp-options: -DXMONAD_CONTRIB_VERSION_* homepage: https://xmonad.org/ @@ -38,7 +38,7 @@ build-type: Simple bug-reports: https://github.com/xmonad/xmonad-contrib/issues -tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.4 || == 9.8.1 +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.6 || == 9.8.2 || == 9.10.1 source-repository head type: git @@ -54,29 +54,30 @@ manual: True library - build-depends: base >= 4.11 && < 5, + build-depends: base >= 4.12 && < 5, bytestring >= 0.10 && < 0.13, containers >= 0.5 && < 0.8, directory, filepath, - time >= 1.8 && < 1.13, + time >= 1.8 && < 1.15, process, random, mtl >= 1 && < 3, + transformers, unix, X11 >= 1.10 && < 1.11, - xmonad >= 0.16.99999 && < 0.19, + xmonad >= 0.18.0 && < 0.19, utf8-string, deepseq default-language: Haskell2010 cpp-options: -DXMONAD_CONTRIB_VERSION_MAJOR=0 -DXMONAD_CONTRIB_VERSION_MINOR=18 - -DXMONAD_CONTRIB_VERSION_PATCH=0 + -DXMONAD_CONTRIB_VERSION_PATCH=1 ghc-options: -Wall -Wno-unused-do-bind if flag(pedantic) - ghc-options: -Werror -Wwarn=deprecations -Wwarn=dodgy-imports + ghc-options: -Werror -Wwarn=deprecations -- Keep this in sync with the oldest version in 'tested-with' if impl(ghc > 8.6.5) @@ -130,6 +131,7 @@ XMonad.Actions.PhysicalScreens XMonad.Actions.Plane XMonad.Actions.Prefix + XMonad.Actions.Profiles XMonad.Actions.Promote XMonad.Actions.RandomBackground XMonad.Actions.RepeatAction @@ -191,6 +193,7 @@ XMonad.Hooks.EwmhDesktops XMonad.Hooks.FadeInactive XMonad.Hooks.FadeWindows + XMonad.Hooks.FloatConfigureReq XMonad.Hooks.FloatNext XMonad.Hooks.Focus XMonad.Hooks.InsertPosition @@ -234,6 +237,7 @@ XMonad.Layout.Circle XMonad.Layout.CircleEx XMonad.Layout.Column + XMonad.Layout.Columns XMonad.Layout.Combo XMonad.Layout.ComboP XMonad.Layout.Cross @@ -425,7 +429,9 @@ RotateSome Selective SwapWorkspaces + WindowNavigation Utils + XMonad.Actions.CopyWindow XMonad.Actions.CycleRecentWS XMonad.Actions.CycleWS XMonad.Actions.FocusNth @@ -437,10 +443,13 @@ XMonad.Actions.SwapWorkspaces XMonad.Actions.TagWindows XMonad.Actions.WindowBringer + XMonad.Actions.WindowGo + XMonad.Actions.WindowNavigation XMonad.Hooks.ManageDocks XMonad.Hooks.ManageHelpers XMonad.Hooks.UrgencyHook XMonad.Hooks.WorkspaceHistory + XMonad.Hooks.StatusBar.PP XMonad.Layout.Decoration XMonad.Layout.LayoutModifier XMonad.Layout.LimitWindows @@ -474,13 +483,13 @@ XMonad.Util.XUtils XPrompt hs-source-dirs: tests, . - build-depends: base + build-depends: base >= 4.12 && < 5 , QuickCheck >= 2 , X11 >= 1.10 && < 1.11 , bytestring >= 0.10 && < 0.13 , containers , directory - , time >= 1.8 && < 1.13 + , time >= 1.8 && < 1.15 , hspec >= 2.4.0 && < 3 , mtl , random @@ -494,7 +503,7 @@ default-language: Haskell2010 if flag(pedantic) - ghc-options: -Werror -Wwarn=deprecations -Wwarn=dodgy-imports + ghc-options: -Werror -Wwarn=deprecations -- Keep this in sync with the oldest version in 'tested-with' if impl(ghc > 8.6.5)