summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-14 22:50:03 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-14 22:50:03 +0200
commit55edb549a5b8d86821e360d2d9e19a889d59b4b9 (patch)
treea5f831f0110e71ce2e83474125eaa17332f16081 /lib
parent861fa81d8503b64023777ec815845361bbcc2885 (diff)
downloadphi-55edb549a5b8d86821e360d2d9e19a889d59b4b9.tar
phi-55edb549a5b8d86821e360d2d9e19a889d59b4b9.zip
Use Cairo for background rendering
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Widget.hs13
-rw-r--r--lib/Phi/Widgets/Clock.hs20
-rw-r--r--lib/Phi/Widgets/Taskbar.hs55
-rw-r--r--lib/Phi/X11.hs141
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