Use CacheArrow for rendering

Extremely hacky at the moment, for now the caching isn't used at all...

lib/Phi/Border.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Phi.Border ( BorderWidth(..)
                   , simpleBorderWidth
@@ -23,7 +23,7 @@ data BorderWidth = BorderWidth { borderTop    :: !Int
                                , borderRight  :: !Int
                                , borderBottom :: !Int
                                , borderLeft   :: !Int
-                               } deriving Show
+                               } deriving (Show, Eq)
 
 simpleBorderWidth :: Int -> BorderWidth
 simpleBorderWidth w = BorderWidth w w w w
@@ -34,7 +34,7 @@ borderH bw = borderLeft bw + borderRight bw
 borderV :: BorderWidth -> Int
 borderV bw = borderTop bw + borderBottom bw
 
-data BorderState = BorderState ![WidgetState] deriving Show
+data BorderState = BorderState ![WidgetState] deriving Eq
 
 data BorderConfig = BorderConfig { margin          :: !BorderWidth
                                  , borderWidth     :: !Int
@@ -43,7 +43,7 @@ data BorderConfig = BorderConfig { margin          :: !BorderWidth
                                  , backgroundColor :: !Color
                                  , cornerRadius    :: !Int
                                  , borderWeight    :: !Float
-                                 } deriving Show
+                                 } deriving (Show, Eq)
 
 defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
                                    , borderWidth = 1
@@ -54,10 +54,9 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
                                    , borderWeight = 1
                                    }
 
-data Border = Border !BorderConfig ![Widget] deriving Show
+data Border = Border !BorderConfig ![Widget] deriving (Show, Eq)
 
-instance WidgetClass Border where
+instance WidgetClass Border BorderState where
-  type WidgetData Border = BorderState
   initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
   
   minSize (Border config _) (BorderState widgetStates) height screen =
@@ -88,10 +87,11 @@ instance WidgetClass Border where
       width' = width - borderH m - 2*bw - borderH p
       height' = height - borderV m - 2*bw - borderV p
 
-  render (Border config _) (BorderState widgetStates) w h screen = when (w > borderH m - 2*bw - borderH p) $ do
+  render (Border config _) (BorderState widgetStates) x y w h screen = when (w > borderH m - 2*bw - borderH p) $ do
     drawBorder config 0 0 w h
     clip
-    renderWidgets widgetStates screen
+    renderWidgets widgetStates screen x y
+    return ()
     where
       m = margin config
       bw = borderWidth config

lib/Phi/Widget.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}
 
 module Phi.Widget ( Display(..)
                   , withDisplay
@@ -16,11 +16,14 @@ module Phi.Widget ( Display(..)
                   , handleMessageWidgets
                   ) where
 
+import Control.Arrow
+import Control.Arrow.Transformer
+import Control.CacheArrow
 import Control.Concurrent.MVar
 import Control.Monad
 import Control.Monad.IO.Class
 
-import Data.Traversable
+import Data.Traversable hiding (forM)
 
 import qualified Graphics.X11.Xlib as Xlib
 import Graphics.Rendering.Cairo
@@ -64,35 +67,50 @@ unionArea a b = fromIntegral $ uw*uh
     by2 = by1 + fromIntegral bh
 
 
-class Show a => WidgetClass a where
+class (Show a, Eq a, Eq d) => WidgetClass a d | a -> d where
-  type WidgetData a :: *
+  initWidget :: a -> Phi -> Display -> IO d
   
-  initWidget :: a -> Phi -> Display -> IO (WidgetData a)
+  minSize :: a -> d -> Int -> Xlib.Rectangle -> Int
-  
-  minSize :: a -> WidgetData a -> Int -> Xlib.Rectangle -> Int
   
   weight :: a -> Float
   weight _ = 0
 
-  layout :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> WidgetData a
+  layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d
   layout _ priv _ _ _ = priv
   
-  render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> Render ()
+  render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()
   
-  handleMessage :: a -> WidgetData a -> Message -> WidgetData a
+  handleMessage :: a -> d -> Message -> d
   handleMessage _ priv _ = priv
 
-data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget !a
+data Widget = forall a d. WidgetClass a d => Widget !a
 deriving instance Show Widget
 
-data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState { stateWidget      :: !a
+instance Eq Widget where
+  _ == _ = False
+
+data WidgetState = forall a d. WidgetClass a d =>
+                   WidgetState { stateWidget      :: !a
                                , stateX           :: !Int
                                , stateY           :: !Int
                                , stateWidth       :: !Int
                                , stateHeight      :: !Int
-                                                                                 , statePrivateData :: !(WidgetData a)
+                               , statePrivateData :: !d
+                               , stateRender      :: !(CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface)
                                }
-deriving instance Show WidgetState
+
+instance Eq WidgetState where
+  _ == _ = False
+
+createStateRender :: WidgetClass 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
+  surface <- createImageSurface FormatARGB32 w h
+  renderWith surface $ do
+    setOperator OperatorClear
+    paint
+    setOperator OperatorOver
+    render widget state x y w h screen
+  return surface
 
 createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
 createWidgetState phi disp (Widget w) = do
@@ -103,6 +121,7 @@ createWidgetState phi disp (Widget w) = do
                      , stateWidth = 0
                      , stateHeight = 0
                      , statePrivateData = priv
+                     , stateRender = createStateRender
                      }
 
 layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> [WidgetState]
@@ -118,40 +137,39 @@ layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX
                                     in (wX + stateWidth lw, lw)
     
     layoutWidget wX state = case state of
-      WidgetState {stateWidget = w, statePrivateData = priv} ->
+      WidgetState {stateWidget = w, statePrivateData = priv, stateRender = render} ->
         let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(nneg $ weight w)/wsum
             priv' = layout w priv wWidth height screen
-        in WidgetState w wX y wWidth height priv'
+        in WidgetState w wX y wWidth height priv' render
     
     nneg :: (Num a, Ord a) => a -> a
     nneg x = max 0 x
 
-renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render ()
+renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Int -> Int -> Render [WidgetState]
-renderWidgets widgets screen = forM_ widgets $ \WidgetState { stateWidget = widget
+renderWidgets widgets screen winX winY = forM widgets $ \(WidgetState widget x y w h priv render) -> do
-                                                            , stateX = x
+  (surface, render') <- liftIO $ runKleisli (runCache render) (widget, priv, winX+x, winY+y, w, h, screen)
-                                                            , stateY = y
+  
-                                                            , stateWidth = w
-                                                            , stateHeight = h
-                                                            , statePrivateData = priv } -> do
   save
   translate (fromIntegral x) (fromIntegral y)
-  render widget priv w h screen
+  withPatternForSurface surface setSource
+  paint
   restore
   
+  return $ WidgetState widget x y w h priv render'
+
 handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
 handleMessageWidgets message = map handleMessageWidget
   where
-    handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message
+    handleMessageWidget (WidgetState w x y width height priv render) = WidgetState w x y width height (handleMessage w priv message) render
 
-data Separator = Separator Int Float deriving Show
+data Separator = Separator Int Float deriving (Show, Eq)
 
-instance WidgetClass Separator where
+instance WidgetClass Separator () where
-  type WidgetData Separator = ()
   initWidget _ _ _ = return ()
   
   minSize (Separator s _) _ _ _ = s
   weight (Separator _ w) = w
-  render _ _ _ _ _ = return ()
+  render _ _ _ _ _ _ _ = return ()
 
 separator :: Int -> Float -> Widget
 separator s w = Widget $ Separator s w

lib/Phi/Widgets/AlphaBox.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Phi.Widgets.AlphaBox ( alphaBox
                             ) where
@@ -11,13 +11,12 @@ import Control.Monad
 import Graphics.Rendering.Cairo
 
 
-data AlphaBoxState = AlphaBoxState ![WidgetState] deriving Show
+data AlphaBoxState = AlphaBoxState ![WidgetState] deriving Eq
 
-data AlphaBox = AlphaBox !Double ![Widget] deriving Show
+data AlphaBox = AlphaBox !Double ![Widget] deriving (Show, Eq)
 
 
-instance WidgetClass AlphaBox where
+instance WidgetClass AlphaBox AlphaBoxState where
-  type WidgetData AlphaBox = AlphaBoxState
   initWidget (AlphaBox _ widgets) phi disp = liftM AlphaBoxState $ mapM (createWidgetState phi disp) widgets
   
   minSize (AlphaBox _ _) (AlphaBoxState widgetStates) height screen =
@@ -27,10 +26,10 @@ instance WidgetClass AlphaBox where
   
   layout (AlphaBox _ _) (AlphaBoxState widgetStates) width height screen = AlphaBoxState $ layoutWidgets widgetStates 0 0 width height screen
 
-  render (AlphaBox alpha _) (AlphaBoxState widgetStates) w h screen = do
+  render (AlphaBox alpha _) (AlphaBoxState widgetStates) x y w h screen = do
     renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do
       renderWith surface $ do
-        renderWidgets widgetStates screen
+        renderWidgets widgetStates screen x y
         
         setOperator OperatorDestIn
         setSourceRGBA 0 0 0 alpha

lib/Phi/Widgets/Clock.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
 
 module Phi.Widgets.Clock ( ClockConfig(..)
                          , defaultClockConfig
@@ -29,20 +29,21 @@ data ClockConfig = ClockConfig { clockFormat :: !String
                                , fontColor   :: !Color
                                , lineSpacing :: !Double
                                , clockSize   :: !Int
-                               } deriving Show
+                               } deriving (Show, Eq)
 
 defaultClockConfig :: ClockConfig
 defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50
 
-data Clock = Clock !ClockConfig deriving Show
+data Clock = Clock !ClockConfig deriving (Show, Eq)
 
-data ClockState = ClockState !ZonedTime deriving Show
+instance Eq ZonedTime where
+  (ZonedTime localTime timezone) == (ZonedTime localTime' timezone') = (localTime == localTime') && (timezone == timezone')
+
+data ClockState = ClockState !ZonedTime deriving (Show, Eq)
 
 data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
 
-instance WidgetClass Clock where
+instance WidgetClass Clock ClockState where
-  type WidgetData Clock = ClockState
-  
   initWidget (Clock _) phi _ = do
     forkIO $ forever $ do
       time <- getZonedTime
@@ -57,8 +58,7 @@ instance WidgetClass Clock where
     
   minSize (Clock config) _ _ _ = clockSize config
   
-  render (Clock config) (ClockState time) w h _ = do
+  render (Clock config) (ClockState time) _ _ w h _ = do
-    time <- liftIO getZonedTime
     let (r, g, b, a) = fontColor config
         str = formatTime defaultTimeLocale (clockFormat config) time
     setSourceRGBA r g b a

lib/Phi/Widgets/Systray.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
 
 module Phi.Widgets.Systray ( systray
                            ) where
@@ -48,16 +48,16 @@ instance Show (IORef a) where
 data SystrayIconState = SystrayIconState !Window !Window deriving Show
 
 data SystrayState = SystrayState !Phi !Rectangle !Int !(IORef Int) ![SystrayIconState] deriving Show
+instance Eq SystrayState where
+  _ == _ = False
 
-data Systray = Systray deriving Show
+data Systray = Systray deriving (Show, Eq)
 
 data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int !Bool
                       deriving (Show, Typeable)
 
 
-instance WidgetClass Systray where
+instance WidgetClass Systray SystrayState where
-  type WidgetData Systray = SystrayState
-  
   initWidget (Systray) phi dispvar = do
     phi' <- dupPhi phi
     forkIO $ systrayRunner phi' dispvar
@@ -71,15 +71,13 @@ instance WidgetClass Systray where
 
   weight _ = 0
   
-  render Systray (SystrayState phi systrayScreen reset lastResetRef icons) w h screen = case True of 
+  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
-      Matrix _ _ _ _ dx dy <- getMatrix
       forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
-        let x = round dx + i*(h+2)
+        let x' = x + i*(h+2)
-            y = round dy
+        sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset)
-        sendMessage phi $ RenderIcon midParent window x y h h (lastReset /= reset)
         
       | otherwise -> return ()
   

lib/Phi/Widgets/Taskbar.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances #-}
 
 module Phi.Widgets.Taskbar ( IconStyle
                            , idIconStyle
@@ -50,6 +50,8 @@ import Phi.X11.Atoms
 type IconStyle = Surface -> Render ()
 instance Show IconStyle where
   show _ = "IconStyle <?>"
+instance Eq IconStyle where
+  _ == _ = True
 
 idIconStyle :: IconStyle
 idIconStyle = flip withPatternForSurface setSource
@@ -103,20 +105,20 @@ data TaskStyle = TaskStyle { taskFont      :: !String
                            , taskColor     :: !Color
                            , taskBorder    :: !BorderConfig
                            , taskIconStyle :: !IconStyle
-                           } deriving Show
+                           } deriving (Show, Eq)
 
 data DesktopStyle = DesktopStyle { desktopFont       :: !String
                                  , desktopLabelWidth :: !Int
                                  , desktopLabelGap   :: !Int
                                  , desktopColor      :: !Color
                                  , desktopBorder     :: !BorderConfig
-                                 } deriving Show
+                                 } deriving (Show, Eq)
 
 data TaskbarConfig = TaskbarConfig { taskMaxSize      :: !Int
                                    , normalTaskStyle  :: !TaskStyle
                                    , activeTaskStyle  :: !TaskStyle
                                    , desktopStyle     :: !(Maybe (DesktopStyle, DesktopStyle))
-                                   } deriving Show
+                                   } deriving (Show, Eq)
 
 defaultStyle :: TaskStyle
 defaultStyle = TaskStyle { taskFont = "Sans 8"
@@ -132,7 +134,7 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
                                      , desktopStyle = Nothing
                                      }
 
-data Taskbar = Taskbar TaskbarConfig deriving Show
+data Taskbar = Taskbar TaskbarConfig deriving (Show, Eq)
 
 instance Show Surface where
   show _ = "Surface <?>"
@@ -146,6 +148,8 @@ data TaskbarState = TaskbarState { taskbarActiveWindow      :: !Window
                                  , taskbarWindowScaledIcons :: !(M.Map Window (IORef (Maybe (Int, Surface))))
                                  , taskbarWindowScreens     :: !(M.Map Window Xlib.Rectangle)
                                  } deriving Show
+instance Eq TaskbarState where
+  _ == _ = False
 
 data WindowState = WindowState { windowTitle   :: !String
                                , windowDesktop :: !Int
@@ -161,9 +165,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
 instance Show (IORef a) where
   show _ = "IORef <?>"
 
-instance WidgetClass Taskbar where
+instance WidgetClass Taskbar TaskbarState where
-  type WidgetData Taskbar = TaskbarState
-  
   initWidget (Taskbar _) phi dispvar = do
     phi' <- dupPhi phi
     forkIO $ taskbarRunner phi' dispvar
@@ -182,7 +184,7 @@ instance WidgetClass Taskbar where
                                        , taskbarWindowIcons = windowIcons
                                        , taskbarWindowScaledIcons = windowScaledIcons
                                        , taskbarWindowScreens = windowScreens
-                                       } w h screen = do
+                                       } _ _ w h screen = do
     let screenWindows  = filter ((== Just screen) . flip M.lookup windowScreens) windows
         desktopNumbers = take desktopCount [0..]
         desktops       = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers

lib/Phi/X11.hs

@@ -218,12 +218,13 @@ updatePanels dispvar = do
             setSource pattern
             paint
             restore
-          Widget.renderWidgets layoutedWidgets $ panelScreenArea panel
+          Widget.renderWidgets layoutedWidgets (panelScreenArea panel) 0 0
         renderWith xbuffer $ do
           withPatternForSurface buffer $ \pattern -> do
             setSource pattern
             paint
       
+      surfaceFlush xbuffer
       surfaceFinish xbuffer
       
       -- copy buffer to window

phi.cabal

@@ -11,7 +11,7 @@ maintainer:          mschiffer@universe-factory.net
 build-type:          Simple
 
 library
-  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix
+  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, arrows, CacheArrow
   exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
                      Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
   other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler