aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Util/Stack.hs
blob: 387bdbb4d058827719ee51113a7eb8f683fbe8ae (plain) (blame)
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
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
{-# LANGUAGE PatternGuards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.Stack
-- Copyright   :  Quentin Moser <moserq@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Quentin Moser <moserq@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Utility functions for manipulating @Maybe Stack@s.
--
-----------------------------------------------------------------------------

module XMonad.Util.Stack ( -- * Usage
                           -- | This is a developer-oriented module, intended to be used
                           -- for writing new extentions.
                           Zipper
                         , emptyZ
                         , singletonZ

                           -- * Conversions
                         , fromIndex
                         , toIndex
                         , fromTags
                         , toTags

                           -- * 'Zipper' manipulation functions
                           -- ** Insertion, movement
                         , insertUpZ
                         , insertDownZ
                         , swapUpZ
                         , swapDownZ
                         , swapMasterZ
                           -- ** Focus movement
                         , focusUpZ
                         , focusDownZ
                         , focusMasterZ
                           -- ** Extraction
                         , getFocusZ
                         , getIZ
                           -- ** Sorting
                         , sortZ
                         , sortByZ
                           -- ** Maps
                         , mapZ
                         , mapZ_
                         , mapZM
                         , mapZM_
                         , onFocusedZ
                         , onFocusedZM
                         , onIndexZ
                         , onIndexZM
                           -- ** Filters
                         , filterZ
                         , filterZ_
                         , deleteFocusedZ
                         , deleteIndexZ
                           -- ** Folds
                         , foldrZ
                         , foldlZ
                         , foldrZ_
                         , foldlZ_
                         , elemZ

                           -- * Other utility functions
                         , getI
                         , tagBy
                         , fromE
                         , mapE
                         , mapE_
                         , mapEM
                         , mapEM_
                         ) where

import qualified XMonad.StackSet as W
import Control.Monad (liftM)
import Data.List (sortBy)



type Zipper a = Maybe (W.Stack a)

emptyZ :: Zipper a
emptyZ = Nothing

singletonZ :: a -> Zipper a
singletonZ a = Just $ W.Stack a [] []

-- * Conversions

-- | Create a stack from a list, and the 0-based index of the focused element.
-- If the index is out of bounds, focus will go to the first element.
fromIndex :: [a] -> Int -> Zipper a
fromIndex as i = fromTags $ zipWith ($) (replicate i Left ++ [Right] ++ repeat Left) as

-- | Turn a stack into a list and the index of its focused element.
toIndex :: Zipper a -> ([a], Maybe Int)
toIndex Nothing = ([], Nothing)
toIndex (Just s) = (W.integrate s, Just $ length $ W.up s)

-- | Create a stack from a list of 'Either'-tagged values. Focus will go to
-- the first 'Right' value, or if there is none, to the first 'Left' one.
fromTags :: [Either a a] -> Zipper a
fromTags = finalize . foldr step ([], Nothing, [])
    where step (Right a) (u, Just f, d) = ([], Just a, u++f:d)
          step (Right a) (u, Nothing, d) = (u, Just a, d)
          step (Left a) (u, Just f, d) = (a:u, Just f, d)
          step (Left a) (u, Nothing, d) = (u, Nothing, a:d)
          finalize (u, Just f, d) = Just $ W.Stack f (reverse u) d
          finalize (u, Nothing, a:d) = Just $ W.Stack a (reverse u) d
          finalize (_, Nothing, []) = Nothing

-- | Turn a stack into an 'Either'-tagged list. The focused element
-- will be tagged with 'Right', the others with 'Left'.
toTags :: Zipper a -> [Either a a]
toTags Nothing = []
toTags (Just s) = map Left (reverse . W.up $ s) ++ [Right . W.focus $ s]
                  ++ map Left (W.down s)


-- * Zipper functions

-- ** Insertion, movement

-- | Insert an element before the focused one, and focus it
insertUpZ :: a -> Zipper a -> Zipper a
insertUpZ a Nothing = W.differentiate [a]
insertUpZ a (Just s) = Just s { W.focus = a , W.down = W.focus s : W.down s }

-- | Insert an element after the focused one, and focus it
insertDownZ :: a -> Zipper a -> Zipper a
insertDownZ a Nothing = W.differentiate [a]
insertDownZ a (Just s) = Just s { W.focus = a, W.up = W.focus s : W.up s }

-- | Swap the focused element with the previous one
swapUpZ :: Zipper a -> Zipper a
swapUpZ Nothing = Nothing
swapUpZ (Just s) | u:up <- W.up s = Just s { W.up = up, W.down = u:W.down s}
swapUpZ (Just s) = Just s { W.up = reverse (W.down s), W.down = [] }

-- | Swap the focused element with the next one
swapDownZ :: Zipper a -> Zipper a
swapDownZ Nothing = Nothing
swapDownZ (Just s) | d:down <- W.down s = Just s { W.down = down, W.up = d:W.up s }
swapDownZ (Just s) = Just s { W.up = [], W.down = reverse (W.up s) } 

-- | Swap the focused element with the first one
swapMasterZ :: Zipper a -> Zipper a
swapMasterZ Nothing = Nothing
swapMasterZ (Just (W.Stack f up down)) = Just $ W.Stack f [] (reverse up ++ down)

-- ** Focus movement

-- | Move the focus to the previous element
focusUpZ :: Zipper a -> Zipper a
focusUpZ Nothing = Nothing
focusUpZ (Just s) | u:up <- W.up s = Just $ W.Stack u up (W.focus s:W.down s)
focusUpZ (Just s) | null $ W.down s = Just s
focusUpZ (Just (W.Stack f _ down)) = Just $ W.Stack (last down) (reverse (init down) ++ [f]) []

-- | Move the focus to the next element
focusDownZ :: Zipper a -> Zipper a
focusDownZ Nothing = Nothing
focusDownZ (Just s) | d:down <- W.down s = Just $ W.Stack d (W.focus s:W.up s) down
focusDownZ (Just s) | null $ W.up s = Just s
focusDownZ (Just (W.Stack f up _)) = Just $ W.Stack (last up) [] (reverse (init up) ++ [f])

-- | Move the focus to the first element
focusMasterZ :: Zipper a -> Zipper a
focusMasterZ Nothing = Nothing
focusMasterZ (Just (W.Stack f up down)) | not $ null up
    = Just $ W.Stack (last up) [] (reverse (init up) ++ [f] ++ down)
focusMasterZ (Just s) = Just s

-- ** Extraction

-- | Get the focused element
getFocusZ :: Zipper a -> Maybe a
getFocusZ = fmap W.focus

-- | Get the element at a given index
getIZ :: Int -> Zipper a -> Maybe a
getIZ i = getI i . W.integrate'

-- ** Sorting

-- | Sort a stack of elements supporting 'Ord'
sortZ :: Ord a => Zipper a -> Zipper a
sortZ = sortByZ compare

-- | Sort a stack with an arbitrary sorting function
sortByZ :: (a -> a -> Ordering) -> Zipper a -> Zipper a
sortByZ f = fromTags . sortBy (adapt f) . toTags
    where adapt g e1 e2 = g (fromE e1) (fromE e2)

-- ** Maps
             
-- | Map a function over a stack. The boolean argument indcates whether
-- the current element is the focused one
mapZ :: (Bool -> a -> b) -> Zipper a -> Zipper b
mapZ f as = fromTags . map (mapE f) . toTags $ as

-- | 'mapZ' without the 'Bool' argument
mapZ_ :: (a -> b) -> Zipper a -> Zipper b
mapZ_ = mapZ . const

-- | Monadic version of 'mapZ'
mapZM :: Monad m => (Bool -> a -> m b) -> Zipper a -> m (Zipper b)
mapZM f as = fromTags `liftM` (mapM (mapEM f) . toTags) as


-- | Monadic version of 'mapZ_'
mapZM_ :: Monad m => (a -> m b) -> Zipper a -> m (Zipper b)
mapZM_ = mapZM . const

-- | Apply a function to the focused element
onFocusedZ :: (a -> a) -> Zipper a -> Zipper a
onFocusedZ f = mapZ $ \b a -> if b then f a else a

-- | Monadic version of 'onFocusedZ'
onFocusedZM :: Monad m => (a -> m a) -> Zipper a -> m (Zipper a)
onFocusedZM f = mapZM $ \b a -> if b then f a else return a

-- | Apply a function to the element at the given index
onIndexZ :: Int -> (a -> a) -> Zipper a -> Zipper a
onIndexZ i _ as | i < 0 = as
onIndexZ i f as = case splitAt i $ toTags as of
                    (before, []) -> fromTags before
                    (before, a:after) -> fromTags $ before ++ mapE (const f) a : after

-- | Monadic version of 'onIndexZ'
onIndexZM :: Monad m => Int -> (a -> m a) -> Zipper a -> m (Zipper a)
onIndexZM i f as = case splitAt i $ toTags as of
                     (before, []) -> return $ fromTags before
                     (before, a:after) -> do a' <- mapEM (const f) a
                                             return $ fromTags $ before ++ a' : after

-- ** Filters

-- | Fiter a stack according to a predicate. The refocusing behavior
-- mimics XMonad's usual one. The boolean argument indicates whether the current
-- element is the focused one.
filterZ :: (Bool -> a -> Bool) -> Zipper a -> Zipper a
filterZ _ Nothing = Nothing
filterZ p (Just s) = case ( p True (W.focus s)
                          , filter (p False) (W.up s)
                          , filter (p False) (W.down s) ) of
                       (True, up', down') -> Just s { W.up = up', W.down = down' }
                       (False, [], []) -> Nothing
                       (False, f:up', []) -> Just s { W.focus = f, W.up = up', W.down = [] }
                       (False, up', f:down') ->  Just s { W.focus = f
                                                        , W.up = up'
                                                        , W.down = down' }

-- | 'filterZ' without the 'Bool' argument
filterZ_ :: (a -> Bool) -> Zipper a -> Zipper a
filterZ_ = filterZ . const

-- | Delete the focused element
deleteFocusedZ :: Zipper a -> Zipper a
deleteFocusedZ = filterZ (\b _ -> not b)

-- | Delete the ith element
deleteIndexZ :: Int -> Zipper a -> Zipper a
deleteIndexZ i z = let numbered = (fromTags . zipWith number [0..] . toTags) z
                       number j ea = mapE (\_ a -> (j,a)) ea
                   in mapZ_ snd $ filterZ_ ((/=i) . fst) numbered

-- ** Folds

-- | Analogous to 'foldr'. The 'Bool' argument to the step functions indicates
-- whether the current element is the focused one
foldrZ :: (Bool -> a -> b -> b) -> b -> Zipper a -> b
foldrZ _ b Nothing = b
foldrZ f b (Just s) = let b1 = foldr (f False) b (W.down s)
                          b2 = f True (W.focus s) b1
                          b3 = foldl (flip $ f False) b2 (W.up s)
                      in b3

-- | Analogous to 'foldl'. The 'Bool' argument to the step functions indicates
-- whether the current element is the focused one
foldlZ :: (Bool -> b -> a -> b) -> b -> Zipper a -> b
foldlZ _ b Nothing = b
foldlZ f b (Just s) = let b1 = foldr (flip $ f False) b (W.up s)
                          b2 = f True b1 (W.focus s)
                          b3 = foldl (f False) b2 (W.down s)
                      in b3

-- | 'foldrZ' without the 'Bool' argument.
foldrZ_ :: (a -> b -> b) -> b -> Zipper a -> b
foldrZ_ = foldrZ . const

-- | 'foldlZ' without the 'Bool' argument.
foldlZ_ :: (b -> a -> b) -> b -> Zipper a -> b
foldlZ_ = foldlZ . const

-- | Find whether an element is present in a stack.
elemZ :: Eq a => a -> Zipper a -> Bool
elemZ a as = foldlZ_ step False as
    where step True _ = True
          step False a' = a' == a


-- * Other utility functions

-- | Safe version of '!!'
getI :: Int -> [a] -> Maybe a
getI _ [] = Nothing
getI 0 (a:_) = Just a
getI i (_:as) = getI (i-1) as

-- | Map a function across both 'Left's and 'Right's.
-- The 'Bool' argument is 'True' in a 'Right', 'False'
-- in a 'Left'.
mapE :: (Bool -> a -> b) -> Either a a -> Either b b
mapE f (Left a) = Left $ f False a
mapE f (Right a) = Right $ f True a

mapE_ :: (a -> b) -> Either a a -> Either b b
mapE_ = mapE . const

-- | Monadic version of 'mapE'
mapEM :: Monad m => (Bool -> a -> m b) -> Either a a -> m (Either b b)
mapEM f (Left a) = Left `liftM` f False a
mapEM f (Right a) = Right `liftM` f True a

mapEM_ :: Monad m => (a -> m b) -> Either a a -> m (Either b b)
mapEM_ = mapEM . const

-- | Get the @a@ from an @Either a a@
fromE :: Either a a -> a
fromE (Right a) = a
fromE (Left a) = a

-- | Tag the element with 'Right' if the property is true, 'Left' otherwise
tagBy :: (a -> Bool) -> a -> Either a a
tagBy p a = if p a then Right a else Left a