xmonad-conf/lib/FullscreenManager.hs

{-# 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