summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Border.hs2
-rw-r--r--lib/Phi/Widget.hs12
-rw-r--r--lib/Phi/Widgets/AlphaBox.hs2
-rw-r--r--lib/Phi/Widgets/Taskbar.hs341
4 files changed, 182 insertions, 175 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 0c6c9c4..4b32dd3 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -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
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index f498b2c..5ffd534 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -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)
diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs
index 508f9d4..f6b0e74 100644
--- a/lib/Phi/Widgets/AlphaBox.hs
+++ b/lib/Phi/Widgets/AlphaBox.hs
@@ -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
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index 4c4b9c2..723427b 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -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)
-
-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)
+ , windowIcons :: ![Icon]
+ , windowScreen :: !Xlib.Rectangle
+ } deriving (Eq, Show)
+
+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)
-
-instance Show (IORef a) where
- show _ = "IORef <?>"
+ deriving (Typeable, Show)
-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
-
- setOperator OperatorOver
+ cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get
+ cache' <- renderWith surface $ flip execStateT cache $ do
+ lift $ do
+ setOperator OperatorClear
+ paint
+
+ 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
-
- setSourceRGBA r g b a
- renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
-
- restore
+ 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)
+
+ 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
-
- setSourceRGBA r g b a
- renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) y (w - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
- restore
+ 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
- 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
-
- 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
-
- downscaled scalef icon
- paint
- return $ Just scaledIcon
+ 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)
+
+ 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
- _ -> 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)
-
- getScaledIcons (window, Just icon) = return (window, icon)
- getScaledIcons (window, Nothing) = liftM2 (,) (return window) $ newIORef Nothing
-
- 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
+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
+
+ return $ WindowState { windowTitle = name
+ , windowDesktop = workspace
+ , windowVisible = visible
+ , windowIcons = icons
+ , windowScreen = screen
+ }
+
+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
-
- moreIcons <- readIcons rest
- return $ (fromIntegral $ max width height, icon):moreIcons
+ surfaceMarkDirty surface
+
+ liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest)
readIcons _ = return []
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-27 06:02:12 +0100