neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make render function return cachable surface slices

Browse source
This commit is contained in:
Matthias Schiffer 2011-08-21 19:34:16 +02:00
parent ddca7c3ec5
commit 42c14fa1ca
8 changed files with 234 additions and 161 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
lib/Phi/Border.hs
View file

@ -53,19 +53,21 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
, borderWeight = 1 , borderWeight = 1
} }
data Border w d = (Widget w d) => Border !BorderConfig !w data Border w s c = (Widget w s c) => Border !BorderConfig !w
deriving instance Show (Border w d) deriving instance Show (Border w s c)
deriving instance Eq (Border w d) deriving instance Eq (Border w s c)
instance Eq d => Widget (Border w d) d where data BorderCache w s c = (Widget w s c) => BorderCache !c
instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
initWidget (Border _ w) = initWidget w initWidget (Border _ w) = initWidget w
minSize (Border config w) d height screen = minSize (Border config w) s height screen =
case True of case True of
_ | childSize == 0 -> 0 _ | childSize == 0 -> 0
| otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m) | otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m)
where where
childSize = minSize w d height' screen childSize = minSize w s height' screen
m = margin config m = margin config
bw = borderWidth config bw = borderWidth config
@ -75,9 +77,9 @@ instance Eq d => Widget (Border w d) d where
weight (Border config _) = borderWeight config weight (Border config _) = borderWeight config
layout (Border config w) d width height screen = case True of layout (Border config w) s width height screen = case True of
_ | width' > 0 -> layout w d width' height' screen _ | width' > 0 -> layout w s width' height' screen
| otherwise -> d | otherwise -> s
where where
m = margin config m = margin config
bw = borderWidth config bw = borderWidth config
@ -86,18 +88,49 @@ instance Eq d => Widget (Border w d) d where
width' = width - borderH m - 2*bw - borderH p width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p height' = height - borderV m - 2*bw - borderV p
render (Border config w) d x y width height screen = when (width > borderH m - 2*bw - borderH p) $ do render (Border config w) s x y width height screen = case () of
drawBorder config 0 0 width height _ | (width > borderH m - 2*bw - borderH p) -> do
clip border <- createImageSurface FormatARGB32 width height
translate (fromIntegral dx) (fromIntegral dy) renderWith border $ do
render w d (x+dx) (y+dy) width' height' screen setOperator OperatorClear
return () paint
setOperator OperatorOver
drawBorder config 0 0 width height
surfaces <- render w s (x+dx) (y+dy) width' height' screen
let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)]
surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)])
forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
surf' <- createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do
setOperator OperatorClear
paint
setOperator OperatorOver
save
translate (fromIntegral (-x)) 0
withPatternForSurface border setSource
paint
restore
case surf of
Just surface -> do
translate 0 (fromIntegral dy)
withPatternForSurface surface setSource
paint
Nothing -> return ()
return (updated, SurfaceSlice x surf')
| otherwise -> do
surface <- createImageSurface FormatARGB32 width height
return [(True, SurfaceSlice 0 surface)]
where where
m = margin config m = margin config
bw = borderWidth config bw = borderWidth config
p = padding config p = padding config
dx = borderLeft m + bw + borderLeft p leftWidth = borderLeft m + bw + borderLeft p
rightWidth = borderRight m + bw + borderRight p
dx = leftWidth
dy = borderTop m + bw + borderTop p dy = borderTop m + bw + borderTop p
width' = width - borderH m - 2*bw - borderH p width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p height' = height - borderV m - 2*bw - borderV p
@ -139,5 +172,5 @@ roundRectangle x y width height radius = do
arc (x + radius) (y + radius) radius pi (pi*3/2) arc (x + radius) (y + radius) radius pi (pi*3/2)
closePath closePath
border :: (Widget w d) => BorderConfig -> w -> Border w d border :: (Widget w s c) => BorderConfig -> w -> Border w s c
border = Border border = Border

70
lib/Phi/Widget.hs
View file

@ -6,6 +6,7 @@ module Phi.Widget ( Display(..)
, getScreenWindows , getScreenWindows
, getScreens , getScreens
, unionArea , unionArea
, SurfaceSlice(..)
, Widget(..) , Widget(..)
, CompoundWidget , CompoundWidget
, (<~>) , (<~>)
@ -20,8 +21,6 @@ import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Traversable hiding (forM)
import qualified Graphics.X11.Xlib as Xlib import qualified Graphics.X11.Xlib as Xlib
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
@ -64,20 +63,22 @@ unionArea a b = fromIntegral $ uw*uh
by2 = by1 + fromIntegral bh by2 = by1 + fromIntegral bh
class (Show a, Eq a, Eq d) => Widget a d | a -> d where data SurfaceSlice = SurfaceSlice !Int !Surface
initWidget :: a -> Phi -> Display -> IO d
class (Show a, Eq a, Eq s) => Widget a s c | a -> s, a -> c where
initWidget :: a -> Phi -> Display -> IO s
minSize :: a -> d -> Int -> Xlib.Rectangle -> Int minSize :: a -> s -> Int -> Xlib.Rectangle -> Int
weight :: a -> Float weight :: a -> Float
weight _ = 0 weight _ = 0
layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s
layout _ priv _ _ _ = priv layout _ priv _ _ _ = priv
render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render () render :: a -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> IO [(Bool, SurfaceSlice)]
handleMessage :: a -> d -> Message -> d handleMessage :: a -> s -> Message -> s
handleMessage _ priv _ = priv handleMessage _ priv _ = priv
{-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface {-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface
@ -90,57 +91,64 @@ createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
render widget state x y w h screen render widget state x y w h screen
return surface-} return surface-}
data CompoundWidget a da b db = (Widget a da, Widget b db) => CompoundWidget !a !b data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
deriving instance Eq (CompoundWidget a da b db) deriving instance Eq (CompoundWidget a sa ca b sb cb)
deriving instance Show (CompoundWidget a da b db) deriving instance Show (CompoundWidget a sa ca b sb cb)
data CompoundState a da b db = (Widget a da, Widget b db) => CompoundState !da !db !Int data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int
deriving instance Eq (CompoundState a da b db) deriving instance Eq (CompoundState a sa ca b sb cb)
instance Widget (CompoundWidget a da b db) (CompoundState a da b db) where data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb
instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0) initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen
weight (CompoundWidget a b) = weight' a + weight' b weight (CompoundWidget a b) = weight' a + weight' b
layout c@(CompoundWidget a b) d@(CompoundState da db _) width height screen = CompoundState da' db' xb layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb
where where
sizesum = minSize c d height screen sizesum = minSize c s height screen
wsum = let wsum = weight c wsum = let wsum = weight c
in if wsum > 0 then wsum else 1 in if wsum > 0 then wsum else 1
surplus = width - sizesum surplus = width - sizesum
(xb, da') = layoutWidget a da (xb, sa') = layoutWidget a sa
(_, db') = layoutWidget b db (_, sb') = layoutWidget b sb
layoutWidget w priv = let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(weight' w)/wsum layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum
in (wWidth, layout w priv wWidth height screen) in (wWidth, layout w s wWidth height screen)
render (CompoundWidget a b) (CompoundState da db xb) x y w h screen = do render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do
save surfacea <- render a sa x y xb h screen
render a da x y xb h screen surfaceb <- render b sb (x+xb) y (w-xb) h screen
restore return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
translate (fromIntegral xb) 0
render b db (x+xb) y (w-xb) h screen
handleMessage (CompoundWidget a b) (CompoundState da db xb) message = CompoundState (handleMessage a da message) (handleMessage b db message) xb handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb
weight' :: (Widget a da) => a -> Float weight' :: (Widget a sa ca) => a -> Float
weight' = max 0 . weight weight' = max 0 . weight
(<~>) :: (Widget a da, Widget b db) => a -> b -> CompoundWidget a da b db (<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb
a <~> b = CompoundWidget a b a <~> b = CompoundWidget a b
data Separator = Separator !Int !Float deriving (Show, Eq) data Separator = Separator !Int !Float deriving (Show, Eq)
instance Widget Separator () where instance Widget Separator () () where
initWidget _ _ _ = return () initWidget _ _ _ = return ()
minSize (Separator s _) _ _ _ = s minSize (Separator s _) _ _ _ = s
weight (Separator _ w) = w weight (Separator _ w) = w
render _ _ _ _ _ _ _ = return () render _ _ _ _ width height _ = do
surface <- createImageSurface FormatARGB32 width height
renderWith surface $ do
setOperator OperatorClear
paint
return [(True, SurfaceSlice 0 surface)]
separator :: Int -> Float -> Separator separator :: Int -> Float -> Separator
separator = Separator separator = Separator

26
lib/Phi/Widgets/AlphaBox.hs
View file

@ -12,11 +12,11 @@ import Control.Monad
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
data AlphaBox w d = (Widget w d) => AlphaBox !Double !w data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w
deriving instance Show (AlphaBox w d) deriving instance Show (AlphaBox w s c)
deriving instance Eq (AlphaBox w d) deriving instance Eq (AlphaBox w s c)
instance Eq d => Widget (AlphaBox w d) d where instance Eq s => Widget (AlphaBox w s c) s () where
initWidget (AlphaBox _ w) = initWidget w initWidget (AlphaBox _ w) = initWidget w
minSize (AlphaBox _ w) = minSize w minSize (AlphaBox _ w) = minSize w
@ -25,21 +25,25 @@ instance Eq d => Widget (AlphaBox w d) d where
layout (AlphaBox _ w) = layout w layout (AlphaBox _ w) = layout w
render (AlphaBox alpha w) d x y width height screen = do render (AlphaBox alpha w) s x y width height screen = do
renderWithSimilarSurface ContentColorAlpha width height $ \surface -> do surfaces <- render w s x y width height screen
renderWith surface $ do let surfacesWidths = zipWith (\(updated, SurfaceSlice x surf) x' -> (updated, x, x'-x, surf)) surfaces (map (\(_, SurfaceSlice x _) -> x) (tail surfaces) ++ [width])
render w d x y width height screen forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
surf' <- createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do
setOperator OperatorSource
withPatternForSurface surf setSource
paint
setOperator OperatorDestIn setOperator OperatorDestIn
setSourceRGBA 0 0 0 alpha setSourceRGBA 0 0 0 alpha
paint paint
withPatternForSurface surface setSource return (updated, SurfaceSlice x surf')
paint
handleMessage (AlphaBox _ w) = handleMessage w handleMessage (AlphaBox _ w) = handleMessage w
alphaBox :: (Widget w d) => Double -> w -> AlphaBox w d alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c
alphaBox = AlphaBox alphaBox = AlphaBox

49
lib/Phi/Widgets/Clock.hs
View file

@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
instance Widget Clock ClockState where instance Widget Clock ClockState () where
initWidget (Clock _) phi _ = do initWidget (Clock _) phi _ = do
forkIO $ forever $ do forkIO $ forever $ do
time <- getZonedTime time <- getZonedTime
@ -59,26 +59,33 @@ instance Widget Clock ClockState where
minSize (Clock config) _ _ _ = clockSize config minSize (Clock config) _ _ _ = clockSize config
render (Clock config) (ClockState time) _ _ w h _ = do render (Clock config) (ClockState time) _ _ w h _ = do
let (r, g, b, a) = fontColor config surface <- createImageSurface FormatARGB32 w h
str = formatTime defaultTimeLocale (clockFormat config) time renderWith surface $ do
setSourceRGBA r g b a setOperator OperatorClear
paint
layout <- createLayout ""
(_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do setOperator OperatorOver
layoutSetMarkup layout str let (r, g, b, a) = fontColor config
layoutSetAlignment layout AlignCenter str = formatTime defaultTimeLocale (clockFormat config) time
layoutSetSpacing layout $ lineSpacing config setSourceRGBA r g b a
layoutGetExtents layout
layout <- createLayout ""
let scalef = min 1 ((fromIntegral w)/textWidth) (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
when (scalef < 1) $ do layoutSetMarkup layout str
scale scalef scalef layoutSetAlignment layout AlignCenter
updateLayout layout layoutSetSpacing layout $ lineSpacing config
layoutGetExtents layout
(_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout
let scalef = min 1 ((fromIntegral w)/textWidth)
moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2) when (scalef < 1) $ do
showLayout layout scale scalef scalef
updateLayout layout
(_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout
moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2)
showLayout layout
return [(True, SurfaceSlice 0 surface)]
handleMessage _ priv m = case (fromMessage m) of handleMessage _ priv m = case (fromMessage m) of
Just (UpdateTime time) -> ClockState time Just (UpdateTime time) -> ClockState time

19
lib/Phi/Widgets/Systray.hs
View file

@ -47,7 +47,7 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon
deriving (Show, Typeable) deriving (Show, Typeable)
instance Widget Systray SystrayState where instance Widget Systray SystrayState () where
initWidget (Systray) phi dispvar = do initWidget (Systray) phi dispvar = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ systrayRunner phi' dispvar forkIO $ systrayRunner phi' dispvar
@ -61,15 +61,20 @@ instance Widget Systray SystrayState where
weight _ = 0 weight _ = 0
render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = case True of render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do
_ | screen == systrayScreen -> do when (screen == systrayScreen) $ do
lastReset <- liftIO $ readIORef lastResetRef lastReset <- readIORef lastResetRef
liftIO $ writeIORef lastResetRef reset writeIORef lastResetRef reset
forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
let x' = x + i*(h+2) let x' = x + i*(h+2)
sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset) sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset)
| otherwise -> return () surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do
setOperator OperatorClear
paint
return [(True, SurfaceSlice 0 surface)]
handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of
Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons) Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons)

77
lib/Phi/Widgets/Taskbar.hs
View file

@ -166,7 +166,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
instance Show (IORef a) where instance Show (IORef a) where
show _ = "IORef <?>" show _ = "IORef <?>"
instance Widget Taskbar TaskbarState where instance Widget Taskbar TaskbarState () where
initWidget (Taskbar _) phi dispvar = do initWidget (Taskbar _) phi dispvar = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ taskbarRunner phi' dispvar forkIO $ taskbarRunner phi' dispvar
@ -204,41 +204,50 @@ instance Widget Taskbar TaskbarState where
desktopsWidth = sum $ map dwidth desktopNumbers desktopsWidth = sum $ map dwidth desktopNumbers
windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do surface <- createImageSurface FormatARGB32 w h
let dstyle' = dstyle desktop renderWith surface $ do
dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth setOperator OperatorClear
paint
case dstyle' of
Just ds -> do setOperator OperatorOver
let (r, g, b, a) = desktopColor ds
save flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h let dstyle' = dstyle desktop
clip dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
setSourceRGBA r g b a
renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
restore
forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
mstate = M.lookup window windowStates
micons = M.lookup window windowIcons
mscaledIconRef = M.lookup window windowScaledIcons
x = dx + i*windowWidth
y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
case (mstate, micons, mscaledIconRef) of
(Just state, Just icons, Just scaledIconRef) ->
renderTask state icons scaledIconRef style x y windowWidth h'
_ -> return ()
_ -> return () case dstyle' of
Just ds -> do
let (r, g, b, a) = desktopColor ds
save
drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
clip
setSourceRGBA r g b a
renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
restore
forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
mstate = M.lookup window windowStates
micons = M.lookup window windowIcons
mscaledIconRef = M.lookup window windowScaledIcons
x = dx + i*windowWidth
y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
case (mstate, micons, mscaledIconRef) of
(Just state, Just icons, Just scaledIconRef) ->
renderTask state icons scaledIconRef style x y windowWidth h'
_ -> return ()
_ -> return ()
return $ nwindows + length desktopWindows return $ nwindows + length desktopWindows
return [(True, SurfaceSlice 0 surface)]
handleMessage _ priv m = case (fromMessage m) of handleMessage _ priv m = case (fromMessage m) of

85
lib/Phi/X11.hs
View file

@ -38,21 +38,22 @@ import qualified Phi.Bindings.Util as Util
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
} }
data PhiState w d = (Widget.Widget w d) => PhiState { phiRootImage :: !Surface data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface
, phiPanels :: ![PanelState w d] , phiPanels :: ![PanelState w s c]
, phiRepaint :: !Bool , phiRepaint :: !Bool
, phiShutdown :: !Bool , phiShutdown :: !Bool
, phiShutdownHold :: !Int , phiShutdownHold :: !Int
}
data PanelState w d = (Widget.Widget w d) => PanelState { panelWindow :: !Window
, panelPixmap :: !Pixmap
, panelArea :: !Rectangle
, panelScreenArea :: !Rectangle
, panelWidget :: !w
, panelWidgetState :: !d
} }
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window
, panelPixmap :: !Pixmap
, panelArea :: !Rectangle
, panelScreenArea :: !Rectangle
, panelWidget :: !w
, panelWidgetState :: !s
, panelWidgetCache :: !(Maybe c)
}
data PhiConfig = PhiConfig { phiPhi :: !Phi data PhiConfig = PhiConfig { phiPhi :: !Phi
, phiPanelConfig :: !Panel.PanelConfig , phiPanelConfig :: !Panel.PanelConfig
, phiXConfig :: !XConfig , phiXConfig :: !XConfig
@ -65,17 +66,16 @@ newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
runPhiReader :: PhiConfig -> PhiReader a -> IO a runPhiReader :: PhiConfig -> PhiReader a -> IO a
runPhiReader config (PhiReader a) = runReaderT a config runPhiReader config (PhiReader a) = runReaderT a config
newtype PhiX w d a = PhiX (StateT (PhiState w d) PhiReader a) newtype PhiX w s c a = PhiX (StateT (PhiState w s c) PhiReader a)
deriving (Monad, MonadState (PhiState w d), MonadReader PhiConfig, MonadIO) deriving (Monad, MonadState (PhiState w s c), MonadReader PhiConfig, MonadIO)
runPhiX :: PhiConfig -> PhiState w d -> PhiX w d a -> IO (a, PhiState w d) runPhiX :: PhiConfig -> PhiState w s c -> PhiX w s c a -> IO (a, PhiState w s c)
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
} }
runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO ()
runPhi :: (Widget.Widget w d) => XConfig -> Panel.PanelConfig -> w -> IO ()
runPhi xconfig config widget = do runPhi xconfig config widget = do
xSetErrorHandler xSetErrorHandler
@ -158,12 +158,12 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown termHandler phi = Catch $ sendMessage phi Shutdown
handlePanel :: Message -> PanelState w d -> PanelState w d handlePanel :: Message -> PanelState w s c -> PanelState w s c
handlePanel message panel@PanelState {panelWidget = widget, panelWidgetState = state} = panel {panelWidgetState = state'} handlePanel message panel@PanelState {panelWidget = widget, panelWidgetState = state} = panel {panelWidgetState = state'}
where where
state' = Widget.handleMessage widget state message state' = Widget.handleMessage widget state message
handleMessage :: Widget.Display -> Message -> PhiX w d () handleMessage :: Widget.Display -> Message -> PhiX w s c ()
handleMessage dispvar m = do handleMessage dispvar m = do
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
@ -195,7 +195,7 @@ receiveEvents phi dispvar = do
when (not handled) $ threadWaitRead connection when (not handled) $ threadWaitRead connection
updatePanels :: (Widget w d) => Widget.Display -> PhiX w d () updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c ()
updatePanels dispvar = do updatePanels dispvar = do
rootImage <- gets phiRootImage rootImage <- gets phiRootImage
panels <- gets phiPanels panels <- gets phiPanels
@ -205,7 +205,7 @@ updatePanels dispvar = do
area = panelArea panel area = panelArea panel
let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel
panel' = panel { panelWidgetState = layoutedWidget } panelSurfaces <- liftIO $ (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
Widget.withDisplay dispvar $ \disp -> do Widget.withDisplay dispvar $ \disp -> do
let screen = defaultScreen disp let screen = defaultScreen disp
@ -215,31 +215,37 @@ updatePanels dispvar = do
liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
renderWith buffer $ do renderWith buffer $ do
withPatternForSurface rootImage $ \pattern -> do save
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
withPatternForSurface rootImage setSource
paint
restore
forM_ panelSurfaces $ \(updated, SurfaceSlice x surface) -> do
save save
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) translate (fromIntegral x) 0
setSource pattern withPatternForSurface surface setSource
paint paint
restore restore
(withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
renderWith xbuffer $ do renderWith xbuffer $ do
withPatternForSurface buffer $ \pattern -> do withPatternForSurface buffer setSource
setSource pattern paint
paint
surfaceFinish xbuffer surfaceFinish xbuffer
-- copy buffer to window -- copy buffer to window
liftIO $ do liftIO $ do
(withDimension area $ clearArea disp (panelWindow panel') 0 0) True (withDimension area $ clearArea disp (panelWindow panel) 0 0) True
sync disp False sync disp False
return panel' return $ panel { panelWidgetState = layoutedWidget }
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
handlePropertyUpdate :: Display -> Event -> PhiX w d () handlePropertyUpdate :: Display -> Event -> PhiX w s c ()
handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
phi <- asks phiPhi phi <- asks phiPhi
atoms <- asks phiAtoms atoms <- asks phiAtoms
@ -251,7 +257,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
sendMessage phi Repaint sendMessage phi Repaint
updateRootImage :: Display -> PhiX w d () updateRootImage :: Display -> PhiX w s c ()
updateRootImage disp = do updateRootImage disp = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
@ -289,8 +295,8 @@ updateRootImage disp = do
surfaceFinish rootSurface surfaceFinish rootSurface
createPanel :: (Widget w d) => Display -> Window -> w -> d -> Rectangle -> PhiX w d (PanelState w d) createPanel :: (Widget w s c) => Display -> Window -> w -> s -> Rectangle -> PhiX w s c (PanelState w s c)
createPanel disp win w d screenRect = do createPanel disp win w s screenRect = do
config <- asks phiPanelConfig config <- asks phiPanelConfig
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
let screen = defaultScreen disp let screen = defaultScreen disp
@ -304,10 +310,11 @@ createPanel disp win w d screenRect = do
, panelArea = rect , panelArea = rect
, panelScreenArea = screenRect , panelScreenArea = screenRect
, panelWidget = w , panelWidget = w
, panelWidgetState = d , panelWidgetState = s
, panelWidgetCache = Nothing
} }
createPanelWindow :: Display -> Rectangle -> PhiX w d Window createPanelWindow :: Display -> Rectangle -> PhiX w s c Window
createPanelWindow disp screenRect = do createPanelWindow disp screenRect = do
config <- asks phiPanelConfig config <- asks phiPanelConfig
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
@ -326,7 +333,7 @@ createPanelWindow disp screenRect = do
withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
setPanelProperties :: Display -> PanelState w d -> PhiX w d () setPanelProperties :: Display -> PanelState w s c -> PhiX w s c ()
setPanelProperties disp panel = do setPanelProperties disp panel = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
liftIO $ do liftIO $ do
@ -357,7 +364,7 @@ setPanelProperties disp panel = do
setStruts disp panel setStruts disp panel
setStruts :: Display -> PanelState w d -> PhiX w d () setStruts :: Display -> PanelState w s c -> PhiX w s c ()
setStruts disp panel = do setStruts disp panel = do
atoms <- asks phiAtoms atoms <- asks phiAtoms
config <- asks phiPanelConfig config <- asks phiPanelConfig

2
src/Phi.hs
View file

@ -52,5 +52,5 @@ main = do
, lineSpacing = (-3) , lineSpacing = (-3)
, clockSize = 75 , clockSize = 75
} }
brightBorder :: (Widget w d) => w -> Border w d brightBorder :: (Widget w s c) => w -> Border w s c
brightBorder = border normalDesktopBorder brightBorder = border normalDesktopBorder