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

Use new caching framework for scaled icons in taskbar

Browse source
This commit is contained in:
Matthias Schiffer 2011-08-22 06:17:22 +02:00
parent 9023453782
commit 37538aa626
5 changed files with 181 additions and 174 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/Phi/Border.hs
View file

@ -57,8 +57,6 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
} }
data Border w s c = (Widget w s c) => Border !BorderConfig !w 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)
data BorderCache w s c = (Widget w s c) => BorderCache !c data BorderCache w s c = (Widget w s c) => BorderCache !c

12
lib/Phi/Widget.hs
View file

@ -13,6 +13,7 @@ module Phi.Widget ( Display(..)
, IOCache , IOCache
, RenderCache , RenderCache
, createIOCache , createIOCache
, runIOCache
, createRenderCache , createRenderCache
, renderCached , renderCached
, Separator , Separator
@ -73,7 +74,7 @@ unionArea a b = fromIntegral $ uw*uh
data SurfaceSlice = SurfaceSlice !Int !Surface data SurfaceSlice = SurfaceSlice !Int !Surface
class (Show w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where class Eq s => Widget w s c | w -> s, w -> c where
initWidget :: w -> Phi -> Display -> IO s initWidget :: w -> Phi -> Display -> IO s
initCache :: w -> c initCache :: w -> c
@ -97,6 +98,13 @@ type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surfac
createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli createIOCache = lift . Kleisli
runIOCache :: Eq a => a -> StateT (IOCache a b) IO (b, Bool)
runIOCache a = do
cache <- get
(b, updated, cache') <- liftIO $ runKleisli (runCache' cache) a
put cache'
return (b, updated)
createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ()) createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
-> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
@ -116,8 +124,6 @@ renderCached widget state x y w h screen = do
return [(updated, SurfaceSlice 0 surf)] return [(updated, SurfaceSlice 0 surf)]
data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b 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 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) deriving instance Eq (CompoundState a sa ca b sb cb)

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

@ -14,8 +14,6 @@ import Graphics.Rendering.Cairo
data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w 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)
data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c

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

@ -1,4 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widgets.Taskbar ( IconStyle module Phi.Widgets.Taskbar ( IconStyle
, idIconStyle , idIconStyle
@ -13,7 +13,7 @@ module Phi.Widgets.Taskbar ( IconStyle
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State.Strict
import Control.Monad.Trans import Control.Monad.Trans
import Data.Array.MArray import Data.Array.MArray
@ -24,7 +24,10 @@ import Data.IORef
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Typeable import Data.Typeable
import Data.Unique
import Data.Word import Data.Word
import qualified Data.Accessor.Basic as A
import qualified Data.Accessor.Container as AC
import qualified Data.Map as M import qualified Data.Map as M
import Foreign.C.Types import Foreign.C.Types
@ -49,15 +52,10 @@ import Phi.X11.Atoms
type IconStyle = Surface -> Render () type IconStyle = Surface -> Render ()
instance Show IconStyle where
show _ = "IconStyle <?>"
instance Eq IconStyle where
_ == _ = True
idIconStyle :: IconStyle idIconStyle :: IconStyle
idIconStyle = flip withPatternForSurface setSource idIconStyle = flip withPatternForSurface setSource
desaturateIconStyle :: Double -> IconStyle desaturateIconStyle :: Double -> IconStyle
desaturateIconStyle v icon = do desaturateIconStyle v icon = do
w <- imageSurfaceGetWidth icon w <- imageSurfaceGetWidth icon
@ -106,20 +104,20 @@ data TaskStyle = TaskStyle { taskFont :: !String
, taskColor :: !Color , taskColor :: !Color
, taskBorder :: !BorderConfig , taskBorder :: !BorderConfig
, taskIconStyle :: !IconStyle , taskIconStyle :: !IconStyle
} deriving (Show, Eq) }
data DesktopStyle = DesktopStyle { desktopFont :: !String data DesktopStyle = DesktopStyle { desktopFont :: !String
, desktopLabelWidth :: !Int , desktopLabelWidth :: !Int
, desktopLabelGap :: !Int , desktopLabelGap :: !Int
, desktopColor :: !Color , desktopColor :: !Color
, desktopBorder :: !BorderConfig , desktopBorder :: !BorderConfig
} deriving (Show, Eq) }
data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
, normalTaskStyle :: !TaskStyle , normalTaskStyle :: !TaskStyle
, activeTaskStyle :: !TaskStyle , activeTaskStyle :: !TaskStyle
, desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle)) , desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle))
} deriving (Show, Eq) }
defaultStyle :: TaskStyle defaultStyle :: TaskStyle
defaultStyle = TaskStyle { taskFont = "Sans 8" defaultStyle = TaskStyle { taskFont = "Sans 8"
@ -135,45 +133,69 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
, desktopStyle = Nothing , desktopStyle = Nothing
} }
data Taskbar = Taskbar TaskbarConfig deriving (Show, Eq) data Taskbar = Taskbar TaskbarConfig
instance Show Surface where
show _ = "Surface <?>"
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarDesktopCount :: !Int , taskbarDesktopCount :: !Int
, taskbarCurrentDesktop :: !Int , taskbarCurrentDesktop :: !Int
, taskbarWindows :: ![Window] , taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState) , taskbarWindowStates :: !(M.Map Window WindowState)
, taskbarWindowIcons :: !(M.Map Window [(Int, Surface)]) } deriving Eq
, taskbarWindowScaledIcons :: !(M.Map Window (IORef (Maybe (Int, Surface))))
, taskbarWindowScreens :: !(M.Map Window Xlib.Rectangle) data Icon = Icon !Unique !Int !Surface
} deriving Show instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b
instance Eq TaskbarState where instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }"
_ == _ = False
createIcon :: Int -> Surface -> IO Icon
createIcon size surface = do
id <- newUnique
return $ Icon id size surface
data WindowState = WindowState { windowTitle :: !String data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int , windowDesktop :: !Int
, windowVisible :: !Bool , windowVisible :: !Bool
} deriving (Show, Eq) , windowIcons :: ![Icon]
, windowScreen :: !Xlib.Rectangle
} deriving (Eq, Show)
data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState) !(M.Map Window [(Int, Surface)]) !(M.Map Window (IORef (Maybe (Int, Surface)))) !(M.Map Window Xlib.Rectangle) data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Surface))
}
emptyWindowCache :: WindowCache
emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon
}
createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
-- 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
liftT f m = do
s0 <- gets $ A.get f
(a,s1) <- lift $ runStateT m s0
modify $ A.set f s1
return a
liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a
liftIOStateT m = do
s0 <- get
(a,s1) <- liftIO $ runStateT m s0
put s1
return a
data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
| DesktopCountUpdate !Int | DesktopCountUpdate !Int
| CurrentDesktopUpdate !Int | CurrentDesktopUpdate !Int
| ActiveWindowUpdate !Window | ActiveWindowUpdate !Window
deriving (Show, Typeable) deriving (Typeable, Show)
instance Show (IORef a) where instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
show _ = "IORef <?>"
instance Widget Taskbar TaskbarState () where
initWidget (Taskbar _) phi dispvar = do initWidget (Taskbar _) phi dispvar = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ taskbarRunner phi' dispvar forkIO $ taskbarRunner phi' dispvar
return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty M.empty return $ TaskbarState 0 0 (-1) [] M.empty
initCache _ = () initCache _ = M.empty
minSize _ _ _ _ = 0 minSize _ _ _ _ = 0
weight _ = 1 weight _ = 1
@ -183,11 +205,8 @@ instance Widget Taskbar TaskbarState () where
, taskbarCurrentDesktop = currentDesktop , taskbarCurrentDesktop = currentDesktop
, taskbarWindows = windows , taskbarWindows = windows
, taskbarWindowStates = windowStates , taskbarWindowStates = windowStates
, taskbarWindowIcons = windowIcons
, taskbarWindowScaledIcons = windowScaledIcons
, taskbarWindowScreens = windowScreens
} _ _ w h screen = do } _ _ w h screen = do
let screenWindows = filter ((== Just screen) . flip M.lookup windowScreens) windows let screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
desktopNumbers = take desktopCount [0..] desktopNumbers = take desktopCount [0..]
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
@ -207,11 +226,13 @@ instance Widget Taskbar TaskbarState () where
windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
surface <- liftIO $ createImageSurface FormatARGB32 w h surface <- liftIO $ createImageSurface FormatARGB32 w h
renderWith surface $ do cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get
setOperator OperatorClear cache' <- renderWith surface $ flip execStateT cache $ do
paint lift $ do
setOperator OperatorClear
paint
setOperator OperatorOver setOperator OperatorOver
flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
let dstyle' = dstyle desktop let dstyle' = dstyle desktop
@ -220,44 +241,41 @@ instance Widget Taskbar TaskbarState () where
case dstyle' of case dstyle' of
Just ds -> do Just ds -> do
let (r, g, b, a) = desktopColor ds let (r, g, b, a) = desktopColor ds
save lift $ do
drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h save
clip drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
clip
setSourceRGBA r g b a setSourceRGBA r g b a
renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1) renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
restore restore
forM_ (zip [0..] desktopWindows) $ \(i, window) -> do forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
mstate = M.lookup window windowStates mstate = M.lookup window windowStates
micons = M.lookup window windowIcons
mscaledIconRef = M.lookup window windowScaledIcons
x = dx + i*windowWidth x = dx + i*windowWidth
y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
case (mstate, micons, mscaledIconRef) of case mstate of
(Just state, Just icons, Just scaledIconRef) -> Just state ->
renderTask state icons scaledIconRef style x y windowWidth h' liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h'
_ -> return () Nothing -> return ()
_ -> return () _ -> return ()
return $ nwindows + length desktopWindows return $ nwindows + length desktopWindows
put cache'
return [(True, SurfaceSlice 0 surface)] return [(True, SurfaceSlice 0 surface)]
handleMessage _ priv m = case (fromMessage m) of handleMessage _ priv m = case (fromMessage m) of
Just (WindowListUpdate windows windowStates icons scaledIcons screens) -> priv { taskbarWindows = windows Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows
, taskbarWindowStates = windowStates , taskbarWindowStates = windowStates
, taskbarWindowIcons = icons }
, taskbarWindowScaledIcons = scaledIcons
, taskbarWindowScreens = screens
}
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
@ -278,33 +296,26 @@ renderText font x y w h text = do
moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
showLayout layout showLayout layout
renderTask :: WindowState -> [(Int, Surface)] -> IORef (Maybe (Int, Surface)) -> TaskStyle -> Int -> Int -> Int -> Int -> Render () renderTask :: WindowState -> TaskStyle -> Int -> Int -> Int -> Int -> StateT WindowCache Render ()
renderTask state icons scaledIconRef style x y w h = do renderTask state style x y w h = do
let (r, g, b, a) = taskColor style let (r, g, b, a) = taskColor style
leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder 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) rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
h' = h - (borderV $ margin $ taskBorder style) h' = h - (borderV $ margin $ taskBorder style)
save lift $ do
drawBorder (taskBorder style) x y w h save
clip drawBorder (taskBorder style) x y w h
clip
setSourceRGBA r g b a 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 (x + leftBorder + h' + 3)) y (w - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
restore restore
mscaledIcon <- liftIO $ readIORef scaledIconRef
scaledIcon <- case mscaledIcon of
Just (size, icon) | size == h' -> do
return $ Just icon
_ -> do
scaledIcon <- createScaledIcon icons h'
liftIO $ writeIORef scaledIconRef $ fmap ((,) h') scaledIcon
return scaledIcon
(scaledIcon, updated) <- liftT createScaledIconCached' $ liftIOStateT $ runIOCache (windowIcons state, h')
case scaledIcon of case scaledIcon of
Just icon -> do Just icon -> lift $ do
save save
translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style)) translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
taskIconStyle style icon taskIconStyle style icon
@ -314,30 +325,30 @@ renderTask state icons scaledIconRef style x y w h = do
_ -> return () _ -> return ()
createScaledIcon :: [(Int, Surface)] -> Int -> Render (Maybe Surface) createScaledIcon :: ([Icon], Int) -> IO (Maybe Surface)
createScaledIcon icons h = do createScaledIcon (icons, h) = do
case bestIcon of case bestIcon of
Just icon -> do Just (Icon _ _ icon) -> do
scaledIcon <- liftIO $ createSimilarSurface icon ContentColorAlpha h h scaledIcon <- createSimilarSurface icon ContentColorAlpha h h
renderWith scaledIcon $ do renderWith scaledIcon $ do
imageW <- imageSurfaceGetWidth icon imageW <- imageSurfaceGetWidth icon
imageH <- imageSurfaceGetHeight icon imageH <- imageSurfaceGetHeight icon
let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH) let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH)
case True of case () of
_ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2) _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2)
| otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0 | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0
downscaled scalef icon downscaled scalef icon
paint paint
return $ Just scaledIcon return $ Just scaledIcon
_ -> return Nothing _ -> return Nothing
where where
bestIcon = fmap snd . listToMaybe $ sortBy compareIcons icons bestIcon = listToMaybe $ sortBy compareIcons icons
compareIcons = flip (compare `on` fst) compareIcons = flip (compare `on` (\(Icon _ size _) -> size))
windowOnDesktop :: Int -> WindowState -> Bool windowOnDesktop :: Int -> WindowState -> Bool
@ -347,19 +358,19 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
taskbarRunner :: Phi -> Display -> IO () taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do taskbarRunner phi dispvar = do
let screens = getScreens dispvar let screens = getScreens dispvar
(windows, states, icons, scaledIcons, windowScreens) <- liftIO $ withDisplay dispvar $ \disp -> do (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, states, icons, scaledIcons, windowScreens) <- getWindowStates disp screens (getAtoms dispvar) M.empty M.empty M.empty M.empty (windows, states) <- getWindowStates disp screens (getAtoms dispvar) M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar) desktopCount <- getDesktopCount disp (getAtoms dispvar)
current <- getCurrentDesktop disp (getAtoms dispvar) current <- getCurrentDesktop disp (getAtoms dispvar)
activeWindow <- getActiveWindow disp (getAtoms dispvar) activeWindow <- getActiveWindow disp (getAtoms dispvar)
sendMessage phi $ WindowListUpdate windows states icons scaledIcons windowScreens sendMessage phi $ WindowListUpdate windows states
sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi $ CurrentDesktopUpdate current sendMessage phi $ CurrentDesktopUpdate current
sendMessage phi $ ActiveWindowUpdate activeWindow sendMessage phi $ ActiveWindowUpdate activeWindow
return (windows, states, icons, scaledIcons, windowScreens) return (windows, states)
sendMessage phi Repaint sendMessage phi Repaint
flip evalStateT (windows, states, icons, scaledIcons, windowScreens) $ forever $ do flip evalStateT (windows, states) $ forever $ do
m <- receiveMessage phi m <- receiveMessage phi
case (fromMessage m) of case (fromMessage m) of
Just event -> Just event ->
@ -367,7 +378,7 @@ taskbarRunner phi dispvar = do
_ -> _ ->
return () return ()
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle) IO () handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
let atoms = getAtoms dispvar let atoms = getAtoms dispvar
let screens = getScreens dispvar let screens = getScreens dispvar
@ -397,48 +408,52 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
sendMessage phi $ CurrentDesktopUpdate current sendMessage phi $ CurrentDesktopUpdate current
sendMessage phi Repaint sendMessage phi Repaint
when (atom == atom_NET_CLIENT_LIST atoms) $ do when (atom == atom_NET_CLIENT_LIST atoms) $ do
(windows, windowStates, icons, scaledIcons, windowScreens) <- get (windows, windowStates) <- get
(windows', windowStates', icons', scaledIcons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windowStates icons scaledIcons windowScreens (windows', windowStates') <- liftIO $ getWindowStates disp screens atoms windowStates
when (windows /= windows') $ do when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates' icons' scaledIcons' windowScreens' sendMessage phi $ WindowListUpdate windows' windowStates'
sendMessage phi Repaint sendMessage phi Repaint
put (windows', windowStates', icons', scaledIcons', windowScreens') put (windows', windowStates')
else do else do
(windows, windowStates, icons, scaledIcons, windowScreens) <- get (windows, windowStates) <- get
when (elem window windows) $ do when (elem window windows) $ do
when (atom == atom_NET_WM_ICON atoms) $ do case () of
icon <- liftIO $ getWindowIcons disp atoms window _ | (atom == atom_NET_WM_ICON atoms) -> do
scaledIcon <- liftIO $ newIORef Nothing icons <- liftIO $ getWindowIcons disp atoms window
let icons' = M.insert window icon icons let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates
scaledIcons' = M.insert window scaledIcon scaledIcons sendMessage phi $ WindowListUpdate windows windowStates'
sendMessage phi $ WindowListUpdate windows windowStates icons' scaledIcons' windowScreens
sendMessage phi Repaint
put (windows, windowStates, icons', scaledIcons', windowScreens)
when (atom /= atom_NET_WM_ICON atoms) $ do
let windowState = M.lookup window windowStates
windowState' <- liftIO $ getWindowState disp atoms window
when (windowState /= (Just windowState')) $ do
let windowStates' = M.insert window windowState' windowStates
sendMessage phi $ WindowListUpdate windows windowStates' icons scaledIcons windowScreens
sendMessage phi Repaint sendMessage phi Repaint
put (windows, windowStates', icons, scaledIcons, windowScreens) put (windows, windowStates')
| otherwise -> do
(name, desktop, visible) <- liftIO $ getWindowInfo disp atoms window
let mwindowState = M.lookup window windowStates
case mwindowState of
Just windowState -> do
let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible}
when (windowState /= windowState') $ do
let windowStates' = M.insert window windowState' windowStates
sendMessage phi $ WindowListUpdate windows windowStates'
sendMessage phi Repaint
put (windows, windowStates')
Nothing ->
return ()
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
let screens = getScreens dispvar let screens = getScreens dispvar
(windows, windowStates, icons, scaledIcons, windowScreens) <- get (windows, windowStates) <- get
when (elem window windows) $ withDisplay dispvar $ \disp -> do when (elem window windows) $ withDisplay dispvar $ \disp -> do
let screen = M.lookup window windowScreens let screen = fmap windowScreen . M.lookup window $ windowStates
screen' <- liftIO $ getWindowScreen disp screens window screen' <- liftIO $ getWindowScreen disp screens window
when (screen /= (Just screen')) $ do when (screen /= (Just screen')) $ do
let windowScreens' = M.insert window screen' windowScreens let windowStates' = M.update (\state -> Just state {windowScreen = screen'}) window windowStates
sendMessage phi $ WindowListUpdate windows windowStates icons scaledIcons windowScreens' sendMessage phi $ WindowListUpdate windows windowStates'
sendMessage phi Repaint sendMessage phi Repaint
put (windows, windowStates, icons, scaledIcons, windowScreens') put (windows, windowStates')
handleEvent _ _ _ = return () handleEvent _ _ _ = return ()
@ -456,74 +471,64 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
getActiveWindow disp atoms = getActiveWindow disp atoms =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> M.Map Window [(Int, Surface)] -> M.Map Window (IORef (Maybe (Int, Surface))) -> M.Map Window Xlib.Rectangle getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
-> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle) getWindowStates disp screens atoms windowStates = do
getWindowStates disp screens atoms windowStates windowIcons windowScaledIcons windowScreens = do
windows <- getWindowList disp atoms windows <- getWindowList disp atoms
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
windowScaledIcons' = map (\w -> (w, M.lookup w windowScaledIcons)) windows
windowScreens' = map (\w -> (w, M.lookup w windowScreens)) windows
newWindowStates <- mapM getWindowState' windowStates' newWindowStates <- mapM getWindowState' windowStates'
newWindowIcons <- mapM getWindowIcons' windowIcons'
newWindowScaledIcons <- mapM getScaledIcons windowScaledIcons'
newWindowScreens <- mapM getWindowScreen' windowScreens'
return (windows, M.fromList newWindowStates, M.fromList newWindowIcons, M.fromList newWindowScaledIcons, M.fromList newWindowScreens) return (windows, M.fromList newWindowStates)
where where
getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do getWindowState' (window, Nothing) = do
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
windowState <- getWindowState disp atoms window windowState <- getWindowState disp screens atoms window
return (window, windowState) return (window, windowState)
getWindowIcons' (window, Just icons) = return (window, icons) getWindowState :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> Window -> IO WindowState
getWindowIcons' (window, Nothing) = do getWindowState disp screens atoms window = do
icons <- getWindowIcons disp atoms window (name, workspace, visible) <- getWindowInfo disp atoms window
return (window, icons) icons <- getWindowIcons disp atoms window
screen <- getWindowScreen disp screens window
getScaledIcons (window, Just icon) = return (window, icon) return $ WindowState { windowTitle = name
getScaledIcons (window, Nothing) = liftM2 (,) (return window) $ newIORef Nothing , windowDesktop = workspace
, windowVisible = visible
, windowIcons = icons
, windowScreen = screen
}
getWindowScreen' (window, Just screen) = return (window, screen) getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
getWindowScreen' (window, Nothing) = do getWindowInfo disp atoms window = do
screen <- getWindowScreen disp screens window
return (window, screen)
getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
getWindowState disp atoms window = do
netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
wmname <- case netwmname of wmname <- case netwmname of
Just name -> return name Just name -> return name
Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
visible <- showWindow disp atoms window visible <- showWindow disp atoms window
return $ WindowState wmname workspace visible return (wmname, workspace, visible)
where where
unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar)) unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)] getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe [] getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
readIcons :: [CLong] -> IO [(Int, Surface)] readIcons :: [CLong] -> IO [Icon]
readIcons (width:height:iconData) = do readIcons (width:height:iconData) = do
if ((fromIntegral $ length iconData) < (width*height)) then return [] else do if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32) surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32)
forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
surfaceMarkDirty icon surfaceMarkDirty surface
moreIcons <- readIcons rest liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest)
return $ (fromIntegral $ max width height, icon):moreIcons
readIcons _ = return [] readIcons _ = return []

2
phi.cabal
View file

@ -11,7 +11,7 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple build-type: Simple
library library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, arrows, CacheArrow build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, data-accessor, arrows, CacheArrow
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11, exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler