Use Cairo for background rendering

4 files changed, 163 insertions, 66 deletions

diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index d28c21d..e0d051b 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
 
-module Phi.Widget ( Display
+module Phi.Widget ( Display(..)
+                  , withDisplay
                   , Widget(..)
                   , WidgetClass(..)
                   , WidgetState(..)
@@ -11,7 +12,6 @@ module Phi.Widget ( Display
                   , handleMessageWidgets
                   ) where
 
-import Control.Concurrent
 import Control.Monad
 
 import Data.Traversable
@@ -23,7 +23,14 @@ import Graphics.Rendering.Cairo
 import Phi.Phi
 
 
-type Display = MVar Graphics.X11.Xlib.Display
+newtype Display = Display Graphics.X11.Xlib.Display
+
+withDisplay :: Display -> (Graphics.X11.Xlib.Display -> IO a) -> IO a
+withDisplay (Display disp) f = do
+  Graphics.X11.Xlib.lockDisplay disp
+  a <- f disp
+  Graphics.X11.Xlib.unlockDisplay disp
+  return a
 
 
 class Show a => WidgetClass a where
diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index 602a1fc..3e88b0e 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
 
 module Phi.Widgets.Clock ( ClockConfig(..)
                          , defaultClockConfig
@@ -36,21 +36,28 @@ defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50
 
 data Clock = Clock ClockConfig deriving Show
 
+data ClockState = ClockState ZonedTime deriving Show
+
+data ClockMessage = UpdateTime ZonedTime deriving (Show, Typeable)
+
 instance WidgetClass Clock where
-  type WidgetData Clock = ()
+  type WidgetData Clock = ClockState
   
   initWidget (Clock _) phi _ = do
     forkIO $ forever $ do
       time <- getZonedTime
+      sendMessage phi $ UpdateTime time
       sendMessage phi Repaint
       
       threadDelay $ ceiling $ 1000000*(max 1 $ 60 - (todSec . localTimeOfDay . zonedTimeToLocalTime $ time))
-    return ()
+    
+    time <- getZonedTime
+    return $ ClockState time
 
     
   minSize (Clock config ) = clockSize config
   
-  render (Clock config) _ 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
@@ -72,6 +79,11 @@ instance WidgetClass Clock where
     
     moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2)
     showLayout layout
+  
+  handleMessage _ priv m = case (fromMessage m) of
+    Just (UpdateTime time) -> ClockState time
+    _ -> priv
+
 
 clock :: ClockConfig -> Widget
 clock config = do
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
new file mode 100644
index 0000000..1b86ffd
--- /dev/null
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Phi.Widgets.Taskbar ( TaskbarConfig(..)
+                           , defaultTaskbarConfig
+                           , taskbar
+                           ) where
+
+import Control.Concurrent
+import Control.Monad
+
+import Data.Typeable
+import Data.Time.LocalTime
+import Data.Time.Format
+
+import Graphics.Rendering.Cairo
+
+import Graphics.Rendering.Pango.Cairo
+import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
+import Graphics.Rendering.Pango.Layout
+
+import System.Locale
+
+import Phi.Phi
+import Phi.Types
+import Phi.Widget
+
+
+data TaskbarConfig = TaskbarConfig deriving Show
+
+defaultTaskbarConfig :: TaskbarConfig
+defaultTaskbarConfig = TaskbarConfig
+
+data Taskbar = Taskbar TaskbarConfig deriving Show
+
+data TaskbarState = TaskbarState deriving Show
+
+instance WidgetClass Taskbar where
+  type WidgetData Taskbar = TaskbarState
+  
+  initWidget (Taskbar _) phi dispvar = do
+    --withMVar dispvar $ \disp ->
+      
+    --  return ()
+    return TaskbarState
+
+    
+  minSize _ = 0
+  weight _ = 1
+  
+  render (Taskbar config) _ w h = do
+    return ()
+
+taskbar :: TaskbarConfig -> Widget
+taskbar config = do
+  Widget $ Taskbar config
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 3fc08e6..e5d220b 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -35,14 +35,12 @@ data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
                        }
 
 data PhiState = PhiState { phiPhi        :: !Phi
-                         , phiRootPixmap :: !Pixmap
+                         , phiRootImage  :: !Surface
                          , phiPanels     :: ![PanelState]
                          }
 
 data PanelState = PanelState { panelWindow       :: !Window
-                             , panelGC           :: !GC
-                             , panelPixmap       :: !Pixmap
-                             , panelSurface      :: !Surface
+                             , panelBuffer       :: !Surface
                              , panelArea         :: !Rectangle
                              , panelScreenArea   :: !Rectangle
                              , panelWidgetStates :: ![Widget.WidgetState]
@@ -65,12 +63,12 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
 runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
 runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 
-withMVarX :: MVar a -> (a -> PhiX b) -> PhiX b
-withMVarX m f = do
-  a <- liftIO $ takeMVar m
-  b <- f a
-  liftIO $ putMVar m a
-  return b
+withDisplayX :: Widget.Display -> (Display -> PhiX a) -> PhiX a
+withDisplayX (Widget.Display disp) f = do
+  liftIO $ lockDisplay disp
+  a <- f disp
+  liftIO $ unlockDisplay disp
+  return a
 
 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
@@ -78,31 +76,33 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
 
 runPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
 runPhi xconfig config widgets = do
+  initThreads
   phi <- initPhi
   disp <- openDisplay []
 
   atoms <- initAtoms disp
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootPixmap = 0, phiPanels = [] } $ do
-    updateRootPixmap disp
+  bg <- createImageSurface FormatRGB24 1 1
+  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootImage = bg, phiPanels = [] } $ do
+    updateRootImage disp
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
     
-    dispvar <- liftIO $ newEmptyMVar
+    let dispvar = Widget.Display disp
     widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
-    panels <- mapM (createPanel disp widgetStates) screens
-    
-    forM_ panels $ \panel -> do
-      setPanelProperties disp panel
-      liftIO $ mapWindow disp (panelWindow panel)
-    
-    modify $ \state -> state { phiPanels = panels }
-    
-    updatePanels disp True
-    
-    liftIO $ putMVar dispvar disp
     
+    withDisplayX dispvar $ \disp -> do
+      panels <- mapM (createPanel disp widgetStates) screens
+      
+      forM_ panels $ \panel -> do
+        setPanelProperties disp panel
+        liftIO $ mapWindow disp (panelWindow panel)
+      
+      modify $ \state -> state { phiPanels = panels }
+      
+      updatePanels disp True
+      
     liftIO $ forkIO $ receiveEvents phi dispvar
 
     forever $ do
@@ -116,28 +116,28 @@ handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {pane
   where
     widgets' = Widget.handleMessageWidgets message widgets
 
-handleMessage :: MVar Display -> Message -> PhiX ()
+handleMessage :: Widget.Display -> Message -> PhiX ()
 handleMessage dispvar m = do
   modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
   
   case (fromMessage m) of
-    Just Repaint -> withMVarX dispvar $ \disp ->
+    Just Repaint -> withDisplayX dispvar $ \disp ->
       updatePanels disp True
     _ ->
       case (fromMessage m) of
-        Just ExposeEvent {} -> withMVarX dispvar $ \disp ->
+        Just ExposeEvent {} -> withDisplayX dispvar $ \disp ->
           updatePanels disp False
-        Just event@PropertyEvent {} -> withMVarX dispvar $ \disp ->
+        Just event@PropertyEvent {} -> withDisplayX dispvar $ \disp ->
           handlePropertyUpdate disp event
         _ ->
           return ()
 
-receiveEvents :: Phi -> MVar Display -> IO ()
+receiveEvents :: Phi -> Widget.Display -> IO ()
 receiveEvents phi dispvar = do
-  connection <- withMVar dispvar $ return . Fd . connectionNumber
+  connection <- Widget.withDisplay dispvar $ return . Fd . connectionNumber
   
   forever $ allocaXEvent $ \xevent -> do
-    handled <- withMVar dispvar $ \disp -> do
+    handled <- Widget.withDisplay dispvar $ \disp -> do
       pend <- pending disp
       if pend /= 0 then
         do
@@ -152,28 +152,38 @@ receiveEvents phi dispvar = do
 
 updatePanels :: Display -> Bool -> PhiX ()
 updatePanels disp redraw = do
-  
-  rootPixmap <- gets phiRootPixmap
+  rootImage <- gets phiRootImage
   panels <- gets phiPanels
     
   panels' <- forM panels $ \panel -> do
+    let buffer = panelBuffer panel
+        area = panelArea panel
+    
     newPanel <- if not redraw then return panel else do
-      let surface = panelSurface panel
-          area = panelArea panel
-          layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0
+      let layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0
           panel' = panel { panelWidgetStates = layoutedWidgets }
       
-      -- draw background
-      liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0
-      surfaceMarkDirty surface
-      
-      renderWith surface $ Widget.renderWidgets layoutedWidgets
+      renderWith buffer $ do
+        withPatternForSurface rootImage $ \pattern -> do
+          save
+          translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
+          setSource pattern
+          paint
+          restore
+        Widget.renderWidgets layoutedWidgets
       
-      surfaceFlush surface
       return panel'
-      
-    -- copy pixmap to window
-    liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0
+    
+    let screen = defaultScreen disp
+        visual = defaultVisual disp screen
+    surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual
+    
+    -- copy buffer to window
+    renderWith surface $ withPatternForSurface buffer $ \pattern -> do
+      setSource pattern
+      paint
+    surfaceFinish surface
+    
     return newPanel
 
   modify $ \state -> state { phiPanels = panels' }
@@ -185,18 +195,39 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
   panels <- gets phiPanels
 
   when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
-    updateRootPixmap disp
+    updateRootImage disp
     updatePanels disp True
   
 
-updateRootPixmap :: Display -> PhiX ()
-updateRootPixmap disp = do
+updateRootImage :: Display -> PhiX ()
+updateRootImage disp = do
   atoms <- asks phiAtoms
+  
+  
   let screen = defaultScreen disp
+      visual = defaultVisual disp screen
       rootwin = defaultRootWindow disp
   pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
             \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
-  modify $ \state -> state { phiRootPixmap = pixmap }
+  (_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
+  
+  -- update surface size
+  oldBg <- gets phiRootImage
+  imageWidth <- liftM fromIntegral $ imageSurfaceGetWidth oldBg
+  imageHeight <- liftM fromIntegral $ imageSurfaceGetHeight oldBg
+  when (imageWidth /= rootWidth || imageHeight /= rootHeight) $ do
+    surfaceFinish oldBg
+    newBg <- liftIO $ createImageSurface FormatRGB24 (fromIntegral rootWidth) (fromIntegral rootHeight)
+    modify $ \state -> state { phiRootImage = newBg }
+  
+  bg <- gets phiRootImage
+  rootSurface <- liftIO $ Util.createXlibSurface disp pixmap visual (fromIntegral rootWidth) (fromIntegral rootHeight)
+  
+  renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do
+    setSource pattern
+    paint
+  
+  surfaceFinish rootSurface
 
 
 createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
@@ -206,19 +237,11 @@ createPanel disp widgets screenRect = do
   let rect = panelBounds config screenRect
       
   win <- createPanelWindow disp rect
-  gc <- liftIO $ createGC disp win
   
-  let screen = defaultScreen disp
-      depth = defaultDepth disp screen
-      visual = defaultVisual disp screen
-
-  pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth
-  surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual
+  buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24
   
   return PanelState { panelWindow = win
-                    , panelGC = gc
-                    , panelPixmap = pixmap
-                    , panelSurface = surface
+                    , panelBuffer = buffer
                     , panelArea = rect
                     , panelScreenArea = screenRect
                     , panelWidgetStates = widgets