1 files changed, 47 insertions, 21 deletions

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