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

Add a lot of caching framework

Browse source
This commit is contained in:
Matthias Schiffer 2011-08-21 21:39:26 +02:00
parent 42c14fa1ca
commit 8222c6041d
7 changed files with 106 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lib/Phi/Border.hs
View file

@ -16,6 +16,9 @@ import Phi.Types
import Phi.Widget
import Control.Monad
import Control.Monad.State.Strict
import Data.Maybe
import Graphics.Rendering.Cairo
@ -61,6 +64,7 @@ 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
initCache (Border _ w) = BorderCache $ initCache w
minSize (Border config w) s height screen =
case True of
@ -90,17 +94,19 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
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
border <- liftIO $ 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
BorderCache c <- get
(surfaces, c') <- liftIO $ flip runStateT c $ render w s (x+dx) (y+dy) width' height' screen
put $ BorderCache c'
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
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do
setOperator OperatorClear
paint
@ -121,7 +127,7 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
return (updated, SurfaceSlice x surf')
| otherwise -> do
surface <- createImageSurface FormatARGB32 width height
surface <- liftIO $ createImageSurface FormatARGB32 width height
return [(True, SurfaceSlice 0 surface)]
where
m = margin config

68
lib/Phi/Widget.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widget ( Display(..)
, withDisplay
@ -10,6 +10,11 @@ module Phi.Widget ( Display(..)
, Widget(..)
, CompoundWidget
, (<~>)
, IOCache
, RenderCache
, createIOCache
, createRenderCache
, renderCached
, Separator
, separator
) where
@ -19,8 +24,11 @@ import Control.Arrow.Transformer
import Control.CacheArrow
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.State.Strict hiding (lift)
import Control.Monad.IO.Class
import Data.Maybe
import qualified Graphics.X11.Xlib as Xlib
import Graphics.Rendering.Cairo
@ -65,31 +73,47 @@ unionArea a b = fromIntegral $ uw*uh
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
class (Show w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where
initWidget :: w -> Phi -> Display -> IO s
minSize :: a -> s -> Int -> Xlib.Rectangle -> Int
initCache :: w -> c
weight :: a -> Float
minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
weight :: w -> Float
weight _ = 0
layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s
layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s
layout _ priv _ _ _ = priv
render :: a -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> IO [(Bool, SurfaceSlice)]
render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
handleMessage :: a -> s -> Message -> s
handleMessage :: w -> s -> Message -> s
handleMessage _ priv _ = priv
{-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface
createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
type IOCache = CacheArrow (Kleisli IO)
type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli
createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
-> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do
setOperator OperatorClear
paint
setOperator OperatorOver
render widget state x y w h screen
return surface-}
f widget state x y w h screen
return surface
renderCached :: (Eq w, Eq s) => w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache w s) IO [(Bool, SurfaceSlice)]
renderCached widget state x y w h screen = do
cache <- get
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (widget, state, x, y, w, h, screen)
put cache'
return [(updated, SurfaceSlice 0 surf)]
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)
@ -104,6 +128,8 @@ data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => Compoun
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)
initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
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
@ -123,8 +149,10 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb)
in (wWidth, layout w s wWidth height 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
CompoundCache ca cb <- get
(surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen
(surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen
put $ CompoundCache ca' cb'
return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb
@ -137,17 +165,15 @@ a <~> b = CompoundWidget a b
data Separator = Separator !Int !Float deriving (Show, Eq)
instance Widget Separator () () where
instance Widget Separator () (RenderCache Separator ()) where
initWidget _ _ _ = return ()
initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do
setOperator OperatorClear
paint
minSize (Separator s _) _ _ _ = s
weight (Separator _ w) = w
render _ _ _ _ width height _ = do
surface <- createImageSurface FormatARGB32 width height
renderWith surface $ do
setOperator OperatorClear
paint
return [(True, SurfaceSlice 0 surface)]
render = renderCached
separator :: Int -> Float -> Separator

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

@ -8,6 +8,7 @@ import Phi.Types
import Phi.Widget
import Control.Monad
import Control.Monad.State.Strict
import Graphics.Rendering.Cairo
@ -16,8 +17,11 @@ 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 s => Widget (AlphaBox w s c) s () where
data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c
instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where
initWidget (AlphaBox _ w) = initWidget w
initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w
minSize (AlphaBox _ w) = minSize w
@ -26,10 +30,13 @@ instance Eq s => Widget (AlphaBox w s c) s () where
layout (AlphaBox _ w) = layout w
render (AlphaBox alpha w) s x y width height screen = do
surfaces <- render w s x y width height screen
AlphaBoxCache c <- get
(surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen
put $ AlphaBoxCache c'
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
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do
setOperator OperatorSource
withPatternForSurface surf setSource

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

@ -1,4 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widgets.Clock ( ClockConfig(..)
, defaultClockConfig
@ -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 (RenderCache Clock ClockState) where
initWidget (Clock _) phi _ = do
forkIO $ forever $ do
time <- getZonedTime
@ -54,38 +54,32 @@ instance Widget Clock ClockState () where
time <- getZonedTime
return $ ClockState time
initCache _ = createRenderCache $ \(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
minSize (Clock config) _ _ _ = clockSize config
render (Clock config) (ClockState time) _ _ w h _ = do
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)]
render = renderCached
handleMessage _ priv m = case (fromMessage m) of
Just (UpdateTime time) -> ClockState time

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

@ -55,6 +55,8 @@ instance Widget Systray SystrayState () where
lastReset <- newIORef 0
return $ SystrayState phi (head . getScreens $ dispvar) 0 lastReset []
initCache _ = ()
minSize _ (SystrayState _ systrayScreen _ _ icons) height screen = case True of
_ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1
| otherwise -> 0
@ -63,13 +65,13 @@ instance Widget Systray SystrayState () where
render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do
when (screen == systrayScreen) $ do
lastReset <- readIORef lastResetRef
writeIORef lastResetRef reset
lastReset <- liftIO $ readIORef lastResetRef
liftIO $ 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)
surface <- createImageSurface FormatARGB32 w h
surface <- liftIO $ createImageSurface FormatARGB32 w h
renderWith surface $ do
setOperator OperatorClear
paint

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

@ -172,7 +172,8 @@ instance Widget Taskbar TaskbarState () where
forkIO $ taskbarRunner phi' dispvar
return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty M.empty
initCache _ = ()
minSize _ _ _ _ = 0
weight _ = 1
@ -205,7 +206,7 @@ instance Widget Taskbar TaskbarState () where
desktopsWidth = sum $ map dwidth desktopNumbers
windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
surface <- createImageSurface FormatARGB32 w h
surface <- liftIO $ createImageSurface FormatARGB32 w h
renderWith surface $ do
setOperator OperatorClear
paint

11
lib/Phi/X11.hs
View file

@ -18,7 +18,7 @@ import Data.Char
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad.State
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Monad.Trans
@ -51,7 +51,7 @@ data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow
, panelScreenArea :: !Rectangle
, panelWidget :: !w
, panelWidgetState :: !s
, panelWidgetCache :: !(Maybe c)
, panelWidgetCache :: !c
}
data PhiConfig = PhiConfig { phiPhi :: !Phi
@ -205,7 +205,8 @@ updatePanels dispvar = do
area = panelArea panel
let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel
panelSurfaces <- liftIO $ (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
(withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
Widget.withDisplay dispvar $ \disp -> do
let screen = defaultScreen disp
@ -239,7 +240,7 @@ updatePanels dispvar = do
(withDimension area $ clearArea disp (panelWindow panel) 0 0) True
sync disp False
return $ panel { panelWidgetState = layoutedWidget }
return $ panel { panelWidgetState = layoutedWidget, panelWidgetCache = cache' }
modify $ \state -> state { phiPanels = panels' }
@ -311,7 +312,7 @@ createPanel disp win w s screenRect = do
, panelScreenArea = screenRect
, panelWidget = w
, panelWidgetState = s
, panelWidgetCache = Nothing
, panelWidgetCache = initCache w
}
createPanelWindow :: Display -> Rectangle -> PhiX w s c Window