1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# LANGUAGE TypeOperators #-}
module Rahm.Desktop.Layout.PinWindow where
import Control.Arrow (Arrow (second))
import Control.Exception (throw)
import Control.Monad (unless, when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Foldable (find)
import Data.List (nubBy)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe, maybe)
import Data.Semigroup (Endo (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Rahm.Desktop.Common (runMaybeT_)
import Rahm.Desktop.Logger
import qualified Rahm.Desktop.StackSet as W
import XMonad
import qualified XMonad.StackSet as W (filter)
import qualified XMonad.Util.ExtensibleState as XS
import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor), resetBorderColor)
newtype PinWindowState = PinWindowState (Map ScreenId [(Window, W.RationalRect)])
deriving (Show, Read)
instance Default PinWindowState where
def = PinWindowState mempty
instance ExtensionClass PinWindowState where
initialValue = def
extensionType = PersistentExtension
newtype PinWindowLayout (l :: * -> *) (a :: *) = PinWindowLayout (l a)
deriving (Show, Read)
pinnedWindowColor = BorderColor "#00ff00" "#408040"
instance (LayoutClass l a, sid ~ ScreenId, a ~ Window) => LayoutClass (PinWindowLayout l) a where
runLayout (W.Workspace t (PinWindowLayout l) stack) rect = do
-- Clean up window id's thare should not be pinned anymore because the
-- windows were unmanaged.
(PinWindowState pinned') <- XS.get
ws <- gets windowset
XS.put $ PinWindowState (cleanupPinned pinned' ws)
(PinWindowState pinned) <- XS.get
let myScreen = find ((== t) . W.tag . W.workspace) (W.screens ws)
pinnedRects =
maybe
[]
(map $ second (scaleRationalRect rect))
(((`Map.lookup` pinned) . W.screen) =<< myScreen)
allPinned = Set.fromList $ map fst $ concat $ Map.elems pinned
pinnedOnMyScreen = map fst pinnedRects
windowsToMove =
filter (\win -> W.findTag win ws /= Just t) pinnedOnMyScreen
modifyWindowSet $
appEndo . mconcat $
-- Move the windows that are supposed to now be on this workspace here
map (Endo . W.shiftWinNoFocus t) windowsToMove
++
-- once again, sink the windows that are supposed to be here. Make
-- sure they don't float.
map (Endo . W.sink) (Set.toList allPinned)
(rects, maybeNewLayout) <-
runLayout
(W.Workspace t l (W.filter (not . (`Set.member` allPinned)) =<< stack))
rect
return (pinnedRects ++ rects, PinWindowLayout <$> maybeNewLayout)
where
cleanupPinned mp ss =
let aw = Set.fromList (W.allWindows ss)
in Map.map (filter ((`Set.member` aw) . fst)) mp
handleMessage (PinWindowLayout l) a = do
maybeNewLayout <- handleMessage l a
return (PinWindowLayout <$> maybeNewLayout)
pinWindow :: Window -> X ()
pinWindow win = runMaybeT_ $ do
lift $ logs Debug "Pinning window %d" win
ws@(W.StackSet cur vis _ flt) <- gets windowset
t <- hoist (W.findTag win ws)
scr <- hoist $ find ((== t) . (W.tag . W.workspace)) (cur : vis)
rect <- hoist $ Map.lookup win flt
lift $ do
XS.modify $ \(PinWindowState mp) ->
PinWindowState $
Map.alter
(Just . maybe [(win, rect)] ((win, rect) :))
(W.screen scr)
mp
-- Don't float the window anymore.
modifyWindowSet $ W.sink win
setBorderColor pinnedWindowColor [win]
where
hoist = MaybeT . return
unpinWindow :: Window -> X ()
unpinWindow win = runMaybeT_ $ do
(PinWindowState mp) <- lift XS.get
(win, rect) <- hoist $ find ((== win) . fst) (concat $ Map.elems mp)
lift $ do
XS.put $
PinWindowState $
Map.map (filter ((/= win) . fst)) mp
-- refloat the window.
modifyWindowSet $ W.float win rect
resetBorderColor [win]
where
hoist = MaybeT . return
toggleWindowPin :: Window -> X ()
toggleWindowPin win = do
isPinned <- isWindowPinned win
if isPinned
then unpinWindow win
else pinWindow win
isWindowPinned :: Window -> X Bool
isWindowPinned win = do
(PinWindowState mp) <- XS.get
return $ any (any $ (== win) . fst) (Map.elems mp)
pinnedWindows :: X [Window]
pinnedWindows = do
(PinWindowState s) <- XS.get
return $ map fst $ concat $ Map.elems s
pinnable :: l a -> PinWindowLayout l a
pinnable = PinWindowLayout
-- Unpins the window, executes the action, then repins the window. Useful for
-- window shifts and whatnot.
withWindowsUnpinned :: [Window] -> X () -> X ()
withWindowsUnpinned wins fn =
do
allPinnedWindows <- pinnedWindows
let windowsToUnpin = allPinnedWindows `List.intersect` wins
mapM_ unpinWindow windowsToUnpin
fn `catchX` mapM_ pinWindow windowsToUnpin
mapM_ pinWindow windowsToUnpin
|
