From 7ed869fcf17dcd9ddb2e02c927c2699eb104df7b Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Mon, 22 Aug 2011 21:10:59 +0200 Subject: Cache windows in taskbar --- lib/Phi/Widget.hs | 6 +-- lib/Phi/Widgets/Taskbar.hs | 91 +++++++++++++++++++++++++++++++--------------- 2 files changed, 65 insertions(+), 32 deletions(-) diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 5ffd534..68bed1b 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -98,12 +98,12 @@ type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surfac createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache = lift . Kleisli -runIOCache :: Eq a => a -> StateT (IOCache a b) IO (b, Bool) +runIOCache :: Eq a => a -> StateT (IOCache a b) IO b runIOCache a = do cache <- get - (b, updated, cache') <- liftIO $ runKleisli (runCache' cache) a + (b, cache') <- liftIO $ runKleisli (runCache cache) a put cache' - return (b, updated) + return b createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()) -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index 723427b..da68c27 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -51,13 +51,15 @@ import Phi.Widget import Phi.X11.Atoms -type IconStyle = Surface -> Render () +newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () } +instance Eq IconStyle where + _ == _ = True idIconStyle :: IconStyle -idIconStyle = flip withPatternForSurface setSource +idIconStyle = IconStyle $ flip withPatternForSurface setSource desaturateIconStyle :: Double -> IconStyle -desaturateIconStyle v icon = do +desaturateIconStyle v = IconStyle $ \icon -> do w <- imageSurfaceGetWidth icon h <- imageSurfaceGetHeight icon @@ -66,14 +68,14 @@ desaturateIconStyle v icon = do setOperator OperatorAdd withPatternForSurface icon setSource paint - + setSourceRGB 0 0 0 paint setOperator OperatorHslSaturation setSourceRGBA 0 0 0 (1-v) paint - + setOperator OperatorDestIn withPatternForSurface icon setSource paint @@ -104,7 +106,7 @@ data TaskStyle = TaskStyle { taskFont :: !String , taskColor :: !Color , taskBorder :: !BorderConfig , taskIconStyle :: !IconStyle - } + } deriving Eq data DesktopStyle = DesktopStyle { desktopFont :: !String , desktopLabelWidth :: !Int @@ -159,13 +161,24 @@ data WindowState = WindowState { windowTitle :: !String , windowScreen :: !Xlib.Rectangle } deriving (Eq, Show) -data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Surface)) +data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) + , renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface) } +createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached +renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached + + +newtype DesktopCache = DesktopCache (IOCache () ()) + emptyWindowCache :: WindowCache emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon + , renderWindowCached = createIOCache doRenderWindow } -createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached + +data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache) + , windowCaches :: !(M.Map Window WindowCache) + } -- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a @@ -182,6 +195,9 @@ liftIOStateT m = do put s1 return a +cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b +cached t = liftT t . liftIOStateT . runIOCache + data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState) | DesktopCountUpdate !Int | CurrentDesktopUpdate !Int @@ -233,7 +249,7 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where paint setOperator OperatorOver - + flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do let dstyle' = dstyle desktop dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth @@ -259,8 +275,14 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) case mstate of - Just state -> - liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h' + Just state -> do + windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h' + lift $ do + save + translate (fromIntegral $ x - 5) (fromIntegral $ y - 5) + withPatternForSurface windowSurface setSource + paint + restore Nothing -> return () @@ -296,36 +318,47 @@ renderText font x y w h text = do moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) showLayout layout -renderTask :: WindowState -> TaskStyle -> Int -> Int -> Int -> Int -> StateT WindowCache Render () -renderTask state style x y w h = do +renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface +renderWindow state style w h = do + let h' = h - (borderV $ margin $ taskBorder style) + + scaledIcon <- cached createScaledIconCached' (windowIcons state, h') + cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h) + +doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface +doRenderWindow (title, scaledIcon, style, w, h) = do let (r, g, b, a) = taskColor style leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style) rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style) h' = h - (borderV $ margin $ taskBorder style) - lift $ do + surface <- createImageSurface FormatARGB32 (w+10) (h+10) + renderWith surface $ do + translate 5 5 + save - drawBorder (taskBorder style) x y w h + drawBorder (taskBorder style) 0 0 w h clip setSourceRGBA r g b a - renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) y (w - leftBorder - h' - 3 - rightBorder) h $ windowTitle state - + renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title + restore - - (scaledIcon, updated) <- liftT createScaledIconCached' $ liftIOStateT $ runIOCache (windowIcons state, h') - case scaledIcon of - Just icon -> lift $ do - save - translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style)) - taskIconStyle style icon - paint - restore - _ -> return () + case scaledIcon of + Just (Icon _ _ icon) -> do + save + translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style) + withIconStyle (taskIconStyle style) icon + paint + restore + + _ -> return () + + return surface -createScaledIcon :: ([Icon], Int) -> IO (Maybe Surface) +createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon) createScaledIcon (icons, h) = do case bestIcon of Just (Icon _ _ icon) -> do @@ -342,7 +375,7 @@ createScaledIcon (icons, h) = do downscaled scalef icon paint - return $ Just scaledIcon + fmap Just $ createIcon h scaledIcon _ -> return Nothing -- cgit v1.2.3