From 0f492217173ef02eef5b2f7537e5d1e28d41ecd9 Mon Sep 17 00:00:00 2001 From: Andrea Rossato Date: Tue, 19 Feb 2008 13:21:15 +0100 Subject: Decoratione: generate rectangles first, and create windows accordingly With this patch Decoration will first generate a rectangle and only if there is a rectangle available a window will be created. This makes the Decoration state a bit more difficult to process, but should reduce resource consumption. darcs-hash:20080219122115-32816-56ccaf1fed88e2830d6cd76d346eaca119d3143a.gz --- XMonad/Layout/Decoration.hs | 128 ++++++++++++++++++++++++-------------------- 1 file changed, 71 insertions(+), 57 deletions(-) (limited to 'XMonad/Layout/Decoration.hs') diff --git a/XMonad/Layout/Decoration.hs b/XMonad/Layout/Decoration.hs index 1e6bf0e..e1a29e9 100644 --- a/XMonad/Layout/Decoration.hs +++ b/XMonad/Layout/Decoration.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts #-} -- for deriving Typeable {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.Decoration @@ -27,8 +26,7 @@ module XMonad.Layout.Decoration , shrinkText, CustomShrink ( CustomShrink ) , Shrinker (..), DefaultShrinker , module XMonad.Layout.LayoutModifier - , isInStack, isVisible, isInvisible, isWithin - , lookFor, lookFor', fi + , isInStack, isVisible, isInvisible, isWithin, fi ) where import Control.Monad (when) @@ -87,7 +85,7 @@ defaultTheme = data DecorationMsg = SetTheme Theme deriving ( Typeable ) instance Message DecorationMsg -type DecoWin = (Window,Maybe Rectangle) +type DecoWin = (Maybe Window, Maybe Rectangle) type OrigWin = (Window,Rectangle) data DecorationState = DS { decos :: [(OrigWin,DecoWin)] @@ -124,7 +122,6 @@ class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where then Just $ Rectangle x y wh ht else Nothing - decorate :: ds a -> Dimension -> Dimension -> Rectangle -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle) decorate ds w h r s ars ar = return $ pureDecoration ds w h r s ars ar @@ -136,14 +133,15 @@ instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration d redoLayout (Decoration st sh t ds) sc stack wrs | decorate_first = do whenIJust st releaseResources return (wrs, Just $ Decoration (I Nothing) sh t ds) - | I Nothing <- st = initState t wrs >>= processState + | I Nothing <- st = initState t ds sc stack wrs >>= processState | I (Just s) <- st = do let dwrs = decos s (d,a) = curry diff (get_ws dwrs) ws toDel = todel d dwrs toAdd = toadd a wrs - deleteWindows (getDWs toDel) - ndwrs <- createDecos t toAdd - processState (s {decos = ndwrs ++ del_dwrs d dwrs }) + deleteDecos (map snd toDel) + ndwrs <- createDecos t ds sc stack wrs toAdd + ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs + processState (s {decos = ndecos }) | otherwise = return (wrs, Nothing) where @@ -171,13 +169,13 @@ instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration d | otherwise = (w,r) : remove_stacked (r:rs) xs remove_stacked _ [] = [] - insert_dwr ((w,r),(dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs - insert_dwr (x ,(_ ,Nothing)) xs = x:xs + insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs + insert_dwr (x ,( _ , _ )) xs = x:xs dwrs_to_wrs = remove_stacked [] . foldr insert_dwr [] - processState s = do ndwrs <- resync (decos s) wrs - showWindows (getDWs ndwrs) + processState s = do let ndwrs = decos s + showDecos (map snd ndwrs) updateDecos sh t (font s) ndwrs return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds)) @@ -185,7 +183,7 @@ instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration d | Just e <- fromMessage m :: Maybe Event = do decorationEventHook ds s e handleEvent sh t s e return Nothing - | Just Hide <- fromMessage m = do hideWindows (getDWs dwrs) + | Just Hide <- fromMessage m = do hideDecos (map snd dwrs) return Nothing | Just (SetTheme nt) <- fromMessage m = do releaseResources s return $ Just $ Decoration (I Nothing) sh nt ds @@ -193,9 +191,8 @@ instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration d return $ Just $ Decoration (I Nothing) sh t ds handleMess _ _ = return Nothing - emptyLayoutMod (Decoration (I (Just (DS dwrs f))) sh t ds) _ _ = do - deleteWindows (getDWs dwrs) - releaseXMF f + emptyLayoutMod (Decoration (I (Just s)) sh t ds) _ _ = do + releaseResources s return ([], Just $ Decoration (I Nothing) sh t ds) emptyLayoutMod _ _ _ = return ([], Nothing) @@ -203,8 +200,10 @@ instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration d handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X () handleEvent sh t (DS dwrs fs) e - | PropertyEvent {ev_window = w} <- e, w `elem` (map (fst . fst) dwrs) = updateDecos sh t fs dwrs - | ExposeEvent {ev_window = w} <- e, w `elem` (map (fst . snd) dwrs) = updateDecos sh t fs dwrs + | PropertyEvent {ev_window = w} <- e + , w `elem` (map (fst . fst) dwrs) = updateDecos sh t fs dwrs + | ExposeEvent {ev_window = w} <- e + , w `elem` (catMaybes $ map (fst . snd) dwrs) = updateDecos sh t fs dwrs handleEvent _ _ _ _ = return () handleMouseFocusDrag :: Bool -> DecorationState -> Event -> X () @@ -223,44 +222,60 @@ handleMouseFocusDrag b (DS dwrs _) ButtonEvent { ev_window = ew sendMessage (SetGeometry rect)) (return ()) handleMouseFocusDrag _ _ _ = return () -lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,DecoWin) -lookFor w ((wr,(dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr)) - | otherwise = lookFor w dwrs +lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle)) +lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr)) + | otherwise = lookFor w dwrs +lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs lookFor _ [] = Nothing -lookFor' :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,DecoWin) -lookFor' w (((w',r),dwr):dwrs) | w == w' = Just ((w,r),dwr) - | otherwise = lookFor' w dwrs -lookFor' _ [] = Nothing - -getDWs :: [(OrigWin,DecoWin)] -> [Window] -getDWs = map (fst . snd) - -initState :: Theme -> [(Window,Rectangle)] -> X DecorationState -initState t wrs = do +initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle + -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState +initState t ds sc s wrs = do fs <- initXMF (fontName t) - dwrs <- createDecos t wrs + dwrs <- createDecos t ds sc s wrs wrs return $ DS dwrs fs releaseResources :: DecorationState -> X () releaseResources s = do - deleteWindows (getDWs $ decos s) - releaseXMF (font s) - -createDecos :: Theme -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)] -createDecos _ [] = return [] -createDecos t (wr:wrs) = do - let rect = Rectangle 0 0 1 1 - mask = Just (exposureMask .|. buttonPressMask) - dw <- createNewWindow rect mask (inactiveColor t) True - dwrs <- createDecos t wrs - return ((wr,(dw,Nothing)):dwrs) - -updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin, DecoWin)] -> X () + deleteDecos (map snd $ decos s) + releaseXMF (font s) + +createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window + -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)] +createDecos t ds sc s wrs ((w,r):xs) = do + deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r) + case deco of + Just dr -> do let mask = Just (exposureMask .|. buttonPressMask) + dw <- createNewWindow dr mask (inactiveColor t) True + dwrs <- createDecos t ds sc s wrs xs + return $ ((w,r), (Just dw, Just dr)) : dwrs + Nothing -> do dwrs <- createDecos t ds sc s wrs xs + return $ ((w,r), (Nothing, Nothing)) : dwrs +createDecos _ _ _ _ _ [] = return [] + +showDecos :: [DecoWin] -> X () +showDecos (m:mwrs) + | (Just w,_) <- m = showWindow w >> showDecos mwrs + | otherwise = showDecos mwrs +showDecos [] = return () + +hideDecos :: [DecoWin] -> X () +hideDecos (m:mwrs) + | (Just w,_) <- m = hideWindow w >> hideDecos mwrs + | otherwise = hideDecos mwrs +hideDecos [] = return () + +deleteDecos :: [DecoWin] -> X () +deleteDecos (m:mwrs) + | (Just w,_) <- m = deleteWindow w >> deleteDecos mwrs + | otherwise = deleteDecos mwrs +deleteDecos [] = return () + +updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X () updateDecos s t f = mapM_ $ updateDeco s t f -updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin, DecoWin) -> X () -updateDeco sh t fs ((w,_),(dw,Just (Rectangle _ _ wh ht))) = do +updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X () +updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do nw <- getName w ur <- readUrgents dpy <- asks display @@ -269,16 +284,15 @@ updateDeco sh t fs ((w,_),(dw,Just (Rectangle _ _ wh ht))) = do | win `elem` ur -> uc | otherwise -> ic) . W.peek) `fmap` gets windowset - (bc,borderc,tc) <- focusColor w - (inactiveColor t, inactiveBorderColor t, inactiveTextColor t) - (activeColor t, activeBorderColor t, activeTextColor t) - (urgentColor t, urgentBorderColor t, urgentTextColor t) - let s = shrinkIt sh - name <- shrinkWhile s (\n -> do - size <- io $ textWidthXMF dpy fs n - return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + (bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t) + (activeColor t, activeBorderColor t, activeTextColor t) + (urgentColor t, urgentBorderColor t, urgentTextColor t) + let s = shrinkIt sh + name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n + return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) paintAndWrite dw fs wh ht 1 bc borderc tc bc AlignCenter name -updateDeco _ _ _ (_,(w,Nothing)) = hideWindow w +updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w +updateDeco _ _ _ _ = return () isInStack :: Eq a => W.Stack a -> a -> Bool isInStack s = flip elem (W.integrate s) -- cgit v1.2.3