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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
{-# LANGUAGE DeriveAnyClass #-}
module Rahm.Desktop.Layout.Bordering
( Bordering (..),
banishToBorder,
unbanish,
rotateBorderForward,
rotateBorderBackward,
bordering,
toggleBanish,
changeWidth,
changeHeight,
moveForward,
moveBackward,
)
where
import Control.Arrow
import Control.Monad
import Data.List (find, partition)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy)
import qualified Data.Set as Set
import Data.Tuple (swap)
import Data.Typeable (cast)
import Rahm.Desktop.Logger
import qualified Rahm.Desktop.StackSet as W
import XMonad
data BorderPosition
= North
| NorthEast
| East
| SouthEast
| South
| SouthWest
| West
| NorthWest
deriving (Eq, Show, Read, Ord, Enum, Bounded)
data BorderingData a = BorderingData
{ extraWindows :: Map BorderPosition a,
borderingWidth :: Rational,
borderingHeight :: Rational,
borderingPadding :: Int
}
deriving (Eq, Ord, Show, Read)
data Bordering (l :: * -> *) (a :: *) = Bordering
{ borderingData :: BorderingData a,
wrappedLayout :: l a
}
deriving (Eq, Ord, Show, Read)
data ModifyBordering a
= ModifyBordering (BorderingData a -> BorderingData a)
deriving (Message)
enumNext :: (Eq a, Enum a, Bounded a) => a -> a
enumNext a
| a == maxBound = minBound
| otherwise = succ a
enumPrev :: (Eq a, Enum a, Bounded a) => a -> a
enumPrev a
| a == minBound = maxBound
| otherwise = pred a
bordering :: l a -> Bordering l a
bordering = Bordering (BorderingData mempty (1 / 6) (1 / 6) 10)
banishToBorder :: a -> ModifyBordering a
banishToBorder win =
let allPositions =
(\(a, b) -> b ++ a) $ break (== SouthEast) [minBound .. maxBound]
in ModifyBordering $ \dat ->
maybe
dat
( \pos ->
dat {extraWindows = Map.insert pos win (extraWindows dat)}
)
$ find (not . (`Map.member` extraWindows dat)) allPositions
toggleBanish :: (Eq a) => a -> ModifyBordering a
toggleBanish win = ModifyBordering $ \dat ->
let (ModifyBordering fn) =
if elem win $ Map.elems $ extraWindows dat
then unbanish win
else banishToBorder win
in fn dat
unbanish :: (Eq a) => a -> ModifyBordering a
unbanish win =
ModifyBordering $ \dat ->
maybe
dat
(\pos -> dat {extraWindows = Map.delete pos (extraWindows dat)})
$ (fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat))
rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a
rotateBorder next = ModifyBordering $ \dat ->
dat {extraWindows = Map.mapKeys next (extraWindows dat)}
rotateBorderForward :: Proxy a -> ModifyBordering a
rotateBorderForward _ = rotateBorder enumNext
rotateBorderBackward :: Proxy a -> ModifyBordering a
rotateBorderBackward _ = rotateBorder enumPrev
changeWidth :: Proxy a -> Rational -> ModifyBordering a
changeWidth _ amt = ModifyBordering $ \dat ->
dat {borderingWidth = guard $ borderingWidth dat + amt}
where
guard x
| x < 1 / 12 = 1 / 12
| x > 4 / 12 = 4 / 12
| otherwise = x
changeHeight :: Proxy a -> Rational -> ModifyBordering a
changeHeight _ amt = ModifyBordering $ \dat ->
dat {borderingHeight = guard $ borderingHeight dat + amt}
where
guard x
| x < 1 / 12 = 1 / 12
| x > 4 / 12 = 4 / 12
| otherwise = x
instance Semigroup (ModifyBordering a) where
(<>) = mappend
instance Monoid (ModifyBordering a) where
mempty = ModifyBordering id
mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1)
move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a
move fn win = ModifyBordering $ \dat ->
let mKey = fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat)
in case mKey of
Nothing -> dat
Just key ->
let newKey =
until
(\k -> not (Map.member k (extraWindows dat) && k /= key))
fn
(fn key)
wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat
in dat {extraWindows = wins'}
moveForward :: (Eq a) => a -> ModifyBordering a
moveForward = move enumNext
moveBackward :: (Eq a) => a -> ModifyBordering a
moveBackward = move enumPrev
instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where
runLayout (W.Workspace t (Bordering dat l) as) rect = do
let (out, rest) = filterStack as
(rects, maybeNewLayout) <- runLayout (W.Workspace t l rest) rect
return (layoutRest out ++ rects, Bordering dat <$> maybeNewLayout)
where
filterStack Nothing = ([], Nothing)
filterStack (Just (W.Stack f h t)) = do
let elSet = Set.fromList (Map.elems $ extraWindows dat)
((hp, h'), (tp, t')) = dbl (partition (`Set.member` elSet)) (h, t)
in case (Set.member f elSet, h', t', hp ++ tp) of
(False, _, _, r) -> (r, Just $ W.Stack f h' t')
(True, (a : h''), _, r) -> (f : r, Just $ W.Stack a h'' t')
(True, [], (a : t''), r) -> (f : r, Just $ W.Stack a [] t'')
(True, [], [], r) -> (f : r, Nothing)
layoutRest windows =
map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $
filter ((`elem` windows) . snd) $
Map.toList (extraWindows dat)
padRect (Rectangle x y w h) =
let p :: (Integral a) => a
p = fromIntegral (borderingPadding dat)
in Rectangle (x + p) (y + p) (w - p * 2) (h - p * 2)
loc2Rect loc = case loc of
North -> W.RationalRect (1 / 2 - (bw / 2)) 0 bw bh
NorthEast -> W.RationalRect (1 - bw) 0 bw bh
East -> W.RationalRect (1 - bw) (1 / 2 - (bh / 2)) bw bh
SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh
South -> W.RationalRect (1 / 2 - (bw / 2)) (1 - bh) bw bh
SouthWest -> W.RationalRect 0 (1 - bh) bw bh
West -> W.RationalRect 0 (1 / 2 - (bh / 2)) bw bh
NorthWest -> W.RationalRect 0 0 bw bh
where
bw = borderingWidth dat
bh = borderingHeight dat
dbl f = f *** f
handleMessage (Bordering d l) m@(fromMessage -> Just e@DestroyWindowEvent {ev_window = w}) = do
maybeNewLayout <- handleMessage l m
return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout)
where
f e@BorderingData {extraWindows = ws} =
e {extraWindows = Map.filter (maybe True (/= w) . cast) ws}
handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) =
return (Just $ Bordering (fn d) l)
handleMessage (Bordering d l) a = do
maybeNewLayout <- handleMessage l a
return (Bordering d <$> maybeNewLayout)
|
