Add a lot of caching framework

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