summaryrefslogtreecommitdiffstats
path: root/Operations.hs
blob: 889d03cfb741aca8e1d1261c144ddba8069848e1 (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
module Operations where

import Data.List
import Data.Maybe
import Data.Bits
import qualified Data.Map as M

import Control.Monad.State

import System.Posix.Process
import System.Environment

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras

import XMonad

import qualified StackSet as W


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

-- | refresh. Refresh the currently focused window. Resizes to full
-- screen and raises the window.
refresh :: X ()
refresh = do
    XState {workspace = ws, wsOnScreen = ws2sc, xineScreens = xinesc
           ,display   = d ,layoutDescs = fls  ,defaultLayoutDesc = dfltfl } <- get

    flip mapM_ (M.assocs ws2sc) $ \(n, scn) -> do
        let sc = xinesc !! scn
            fl = M.findWithDefault dfltfl n fls
        mapM_ (\(w, Rectangle a b c e) -> io $ moveResizeWindow d w a b c e) $
            case layoutType fl of
                Full -> fmap (flip (,) sc) $ maybeToList $ W.peekStack n ws
                Tall -> tile (tileFraction fl) sc $ W.index n ws
                Wide -> vtile (tileFraction fl) sc $ W.index n ws
        whenJust (W.peekStack n ws) (io . raiseWindow d)
    whenJust (W.peek ws) setFocus

-- | tile.  Compute the positions for windows in horizontal layout
-- mode.
tile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)]
tile _ _ []    = []
tile _ d [w]   = [(w, d)]
tile r (Rectangle sx sy sw sh) (w:s) 
 = (w, Rectangle sx sy (fromIntegral lw) sh) : zipWith f [sy, sy + rh ..] s
 where
    lw = floor $ fromIntegral sw * r
    rw = sw - fromIntegral lw
    rh = fromIntegral sh `div` fromIntegral (length s)
    f i a = (a, Rectangle (sx + lw) i rw (fromIntegral rh))

-- | vtile. Tile vertically.
vtile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)]
vtile r rect ws = map (\(w, wr) -> (w, flipRect wr)) $ tile r (flipRect rect) ws

flipRect :: Rectangle -> Rectangle
flipRect (Rectangle { rect_x = x, rect_y = y, rect_width = w, rect_height = h })
        = Rectangle { rect_x = y, rect_y = x, rect_width = h, rect_height = w }

-- | switchLayout.  Switch to another layout scheme.  Switches the
-- current workspace.
switchLayout :: X ()
switchLayout = layout $ \fl -> fl { layoutType = rot (layoutType fl) }

-- | changeSplit.  Changes the window split.
changeSplit :: Rational -> X ()
changeSplit delta = layout $ \fl ->
    fl { tileFraction = min 1 (max 0 (tileFraction fl + delta)) }

-- | layout. Modify the current workspace's layout with a pure
-- function and refresh.
layout :: (LayoutDesc -> LayoutDesc) -> X ()
layout f = do
    modify $ \s ->
        let fls = layoutDescs s
            n   = W.current . workspace $ s
            fl  = M.findWithDefault (defaultLayoutDesc s) n fls
        in s { layoutDescs = M.insert n (f fl) fls }
    refresh

-- | windows. Modify the current window list with a pure function, and refresh
windows :: (WorkSpace -> WorkSpace) -> X ()
windows f = do
    modify $ \s -> s { workspace = f (workspace s) }
    refresh
    ws <- gets workspace
    trace (show ws) -- log state changes to stderr

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

-- ---------------------------------------------------------------------
-- Window operations

-- | setButtonGrab. Tell whether or not to intercept clicks on a given window
buttonsToGrab :: [Button]
buttonsToGrab = [button1, button2, button3]

setButtonGrab :: Bool -> Window -> X ()
setButtonGrab True  w = withDisplay $ \d -> io $
    flip mapM_ buttonsToGrab $ \b ->
        grabButton d b anyModifier w False
                   (buttonPressMask .|. buttonReleaseMask)
                   grabModeAsync grabModeSync none none

setButtonGrab False w = withDisplay $ \d -> io $
    flip mapM_ buttonsToGrab $ \b ->
        ungrabButton d b anyModifier w

-- | manage. Add a new window to be managed in the current workspace. Bring it into focus.
-- If the window is already under management, it is just raised.
--
-- When we start to manage a window, it gains focus.
--
manage :: Window -> X ()
manage w = do
    withDisplay $ \d -> io $ do
        selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask
        mapWindow d w
    setFocus w
    windows $ W.push w

-- | unmanage. A window no longer exists, remove it from the window
-- list, on whatever workspace it is.
unmanage :: Window -> X ()
unmanage w = do
    windows $ W.delete w
    withServerX $ do
      setTopFocus
      withDisplay $ \d -> io (sync d False)
      -- TODO, everything operates on the current display, so wrap it up.

-- | Grab the X server (lock it) from the X monad
withServerX :: X () -> X ()
withServerX f = withDisplay $ \dpy -> do
    io $ grabServer dpy
    f
    io $ ungrabServer dpy

safeFocus :: Window -> X ()
safeFocus w = do ws <- gets workspace
                 if W.member w ws
                    then setFocus w
                    else do b <- isRoot w
                            when b setTopFocus

-- | Explicitly set the keyboard focus to the given window
setFocus :: Window -> X ()
setFocus w = do
    XState { workspace = ws, wsOnScreen = ws2sc} <- get

    -- clear mouse button grab and border on other windows
    flip mapM_ (M.keys ws2sc) $ \n -> do
        flip mapM_ (W.index n ws) $ \otherw -> do
            setButtonGrab True otherw
            setBorder otherw 0xdddddd

    withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0
    setButtonGrab False w
    setBorder w 0xff0000    -- make this configurable

    -- This does not use 'windows' intentionally.  'windows' calls refresh,
    -- which means infinite loops.
    modify $ \s -> s { workspace = W.raiseFocus w (workspace s) }

-- | Set the focus to the window on top of the stack, or root
setTopFocus :: X ()
setTopFocus = do
    ws <- gets workspace
    case W.peek ws of
        Just new -> setFocus new
        Nothing  -> gets theRoot >>= setFocus

-- | Set the border color for a particular window.
setBorder :: Window -> Pixel -> X ()
setBorder w p = withDisplay $ \d -> io $ setWindowBorder d w p

-- | raise. focus to window at offset 'n' in list.
-- The currently focused window is always the head of the list
raise :: Ordering -> X ()
raise = windows . W.rotate

-- | promote.  Make the focused window the master window in its
-- workspace
--
-- TODO: generic cycling clockwise and anticlockwise
--
promote :: X ()
promote = windows $ \w -> maybe w (\k -> W.promote k w) (W.peek w)

-- | Kill the currently focused client
kill :: X ()
kill = withDisplay $ \d -> do
    ws <- gets workspace
    whenJust (W.peek ws) $ \w -> do
        protocols <- io $ getWMProtocols d w
        XState {wmdelete = wmdelt, wmprotocols = wmprot} <- get
        if wmdelt `elem` protocols
            then io $ allocaXEvent $ \ev -> do
                    setEventType ev clientMessage
                    setClientMessageEvent ev w wmprot 32 wmdelt 0
                    sendEvent d w False noEventMask ev
            else io (killClient d w) >> return ()

-- | tag. Move a window to a new workspace
tag :: Int -> X ()
tag o = do
    ws <- gets workspace
    let m = W.current ws
    when (n /= m) $
        whenJust (W.peek ws) $ \w -> do
            hide w
            windows $ W.shift n
    where n = o-1

-- | view. Change the current workspace to workspce at offset 'n-1'.
view :: Int -> X ()
view o = do
    XState { workspace = ws, wsOnScreen = ws2sc } <- get
    let m = W.current ws
    -- is the workspace we want to switch to currently visible?
    if M.member n ws2sc
        then windows $ W.view n
        else do
            sc <- case M.lookup m ws2sc of
                Nothing -> do
                    trace "Current workspace isn't visible! This should never happen!"
                    -- we don't know what screen to use, just use the first one.
                    return 0
                Just sc -> return sc
            modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) }
            gets wsOnScreen >>= trace . show
            windows $ W.view n
            mapM_ hide (W.index m ws)
    setTopFocus
    where n = o-1

-- | True if window is under management by us
isClient :: Window -> X Bool
isClient w = liftM (W.member w) (gets workspace)

-- | screenWS. Returns the workspace currently visible on screen n
screenWS :: Int -> X Int
screenWS n = do
    ws2sc <- gets wsOnScreen
    -- FIXME: It's ugly to have to query this way. We need a different way to
    -- keep track of screen <-> workspace mappings.
    let ws = fmap fst $ find (\(_, scn) -> scn == (n-1)) (M.assocs ws2sc)
    return $ (fromMaybe 0 ws) + 1

-- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has
-- to be in PATH for this to work.
restart :: IO ()
restart = do
    prog <- getProgName
    args <- getArgs
    executeFile prog True args Nothing

-- | Starts dmenu on the current screen. (Requires patches to dmenu for the -x
-- and -w options.)
dmenu :: X ()
dmenu = do
    XState { xineScreens = xinesc, workspace = ws, wsOnScreen = ws2sc } <- get
    let curscreen = fromMaybe 0 (M.lookup (W.current ws) ws2sc)
        sc = xinesc !! curscreen
    spawn $ concat [ "exe=`dmenu_path | dmenu -x ", show (rect_x sc)
                   , " -w " , show (rect_width sc) , "` && exec $exe" ]