Cache windows in taskbar
This commit is contained in:
parent
37538aa626
commit
7ed869fcf1
2 changed files with 66 additions and 33 deletions
|
|
@ -98,12 +98,12 @@ type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surfac
|
|||
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
|
||||
createIOCache = lift . Kleisli
|
||||
|
||||
runIOCache :: Eq a => a -> StateT (IOCache a b) IO (b, Bool)
|
||||
runIOCache :: Eq a => a -> StateT (IOCache a b) IO b
|
||||
runIOCache a = do
|
||||
cache <- get
|
||||
(b, updated, cache') <- liftIO $ runKleisli (runCache' cache) a
|
||||
(b, cache') <- liftIO $ runKleisli (runCache cache) a
|
||||
put cache'
|
||||
return (b, updated)
|
||||
return b
|
||||
|
||||
createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
|
||||
-> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
||||
|
|
|
|||
|
|
@ -51,13 +51,15 @@ import Phi.Widget
|
|||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
type IconStyle = Surface -> Render ()
|
||||
newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () }
|
||||
instance Eq IconStyle where
|
||||
_ == _ = True
|
||||
|
||||
idIconStyle :: IconStyle
|
||||
idIconStyle = flip withPatternForSurface setSource
|
||||
idIconStyle = IconStyle $ flip withPatternForSurface setSource
|
||||
|
||||
desaturateIconStyle :: Double -> IconStyle
|
||||
desaturateIconStyle v icon = do
|
||||
desaturateIconStyle v = IconStyle $ \icon -> do
|
||||
w <- imageSurfaceGetWidth icon
|
||||
h <- imageSurfaceGetHeight icon
|
||||
|
||||
|
|
@ -66,14 +68,14 @@ desaturateIconStyle v icon = do
|
|||
setOperator OperatorAdd
|
||||
withPatternForSurface icon setSource
|
||||
paint
|
||||
|
||||
|
||||
setSourceRGB 0 0 0
|
||||
paint
|
||||
|
||||
setOperator OperatorHslSaturation
|
||||
setSourceRGBA 0 0 0 (1-v)
|
||||
paint
|
||||
|
||||
|
||||
setOperator OperatorDestIn
|
||||
withPatternForSurface icon setSource
|
||||
paint
|
||||
|
|
@ -104,7 +106,7 @@ data TaskStyle = TaskStyle { taskFont :: !String
|
|||
, taskColor :: !Color
|
||||
, taskBorder :: !BorderConfig
|
||||
, taskIconStyle :: !IconStyle
|
||||
}
|
||||
} deriving Eq
|
||||
|
||||
data DesktopStyle = DesktopStyle { desktopFont :: !String
|
||||
, desktopLabelWidth :: !Int
|
||||
|
|
@ -159,13 +161,24 @@ data WindowState = WindowState { windowTitle :: !String
|
|||
, windowScreen :: !Xlib.Rectangle
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Surface))
|
||||
data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
|
||||
, renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface)
|
||||
}
|
||||
|
||||
createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
|
||||
renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached
|
||||
|
||||
|
||||
newtype DesktopCache = DesktopCache (IOCache () ())
|
||||
|
||||
emptyWindowCache :: WindowCache
|
||||
emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon
|
||||
, renderWindowCached = createIOCache doRenderWindow
|
||||
}
|
||||
createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
|
||||
|
||||
data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
|
||||
, windowCaches :: !(M.Map Window WindowCache)
|
||||
}
|
||||
|
||||
-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant
|
||||
liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a
|
||||
|
|
@ -182,6 +195,9 @@ liftIOStateT m = do
|
|||
put s1
|
||||
return a
|
||||
|
||||
cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b
|
||||
cached t = liftT t . liftIOStateT . runIOCache
|
||||
|
||||
data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
|
||||
| DesktopCountUpdate !Int
|
||||
| CurrentDesktopUpdate !Int
|
||||
|
|
@ -233,7 +249,7 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
|
|||
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
|
||||
|
|
@ -259,8 +275,14 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
|
|||
y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
|
||||
|
||||
case mstate of
|
||||
Just state ->
|
||||
liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h'
|
||||
Just state -> do
|
||||
windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h'
|
||||
lift $ do
|
||||
save
|
||||
translate (fromIntegral $ x - 5) (fromIntegral $ y - 5)
|
||||
withPatternForSurface windowSurface setSource
|
||||
paint
|
||||
restore
|
||||
|
||||
Nothing -> return ()
|
||||
|
||||
|
|
@ -296,36 +318,47 @@ renderText font x y w h text = do
|
|||
moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
|
||||
showLayout layout
|
||||
|
||||
renderTask :: WindowState -> TaskStyle -> Int -> Int -> Int -> Int -> StateT WindowCache Render ()
|
||||
renderTask state style x y w h = do
|
||||
renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface
|
||||
renderWindow state style w h = do
|
||||
let h' = h - (borderV $ margin $ taskBorder style)
|
||||
|
||||
scaledIcon <- cached createScaledIconCached' (windowIcons state, h')
|
||||
cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h)
|
||||
|
||||
doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface
|
||||
doRenderWindow (title, scaledIcon, style, w, h) = do
|
||||
let (r, g, b, a) = taskColor style
|
||||
leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
|
||||
rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
|
||||
h' = h - (borderV $ margin $ taskBorder style)
|
||||
|
||||
lift $ do
|
||||
surface <- createImageSurface FormatARGB32 (w+10) (h+10)
|
||||
renderWith surface $ do
|
||||
translate 5 5
|
||||
|
||||
save
|
||||
drawBorder (taskBorder style) x y w h
|
||||
drawBorder (taskBorder style) 0 0 w h
|
||||
clip
|
||||
|
||||
setSourceRGBA r g b a
|
||||
renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) y (w - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
|
||||
|
||||
restore
|
||||
|
||||
(scaledIcon, updated) <- liftT createScaledIconCached' $ liftIOStateT $ runIOCache (windowIcons state, h')
|
||||
case scaledIcon of
|
||||
Just icon -> lift $ do
|
||||
save
|
||||
translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
|
||||
taskIconStyle style icon
|
||||
paint
|
||||
restore
|
||||
renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title
|
||||
|
||||
_ -> return ()
|
||||
restore
|
||||
|
||||
case scaledIcon of
|
||||
Just (Icon _ _ icon) -> do
|
||||
save
|
||||
translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style)
|
||||
withIconStyle (taskIconStyle style) icon
|
||||
paint
|
||||
restore
|
||||
|
||||
_ -> return ()
|
||||
|
||||
return surface
|
||||
|
||||
|
||||
createScaledIcon :: ([Icon], Int) -> IO (Maybe Surface)
|
||||
createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon)
|
||||
createScaledIcon (icons, h) = do
|
||||
case bestIcon of
|
||||
Just (Icon _ _ icon) -> do
|
||||
|
|
@ -342,7 +375,7 @@ createScaledIcon (icons, h) = do
|
|||
|
||||
downscaled scalef icon
|
||||
paint
|
||||
return $ Just scaledIcon
|
||||
fmap Just $ createIcon h scaledIcon
|
||||
|
||||
_ -> return Nothing
|
||||
|
||||
|
|
|
|||
Reference in a new issue