Use Cairo for background rendering
This commit is contained in:
parent
861fa81d85
commit
55edb549a5
6 changed files with 169 additions and 72 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -73,6 +80,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
|
||||
Widget $ Clock config
|
||||
55
lib/Phi/Widgets/Taskbar.hs
Normal file
55
lib/Phi/Widgets/Taskbar.hs
Normal file
|
|
@ -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
|
||||
131
lib/Phi/X11.hs
131
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,30 +76,32 @@ 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)
|
||||
withDisplayX dispvar $ \disp -> do
|
||||
panels <- mapM (createPanel disp widgetStates) screens
|
||||
|
||||
modify $ \state -> state { phiPanels = panels }
|
||||
forM_ panels $ \panel -> do
|
||||
setPanelProperties disp panel
|
||||
liftIO $ mapWindow disp (panelWindow panel)
|
||||
|
||||
updatePanels disp True
|
||||
modify $ \state -> state { phiPanels = panels }
|
||||
|
||||
liftIO $ putMVar dispvar disp
|
||||
updatePanels disp True
|
||||
|
||||
liftIO $ forkIO $ receiveEvents phi dispvar
|
||||
|
||||
|
|
@ -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 buffer $ do
|
||||
withPatternForSurface rootImage $ \pattern -> do
|
||||
save
|
||||
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
|
||||
setSource pattern
|
||||
paint
|
||||
restore
|
||||
Widget.renderWidgets layoutedWidgets
|
||||
|
||||
renderWith surface $ 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
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ build-type: Simple
|
|||
library
|
||||
build-depends: base >= 4, template-haskell, mtl, time, old-locale, X11, cairo, pango
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||
Phi.Widgets.Clock
|
||||
Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
||||
hs-source-dirs: lib
|
||||
|
||||
|
|
|
|||
10
src/Phi.hs
10
src/Phi.hs
|
|
@ -3,18 +3,18 @@ import Phi.Widget
|
|||
import Phi.Panel
|
||||
import Phi.Border
|
||||
import Phi.X11
|
||||
|
||||
import Phi.Widgets.Clock
|
||||
import Phi.Widgets.Taskbar
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
[border border1 [border border3 [], border border3 []], border border2 [], border brightBorder [theClock]]
|
||||
[theTaskbar, brightBorder [theClock]]
|
||||
where
|
||||
theTaskbar = taskbar defaultTaskbarConfig
|
||||
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
||||
, lineSpacing = (-2)
|
||||
, clockSize = 75
|
||||
}
|
||||
brightBorder = BorderConfig (simpleBorderWidth 1) 1 (BorderWidth (-2) 3 0 3) (0.5, 0.5, 0.5, 0.65) (0.85, 0.85, 0.85, 0.8) 5 0
|
||||
border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2
|
||||
border2 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1
|
||||
border3 = BorderConfig (simpleBorderWidth 0) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.0, 0.0, 0.5, 0.5) 3 1
|
||||
brightBorder = border $ BorderConfig (simpleBorderWidth 1) 1 (BorderWidth (-2) 3 0 3) (0.5, 0.5, 0.5, 0.65) (0.85, 0.85, 0.85, 0.8) 5 0
|
||||
|
|
|
|||
Reference in a new issue