summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Widget.hs6
-rw-r--r--lib/Phi/Widgets/Taskbar.hs91
2 files changed, 65 insertions, 32 deletions
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 5ffd534..68bed1b 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -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
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index 723427b..da68c27 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -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
-
+ renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title
+
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
- _ -> return ()
+ 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 19:24:16 +0100