aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Layout/Fullscreen.hs
blob: a5286a26062df2df018b579dd2ea6fd561ef6688 (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
{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Decoration
-- Copyright   :  (c) 2010 Audun Skaugen
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  audunskaugen@gmail.com
-- Stability   :  unstable
-- Portability :  unportable
--
-- Hooks for sending messages about fullscreen windows to layouts, and
-- a few example layout modifier that implement fullscreen windows.
-----------------------------------------------------------------------------
module XMonad.Layout.Fullscreen
    ( -- * Usage:
      -- $usage
     fullscreenFull
    ,fullscreenFocus
    ,fullscreenFullRect
    ,fullscreenFocusRect
    ,fullscreenFloat
    ,fullscreenFloatRect
    ,fullscreenEventHook
    ,fullscreenManageHook
    ,fullscreenManageHookWith
    ,FullscreenMessage(..)
     -- * Types for reference
    ,FullscreenFloat, FullscreenFocus, FullscreenFull
    ) where

import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Util.WindowProperties
import XMonad.Hooks.ManageHelpers (isFullscreen)
import qualified XMonad.StackSet as W
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as M
import Control.Monad
import Control.Arrow (second)

-- $usage
-- Provides a ManageHook and an EventHook that sends layout messages
-- with information about fullscreening windows. This allows layouts
-- to make their own decisions about what they should to with a
-- window that requests fullscreen.
--
-- The module also includes a few layout modifiers as an illustration
-- of how such layouts should behave.
--
-- To use this module, add 'fullscreenEventHook' and 'fullscreenManageHook'
-- to your config, i.e.
--
-- > xmonad defaultconfig { eventHook = fullscreenEventHook,
-- >                        manageHook = fullscreenManageHook,
-- >                        layoutHook = myLayouts }
--
-- Now you can use layouts that respect fullscreen, for example the
-- provided 'fullscreenFull':
--
-- > myLayouts = fullscreenFull someLayout
--

-- | Messages that control the fullscreen state of the window.
-- AddFullscreen and RemoveFullscreen are sent to all layouts
-- when a window wants or no longer wants to be fullscreen.
-- FullscreenChanged is sent to the current layout after one
-- of the above have been sent.
data FullscreenMessage = AddFullscreen Window
                       | RemoveFullscreen Window
                       | FullscreenChanged
     deriving (Typeable)

instance Message FullscreenMessage

data FullscreenFull a = FullscreenFull W.RationalRect [a]
     deriving (Read, Show)

data FullscreenFocus a = FullscreenFocus W.RationalRect [a]
     deriving (Read, Show)

data FullscreenFloat a = FullscreenFloat W.RationalRect (M.Map a (W.RationalRect, Bool))
     deriving (Read, Show)

instance LayoutModifier FullscreenFull Window where
  pureMess ff@(FullscreenFull frect fulls) m = case fromMessage m of
    Just (AddFullscreen win) -> Just $ FullscreenFull frect $ nub $ win:fulls
    Just (RemoveFullscreen win) -> Just $ FullscreenFull frect $ delete win $ fulls
    Just FullscreenChanged -> Just ff
    _ -> Nothing

  pureModifier (FullscreenFull frect fulls) rect _ list =
    (map (flip (,) rect') visfulls ++ rest, Nothing)
    where visfulls = intersect fulls $ map fst list
          rest = filter (flip notElem visfulls . fst) list
          rect' = scaleRationalRect rect frect

instance LayoutModifier FullscreenFocus Window where
  pureMess ff@(FullscreenFocus frect fulls) m = case fromMessage m of
    Just (AddFullscreen win) -> Just $ FullscreenFocus frect $ nub $ win:fulls
    Just (RemoveFullscreen win) -> Just $ FullscreenFocus frect $ delete win $ fulls
    Just FullscreenChanged -> Just ff
    _ -> Nothing

  pureModifier (FullscreenFocus frect fulls) rect (Just (W.Stack {W.focus = f})) list
     | f `elem` fulls = ((f, rect') : rest, Nothing)
     | otherwise = (list, Nothing)
     where rest = filter ((/= f) . fst) list
           rect' = scaleRationalRect rect frect
  pureModifier _ _ Nothing list = (list, Nothing)

instance LayoutModifier FullscreenFloat Window where
  handleMess (FullscreenFloat frect fulls) m = case fromMessage m of
    Just (AddFullscreen win) -> do
      mrect <- (M.lookup win . W.floating) `fmap` gets windowset
      return $ case mrect of
        Just rect -> Just $ FullscreenFloat frect $ M.insert win (rect,True) fulls
        Nothing -> Nothing

    Just (RemoveFullscreen win) ->
      return $ Just $ FullscreenFloat frect $ M.adjust (second $ const False) win fulls

    -- Modify the floating member of the stack set directly; this is the hackish part.
    Just FullscreenChanged -> do
      state <- get
      let ws = windowset state
          flt = W.floating ws
          flt' = M.intersectionWith doFull fulls flt
      put state {windowset = ws {W.floating = M.union flt' flt}}
      return $ Just $ FullscreenFloat frect $ M.filter snd fulls
      where doFull (_, True) _ = frect
            doFull (rect, False) _ = rect

    Nothing -> return Nothing

-- | Layout modifier that makes fullscreened window fill the
-- entire screen.
fullscreenFull :: LayoutClass l a =>
  l a -> ModifiedLayout FullscreenFull l a
fullscreenFull = fullscreenFullRect $ W.RationalRect 0 0 1 1

-- | As above, but the fullscreened window will fill the
-- specified rectangle instead of the entire screen.
fullscreenFullRect :: LayoutClass l a =>
  W.RationalRect -> l a -> ModifiedLayout FullscreenFull l a
fullscreenFullRect r = ModifiedLayout $ FullscreenFull r []

-- | Layout modifier that makes the fullscreened window fill
-- the entire screen only if it is currently focused.
fullscreenFocus :: LayoutClass l a =>
  l a -> ModifiedLayout FullscreenFocus l a
fullscreenFocus = fullscreenFocusRect $ W.RationalRect 0 0 1 1

-- | As above, but the fullscreened window will fill the
-- specified rectangle instead of the entire screen.
fullscreenFocusRect :: LayoutClass l a =>
  W.RationalRect -> l a -> ModifiedLayout FullscreenFocus l a
fullscreenFocusRect r = ModifiedLayout $ FullscreenFocus r []

-- | Hackish layout modifier that makes floating fullscreened
-- windows fill the entire screen.
fullscreenFloat :: LayoutClass l a =>
  l a -> ModifiedLayout FullscreenFloat l a
fullscreenFloat = fullscreenFloatRect $ W.RationalRect 0 0 1 1

-- | As above, but the fullscreened window will fill the
-- specified rectangle instead of the entire screen.
fullscreenFloatRect :: LayoutClass l a =>
  W.RationalRect -> l a -> ModifiedLayout FullscreenFloat l a
fullscreenFloatRect r = ModifiedLayout $ FullscreenFloat r M.empty

-- | The event hook required for the layout modifiers to work
fullscreenEventHook :: Event -> X All
fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do
  state <- getAtom "_NET_WM_STATE"
  fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"
  wstate <- fromMaybe [] `fmap` getProp32 state win
  let fi :: (Integral i, Num n) => i -> n
      fi = fromIntegral
      isFull = fi fullsc `elem` wstate
      remove = 0
      add = 1
      toggle = 2
      ptype = 4
      chWState f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate)
  when (typ == state && fi fullsc `elem` dats) $ do
    when (action == add || (action == toggle && not isFull)) $ do
      chWState (fi fullsc:)
      broadcastMessage $ AddFullscreen win
      sendMessage FullscreenChanged
    when (action == remove || (action == toggle && isFull)) $ do
      chWState $ delete (fi fullsc)
      broadcastMessage $ RemoveFullscreen win
      sendMessage FullscreenChanged
  return $ All True

fullscreenEventHook (DestroyWindowEvent {ev_window = w}) = do
  -- When a window is destroyed, the layouts should remove that window
  -- from their states.
  broadcastMessage $ RemoveFullscreen w
  cw <- (W.workspace . W.current) `fmap` gets windowset
  sendMessageWithNoRefresh FullscreenChanged cw
  return $ All True

fullscreenEventHook _ = return $ All True

-- | Manage hook that sets the fullscreen property for
-- windows that are initially fullscreen
fullscreenManageHook :: ManageHook
fullscreenManageHook = fullscreenManageHook' isFullscreen

-- | A version of fullscreenManageHook that lets you specify
-- your own query to decide whether a window should be fullscreen.
fullscreenManageHookWith :: Query Bool -> ManageHook
fullscreenManageHookWith h = fullscreenManageHook' $ isFullscreen <||> h

fullscreenManageHook' :: Query Bool -> ManageHook
fullscreenManageHook' isFull = isFull --> do
  w <- ask
  liftX $ do
    broadcastMessage $ AddFullscreen w
    cw <- (W.workspace . W.current) `fmap` gets windowset
    sendMessageWithNoRefresh FullscreenChanged cw
  idHook