summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Phi/Border.hs14
-rw-r--r--lib/Phi/Widget.hs68
-rw-r--r--lib/Phi/Widgets/AlphaBox.hs13
-rw-r--r--lib/Phi/Widgets/Clock.hs56
-rw-r--r--lib/Phi/Widgets/Systray.hs8
-rw-r--r--lib/Phi/Widgets/Taskbar.hs5
-rw-r--r--lib/Phi/X11.hs11
7 files changed, 106 insertions, 69 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index c6e7531..0c6c9c4 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -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
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index f265c62..f498b2c 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -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
+
+ initCache :: w -> c
- minSize :: a -> s -> Int -> Xlib.Rectangle -> Int
+ minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
- weight :: a -> Float
+ 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
diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs
index cd540e3..508f9d4 100644
--- a/lib/Phi/Widgets/AlphaBox.hs
+++ b/lib/Phi/Widgets/AlphaBox.hs
@@ -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
diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index 12906c0..38b6c41 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -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
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
index 662c6a7..7e7ec63 100644
--- a/lib/Phi/Widgets/Systray.hs
+++ b/lib/Phi/Widgets/Systray.hs
@@ -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
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index fbf7da8..4c4b9c2 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 110e9d4..818a9db 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 21:09:36 +0100