From 42c14fa1ca9d47ae32766aaa2aa995c684b7e9cb Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 21 Aug 2011 19:34:16 +0200 Subject: Make render function return cachable surface slices --- lib/Phi/Widgets/AlphaBox.hs | 26 +++++++++------- lib/Phi/Widgets/Clock.hs | 49 ++++++++++++++++------------- lib/Phi/Widgets/Systray.hs | 19 +++++++----- lib/Phi/Widgets/Taskbar.hs | 75 +++++++++++++++++++++++++-------------------- 4 files changed, 97 insertions(+), 72 deletions(-) (limited to 'lib/Phi/Widgets') diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index eacda5a..cd540e3 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -12,11 +12,11 @@ import Control.Monad import Graphics.Rendering.Cairo -data AlphaBox w d = (Widget w d) => AlphaBox !Double !w -deriving instance Show (AlphaBox w d) -deriving instance Eq (AlphaBox w d) +data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +deriving instance Show (AlphaBox w s c) +deriving instance Eq (AlphaBox w s c) -instance Eq d => Widget (AlphaBox w d) d where +instance Eq s => Widget (AlphaBox w s c) s () where initWidget (AlphaBox _ w) = initWidget w minSize (AlphaBox _ w) = minSize w @@ -25,21 +25,25 @@ instance Eq d => Widget (AlphaBox w d) d where layout (AlphaBox _ w) = layout w - render (AlphaBox alpha w) d x y width height screen = do - renderWithSimilarSurface ContentColorAlpha width height $ \surface -> do - renderWith surface $ do - render w d x y width height screen + render (AlphaBox alpha w) s x y width height screen = do + surfaces <- render w s x y width height screen + let surfacesWidths = zipWith (\(updated, SurfaceSlice x surf) x' -> (updated, x, x'-x, surf)) surfaces (map (\(_, SurfaceSlice x _) -> x) (tail surfaces) ++ [width]) + forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do + surf' <- createImageSurface FormatARGB32 surfWidth height + renderWith surf' $ do + setOperator OperatorSource + withPatternForSurface surf setSource + paint setOperator OperatorDestIn setSourceRGBA 0 0 0 alpha paint - withPatternForSurface surface setSource - paint + return (updated, SurfaceSlice x surf') handleMessage (AlphaBox _ w) = handleMessage w -alphaBox :: (Widget w d) => Double -> w -> AlphaBox w d +alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c alphaBox = AlphaBox diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index bee8d39..12906c0 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) -instance Widget Clock ClockState where +instance Widget Clock ClockState () where initWidget (Clock _) phi _ = do forkIO $ forever $ do time <- getZonedTime @@ -59,26 +59,33 @@ instance Widget Clock ClockState where minSize (Clock config) _ _ _ = clockSize config render (Clock config) (ClockState time) _ _ w h _ = do - let (r, g, b, a) = fontColor config - str = formatTime defaultTimeLocale (clockFormat config) time - setSourceRGBA r g b a - - layout <- createLayout "" - (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do - layoutSetMarkup layout str - layoutSetAlignment layout AlignCenter - layoutSetSpacing layout $ lineSpacing config - layoutGetExtents layout - - let scalef = min 1 ((fromIntegral w)/textWidth) - when (scalef < 1) $ do - scale scalef scalef - updateLayout layout - - (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout - - moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2) - showLayout layout + surface <- createImageSurface FormatARGB32 w h + renderWith surface $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + let (r, g, b, a) = fontColor config + str = formatTime defaultTimeLocale (clockFormat config) time + setSourceRGBA r g b a + + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout str + layoutSetAlignment layout AlignCenter + layoutSetSpacing layout $ lineSpacing config + layoutGetExtents layout + + let scalef = min 1 ((fromIntegral w)/textWidth) + when (scalef < 1) $ do + scale scalef scalef + updateLayout layout + + (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout + + moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2) + showLayout layout + return [(True, SurfaceSlice 0 surface)] handleMessage _ priv m = case (fromMessage m) of Just (UpdateTime time) -> ClockState time diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs index 6812018..662c6a7 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/Systray.hs @@ -47,7 +47,7 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon deriving (Show, Typeable) -instance Widget Systray SystrayState where +instance Widget Systray SystrayState () where initWidget (Systray) phi dispvar = do phi' <- dupPhi phi forkIO $ systrayRunner phi' dispvar @@ -61,15 +61,20 @@ instance Widget Systray SystrayState where weight _ = 0 - render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = case True of - _ | screen == systrayScreen -> do - lastReset <- liftIO $ readIORef lastResetRef - liftIO $ writeIORef lastResetRef reset + render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do + when (screen == systrayScreen) $ do + lastReset <- readIORef lastResetRef + writeIORef lastResetRef reset forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do let x' = x + i*(h+2) sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset) - - | otherwise -> return () + + surface <- createImageSurface FormatARGB32 w h + renderWith surface $ do + setOperator OperatorClear + paint + return [(True, SurfaceSlice 0 surface)] + handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons) diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index c17ac36..fbf7da8 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -166,7 +166,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState instance Show (IORef a) where show _ = "IORef " -instance Widget Taskbar TaskbarState where +instance Widget Taskbar TaskbarState () where initWidget (Taskbar _) phi dispvar = do phi' <- dupPhi phi forkIO $ taskbarRunner phi' dispvar @@ -204,41 +204,50 @@ instance Widget Taskbar TaskbarState where desktopsWidth = sum $ map dwidth desktopNumbers windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) - - flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do - let dstyle' = dstyle desktop - dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth - - case dstyle' of - Just ds -> do - let (r, g, b, a) = desktopColor ds - save - drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h - clip - - setSourceRGBA r g b a - renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1) - - restore - - forM_ (zip [0..] desktopWindows) $ \(i, window) -> do - let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config - h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) - mstate = M.lookup window windowStates - micons = M.lookup window windowIcons - mscaledIconRef = M.lookup window windowScaledIcons - x = dx + i*windowWidth - y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) + + surface <- createImageSurface FormatARGB32 w h + renderWith surface $ do + setOperator OperatorClear + 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 + + case dstyle' of + Just ds -> do + let (r, g, b, a) = desktopColor ds + save + drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h + clip - case (mstate, micons, mscaledIconRef) of - (Just state, Just icons, Just scaledIconRef) -> - renderTask state icons scaledIconRef style x y windowWidth h' - - _ -> return () + setSourceRGBA r g b a + renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1) + + restore + + forM_ (zip [0..] desktopWindows) $ \(i, window) -> do + let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config + h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) + mstate = M.lookup window windowStates + micons = M.lookup window windowIcons + mscaledIconRef = M.lookup window windowScaledIcons + x = dx + i*windowWidth + y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) + + case (mstate, micons, mscaledIconRef) of + (Just state, Just icons, Just scaledIconRef) -> + renderTask state icons scaledIconRef style x y windowWidth h' + + _ -> return () - _ -> return () + _ -> return () - return $ nwindows + length desktopWindows + return $ nwindows + length desktopWindows + + return [(True, SurfaceSlice 0 surface)] handleMessage _ priv m = case (fromMessage m) of -- cgit v1.2.3