summaryrefslogtreecommitdiffstats
path: root/Operations.hs
blob: 952e5ace0010e221cc6d5774ee119e34c497f068 (plain)
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
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Operations.hs
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
-- 
-- Maintainer  :  dons@cse.unsw.edu.au
-- Stability   :  unstable
-- Portability :  not portable, mtl, posix
--
-----------------------------------------------------------------------------

module Operations where

import XMonad
import qualified StackSet as W
import {-# SOURCE #-} Config (borderWidth)

import Data.Maybe
import Data.List            (genericIndex, intersectBy, partition, delete)
import Data.Bits            ((.|.))
import Data.Ratio
import qualified Data.Map as M

import Control.Monad.State
import Control.Monad.Reader
import Control.Arrow

import System.IO
import Graphics.X11.Xlib
import Graphics.X11.Xinerama (getScreenInfo)
import Graphics.X11.Xlib.Extras

-- ---------------------------------------------------------------------
-- Window manager operations

-- | manage. Add a new window to be managed in the current workspace.
-- Bring it into focus. If the window is already managed, nothing happens.
--
manage :: Window -> X ()
manage w = withDisplay $ \d -> do
    io $ selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask
    io $ mapWindow d w
    io $ setWindowBorderWidth d w borderWidth

    -- FIXME: This is pretty awkward. We can't can't let "refresh" happen
    -- before the call to float, because that will resize the window and
    -- lose the default sizing.

    isTransient <- isJust `liftM` io (getTransientForHint d w)
    if isTransient
        then do modify $ \s -> s { windowset = W.insertUp w (windowset s) }
                float w -- ^^ now go the refresh.
        else windows $ W.insertUp w

-- | unmanage. A window no longer exists, remove it from the window
-- list, on whatever workspace it is.
--
-- FIXME: clearFloating should be taken care of in W.delete, but if we do it
-- there, floating status is lost when moving windows between workspaces,
-- because W.shift calls W.delete.
unmanage :: Window -> X ()
unmanage w = windows $ W.sink w . W.delete w

-- | focus. focus window up or down. or swap various windows.
focusUp, focusDown, swapUp, swapDown, swapMaster :: X ()
focusUp    = windows W.focusUp
focusDown  = windows W.focusDown
swapUp     = windows W.swapUp
swapDown   = windows W.swapDown
swapMaster = windows W.swapMaster

-- | shift. Move a window to a new workspace, 0 indexed.
shift :: WorkspaceId -> X ()
shift n = withFocused hide >> windows (W.shift n)
    -- refresh will raise it if we didn't need to move it.

-- | view. Change the current workspace to workspace at offset n (0 indexed).
view :: WorkspaceId -> X ()
view = windows . W.view

-- | Modify the size of the status gap at the top of the current screen
-- Taking a function giving the current screen, and current geometry.
modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X ()
modifyGap f = do
    XState { windowset = ws, statusGaps = gaps } <- get
    let n       = fromIntegral $ W.screen (W.current ws)
        (a,i:b) = splitAt n gaps
    modify $ \s -> s { statusGaps = a ++ f n i : b }
    refresh

-- | Kill the currently focused client. If we do kill it, we'll get a
-- delete notify back from X.
--
-- There are two ways to delete a window. Either just kill it, or if it
-- supports the delete protocol, send a delete event (e.g. firefox)
--
kill :: X ()
kill = withDisplay $ \d -> withFocused $ \w -> do
    XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask
    protocols <- io $ getWMProtocols d w
    io $ if wmdelt `elem` protocols
        then allocaXEvent $ \ev -> do
                setEventType ev clientMessage
                setClientMessageEvent ev w wmprot 32 wmdelt 0
                sendEvent d w False noEventMask ev
        else killClient d w >> return ()

-- ---------------------------------------------------------------------
-- Managing windows

-- | windows. Modify the current window list with a pure function, and refresh
windows :: (WindowSet -> WindowSet) -> X ()
windows f = do
    old  <- gets windowset
    let new = f old
    modify (\s -> s { windowset = new })
    refresh

    -- We now go to some effort to compute the minimal set of windows to hide.
    -- The minimal set being only those windows which weren't previously hidden,
    -- which is the intersection of previously visible windows with those now hidden
    mapM_ hide . concatMap (integrate . W.stack) $
        intersectBy (\w x -> W.tag w == W.tag x)
            (map W.workspace $ W.current old : W.visible old)
            (W.hidden new)

    clearEnterEvents

    -- TODO: move this into StackSet.  This isn't exactly the usual integrate.
 where integrate W.Empty        = []
       integrate (W.Node x l r) = x : l ++ r

-- | hide. Hide a window by moving it off screen.
hide :: Window -> X ()
hide w = withDisplay $ \d -> do
    (sw,sh) <- gets dimensions
    io $ moveWindow d w sw sh

-- | refresh. Render the currently visible workspaces, as determined by
-- the StackSet. Also, set focus to the focused window.
--
-- This is our 'view' operation (MVC), in that it pretty prints our model
-- with X calls.
--
refresh :: X ()
refresh = do
    XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get
    d <- asks display

    -- for each workspace, layout the currently visible workspaces
    (`mapM_` (W.current ws : W.visible ws)) $ \w -> do
        let n      = W.tag (W.workspace w)
            this   = W.view n ws
            Just l = fmap fst $ M.lookup n fls
            (flt, tiled) = partition (flip M.member (W.floating ws)) (W.index this)
            (Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w)
            (gt,gb,gl,gr)           = genericIndex gaps   (W.screen w)

        -- just the tiled windows:
        -- now tile the windows on this workspace, modified by the gap
        rs <- doLayout l (Rectangle (sx + fromIntegral gl)
                                    (sy + fromIntegral gt)
                                    (sw - fromIntegral (gl + gr))
                                    (sh - fromIntegral (gt + gb))) tiled
        mapM_ (\(win,rect) -> io (tileWindow d win rect)) rs

        -- now the floating windows:
        -- move/resize the floating windows, if there are any
        (`mapM_` flt) $ \fw -> whenJust (M.lookup fw (W.floating ws)) $
          \(W.RationalRect rx ry rw rh) -> do
            let Rectangle px py pw ph = genericIndex xinesc (W.screen w)
            io $ tileWindow d fw (Rectangle (px + floor (toRational pw*rx))
                                            (py + floor (toRational ph*ry))
                                            (floor (toRational pw*rw))
                                            (floor (toRational ph*rh)))

        -- TODO seems fishy?
        -- Urgh. This is required because the fullscreen layout assumes that
        -- the focused window will be raised. Hmm. This is a reordering.

        -- This really doesn't work with fullscreen mode, where 
        -- focus is used to find the raised window. moving the floating
        -- layer will move focus there, so we now have forgotten the
        -- window on the top of the fullscreen
        --
        -- I think the solution must be to track the floating layer separately
        -- in its own zipper, on each workspace. And from there to
        -- handle pushing between the two.
        --
        let tiled' = case W.peek this of
                        Just x | x `elem` tiled -> x : delete x tiled
                        _ -> tiled

        io $ restackWindows d (flt ++ tiled')

    setTopFocus
    clearEnterEvents
    -- withWindowSet (io . hPrint stderr) -- logging state changes!
--  io performGC -- really helps 

-- | clearEnterEvents.  Remove all window entry events from the event queue.
clearEnterEvents :: X ()
clearEnterEvents = withDisplay $ \d -> io $ do
    sync d False
    allocaXEvent $ \p -> fix $ \again -> do
        more <- checkMaskEvent d enterWindowMask p
        when more again -- beautiful

-- | tileWindow. Moves and resizes w such that it fits inside the given
-- rectangle, including its border.
tileWindow :: Display -> Window -> Rectangle -> IO ()
tileWindow d w r = do
    bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w
    moveResizeWindow d w (rect_x r) (rect_y r)
                         (rect_width  r - bw*2) (rect_height r - bw*2)

-- ---------------------------------------------------------------------

-- | rescreen.  The screen configuration may have changed (due to
-- xrandr), update the state and refresh the screen, and reset the gap.
rescreen :: X ()
rescreen = do
    xinesc <- withDisplay (io . getScreenInfo)

    -- TODO: This stuff is necessary because Xlib apparently caches screen
    -- width/height.  Find a better solution later.  I hate Xlib.
    let sx = maximum $ map (\r -> rect_x r + fromIntegral (rect_width  r)) xinesc
        sy = maximum $ map (\r -> rect_y r + fromIntegral (rect_height r)) xinesc

    modify (\s -> s { xineScreens = xinesc , dimensions  = (sx, sy)
                    , statusGaps  = take (length xinesc) $ (statusGaps s) ++ repeat (0,0,0,0) })

    windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) ->
        let (x:xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs
        in  ws { W.current = W.Screen x 0
               , W.visible = zipWith W.Screen xs [1 ..]
               , W.hidden  = ys }

-- ---------------------------------------------------------------------

-- | setButtonGrab. Tell whether or not to intercept clicks on a given window
setButtonGrab :: Bool -> Window -> X ()
setButtonGrab grab w = withDisplay $ \d -> io $
    if grab
        then flip mapM_ [button1, button2, button3] $ \b ->
            grabButton d b anyModifier w False buttonPressMask
                       grabModeAsync grabModeSync none none
        else ungrabButton d anyButton anyModifier w

-- ---------------------------------------------------------------------
-- Setting keyboard focus

-- | Set the focus to the window on top of the stack, or root
setTopFocus :: X ()
setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek

-- | Set focus explicitly to window 'w' if it is managed by us, or root.
-- This happens if X notices we've moved the mouse (and perhaps moved
-- the mouse to a new screen).
focus :: Window -> X ()
focus w = withWindowSet $ \s -> do
    if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> refresh
                    else whenX (isRoot w) $ setFocusX w -- we could refresh here, moving gap too.
    -- XXX a focus change could be caused by switching workspaces in xinerama.
    -- if so, and the gap is in use, the gap should probably follow the
    -- cursor to the new screen. 
    --
    -- to get the gap though, you need to trigger a refresh.

-- | Call X to set the keyboard focus details.
setFocusX :: Window -> X ()
setFocusX w = withWindowSet $ \ws -> do
    XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask

    -- clear mouse button grab and border on other windows
    (`mapM_` (W.current ws : W.visible ws)) $ \wk -> do
        (`mapM_` (W.index (W.view (W.tag (W.workspace wk)) ws))) $ \otherw -> do
            setButtonGrab True otherw
            io $ setWindowBorder dpy otherw (color_pixel nbc)

    whenX (not `liftM` isRoot w) $ do
        io $ do setInputFocus dpy w revertToPointerRoot 0
                -- raiseWindow dpy w
        setButtonGrab False w
        io $ setWindowBorder dpy w (color_pixel fbc)

-- ---------------------------------------------------------------------
-- Managing layout

-- | switchLayout.  Switch to another layout scheme.  Switches the
-- layout of the current workspace. By convention, a window set as
-- master in Tall mode remains as master in Wide mode. When switching
-- from full screen to a tiling mode, the currently focused window
-- becomes a master. When switching back , the focused window is
-- uppermost.
--
switchLayout :: X ()
switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs'))

-- | Throw an (extensible) message value to the current Layout scheme,
-- possibly modifying how we layout the windows, then refresh.
--
-- TODO, this will refresh on Nothing.
--
sendMessage :: Message a => a -> X ()
sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a))

--
-- Builtin layout algorithms:
--
--   fullscreen mode
--   tall mode
--   wide mode
-- 
-- The latter algorithms support the following operations:
--
--      Shrink
--      Expand
--

data Resize = Shrink | Expand deriving Typeable
instance Message Resize

data IncMasterN = IncMasterN Int deriving Typeable
instance Message IncMasterN

full :: Layout
full = Layout { doLayout     = \sc ws -> return [ (w,sc) | w <- ws ]
              , modifyLayout = const Nothing } -- no changes

tall, wide :: Int -> Rational -> Rational -> Layout
wide nmaster delta frac = mirrorLayout (tall nmaster delta frac)

tall nmaster delta frac =
    Layout { doLayout     = \r -> return . ap zip (tile frac r nmaster . length)
           , modifyLayout = \m -> fmap resize     (fromMessage m) `mplus`
                                  fmap incmastern (fromMessage m) }

    where resize Shrink = tall nmaster delta (frac-delta)
          resize Expand = tall nmaster delta (frac+delta)
          incmastern (IncMasterN d) = tall (max 1 (nmaster+d)) delta frac

-- | Mirror a rectangle
mirrorRect :: Rectangle -> Rectangle
mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)

-- | Mirror a layout
mirrorLayout :: Layout -> Layout
mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) =
              Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w
                     , modifyLayout = fmap mirrorLayout . ml }

-- | tile.  Compute the positions for windows in our default tiling modes
-- Tiling algorithms in the core should satisify the constraint that
--
--  * no windows overlap
--  * no gaps exist between windows.
--
tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle]
tile f r nmaster n | n <= nmaster = splitVertically n r
                   | otherwise    = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2
    where (r1,r2) = splitHorizontallyBy f r

splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle]
splitVertically n r | n < 2 = [r]
splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
    splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh))
    where smallh = sh `div` fromIntegral n
splitHorizontally n r = map mirrorRect $ splitVertically n $ mirrorRect r

splitHorizontallyBy, splitVerticallyBy :: Rational -> Rectangle -> (Rectangle, Rectangle)
splitHorizontallyBy f (Rectangle sx sy sw sh) =
    (Rectangle sx sy leftw sh, Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh)
        where leftw = floor $ fromIntegral sw * f
splitVerticallyBy f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ splitHorizontallyBy f $ mirrorRect r

------------------------------------------------------------------------

-- | layout. Modify the current workspace's layout with a pure
-- function and refresh.
layout :: ((Layout, [Layout]) -> (Layout, [Layout])) -> X ()
layout f = do
    modify $ \s ->
        let n          = W.tag . W.workspace . W.current . windowset $ s
            (Just fl)  = M.lookup n $ layouts s
        in s { layouts = M.insert n (f fl) (layouts s) }
    refresh

------------------------------------------------------------------------
-- Utilities

-- | Return workspace visible on screen 'sc', or 0.
screenWorkspace :: ScreenId -> X WorkspaceId
screenWorkspace sc = withWindowSet $ return . fromMaybe 0 . W.lookupWorkspace sc

-- | Apply an X operation to the currently focused window, if there is one.
withFocused :: (Window -> X ()) -> X ()
withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f

-- | True if window is under management by us
isClient :: Window -> X Bool
isClient w = withWindowSet $ return . W.member w

------------------------------------------------------------------------
-- | Floating layer support

-- | Make a floating window tiled
sink :: Window -> X ()
sink = windows . W.sink

-- | Make a tiled window floating, using its suggested rectangle
float :: Window -> X ()
float w = withDisplay $ \d -> do
    xinesc <- gets xineScreens
    sc     <- (genericIndex xinesc . W.screen . W.current) `liftM` gets windowset
    wa     <- io $ getWindowAttributes d w
    let bw = fi . wa_border_width $ wa
    windows $ W.float w
        (W.RationalRect ((fi (wa_x wa) - fi (rect_x sc)) % fi (rect_width sc))
                        ((fi (wa_y wa) - fi (rect_y sc)) % fi (rect_height sc))
                        (fi (wa_width  wa + bw*2) % fi (rect_width sc))
                        (fi (wa_height wa + bw*2) % fi (rect_height sc)))
  where fi x = fromIntegral x

-- | Toggle floating bit
--
-- TODO not useful unless we remember the original size
--
-- toggleFloating :: Window -> X ()
-- toggleFloating w = gets windowset >>= \ws -> if M.member w (W.floating ws) then sink w else float w

------------------------------------------------------------------------
-- mouse handling

-- | Accumulate mouse motion events
mouseDrag :: (XMotionEvent -> IO ()) -> X ()
mouseDrag f = do
    XConf { theRoot = root, display = d } <- ask
    io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
            grabModeAsync grabModeAsync none none currentTime
    io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop
        maskEvent d (buttonReleaseMask .|. pointerMotionMask) p
        et <- get_EventType p
        when (et == motionNotify) $ get_MotionEvent p >>= f >> again
    io $ ungrabPointer d currentTime

mouseMoveWindow :: Window -> X ()
mouseMoveWindow w = withDisplay $ \d -> do
    io $ raiseWindow d w
    wa <- io $ getWindowAttributes d w
    (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w
    mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) ->
        moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
                       (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))
    float w

mouseResizeWindow :: Window -> X ()
mouseResizeWindow w = withDisplay $ \d -> do
    io $ raiseWindow d w
    wa <- io $ getWindowAttributes d w
    io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa))
                                      (fromIntegral (wa_height wa))
    mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) ->
        resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa))))
                         (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))
    float w