Split up window and frame state

1 files changed, 28 insertions, 9 deletions

diff --git a/MetaTile/Core.hs b/MetaTile/Core.hs
index 5596ec3..572280b 100644
--- a/MetaTile/Core.hs
+++ b/MetaTile/Core.hs
@@ -18,13 +18,15 @@
 
 module MetaTile.Core (
     X, WindowSet, WindowSpace, WorkspaceId, BorderWidth(..), WindowState(..),
-    ScreenId(..), ScreenDetail(..), XState(..),
+    FrameState(..), ScreenId(..), ScreenDetail(..), XState(..),
     XConf(..), XConfig(..), LayoutClass(..),
     Layout(..), readsLayout, Typeable, Message,
     SomeMessage(..), fromMessage, LayoutMessages(..),
     StateExtension(..), ExtensionClass(..),
     runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers,
-    withDisplay, withWindowSet, isRoot, runOnWorkspaces, getWindowState, getsWindowState, setWindowState, modifyWindowState,
+    withDisplay, withWindowSet, isRoot, runOnWorkspaces,
+    getWindowState, getsWindowState, setWindowState, modifyWindowState,
+    getFrameState, getsFrameState, setFrameState, deleteFrameState, modifyFrameState,
     getAtom, spawn, spawnPID, xfork, getMetaTileDir, recompile, trace, whenJust, whenX,
     atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_TAKE_FOCUS, ManageHook, Query(..), runQuery
   ) where
@@ -35,11 +37,9 @@ import Prelude hiding ( catch )
 import Codec.Binary.UTF8.String (encodeString)
 import Control.Exception.Extensible (catch, fromException, try, bracket, throw, finally, SomeException(..))
 import Control.Applicative
-import Control.Arrow ((&&&))
 import Control.Monad.State
 import Control.Monad.Reader
 import Data.Default
-import Data.Function (on)
 import System.FilePath
 import System.IO
 import System.Info
@@ -71,17 +71,19 @@ data WindowState = WindowState
     { wsMapped       :: !Bool
     , wsWaitingUnmap :: !Int         -- ^ the number of expected UnmapEvents
     , wsFrame        :: !Window
-    , wsBorderWidth  :: !BorderWidth
-    } deriving Show
+    } deriving (Show, Eq)
 
-instance Eq WindowState where
-    (==) = (==) `on` (wsMapped &&& wsWaitingUnmap &&& wsFrame)
+data FrameState = FrameState
+    { fsWindow       :: !Window
+    , fsBorderWidth  :: !BorderWidth
+    } deriving Show
 
 
 -- | XState, the (mutable) window manager state.
 data XState = XState
     { windowset        :: !WindowSet                     -- ^ workspace list
     , windowState      :: !(M.Map Window WindowState)    -- ^ the extended window state
+    , frameState       :: !(M.Map Window FrameState)    -- ^ the extended frame state
     , dragging         :: !(Maybe (Position -> Position -> X (), X ()))
     , numberlockMask   :: !KeyMask                       -- ^ The numlock modifier
     , extensibleState  :: !(M.Map String (Either String StateExtension))
@@ -234,7 +236,7 @@ getAtom :: String -> X Atom
 getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False
 
 emptyWindowState :: WindowState
-emptyWindowState = WindowState False 0 none (BorderWidth 0 0 0 0)
+emptyWindowState = WindowState False 0 none
 
 getWindowState :: Window -> X WindowState
 getWindowState w = gets $ M.findWithDefault emptyWindowState w . windowState
@@ -251,6 +253,23 @@ setWindowState w ws = do
 modifyWindowState :: (WindowState -> WindowState) -> Window -> X ()
 modifyWindowState f w = getWindowState w >>= return . f >>= setWindowState w
 
+
+getFrameState :: Window -> X (Maybe FrameState)
+getFrameState fr = gets $ M.lookup fr . frameState
+
+getsFrameState :: (FrameState -> a) -> Window -> X (Maybe a)
+getsFrameState f fr = fmap f <$> getFrameState fr
+
+setFrameState :: Window -> FrameState -> X ()
+setFrameState fr fs = modify $ \s -> s { frameState = M.insert fr fs (frameState s) }
+
+deleteFrameState :: Window -> X ()
+deleteFrameState fr = modify $ \s -> s { frameState = M.delete fr (frameState s) }
+
+modifyFrameState :: (FrameState -> FrameState) -> Window -> X ()
+modifyFrameState f fr = getFrameState fr >>= return . fmap f >>= maybe (return ()) (setFrameState fr)
+
+
 -- | Common non-predefined atoms
 atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE, atom_WM_TAKE_FOCUS :: X Atom
 atom_WM_PROTOCOLS       = getAtom "WM_PROTOCOLS"