From 2cc660607d728d0c93f891840f2b15b5dee51b1e Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <matthias@gamezock.de>
Date: Sat, 13 Feb 2010 18:31:17 +0100
Subject: Initial commit

---
 lib/FullscreenManager.hs | 138 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 138 insertions(+)
 create mode 100644 lib/FullscreenManager.hs

(limited to 'lib/FullscreenManager.hs')

diff --git a/lib/FullscreenManager.hs b/lib/FullscreenManager.hs
new file mode 100644
index 0000000..ac1907f
--- /dev/null
+++ b/lib/FullscreenManager.hs
@@ -0,0 +1,138 @@
+{-# 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
-- 
cgit v1.2.3