xmonad-contrib/XMonad/Layout/Fullscreen.hs

{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Fullscreen
-- 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
     fullscreenSupport
    ,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 def { handleEventHook = fullscreenEventHook,
-- >              manageHook = fullscreenManageHook,
-- >              layoutHook = myLayouts }
--
-- Now you can use layouts that respect fullscreen, for example the
-- provided 'fullscreenFull':
--
-- > myLayouts = fullscreenFull someLayout
--

-- | Modifies your config to apply basic fullscreen support -- fullscreen
-- windows when they request it. Example usage:
--
-- > main = xmonad
-- >      $ fullscreenSupport
-- >      $ defaultConfig { ... }
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
  }

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

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