Use Cairo for background rendering

1 files changed, 82 insertions, 59 deletions

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