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
|
module Wetterhorn.StackSet where
import Control.Monad.Identity
import Control.Monad.Writer (First (..), MonadWriter (tell), execWriter)
import Data.Maybe (isJust)
-- | The root datastructure for holding the state of the windows.
data StackSet s sd t l a = StackSet
{ -- | The currently selected screen.
current :: Screen s sd t l a,
-- | Remaining visible screens.
visible :: [Screen s sd t l a],
-- | Workspaces that exist, but are not on a screen.
hidden :: [Workspace t l a]
}
deriving (Read, Show, Eq, Ord)
class TraverseWorkspace f where
traverseWorkspaces ::
(Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a')
traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m ()
traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w)
foldMapWorkspaces ::
(Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m
foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn)
mapWorkspaces ::
(TraverseWorkspace f) =>
(Workspace t l a -> Workspace t' l' a') ->
f t l a ->
f t' l' a'
mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn)
instance TraverseWorkspace Workspace where
traverseWorkspaces f = f
instance TraverseWorkspace (Screen s sd) where
traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr)
instance TraverseWorkspace (StackSet s sd) where
traverseWorkspaces f (StackSet cur vis hid) =
StackSet
<$> traverseWorkspaces f cur
<*> traverse (traverseWorkspaces f) vis
<*> traverse (traverseWorkspaces f) hid
instance Traversable Stack where
traverse f (Stack u d) =
Stack <$> traverse f u <*> traverse f d
instance (TraverseWorkspace f) => Foldable (f t l) where
foldMap fn =
execWriter
. traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s))
instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where
sequenceA =
traverseWorkspaces $
\(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf
class HasFocus f where
focused :: f a -> Maybe a
data Rectangle = Rectangle Int Int Int Int
deriving (Read, Show, Eq, Ord)
instance HasFocus (StackSet s sd t l) where
focused (StackSet c _ _) = focused c
data Screen s sd t l a = Screen
{ screenDetail :: sd,
screenId :: s,
workspace :: Workspace t l a
}
deriving (Read, Show, Eq, Ord, Functor)
instance HasFocus (Screen s sd t l) where
focused (Screen _ _ w) = focused w
-- | Defines where a window should appear.
data WindowSeat a = Floating Rectangle a | Tiled a
deriving (Read, Show, Eq, Ord, Functor, Foldable)
windowInSeat :: WindowSeat a -> a
windowInSeat (Floating _ a) = a
windowInSeat (Tiled a) = a
instance Traversable WindowSeat where
sequenceA (Floating r fa) = Floating r <$> fa
sequenceA (Tiled fa) = Tiled <$> fa
instance HasFocus WindowSeat where
focused (Floating _ a) = Just a
focused (Tiled a) = Just a
data Workspace t l a = Workspace
{ tag :: t,
layout :: l,
stack :: Stack (WindowSeat a)
}
deriving (Read, Show, Eq, Ord, Functor)
instance HasFocus (Workspace t l) where
focused (Workspace _ _ s) = windowInSeat <$> focused s
data Stack a = Stack
{ -- | The elements above the focused one.
up :: ![a],
-- | The elements below the focused one including the focused one itself.
down :: ![a]
}
deriving (Read, Show, Eq, Ord, Functor, Foldable)
instance HasFocus Stack where
focused (Stack _ (a : _)) = Just a
focused _ = Nothing
-- | Change the tag in a structure.
mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a
mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)})
-- | Change the layout in a structure.
mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a
mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)})
-- | Return all the tags in a structure.
tags :: (TraverseWorkspace f) => f t l a -> [t]
tags = foldMapWorkspaces ((: []) . tag)
-- | Insert a new window into the StackSet. The optional rectangle indicates if
-- the window should be floating or tiled.
--
-- The window is inserted just above the the currently focused window and is
-- given focus.
insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a
insert win rect =
runIdentity
. onCurrentStack
( \(Stack u d) ->
return $
(\w -> Stack u (w : d)) $
maybe (Tiled win) (`Floating` win) rect
)
-- | Find the tag associated with a window.
findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t
findTag a =
getFirst
. foldMapWorkspaces
( \ws ->
foldMap
( \a' ->
First $ if a' == a then Just (tag ws) else Nothing
)
ws
)
-- | Return true if the window exist in a structure
elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool
elem a = isJust . findTag a
-- | Convenience function for inserting a window in stack set tiled.
insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a
insertTiled win = insert win Nothing
applyStack ::
(Monad m) =>
(Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
Workspace t l a ->
m (Workspace t l a)
applyStack fn (Workspace t l s) = Workspace t l <$> fn s
-- | Apply a function to the currently focused stack.
onCurrentStack ::
(Monad m) =>
(Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
StackSet s sd t l a ->
m (StackSet s sd t l a)
onCurrentStack fn (StackSet cur vis hid) =
StackSet <$> cur' cur <*> pure vis <*> pure hid
where
cur' (Screen s sd ws) = Screen s sd <$> ws' ws
ws' (Workspace t l s) = Workspace t l <$> fn s
|
