Add a lot of caching framework

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

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

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

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