139 lines
5.1 KiB
Haskell
139 lines
5.1 KiB
Haskell
|
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, PatternGuards, DeriveDataTypeable #-}
|
||
|
|
|
||
|
|
module FullscreenManager (
|
||
|
|
manageFullscreen,
|
||
|
|
handleFullscreen,
|
||
|
|
doFullscreen,
|
||
|
|
doFloatMaybeFullscreen,
|
||
|
|
setFullscreen,
|
||
|
|
unsetFullscreen,
|
||
|
|
setFullscreenFloat,
|
||
|
|
unsetFullscreenFloat
|
||
|
|
) where
|
||
|
|
|
||
|
|
import XMonad
|
||
|
|
import qualified XMonad.StackSet as W
|
||
|
|
import XMonad.Hooks.ManageHelpers (isFullscreen)
|
||
|
|
|
||
|
|
import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..))
|
||
|
|
import Graphics.X11.Types (Window)
|
||
|
|
|
||
|
|
import Control.Monad
|
||
|
|
import Control.Monad.Trans
|
||
|
|
import Data.List
|
||
|
|
import Data.Maybe
|
||
|
|
import Data.Monoid
|
||
|
|
import qualified Data.Set as S
|
||
|
|
import qualified Data.Map as M
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
data SetFullscreen = SetFullscreen Window Bool Bool deriving Typeable
|
||
|
|
|
||
|
|
instance Message SetFullscreen
|
||
|
|
|
||
|
|
|
||
|
|
data FullscreenManager a = FullscreenManager (M.Map a W.RationalRect)
|
||
|
|
deriving (Show, Read)
|
||
|
|
|
||
|
|
manageFullscreen :: (LayoutClass l a) =>
|
||
|
|
l a
|
||
|
|
-> ModifiedLayout FullscreenManager l a
|
||
|
|
manageFullscreen = ModifiedLayout $ FullscreenManager M.empty
|
||
|
|
|
||
|
|
|
||
|
|
instance LayoutModifier FullscreenManager Window where
|
||
|
|
modifierDescription _ = "FullscreenManager"
|
||
|
|
|
||
|
|
handleMess (FullscreenManager wm) m
|
||
|
|
| Just (SetFullscreen win fs ff) <- fromMessage m = do
|
||
|
|
let ptype = 4
|
||
|
|
state <- getAtom "_NET_WM_STATE"
|
||
|
|
fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"
|
||
|
|
winstate <- withDisplay $ \dpy -> io $ getWindowProperty32 dpy state win
|
||
|
|
let stateset = S.fromList $ fromMaybe [] winstate
|
||
|
|
|
||
|
|
if fs then do
|
||
|
|
floats <- isFloating win
|
||
|
|
let float = if ff then True else floats
|
||
|
|
(_,loc) <- floatLocation win
|
||
|
|
|
||
|
|
let wmnew = if float then
|
||
|
|
M.union wm $ M.singleton win loc
|
||
|
|
else
|
||
|
|
wm
|
||
|
|
withDisplay $ \dpy -> io $ changeProperty32 dpy win state ptype propModeReplace $ S.toList $ S.insert (fromIntegral fullsc) stateset
|
||
|
|
fullscreenWin win
|
||
|
|
return $ Just $ FullscreenManager wmnew
|
||
|
|
else do
|
||
|
|
let float = if ff then True else M.member win wm
|
||
|
|
withDisplay $ \dpy -> io $ changeProperty32 dpy win state ptype propModeReplace $ S.toList $ S.delete (fromIntegral fullsc) stateset
|
||
|
|
if float then do
|
||
|
|
(_,defloc) <- floatLocation win
|
||
|
|
let loc = M.findWithDefault defloc win wm
|
||
|
|
floatWin win loc
|
||
|
|
else
|
||
|
|
tileWin win
|
||
|
|
return $ Just $ FullscreenManager $ M.delete win wm
|
||
|
|
|
||
|
|
handleMess _ _ = return Nothing
|
||
|
|
|
||
|
|
redoLayout (FullscreenManager wm) _ _ wrs = do
|
||
|
|
ws <- gets windowset
|
||
|
|
let wmnew = M.filterWithKey (\w _ -> M.member w $ W.floating ws) wm
|
||
|
|
return (wrs, Just $ FullscreenManager $ wmnew)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
isFloating :: Window -> X (Bool)
|
||
|
|
isFloating w = gets windowset >>= \ws -> return $ M.member w (W.floating ws)
|
||
|
|
|
||
|
|
|
||
|
|
doFullscreen :: ManageHook
|
||
|
|
doFullscreen = Query $ do
|
||
|
|
w <- ask
|
||
|
|
lift $ setFullscreen w
|
||
|
|
return $ Endo id
|
||
|
|
|
||
|
|
doFloatMaybeFullscreen :: ManageHook
|
||
|
|
doFloatMaybeFullscreen = Query $ do
|
||
|
|
w <- ask
|
||
|
|
isFull <- lift $ runQuery isFullscreen w
|
||
|
|
lift $ if isFull then setFullscreenFloat w else unsetFullscreenFloat w
|
||
|
|
return $ Endo id
|
||
|
|
|
||
|
|
|
||
|
|
setFullscreen, unsetFullscreen, setFullscreenFloat, unsetFullscreenFloat :: Window -> X ()
|
||
|
|
setFullscreen w = sendMessage $ SetFullscreen w True False
|
||
|
|
unsetFullscreen w = sendMessage $ SetFullscreen w False False
|
||
|
|
setFullscreenFloat w = sendMessage $ SetFullscreen w True True
|
||
|
|
unsetFullscreenFloat w = sendMessage $ SetFullscreen w False True
|
||
|
|
|
||
|
|
fullscreenWin, tileWin :: Window -> X ()
|
||
|
|
fullscreenWin w = windows $ W.float w $ W.RationalRect 0 0 1 1
|
||
|
|
tileWin w = windows $ W.sink w
|
||
|
|
|
||
|
|
floatWin :: Window -> W.RationalRect -> X ()
|
||
|
|
floatWin w loc = windows $ W.float w loc
|
||
|
|
|
||
|
|
|
||
|
|
handleFullscreen :: Event -> X All
|
||
|
|
handleFullscreen (ClientMessageEvent _ _ _ _ win typ dat) = do
|
||
|
|
state <- getAtom "_NET_WM_STATE"
|
||
|
|
fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"
|
||
|
|
isFull <- runQuery isFullscreen win
|
||
|
|
|
||
|
|
-- Constants for the _NET_WM_STATE protocol
|
||
|
|
let remove = 0
|
||
|
|
add = 1
|
||
|
|
toggle = 2
|
||
|
|
action = head dat
|
||
|
|
|
||
|
|
when (typ == state && (fromIntegral fullsc) `elem` tail dat) $ do
|
||
|
|
when (action == add || (action == toggle && not isFull)) $ setFullscreen win
|
||
|
|
when (head dat == remove || (action == toggle && isFull)) $ unsetFullscreen win
|
||
|
|
|
||
|
|
return $ All True
|
||
|
|
|
||
|
|
handleFullscreen _ = return $ All True
|