From 42c14fa1ca9d47ae32766aaa2aa995c684b7e9cb Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sun, 21 Aug 2011 19:34:16 +0200 Subject: Make render function return cachable surface slices --- lib/Phi/Border.hs | 67 ++++++++++++++++++++++++++--------- lib/Phi/Widget.hs | 70 ++++++++++++++++++++----------------- lib/Phi/Widgets/AlphaBox.hs | 26 ++++++++------ lib/Phi/Widgets/Clock.hs | 49 +++++++++++++++----------- lib/Phi/Widgets/Systray.hs | 19 ++++++---- lib/Phi/Widgets/Taskbar.hs | 75 +++++++++++++++++++++------------------ lib/Phi/X11.hs | 85 ++++++++++++++++++++++++--------------------- src/Phi.hs | 2 +- 8 files changed, 233 insertions(+), 160 deletions(-) diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index c9b582e..c6e7531 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -53,19 +53,21 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0 , borderWeight = 1 } -data Border w d = (Widget w d) => Border !BorderConfig !w -deriving instance Show (Border w d) -deriving instance Eq (Border w d) +data Border w s c = (Widget w s c) => Border !BorderConfig !w +deriving instance Show (Border w s c) +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 - minSize (Border config w) d height screen = + minSize (Border config w) s height screen = case True of _ | childSize == 0 -> 0 | otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m) where - childSize = minSize w d height' screen + childSize = minSize w s height' screen m = margin config bw = borderWidth config @@ -75,9 +77,9 @@ instance Eq d => Widget (Border w d) d where weight (Border config _) = borderWeight config - layout (Border config w) d width height screen = case True of - _ | width' > 0 -> layout w d width' height' screen - | otherwise -> d + layout (Border config w) s width height screen = case True of + _ | width' > 0 -> layout w s width' height' screen + | otherwise -> s where m = margin 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 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 - drawBorder config 0 0 width height - clip - translate (fromIntegral dx) (fromIntegral dy) - render w d (x+dx) (y+dy) width' height' screen - return () + render (Border config w) s x y width height screen = case () of + _ | (width > borderH m - 2*bw - borderH p) -> do + border <- createImageSurface FormatARGB32 width height + renderWith border $ do + setOperator OperatorClear + 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 m = margin config bw = borderWidth 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 width' = width - borderH m - 2*bw - borderH 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) closePath -border :: (Widget w d) => BorderConfig -> w -> Border w d +border :: (Widget w s c) => BorderConfig -> w -> Border w s c border = Border diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 2b031d9..f265c62 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -6,6 +6,7 @@ module Phi.Widget ( Display(..) , getScreenWindows , getScreens , unionArea + , SurfaceSlice(..) , Widget(..) , CompoundWidget , (<~>) @@ -20,8 +21,6 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class -import Data.Traversable hiding (forM) - import qualified Graphics.X11.Xlib as Xlib import Graphics.Rendering.Cairo @@ -64,20 +63,22 @@ unionArea a b = fromIntegral $ uw*uh by2 = by1 + fromIntegral bh -class (Show a, Eq a, Eq d) => Widget a d | a -> d where - initWidget :: a -> Phi -> Display -> IO d +data SurfaceSlice = SurfaceSlice !Int !Surface + +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 _ = 0 - layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d + layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s 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 {-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 return surface-} -data CompoundWidget a da b db = (Widget a da, Widget b db) => CompoundWidget !a !b -deriving instance Eq (CompoundWidget a da b db) -deriving instance Show (CompoundWidget a da b db) +data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b +deriving instance Eq (CompoundWidget a sa ca b sb cb) +deriving instance Show (CompoundWidget a sa ca b sb cb) + +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 sa ca b sb cb) -data CompoundState a da b db = (Widget a da, Widget b db) => CompoundState !da !db !Int -deriving instance Eq (CompoundState a da b db) +data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb -instance Widget (CompoundWidget a da b db) (CompoundState a da b db) where + +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) 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 - 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 - sizesum = minSize c d height screen + sizesum = minSize c s height screen wsum = let wsum = weight c in if wsum > 0 then wsum else 1 surplus = width - sizesum - (xb, da') = layoutWidget a da - (_, db') = layoutWidget b db + (xb, sa') = layoutWidget a sa + (_, sb') = layoutWidget b sb - layoutWidget w priv = let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(weight' w)/wsum - in (wWidth, layout w priv wWidth height screen) + layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum + in (wWidth, layout w s wWidth height screen) - render (CompoundWidget a b) (CompoundState da db xb) x y w h screen = do - save - render a da x y xb h screen - restore - translate (fromIntegral xb) 0 - render b db (x+xb) y (w-xb) h screen + render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do + surfacea <- render a sa x y xb h screen + surfaceb <- render b sb (x+xb) y (w-xb) h screen + return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb - 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 -(<~>) :: (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 data Separator = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () where +instance Widget Separator () () where initWidget _ _ _ = return () minSize (Separator s _) _ _ _ = s 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 = Separator diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index eacda5a..cd540e3 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -12,11 +12,11 @@ import Control.Monad import Graphics.Rendering.Cairo -data AlphaBox w d = (Widget w d) => AlphaBox !Double !w -deriving instance Show (AlphaBox w d) -deriving instance Eq (AlphaBox w d) +data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +deriving instance Show (AlphaBox w s c) +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 minSize (AlphaBox _ w) = minSize w @@ -25,21 +25,25 @@ instance Eq d => Widget (AlphaBox w d) d where layout (AlphaBox _ w) = layout w - render (AlphaBox alpha w) d x y width height screen = do - renderWithSimilarSurface ContentColorAlpha width height $ \surface -> do - renderWith surface $ do - render w d x y width height screen + render (AlphaBox alpha w) s x y width height screen = do + surfaces <- render w s x y width height screen + let surfacesWidths = zipWith (\(updated, SurfaceSlice x surf) x' -> (updated, x, x'-x, surf)) surfaces (map (\(_, SurfaceSlice x _) -> x) (tail surfaces) ++ [width]) + forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do + surf' <- createImageSurface FormatARGB32 surfWidth height + renderWith surf' $ do + setOperator OperatorSource + withPatternForSurface surf setSource + paint setOperator OperatorDestIn setSourceRGBA 0 0 0 alpha paint - withPatternForSurface surface setSource - paint + return (updated, SurfaceSlice x surf') 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 diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index bee8d39..12906c0 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) -instance Widget Clock ClockState where +instance Widget Clock ClockState () where initWidget (Clock _) phi _ = do forkIO $ forever $ do time <- getZonedTime @@ -59,26 +59,33 @@ instance Widget Clock ClockState where minSize (Clock config) _ _ _ = clockSize config render (Clock config) (ClockState time) _ _ w h _ = do - let (r, g, b, a) = fontColor config - str = formatTime defaultTimeLocale (clockFormat config) time - setSourceRGBA r g b a - - layout <- createLayout "" - (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do - layoutSetMarkup layout str - layoutSetAlignment layout AlignCenter - layoutSetSpacing layout $ lineSpacing config - layoutGetExtents layout - - let scalef = min 1 ((fromIntegral w)/textWidth) - when (scalef < 1) $ do - scale scalef scalef - updateLayout layout - - (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout - - moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2) - showLayout layout + surface <- createImageSurface FormatARGB32 w h + renderWith surface $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + let (r, g, b, a) = fontColor config + str = formatTime defaultTimeLocale (clockFormat config) time + setSourceRGBA r g b a + + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout str + layoutSetAlignment layout AlignCenter + layoutSetSpacing layout $ lineSpacing config + layoutGetExtents layout + + let scalef = min 1 ((fromIntegral w)/textWidth) + when (scalef < 1) $ do + 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 Just (UpdateTime time) -> ClockState time diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs index 6812018..662c6a7 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/Systray.hs @@ -47,7 +47,7 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon deriving (Show, Typeable) -instance Widget Systray SystrayState where +instance Widget Systray SystrayState () where initWidget (Systray) phi dispvar = do phi' <- dupPhi phi forkIO $ systrayRunner phi' dispvar @@ -61,15 +61,20 @@ instance Widget Systray SystrayState where weight _ = 0 - render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = case True of - _ | screen == systrayScreen -> do - lastReset <- liftIO $ readIORef lastResetRef - liftIO $ writeIORef lastResetRef reset + render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do + when (screen == systrayScreen) $ do + lastReset <- readIORef lastResetRef + writeIORef lastResetRef reset forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do let x' = x + i*(h+2) 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 Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons) diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index c17ac36..fbf7da8 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -166,7 +166,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState instance Show (IORef a) where show _ = "IORef " -instance Widget Taskbar TaskbarState where +instance Widget Taskbar TaskbarState () where initWidget (Taskbar _) phi dispvar = do phi' <- dupPhi phi forkIO $ taskbarRunner phi' dispvar @@ -204,41 +204,50 @@ instance Widget Taskbar TaskbarState where desktopsWidth = sum $ map dwidth desktopNumbers windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) - - flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do - let dstyle' = dstyle desktop - dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth - - 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) + + surface <- createImageSurface FormatARGB32 w h + renderWith surface $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + + flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do + let dstyle' = dstyle desktop + dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth + + 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 - case (mstate, micons, mscaledIconRef) of - (Just state, Just icons, Just scaledIconRef) -> - renderTask state icons scaledIconRef style x y windowWidth h' - - _ -> return () + 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 () - return $ nwindows + length desktopWindows + return $ nwindows + length desktopWindows + + return [(True, SurfaceSlice 0 surface)] handleMessage _ priv m = case (fromMessage m) of diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index b2b3c2c..110e9d4 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -38,21 +38,22 @@ import qualified Phi.Bindings.Util as Util data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) } -data PhiState w d = (Widget.Widget w d) => PhiState { phiRootImage :: !Surface - , phiPanels :: ![PanelState w d] - , phiRepaint :: !Bool - , phiShutdown :: !Bool - , phiShutdownHold :: !Int - } - -data PanelState w d = (Widget.Widget w d) => PanelState { panelWindow :: !Window - , panelPixmap :: !Pixmap - , panelArea :: !Rectangle - , panelScreenArea :: !Rectangle - , panelWidget :: !w - , panelWidgetState :: !d +data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface + , phiPanels :: ![PanelState w s c] + , phiRepaint :: !Bool + , phiShutdown :: !Bool + , phiShutdownHold :: !Int } +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 , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig @@ -65,17 +66,16 @@ newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a) runPhiReader :: PhiConfig -> PhiReader a -> IO a runPhiReader config (PhiReader a) = runReaderT a config -newtype PhiX w d a = PhiX (StateT (PhiState w d) PhiReader a) - deriving (Monad, MonadState (PhiState w d), MonadReader PhiConfig, MonadIO) +newtype PhiX w s c a = PhiX (StateT (PhiState w s c) PhiReader a) + 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 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } - -runPhi :: (Widget.Widget w d) => XConfig -> Panel.PanelConfig -> w -> IO () +runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO () runPhi xconfig config widget = do xSetErrorHandler @@ -158,12 +158,12 @@ termHandler :: Phi -> Handler 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'} where 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 modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} @@ -195,7 +195,7 @@ receiveEvents phi dispvar = do 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 rootImage <- gets phiRootImage panels <- gets phiPanels @@ -205,7 +205,7 @@ updatePanels dispvar = do area = panelArea 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 let screen = defaultScreen disp @@ -215,31 +215,37 @@ updatePanels dispvar = do liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \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 - translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) - setSource pattern + translate (fromIntegral x) 0 + withPatternForSurface surface setSource paint restore - (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel) + renderWith xbuffer $ do - withPatternForSurface buffer $ \pattern -> do - setSource pattern - paint + withPatternForSurface buffer setSource + paint surfaceFinish xbuffer -- copy buffer to window liftIO $ do - (withDimension area $ clearArea disp (panelWindow panel') 0 0) True + (withDimension area $ clearArea disp (panelWindow panel) 0 0) True sync disp False - return panel' + return $ panel { panelWidgetState = layoutedWidget } + 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 phi <- asks phiPhi atoms <- asks phiAtoms @@ -251,7 +257,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do sendMessage phi Repaint -updateRootImage :: Display -> PhiX w d () +updateRootImage :: Display -> PhiX w s c () updateRootImage disp = do atoms <- asks phiAtoms @@ -289,8 +295,8 @@ updateRootImage disp = do surfaceFinish rootSurface -createPanel :: (Widget w d) => Display -> Window -> w -> d -> Rectangle -> PhiX w d (PanelState w d) -createPanel disp win w d screenRect = do +createPanel :: (Widget w s c) => Display -> Window -> w -> s -> Rectangle -> PhiX w s c (PanelState w s c) +createPanel disp win w s screenRect = do config <- asks phiPanelConfig let rect = panelBounds config screenRect let screen = defaultScreen disp @@ -304,10 +310,11 @@ createPanel disp win w d screenRect = do , panelArea = rect , panelScreenArea = screenRect , 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 config <- asks phiPanelConfig let rect = panelBounds config screenRect @@ -326,7 +333,7 @@ createPanelWindow disp screenRect = do 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 atoms <- asks phiAtoms liftIO $ do @@ -357,7 +364,7 @@ setPanelProperties disp panel = do 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 atoms <- asks phiAtoms config <- asks phiPanelConfig diff --git a/src/Phi.hs b/src/Phi.hs index 6dc18fb..229a007 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -52,5 +52,5 @@ main = do , lineSpacing = (-3) , clockSize = 75 } - brightBorder :: (Widget w d) => w -> Border w d + brightBorder :: (Widget w s c) => w -> Border w s c brightBorder = border normalDesktopBorder -- cgit v1.2.3