{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances #-}
module XMonad.Layout.BoringWindows (
boringWindows, boringAuto,
markBoring, markBoringEverywhere,
clearBoring, focusUp, focusDown,
focusMaster, swapUp, swapDown,
siftUp, siftDown,
UpdateBoring(UpdateBoring),
BoringMessage(Replace,Merge),
BoringWindows()
) where
import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
LayoutModifier(handleMessOrMaybeModifyIt, redoLayout))
import XMonad(LayoutClass, Message, X, fromMessage,
broadcastMessage, sendMessage, windows, withFocused, Window)
import XMonad.Prelude
import XMonad.Util.Stack (reverseS)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified XMonad.StackSet as W
data BoringMessage = FocusUp | FocusDown | FocusMaster | IsBoring Window | ClearBoring
| Replace String [Window]
| Merge String [Window]
| SwapUp
| SwapDown
| SiftUp
| SiftDown
deriving ( ReadPrec [BoringMessage]
ReadPrec BoringMessage
Int -> ReadS BoringMessage
ReadS [BoringMessage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BoringMessage]
$creadListPrec :: ReadPrec [BoringMessage]
readPrec :: ReadPrec BoringMessage
$creadPrec :: ReadPrec BoringMessage
readList :: ReadS [BoringMessage]
$creadList :: ReadS [BoringMessage]
readsPrec :: Int -> ReadS BoringMessage
$creadsPrec :: Int -> ReadS BoringMessage
Read, Int -> BoringMessage -> ShowS
[BoringMessage] -> ShowS
BoringMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoringMessage] -> ShowS
$cshowList :: [BoringMessage] -> ShowS
show :: BoringMessage -> String
$cshow :: BoringMessage -> String
showsPrec :: Int -> BoringMessage -> ShowS
$cshowsPrec :: Int -> BoringMessage -> ShowS
Show )
instance Message BoringMessage
data UpdateBoring = UpdateBoring
instance Message UpdateBoring
markBoring, clearBoring, focusUp, focusDown, focusMaster, swapUp, swapDown, siftUp, siftDown :: X ()
markBoring :: X ()
markBoring = (Window -> X ()) -> X ()
withFocused (forall a. Message a => a -> X ()
sendMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> BoringMessage
IsBoring)
clearBoring :: X ()
clearBoring = forall a. Message a => a -> X ()
sendMessage BoringMessage
ClearBoring
focusUp :: X ()
focusUp = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
FocusUp
focusDown :: X ()
focusDown = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
FocusDown
focusMaster :: X ()
focusMaster = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
FocusMaster
swapUp :: X ()
swapUp = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
SwapUp
swapDown :: X ()
swapDown = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
SwapDown
siftUp :: X ()
siftUp = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
SiftUp
siftDown :: X ()
siftDown = forall a. Message a => a -> X ()
sendMessage UpdateBoring
UpdateBoring forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Message a => a -> X ()
sendMessage BoringMessage
SiftDown
markBoringEverywhere :: X ()
markBoringEverywhere :: X ()
markBoringEverywhere = (Window -> X ()) -> X ()
withFocused (forall a. Message a => a -> X ()
broadcastMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> BoringMessage
IsBoring)
data BoringWindows a = BoringWindows
{ forall a. BoringWindows a -> Map String [a]
namedBoring :: M.Map String [a]
, forall a. BoringWindows a -> [a]
chosenBoring :: [a]
, forall a. BoringWindows a -> Maybe [a]
hiddenBoring :: Maybe [a]
} deriving (Int -> BoringWindows a -> ShowS
forall a. Show a => Int -> BoringWindows a -> ShowS
forall a. Show a => [BoringWindows a] -> ShowS
forall a. Show a => BoringWindows a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoringWindows a] -> ShowS
$cshowList :: forall a. Show a => [BoringWindows a] -> ShowS
show :: BoringWindows a -> String
$cshow :: forall a. Show a => BoringWindows a -> String
showsPrec :: Int -> BoringWindows a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoringWindows a -> ShowS
Show,ReadPrec [BoringWindows a]
ReadPrec (BoringWindows a)
ReadS [BoringWindows a]
forall a. Read a => ReadPrec [BoringWindows a]
forall a. Read a => ReadPrec (BoringWindows a)
forall a. Read a => Int -> ReadS (BoringWindows a)
forall a. Read a => ReadS [BoringWindows a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BoringWindows a]
$creadListPrec :: forall a. Read a => ReadPrec [BoringWindows a]
readPrec :: ReadPrec (BoringWindows a)
$creadPrec :: forall a. Read a => ReadPrec (BoringWindows a)
readList :: ReadS [BoringWindows a]
$creadList :: forall a. Read a => ReadS [BoringWindows a]
readsPrec :: Int -> ReadS (BoringWindows a)
$creadsPrec :: forall a. Read a => Int -> ReadS (BoringWindows a)
Read)
boringWindows :: (LayoutClass l a, Eq a) => l a -> ModifiedLayout BoringWindows l a
boringWindows :: forall (l :: * -> *) a.
(LayoutClass l a, Eq a) =>
l a -> ModifiedLayout BoringWindows l a
boringWindows = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. Map String [a] -> [a] -> Maybe [a] -> BoringWindows a
BoringWindows forall k a. Map k a
M.empty [] forall a. Maybe a
Nothing)
boringAuto :: (LayoutClass l a, Eq a) => l a -> ModifiedLayout BoringWindows l a
boringAuto :: forall (l :: * -> *) a.
(LayoutClass l a, Eq a) =>
l a -> ModifiedLayout BoringWindows l a
boringAuto = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. Map String [a] -> [a] -> Maybe [a] -> BoringWindows a
BoringWindows forall k a. Map k a
M.empty [] (forall a. a -> Maybe a
Just []))
instance LayoutModifier BoringWindows Window where
redoLayout :: BoringWindows Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)], Maybe (BoringWindows Window))
redoLayout b :: BoringWindows Window
b@BoringWindows{ hiddenBoring :: forall a. BoringWindows a -> Maybe [a]
hiddenBoring = Maybe [Window]
bs } Rectangle
_r Maybe (Stack Window)
mst [(Window, Rectangle)]
arrs = do
let bs' :: [Window]
bs' = forall a. Maybe (Stack a) -> [a]
W.integrate' Maybe (Stack Window)
mst forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
arrs
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
arrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BoringWindows Window
b { hiddenBoring :: Maybe [Window]
hiddenBoring = [Window]
bs' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe [Window]
bs } )
handleMessOrMaybeModifyIt :: BoringWindows Window
-> SomeMessage
-> X (Maybe (Either (BoringWindows Window) SomeMessage))
handleMessOrMaybeModifyIt bst :: BoringWindows Window
bst@(BoringWindows Map String [Window]
nbs [Window]
cbs Maybe [Window]
lbs) SomeMessage
m
| Just (Replace String
k [Window]
ws) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
, forall a. a -> Maybe a
Just [Window]
ws forall a. Eq a => a -> a -> Bool
/= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
k Map String [Window]
nbs =
let nnb :: Map String [Window]
nnb = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
ws then forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
k Map String [Window]
nbs
else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
k [Window]
ws Map String [Window]
nbs
in forall {a} {b}. a -> X (Maybe (Either a b))
rjl BoringWindows Window
bst { namedBoring :: Map String [Window]
namedBoring = Map String [Window]
nnb }
| Just (Merge String
k [Window]
ws) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Window]
ws forall a. Eq a => [a] -> [a] -> [a]
\\)) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
k Map String [Window]
nbs) =
forall {a} {b}. a -> X (Maybe (Either a b))
rjl BoringWindows Window
bst { namedBoring :: Map String [Window]
namedBoring = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Eq a => [a] -> [a] -> [a]
union String
k [Window]
ws Map String [Window]
nbs }
| Just (IsBoring Window
w) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m , Window
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Window]
cbs =
forall {a} {b}. a -> X (Maybe (Either a b))
rjl BoringWindows Window
bst { chosenBoring :: [Window]
chosenBoring = Window
wforall a. a -> [a] -> [a]
:[Window]
cbs }
| Just BoringMessage
ClearBoring <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
cbs) =
forall {a} {b}. a -> X (Maybe (Either a b))
rjl BoringWindows Window
bst { namedBoring :: Map String [Window]
namedBoring = forall k a. Map k a
M.empty, chosenBoring :: [Window]
chosenBoring = []}
| Just BoringMessage
FocusUp <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' forall a b. (a -> b) -> a -> b
$ (Stack Window -> Stack Window) -> Stack Window -> Stack Window
skipBoring forall a. Stack a -> Stack a
W.focusUp'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
FocusDown <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' forall a b. (a -> b) -> a -> b
$ (Stack Window -> Stack Window) -> Stack Window -> Stack Window
skipBoring forall a. Stack a -> Stack a
W.focusDown'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
FocusMaster <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify'
forall a b. (a -> b) -> a -> b
$ (Stack Window -> Stack Window) -> Stack Window -> Stack Window
skipBoring forall a. Stack a -> Stack a
W.focusDown'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stack Window -> Stack Window) -> Stack Window -> Stack Window
skipBoring forall a. Stack a -> Stack a
W.focusUp'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> Stack a
focusMaster'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
SwapUp <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' Stack Window -> Stack Window
skipBoringSwapUp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
SwapDown <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' (forall a. Stack a -> Stack a
reverseS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack Window -> Stack Window
skipBoringSwapUp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> Stack a
reverseS)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
SiftUp <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' (forall a. Eq a => [a] -> Stack a -> Stack a
siftUpSkipping [Window]
bs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Just BoringMessage
SiftDown <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
do (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' (forall a. Stack a -> Stack a
reverseS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> Stack a -> Stack a
siftUpSkipping [Window]
bs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> Stack a
reverseS)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where skipBoring :: (Stack Window -> Stack Window) -> Stack Window -> Stack Window
skipBoring = forall {a}.
(Stack a -> Bool) -> (Stack a -> Stack a) -> Stack a -> Stack a
skipBoring' ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Window]
bs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> a
W.focus)
skipBoringSwapUp :: Stack Window -> Stack Window
skipBoringSwapUp = forall {a}.
(Stack a -> Bool) -> (Stack a -> Stack a) -> Stack a -> Stack a
skipBoring'
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Window]
bs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> [a]
W.down)
forall a. Stack a -> Stack a
swapUp'
skipBoring' :: (Stack a -> Bool) -> (Stack a -> Stack a) -> Stack a -> Stack a
skipBoring' Stack a -> Bool
p Stack a -> Stack a
f Stack a
st = forall a. a -> Maybe a -> a
fromMaybe Stack a
st
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Stack a -> Bool
p
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Stack a -> [a]
W.integrate Stack a
st)
forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate Stack a -> Stack a
f Stack a
st
bs :: [Window]
bs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [Window]
cbsforall a. a -> [a] -> [a]
:forall a. Maybe a -> [a]
maybeToList Maybe [Window]
lbs forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
M.elems Map String [Window]
nbs
rjl :: a -> X (Maybe (Either a b))
rjl = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
handleMessOrMaybeModifyIt BoringWindows Window
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
focusMaster' :: W.Stack a -> W.Stack a
focusMaster' :: forall a. Stack a -> Stack a
focusMaster' c :: Stack a
c@(W.Stack a
_ [] [a]
_) = Stack a
c
focusMaster' (W.Stack a
t (a
l:[a]
ls) [a]
rs) = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
x [] ([a]
xs forall a. [a] -> [a] -> [a]
++ a
t forall a. a -> [a] -> [a]
: [a]
rs) where (a
x :| [a]
xs) = forall a. NonEmpty a -> NonEmpty a
NE.reverse (a
l forall a. a -> [a] -> NonEmpty a
:| [a]
ls)
swapUp' :: W.Stack a -> W.Stack a
swapUp' :: forall a. Stack a -> Stack a
swapUp' (W.Stack a
t (a
l:[a]
ls) [a]
rs) = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
t [a]
ls (a
lforall a. a -> [a] -> [a]
:[a]
rs)
swapUp' (W.Stack a
t [] [a]
rs) = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
t (forall a. [a] -> [a]
reverse [a]
rs) []
siftUpSkipping :: Eq a => [a] -> W.Stack a -> W.Stack a
siftUpSkipping :: forall a. Eq a => [a] -> Stack a -> Stack a
siftUpSkipping [a]
bs (W.Stack a
t [a]
ls [a]
rs)
| ([a]
skips, a
l:[a]
ls') <- ([a], [a])
spanLeft = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
t [a]
ls' (forall a. [a] -> [a]
reverse [a]
skips forall a. [a] -> [a] -> [a]
++ a
l forall a. a -> [a] -> [a]
: [a]
rs)
| ([a]
skips, a
r:[a]
rs') <- ([a], [a])
spanRight = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
t ([a]
rs' forall a. [a] -> [a] -> [a]
++ a
r forall a. a -> [a] -> [a]
: [a]
ls) (forall a. [a] -> [a]
reverse [a]
skips)
| Bool
otherwise = forall a. a -> [a] -> [a] -> Stack a
W.Stack a
t [a]
ls [a]
rs
where
spanLeft :: ([a], [a])
spanLeft = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
bs) [a]
ls
spanRight :: ([a], [a])
spanRight = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
bs) (forall a. [a] -> [a]
reverse [a]
rs)