{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}
module XMonad.Layout.Fullscreen
(
fullscreenSupport
,fullscreenFull
,fullscreenFocus
,fullscreenFullRect
,fullscreenFocusRect
,fullscreenFloat
,fullscreenFloatRect
,fullscreenEventHook
,fullscreenManageHook
,fullscreenManageHookWith
,FullscreenMessage(..)
,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)
fullscreenSupport :: LayoutClass l Window =>
XConfig l -> XConfig (ModifiedLayout FullscreenFull l)
fullscreenSupport c = c {
layoutHook = fullscreenFull $ layoutHook c,
handleEventHook = handleEventHook c <+> fullscreenEventHook,
manageHook = manageHook c <+> fullscreenManageHook
}
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 (not . (flip elem visfulls `orP` covers rect')) 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 (not . ((== f) `orP` covers rect')) 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
Just FullscreenChanged -> do
st <- get
let ws = windowset st
flt = W.floating ws
flt' = M.intersectionWith doFull fulls flt
put st {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
fullscreenFull :: LayoutClass l a =>
l a -> ModifiedLayout FullscreenFull l a
fullscreenFull = fullscreenFullRect $ W.RationalRect 0 0 1 1
fullscreenFullRect :: LayoutClass l a =>
W.RationalRect -> l a -> ModifiedLayout FullscreenFull l a
fullscreenFullRect r = ModifiedLayout $ FullscreenFull r []
fullscreenFocus :: LayoutClass l a =>
l a -> ModifiedLayout FullscreenFocus l a
fullscreenFocus = fullscreenFocusRect $ W.RationalRect 0 0 1 1
fullscreenFocusRect :: LayoutClass l a =>
W.RationalRect -> l a -> ModifiedLayout FullscreenFocus l a
fullscreenFocusRect r = ModifiedLayout $ FullscreenFocus r []
fullscreenFloat :: LayoutClass l a =>
l a -> ModifiedLayout FullscreenFloat l a
fullscreenFloat = fullscreenFloatRect $ W.RationalRect 0 0 1 1
fullscreenFloatRect :: LayoutClass l a =>
W.RationalRect -> l a -> ModifiedLayout FullscreenFloat l a
fullscreenFloatRect r = ModifiedLayout $ FullscreenFloat r M.empty
fullscreenEventHook :: Event -> X All
fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do
wmstate <- getAtom "_NET_WM_STATE"
fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"
wstate <- fromMaybe [] `fmap` getProp32 wmstate 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 wmstate ptype propModeReplace (f wstate)
when (typ == wmstate && 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
broadcastMessage $ RemoveFullscreen w
cw <- (W.workspace . W.current) `fmap` gets windowset
sendMessageWithNoRefresh FullscreenChanged cw
return $ All True
fullscreenEventHook _ = return $ All True
fullscreenManageHook :: ManageHook
fullscreenManageHook = fullscreenManageHook' isFullscreen
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
covers :: Rectangle -> Rectangle -> Bool
(Rectangle x1 y1 w1 h1) `covers` (Rectangle x2 y2 w2 h2) =
let fi = fromIntegral
in x1 <= x2 &&
y1 <= y2 &&
x1 + fi w1 >= x2 + fi w2 &&
y1 + fi h1 >= y2 + fi h2
orP :: (a -> Bool) -> (b -> Bool) -> (a, b) -> Bool
orP f g (x, y) = f x || g y