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
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

12
lib/Phi/Widget.hs
View file

@ -13,6 +13,7 @@ module Phi.Widget ( Display(..)
, IOCache
, RenderCache
, createIOCache
, runIOCache
, createRenderCache
, renderCached
, Separator
@ -73,7 +74,7 @@ unionArea a b = fromIntegral $ uw*uh
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
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 = 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 ())
-> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
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)]
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
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
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

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

2
phi.cabal
View file

@ -11,7 +11,7 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple
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,
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