From 8222c6041d2e2ed5258aa0f9188d2011a17285c9 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 21 Aug 2011 21:39:26 +0200 Subject: Add a lot of caching framework --- lib/Phi/Border.hs | 14 +++++++--- lib/Phi/Widget.hs | 68 +++++++++++++++++++++++++++++++-------------- lib/Phi/Widgets/AlphaBox.hs | 13 +++++++-- lib/Phi/Widgets/Clock.hs | 56 +++++++++++++++++-------------------- lib/Phi/Widgets/Systray.hs | 8 ++++-- lib/Phi/Widgets/Taskbar.hs | 5 ++-- lib/Phi/X11.hs | 11 ++++---- 7 files changed, 106 insertions(+), 69 deletions(-) diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index c6e7531..0c6c9c4 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -16,6 +16,9 @@ import Phi.Types import Phi.Widget import Control.Monad +import Control.Monad.State.Strict + +import Data.Maybe import Graphics.Rendering.Cairo @@ -61,6 +64,7 @@ data BorderCache w s c = (Widget w s c) => BorderCache !c instance Eq s => Widget (Border w s c) s (BorderCache w s c) where initWidget (Border _ w) = initWidget w + initCache (Border _ w) = BorderCache $ initCache w minSize (Border config w) s height screen = case True of @@ -90,17 +94,19 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where render (Border config w) s x y width height screen = case () of _ | (width > borderH m - 2*bw - borderH p) -> do - border <- createImageSurface FormatARGB32 width height + border <- liftIO $ createImageSurface FormatARGB32 width height renderWith border $ do setOperator OperatorClear paint setOperator OperatorOver drawBorder config 0 0 width height - surfaces <- render w s (x+dx) (y+dy) width' height' screen + BorderCache c <- get + (surfaces, c') <- liftIO $ flip runStateT c $ render w s (x+dx) (y+dy) width' height' screen + put $ BorderCache c' let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)] surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)]) forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do - surf' <- createImageSurface FormatARGB32 surfWidth height + surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height renderWith surf' $ do setOperator OperatorClear paint @@ -121,7 +127,7 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where return (updated, SurfaceSlice x surf') | otherwise -> do - surface <- createImageSurface FormatARGB32 width height + surface <- liftIO $ createImageSurface FormatARGB32 width height return [(True, SurfaceSlice 0 surface)] where m = margin config diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index f265c62..f498b2c 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} module Phi.Widget ( Display(..) , withDisplay @@ -10,6 +10,11 @@ module Phi.Widget ( Display(..) , Widget(..) , CompoundWidget , (<~>) + , IOCache + , RenderCache + , createIOCache + , createRenderCache + , renderCached , Separator , separator ) where @@ -19,8 +24,11 @@ import Control.Arrow.Transformer import Control.CacheArrow import Control.Concurrent.MVar import Control.Monad +import Control.Monad.State.Strict hiding (lift) import Control.Monad.IO.Class +import Data.Maybe + import qualified Graphics.X11.Xlib as Xlib import Graphics.Rendering.Cairo @@ -65,31 +73,47 @@ unionArea a b = fromIntegral $ uw*uh data SurfaceSlice = SurfaceSlice !Int !Surface -class (Show a, Eq a, Eq s) => Widget a s c | a -> s, a -> c where - initWidget :: a -> Phi -> Display -> IO s +class (Show w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where + initWidget :: w -> Phi -> Display -> IO s + + initCache :: w -> c - minSize :: a -> s -> Int -> Xlib.Rectangle -> Int + minSize :: w -> s -> Int -> Xlib.Rectangle -> Int - weight :: a -> Float + weight :: w -> Float weight _ = 0 - layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s + layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s layout _ priv _ _ _ = priv - render :: a -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> IO [(Bool, SurfaceSlice)] + render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)] - handleMessage :: a -> s -> Message -> s + handleMessage :: w -> s -> Message -> s handleMessage _ priv _ = priv -{-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface -createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do +type IOCache = CacheArrow (Kleisli IO) +type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface + +createIOCache :: Eq a => (a -> IO b) -> IOCache a b +createIOCache = lift . Kleisli + +createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()) + -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface +createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do surface <- createImageSurface FormatARGB32 w h renderWith surface $ do setOperator OperatorClear paint setOperator OperatorOver - render widget state x y w h screen - return surface-} + f widget state x y w h screen + return surface + +renderCached :: (Eq w, Eq s) => w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache w s) IO [(Bool, SurfaceSlice)] +renderCached widget state x y w h screen = do + cache <- get + (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (widget, state, x, y, w, h, screen) + put cache' + return [(updated, SurfaceSlice 0 surf)] data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b deriving instance Eq (CompoundWidget a sa ca b sb cb) @@ -104,6 +128,8 @@ data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => Compoun instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0) + initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b) + minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen weight (CompoundWidget a b) = weight' a + weight' b @@ -123,8 +149,10 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) in (wWidth, layout w s wWidth height screen) render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do - surfacea <- render a sa x y xb h screen - surfaceb <- render b sb (x+xb) y (w-xb) h screen + CompoundCache ca cb <- get + (surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen + (surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen + put $ CompoundCache ca' cb' return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb @@ -137,17 +165,15 @@ a <~> b = CompoundWidget a b data Separator = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () () where +instance Widget Separator () (RenderCache Separator ()) where initWidget _ _ _ = return () + initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do + setOperator OperatorClear + paint minSize (Separator s _) _ _ _ = s weight (Separator _ w) = w - render _ _ _ _ width height _ = do - surface <- createImageSurface FormatARGB32 width height - renderWith surface $ do - setOperator OperatorClear - paint - return [(True, SurfaceSlice 0 surface)] + render = renderCached separator :: Int -> Float -> Separator diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index cd540e3..508f9d4 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -8,6 +8,7 @@ import Phi.Types import Phi.Widget import Control.Monad +import Control.Monad.State.Strict import Graphics.Rendering.Cairo @@ -16,8 +17,11 @@ 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 s => Widget (AlphaBox w s c) s () where +data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c + +instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where initWidget (AlphaBox _ w) = initWidget w + initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w minSize (AlphaBox _ w) = minSize w @@ -26,10 +30,13 @@ instance Eq s => Widget (AlphaBox w s c) s () where layout (AlphaBox _ w) = layout w render (AlphaBox alpha w) s x y width height screen = do - surfaces <- render w s x y width height screen + AlphaBoxCache c <- get + (surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen + put $ AlphaBoxCache c' + 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 + surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height renderWith surf' $ do setOperator OperatorSource withPatternForSurface surf setSource diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 12906c0..38b6c41 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} module Phi.Widgets.Clock ( ClockConfig(..) , defaultClockConfig @@ -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 (RenderCache Clock ClockState) where initWidget (Clock _) phi _ = do forkIO $ forever $ do time <- getZonedTime @@ -54,38 +54,32 @@ instance Widget Clock ClockState () where time <- getZonedTime return $ ClockState time - + + initCache _ = createRenderCache $ \(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 minSize (Clock config) _ _ _ = clockSize config - render (Clock config) (ClockState time) _ _ w h _ = do - 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)] + render = renderCached 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 662c6a7..7e7ec63 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/Systray.hs @@ -55,6 +55,8 @@ instance Widget Systray SystrayState () where lastReset <- newIORef 0 return $ SystrayState phi (head . getScreens $ dispvar) 0 lastReset [] + initCache _ = () + minSize _ (SystrayState _ systrayScreen _ _ icons) height screen = case True of _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1 | otherwise -> 0 @@ -63,13 +65,13 @@ instance Widget Systray SystrayState () where render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do when (screen == systrayScreen) $ do - lastReset <- readIORef lastResetRef - writeIORef lastResetRef reset + lastReset <- liftIO $ readIORef lastResetRef + liftIO $ 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) - surface <- createImageSurface FormatARGB32 w h + surface <- liftIO $ createImageSurface FormatARGB32 w h renderWith surface $ do setOperator OperatorClear paint diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index fbf7da8..4c4b9c2 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -172,7 +172,8 @@ instance Widget Taskbar TaskbarState () where forkIO $ taskbarRunner phi' dispvar return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty M.empty - + + initCache _ = () minSize _ _ _ _ = 0 weight _ = 1 @@ -205,7 +206,7 @@ instance Widget Taskbar TaskbarState () where desktopsWidth = sum $ map dwidth desktopNumbers windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) - surface <- createImageSurface FormatARGB32 w h + surface <- liftIO $ createImageSurface FormatARGB32 w h renderWith surface $ do setOperator OperatorClear paint diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 110e9d4..818a9db 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -18,7 +18,7 @@ import Data.Char import Control.Concurrent import Control.Concurrent.MVar -import Control.Monad.State +import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Trans @@ -51,7 +51,7 @@ data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow , panelScreenArea :: !Rectangle , panelWidget :: !w , panelWidgetState :: !s - , panelWidgetCache :: !(Maybe c) + , panelWidgetCache :: !c } data PhiConfig = PhiConfig { phiPhi :: !Phi @@ -205,7 +205,8 @@ updatePanels dispvar = do area = panelArea panel let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel - panelSurfaces <- liftIO $ (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel) + (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ + (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel) Widget.withDisplay dispvar $ \disp -> do let screen = defaultScreen disp @@ -239,7 +240,7 @@ updatePanels dispvar = do (withDimension area $ clearArea disp (panelWindow panel) 0 0) True sync disp False - return $ panel { panelWidgetState = layoutedWidget } + return $ panel { panelWidgetState = layoutedWidget, panelWidgetCache = cache' } modify $ \state -> state { phiPanels = panels' } @@ -311,7 +312,7 @@ createPanel disp win w s screenRect = do , panelScreenArea = screenRect , panelWidget = w , panelWidgetState = s - , panelWidgetCache = Nothing + , panelWidgetCache = initCache w } createPanelWindow :: Display -> Rectangle -> PhiX w s c Window -- cgit v1.2.3