From 56a76df88fb7b5a1f11e071b84a98fabaf7e4d8c Mon Sep 17 00:00:00 2001 From: Yclept Nemo Date: Sat, 28 Apr 2018 22:03:31 -0400 Subject: [PATCH] 'XMonad.Actions.SwapPromote': new module Module for tracking master window history per workspace, and associated functions for manipulating the stack using such history. --- XMonad/Actions/SwapPromote.hs | 400 ++++++++++++++++++++++++++++++++++ 1 file changed, 400 insertions(+) create mode 100644 XMonad/Actions/SwapPromote.hs diff --git a/XMonad/Actions/SwapPromote.hs b/XMonad/Actions/SwapPromote.hs new file mode 100644 index 00000000..b6c5ca85 --- /dev/null +++ b/XMonad/Actions/SwapPromote.hs @@ -0,0 +1,400 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.SwapPromote +-- Copyright : (c) 2018 Yclept Nemo +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Module for tracking master window history per workspace, and associated +-- functions for manipulating the stack using such history. +-- +----------------------------------------------------------------------------- + + +module XMonad.Actions.SwapPromote + ( -- * Usage + -- $usage + MasterHistory (..) + -- * State Accessors + , getMasterHistoryMap + , getMasterHistoryFromTag + , getMasterHistoryCurrent + , getMasterHistoryFromWindow + , modifyMasterHistoryFromTag + , modifyMasterHistoryCurrent + -- * Log Hook + , masterHistoryHook + -- * Log Hook Building Blocks + , masterHistoryHook' + , updateMasterHistory + -- * Actions + , swapPromote + , swapPromote' + , swapIn + , swapIn' + , swapHybrid + , swapHybrid' + -- * Action Building Blocks + , swapApply + , swapPromoteStack + , swapInStack + , swapHybridStack + -- * List Utilities + , cycleN + , split + , split' + , merge + , merge' + -- * Stack Utilities + , stackSplit + , stackMerge + ) where + + +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List +import Data.Maybe +import Control.Arrow +import Control.Monad + + +-- $usage +-- Given your configuration file, import this module: +-- +-- > import XMonad.Actions.SwapPromote +-- +-- First add 'masterHistoryHook' to your 'logHook' to track master windows per +-- workspace: +-- +-- > myLogHook = otherHook >> masterHistoryHook +-- +-- Then replace xmonad's default promote keybinding with 'swapPromote'': +-- +-- > , ((mod1Mask, xK_Return), swapPromote' False) +-- +-- Depending on your xmonad configuration or window actions the master history +-- may be empty. If this is the case you can still chain another promotion +-- function: +-- +-- > import XMonad.Actions.DwmPromote +-- > , ((mod1Mask, xK_Return), whenX (swapPromote False) dwmpromote) +-- +-- To be clear, this is only called when the lack of master history hindered +-- the swap and not other conditions, such as having a only a single window. +-- +-- While 'swapPromote' preserves window focus, 'swapIn' preserves the focus +-- position - effectively "swapping" new windows into focus without moving the +-- zipper. A mix of both, 'swapHybrid' promotes focused non-master windows +-- while swapping windows into the focused master. This works well on layouts +-- with large masters. Both come with chainable variants, see 'swapIn'' and +-- 'swapHybrid''. +-- +-- So far floating windows have been treated no differently than tiled windows +-- even though their positions are independent of the stack. Often, yanking +-- floating windows in and out of the workspace will obliterate the stack +-- history - particularly frustrating with 'XMonad.Util.Scratchpad' since it is +-- toggled so frequenty and always replaces the master window. That's why the +-- swap functions accept a boolean argument; when @True@ non-focused floating +-- windows will be ignored. +-- +-- All together: +-- > , ((mod1Mask, xK_Return), whenX (swapHybrid True) dwmpromote) + + +-- | Mapping from workspace tag to master history list. The current master is +-- the head of the list, the previous master the second element, and so on. +-- Without history, the list is empty. +newtype MasterHistory = MasterHistory + { getMasterHistory :: M.Map WorkspaceId [Window] + } deriving (Read,Show,Typeable) + +instance ExtensionClass MasterHistory where + initialValue = MasterHistory M.empty + +-- | Return the master history map from the state. +getMasterHistoryMap :: X (M.Map WorkspaceId [Window]) +getMasterHistoryMap = XS.gets getMasterHistory + +-- | Return the master history list of a given tag. The master history list may +-- be empty. An invalid tag will also result in an empty list. +getMasterHistoryFromTag :: WorkspaceId -> X [Window] +getMasterHistoryFromTag t = M.findWithDefault [] t <$> getMasterHistoryMap + +-- | Return the master history list of the current workspace. +getMasterHistoryCurrent :: X [Window] +getMasterHistoryCurrent = gets (W.currentTag . windowset) + >>= getMasterHistoryFromTag + +-- | Return the master history list of the workspace containing the given +-- window. Return an empty list if the window is not in the stackset. +getMasterHistoryFromWindow :: Window -> X [Window] +getMasterHistoryFromWindow w = gets (W.findTag w . windowset) + >>= maybe (return []) getMasterHistoryFromTag + +-- | Modify the master history list of a given workspace, or the empty list of +-- no such workspace is mapped. The result is then re-inserted into the master +-- history map. +modifyMasterHistoryFromTag :: WorkspaceId -> ([Window] -> [Window]) -> X () +modifyMasterHistoryFromTag t f = XS.modify $ \(MasterHistory m) -> + let l = M.findWithDefault [] t m + in MasterHistory $ M.insert t (f l) m + +-- | Modify the master history list of the current workspace. While the current +-- workspace is guaranteed to exist; its master history may not. For more +-- information see 'modifyMasterHistoryFromTag'. +modifyMasterHistoryCurrent :: ([Window] -> [Window]) -> X () +modifyMasterHistoryCurrent f = gets (W.currentTag . windowset) + >>= flip modifyMasterHistoryFromTag f + +-- | A 'logHook' to update the master history mapping. Non-existent workspaces +-- are removed, and the master history list for the current workspaces is +-- updated. See 'masterHistoryHook''. +masterHistoryHook :: X () +masterHistoryHook = masterHistoryHook' True updateMasterHistory + +-- | Backend for 'masterHistoryHook'. +masterHistoryHook' :: Bool + -- ^ If @True@, remove non-existent workspaces. + -> ([Window] -> [Window] -> [Window]) + -- ^ Function used to update the master history list of + -- the current workspace. First argument is the master + -- history, second is the integrated stack. See + -- 'updateMasterHistory' for more details. + -> X () +masterHistoryHook' removeWorkspaces historyModifier = do + wset <- gets windowset + let W.Workspace wid _ mst = W.workspace . W.current $ wset + tags = map W.tag $ W.workspaces wset + st = W.integrate' mst + XS.modify $ \(MasterHistory mm) -> + let mm' = if removeWorkspaces + then restrictKeys mm $ S.fromList tags + else mm + ms = M.findWithDefault [] wid mm' + ms' = historyModifier ms st + in MasterHistory $ M.insert wid ms' mm' + +-- | Less efficient version of 'M.restrictKeys'. Given broader eventual +-- adoption, replace this with 'M.restrictKeys'. +restrictKeys :: Ord k => M.Map k a -> S.Set k -> M.Map k a +restrictKeys m s = M.filterWithKey (\k _ -> k `S.member` s) m + +-- | Given the current master history list and an integrated stack, return the +-- new master history list. The current master is either moved (if it exists +-- within the history) or added to the head of the list, and all missing (i.e. +-- closed) windows are removed. +updateMasterHistory :: [Window] -- ^ The master history list. + -> [Window] -- ^ The integrated stack. + -> [Window] +updateMasterHistory _ [] = [] +updateMasterHistory ms ws@(w:_) = (w : delete w ms) `intersect` ws + +-- | Wrap 'swapPromoteStack'; see also 'swapApply'. +swapPromote :: Bool -> X Bool +swapPromote = flip swapApply swapPromoteStack + +-- | Like 'swapPromote'' but discard the result. +swapPromote' :: Bool -> X () +swapPromote' = void . swapPromote + +-- | Wrap 'swapInStack'; see also 'swapApply'. +swapIn :: Bool -> X Bool +swapIn = flip swapApply swapInStack + +-- | Like 'swapIn'' but discard the result. +swapIn' :: Bool -> X () +swapIn' = void . swapIn + +-- | Wrap 'swapHybridStack'; see also 'swapApply'. +swapHybrid :: Bool -> X Bool +swapHybrid = flip swapApply swapHybridStack + +-- | Like 'swapHybrid'' but discard the result. +swapHybrid' :: Bool -> X () +swapHybrid' = void . swapHybrid + +-- | Apply the given master history stack modifier to the current stack. If +-- given @True@, all non-focused floating windows will be ignored. Return +-- @True@ if insufficient history; if so use 'whenX' to sequence a backup +-- promotion function. +swapApply :: Bool + -> (Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)) + -> X Bool +swapApply ignoreFloats swapFunction = do + fl <- gets $ W.floating . windowset + st <- gets $ W.stack . W.workspace . W.current . windowset + ch <- getMasterHistoryCurrent + let swapApply' s1 = + let fl' = if ignoreFloats then M.keysSet fl else S.empty + ff = (||) <$> (`S.notMember` fl') <*> (== W.focus s1) + fh = filter ff ch + pm = listToMaybe . drop 1 $ fh + (r,s2) = stackSplit s1 fl' :: ([(Int,Window)],W.Stack Window) + (b,s3) = swapFunction pm s2 + s4 = stackMerge s3 r + mh = let w = head . W.integrate $ s3 + in const $ w : delete w ch + in (b,Just s4,mh) + (x,y,z) = maybe (False,Nothing,id) swapApply' st + -- Any floating master windows will be added to the history when 'windows' + -- calls the log hook. + modifyMasterHistoryCurrent z + windows $ W.modify Nothing . const $ y + return x + +-- | If the focused window is the master window and there is no previous +-- master, do nothing. Otherwise swap the master with the previous master. If +-- the focused window is not the master window, swap it with the master window. +-- In either case focus follows the original window, i.e. the focused window +-- does not change, only its position. +-- +-- The first argument is the previous master (which may not exist), the second +-- a window stack. Return @True@ if the master history hindered the swap; the +-- history is either empty or out-of-sync. Though the latter shouldn't happen +-- this function never changes the stack under such circumstances. +swapPromoteStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window) +swapPromoteStack _ st@(W.Stack _x [] []) = (False,st) +swapPromoteStack Nothing st@(W.Stack _x [] _r) = (True,st) +swapPromoteStack (Just pm) (W.Stack x [] r) = + let (r',l') = (reverse *** cycleN 1) $ span (/= pm) $ reverse r + st' = W.Stack x l' r' + b = null l' + in (b,st') +swapPromoteStack _ (W.Stack x l r) = + let r' = (++ r) . cycleN 1 . reverse $ l + st' = W.Stack x [] r' + in (False,st') + +-- | Perform the same swap as 'swapPromoteStack'. However the new window +-- receives the focus; it appears to "swap into" the position of the original +-- window. Under this model focus follows stack position and the zipper does +-- not move. +-- +-- See 'swapPromoteStack' for more details regarding the parameters. +swapInStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window) +swapInStack _ st@(W.Stack _x [] []) = (False,st) +swapInStack Nothing st@(W.Stack _x [] _r) = (True,st) +swapInStack (Just pm) (W.Stack x [] r) = + let (x',r') = case span (/= pm) r of + (__,[]) -> (x,r) + (sl,sr) -> (pm,sl ++ x : drop 1 sr) + st' = W.Stack x' [] r' + b = x' == x + in (b,st') +swapInStack _ (W.Stack x l r) = + let l' = init l ++ [x] + x' = last l + st' = W.Stack x' l' r + in (False,st') + +-- | If the focused window is the master window, use 'swapInStack'. Otherwise use +-- 'swapPromoteStack'. +-- +-- See 'swapPromoteStack' for more details regarding the parameters. +swapHybridStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window) +swapHybridStack m st@(W.Stack _ [] _) = swapInStack m st +swapHybridStack m st = swapPromoteStack m st + +-- | Cycle a list by the given count. If positive, cycle to the left. If +-- negative, cycle to the right: +-- +-- >>> cycleN 2 [1,2,3,4,5] +-- [3,4,5,1,2] +-- >>> cycleN (-2) [1,2,3,4,5] +-- [4,5,1,2,3] +cycleN :: Int -> [a] -> [a] +cycleN n ls = + let l = length ls + in take l $ drop (n `mod` l) $ cycle ls + +-- Wrap 'split'' with an initial index of @0@, discarding the list's length. +split :: (Num a, Enum a) => (b -> Bool) -> [b] -> ([(a,b)],[b]) +split p l = + let (_,ys,ns) = split' p 0 l + in (ys,ns) + +-- Given a predicate, an initial index and a list, return a tuple containing: +-- * List length. +-- * Indexed list of elements which satisfy the predicate. An indexed element +-- is a tuple containing the element index (offset by the initial index) and +-- the element. +-- * List of elements which do not satisfy the predicate. +-- The initial index and length of the list simplify chaining calls to this +-- function, such as for zippers of lists. +split' :: (Num a, Enum a) => (b -> Bool) -> a -> [b] -> (a,[(a,b)],[b]) +split' p i l = + let accumulate e (c,ys,ns) = if p (snd e) + then (c+1,e:ys,ns) + else (c+1,ys,e:ns) + (c',ys',ns') = foldr accumulate (0,[],[]) $ zip [i..] l + in (c',ys',snd . unzip $ ns') + +-- Wrap 'merge'' with an initial virtual index of @0@. Return only the +-- unindexed list with elements from the leftover indexed list appended. +merge :: (Ord a, Num a) => [(a,b)] -> [b] -> [b] +merge il ul = + let (_,il',ul') = merge' 0 il ul + in ul' ++ map snd il' + +-- Inverse of 'split'. Merge an indexed list with an unindexed list (see +-- 'split''). Given a virtual index, an indexed list and an unindexed list, +-- return a tuple containing: +-- * Virtual index *after* the unindexed list +-- * Remainder of the indexed list +-- * Merged unindexed list +-- +-- If the indexed list is empty, this functions consumes the entire unindexed +-- list. If the unindexed list is empty, this function consumes only adjacent +-- indexed elements. For example, @[(10,"ten"),(12,"twelve")]@ implies missing +-- unindexed elements and so once @(10,"ten")@ is consumed this function +-- concludes. +-- +-- The indexed list is assumed to have been created by 'split'' and not checked +-- for correctness. Indices are assumed to be ascending, i.e. +-- > [(1,"one"),(2,"two"),(4,"four")] +-- +-- The initial and final virtual indices simplify chaining calls to the this +-- function, as as for zippers of lists. Positive values shift the unindexed +-- list towards the tail, as if preceded by that many elements. +merge' :: (Ord a, Num a) => a -> [(a,b)] -> [b] -> (a,[(a,b)],[b]) +merge' i il@((j,a):ps) ul@(b:bs) = if j <= i + then let (x,y,z) = merge' (i+1) ps ul + in (x,y,a:z) + else let (x,y,z) = merge' (i+1) il bs + in (x,y,b:z) +merge' i [] (b:bs) = + let (x,y,z) = merge' (i+1) [] bs + in (x,y,b:z) +merge' i il@((j,a):ps) [] = if j <= i + then let (x,y,z) = merge' (i+1) ps [] + in (x,y,a:z) + else (i,il,[]) +merge' i [] [] = + (i,[],[]) + +-- | Remove all elements of the set from the stack. Skip the currently focused +-- member. Return an indexed list of excluded elements and the modified stack. +-- Use 'stackMerge' to re-insert the elements using this list. +stackSplit :: (Num a, Enum a, Ord b) => W.Stack b -> S.Set b -> ([(a,b)],W.Stack b) +stackSplit (W.Stack x l r) s = + let (c,fl,tl) = split' (`S.member` s) 0 (reverse l) + (_,fr,tr) = split' (`S.member` s) (c+1) r + in (fl++fr,W.Stack x (reverse tl) tr) + +-- | Inverse of 'stackSplit'. Given a list of elements and their original +-- indices, re-insert the elements into these same positions within the stack. +-- Skip the currently focused member. Works best if the stack's length hasn't +-- changed. Some elements may be excluded if shorter. +stackMerge :: (Ord a, Num a) => W.Stack b -> [(a,b)] -> W.Stack b +stackMerge (W.Stack x l r) il = + let (i,il1,l') = merge' 0 il (reverse l) + (_,_ ,r') = merge' (i+1) il1 r + in W.Stack x (reverse l') r'