    {-# 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.Hooks.ManageHelpers     (isFullscreen)
    import           XMonad.Util.WindowProperties
    import qualified XMonad.Util.Rectangle          as R
    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 =
        (visfulls' ++ rest', Nothing)
        where (visfulls,rest) = partition (flip elem fulls . fst) list
              visfulls' = map (second $ const rect') visfulls
              rest' = if null visfulls'
                      then rest
                      else filter (not . R.supersetOf rect' . snd) rest
              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 . orP (== f) (R.supersetOf 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

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

    -- | Applies a pair of predicates to a pair of operands, combining them with ||.
    orP :: (a -> Bool) -> (b -> Bool) -> (a, b) -> Bool
    orP f g (x, y) = f x || g y