diff options
| -rw-r--r-- | lib/Phi/Border.hs | 2 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 12 | ||||
| -rw-r--r-- | lib/Phi/Widgets/AlphaBox.hs | 2 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 341 | ||||
| -rw-r--r-- | phi.cabal | 2 |
5 files changed, 183 insertions, 176 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 [] @@ -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 |