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

Taskbar: show tasks

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-15 15:31:46 +02:00
parent 465d757986
commit 5359238f79
5 changed files with 162 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/Phi/Border.hs
View file

@ -2,6 +2,8 @@
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, borderH
, borderV
, BorderConfig(..)
, defaultBorderConfig
, drawBorder

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

@ -10,9 +10,14 @@ import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Array.MArray
import Data.Bits
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Typeable
import Data.Word
import qualified Data.Map as M
import Foreign.C.Types
@ -21,6 +26,7 @@ import Graphics.Rendering.Cairo
import Graphics.Rendering.Pango.Cairo
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
import Graphics.Rendering.Pango.Layout
import Graphics.Rendering.Pango.Font
import Graphics.X11.Xlib (Window)
import qualified Graphics.X11.Xlib as Xlib
@ -35,14 +41,16 @@ import Phi.Widget
import Phi.X11.Atoms
data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
data TaskbarConfig = TaskbarConfig { taskbarFont :: !String
, taskMaxSize :: !Int
, showDesktops :: !Bool
, taskBorder :: !BorderConfig
, activeTaskBorder :: !BorderConfig
} deriving Show
defaultTaskbarConfig :: TaskbarConfig
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
defaultTaskbarConfig = TaskbarConfig { taskbarFont = "Sans 7"
, taskMaxSize = 150
, showDesktops = False
, taskBorder = defaultBorderConfig
, activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
@ -50,10 +58,14 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
data Taskbar = Taskbar TaskbarConfig deriving Show
instance Show Surface where
show _ = "Surface <?>"
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarDesktopCount :: !Int
, taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState)
, taskbarWindowIcons :: !(M.Map Window [Surface])
} deriving Show
data WindowState = WindowState { windowTitle :: !String
@ -61,7 +73,7 @@ data WindowState = WindowState { windowTitle :: !String
, windowVisible :: !Bool
} deriving (Show, Eq)
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState)
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [Surface])
| DesktopCountUpdate Int
| ActiveWindowUpdate Window
deriving (Show, Typeable)
@ -72,13 +84,13 @@ instance WidgetClass Taskbar where
initWidget (Taskbar _) phi dispvar = do
forkIO $ taskbarRunner phi dispvar
return $ TaskbarState 0 0 [] M.empty
return $ TaskbarState 0 0 [] M.empty M.empty
minSize _ = 0
weight _ = 1
render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do
render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = windowIcons} w h = do
let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
windowCount = sum $ map (length . snd) $ desktopWindows
when (windowCount /= 0) $ do
@ -86,32 +98,92 @@ instance WidgetClass Taskbar where
forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
let border = if window == activeWindow then activeTaskBorder config else taskBorder config
leftBorder = (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border)
rightBorder = (borderRight $ margin border) + (borderWidth border) + (borderRight $ padding border)
h' = h - (borderV $ margin border)
mstate = M.lookup window windowStates
micons = M.lookup window windowIcons
case (mstate, micons) of
(Just state, Just icons) -> do
save
drawBorder border (i*windowWidth) 0 windowWidth h
clip
setSourceRGB 1 1 1
renderText config (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
restore
icon' <- liftIO $ bestIcon h' icons
case icon' of
Just icon -> withPatternForSurface icon $ \pattern -> do
save
translate (fromIntegral $ i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin border)
imageW <- imageSurfaceGetWidth icon
imageH <- imageSurfaceGetHeight icon
let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
scale scalef scalef
setSource pattern
paint
restore
Nothing -> return ()
_ -> return ()
handleMessage _ priv m = case (fromMessage m) of
Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates}
Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons}
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
_ -> priv
renderText :: TaskbarConfig -> Int -> Int -> Int -> Int -> String -> Render ()
renderText config x y w h text = do
layout <- createLayout ""
(_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
layoutSetMarkup layout $ "<span font='" ++ (taskbarFont config) ++ "'>" ++ (escapeMarkup text) ++ "</span>"
layoutSetWidth layout $ Just $ fromIntegral w
layoutSetEllipsize layout EllipsizeEnd
layoutGetExtents layout
moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
showLayout layout
bestIcon :: Int -> [Surface] -> IO (Maybe Surface)
bestIcon h icons = do
imageSizes <- forM icons $ \icon -> liftM2 (,) (return icon) $ liftM2 max (imageSurfaceGetWidth icon) (imageSurfaceGetHeight icon)
let sortedIcons = sortBy compareIcons imageSizes
return $ findBest sortedIcons
where
compareIcons a b = (compare `on` snd) b a
findBest (a1:a2:ax) = if (snd a2) < h then Just $ fst a1 else findBest (a2:ax)
findBest [a] = Just $ fst a
findBest [] = Nothing
windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do
(windows, tasks) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, tasks) <- getWindowStates disp (getAtoms dispvar) [] M.empty
(windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar)
activeWindow <- getActiveWindow disp (getAtoms dispvar)
sendMessage phi $ WindowListUpdate windows tasks
sendMessage phi $ WindowListUpdate windows states icons
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi $ ActiveWindowUpdate activeWindow
return (windows, tasks)
return (windows, states, icons)
sendMessage phi Repaint
flip evalStateT (windows, tasks) $ forever $ do
flip evalStateT (windows, states, icons) $ forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event@XExtras.PropertyEvent {} ->
@ -119,13 +191,14 @@ taskbarRunner phi dispvar = do
_ ->
return ()
handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [Surface]) IO ()
handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
let atoms = getAtoms dispvar
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
, atom_NET_NUMBER_OF_DESKTOPS
, atom_NET_CLIENT_LIST
, atom_NET_WM_ICON
, atom_NET_WM_NAME
, atomWM_NAME
, atom_NET_WM_DESKTOP
@ -143,25 +216,33 @@ handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom,
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi Repaint
when (atom == atom_NET_CLIENT_LIST atoms) $ do
(windows, windowStates) <- get
(windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates
(windows, windowStates, icons) <- get
(windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
when (windows /= windows' || windowStates /= windowStates') $ do
sendMessage phi $ WindowListUpdate windows' windowStates'
when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates' icons'
sendMessage phi Repaint
put (windows', windowStates')
put (windows', windowStates', icons')
else do
(windows, windowStates) <- get
(windows, windowStates, icons) <- get
when (elem window windows) $ do
when (atom == atom_NET_WM_ICON atoms) $ do
icon <- liftIO $ getWindowIcons disp atoms window
let icons' = M.insert window icon icons
sendMessage phi $ WindowListUpdate windows windowStates icons'
sendMessage phi Repaint
put (windows, windowStates, icons')
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'
sendMessage phi $ WindowListUpdate windows windowStates' icons
sendMessage phi Repaint
put (windows, windowStates')
put (windows, windowStates', icons)
getDesktopCount :: Xlib.Display -> Atoms -> IO Int
getDesktopCount disp atoms =
@ -171,23 +252,28 @@ 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 -> Atoms -> [Window] -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
getWindowStates disp atoms oldWindows windowStates = do
getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [Surface] -> IO ([Window], M.Map Window WindowState, M.Map Window [Surface])
getWindowStates disp atoms oldWindows windowStates windowIcons = do
windows <- getWindowList disp atoms oldWindows
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
newWindowStates <- mapM getWindowState' windowStates'
newWindowIcons <- mapM getWindowIcons' windowIcons'
return (windows, M.fromList newWindowStates)
return (windows, M.fromList newWindowStates, M.fromList newWindowIcons)
where
rootwin = Xlib.defaultRootWindow disp
getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do
windowState <- getWindowState disp 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 -> Atoms -> Window -> IO WindowState
getWindowState disp atoms window = do
Xlib.selectInput disp window Xlib.propertyChangeMask
@ -204,6 +290,39 @@ getWindowState disp atoms window = do
where
unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Surface]
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
readIcons :: [CLong] -> IO [Surface]
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)
forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
surfaceMarkDirty icon
moreIcons <- readIcons rest
return $ icon:moreIcons
readIcons _ = return []
premultiply :: Word32 -> Word32
premultiply c = a .|. r .|. g .|. b
where
amask = 0xFF000000
rmask = 0x00FF0000
gmask = 0x0000FF00
bmask = 0x000000FF
a = c .&. amask
pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask
r = pm rmask
g = pm gmask
b = pm bmask
showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
showWindow disp atoms window = do
states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window

1
lib/Phi/X11/AtomList.hs
View file

@ -12,6 +12,7 @@ atoms = [ "UTF8_STRING"
, "_NET_WM_WINDOW_TYPE_MENU"
, "_NET_WM_WINDOW_TYPE_SPLASH"
, "_NET_WM_DESKTOP"
, "_NET_WM_ICON"
, "_NET_WM_STATE"
, "_NET_WM_STATE_SKIP_PAGER"
, "_NET_WM_STATE_SKIP_TASKBAR"

2
phi.cabal
View file

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

4
src/Phi.hs
View file

@ -12,8 +12,8 @@ main = do
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
[theTaskbar, brightBorder [theClock]]
where
theTaskbar = taskbar defaultTaskbarConfig { taskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (0.9, 0.9, 0.9, 0.65) (0.45, 0.45, 0.45, 0.8) 5 0
, activeTaskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (1, 1, 1, 0.65) (0, 0, 0, 0.8) 5 0
theTaskbar = taskbar defaultTaskbarConfig { taskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.65) (0.45, 0.45, 0.45, 0.8) 5 0
, activeTaskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 5 0 5) (1, 1, 1, 0.65) (0, 0, 0, 0.8) 5 0
}
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
, lineSpacing = (-2)