353 lines
15 KiB
Haskell
353 lines
15 KiB
Haskell
{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
|
|
|
|
module Phi.Widgets.Taskbar ( TaskbarConfig(..)
|
|
, defaultTaskbarConfig
|
|
, taskbar
|
|
) where
|
|
|
|
import Control.Concurrent
|
|
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
|
|
|
|
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
|
|
import qualified Graphics.X11.Xlib.Extras as XExtras
|
|
|
|
import Codec.Binary.UTF8.String
|
|
|
|
import Phi.Phi
|
|
import Phi.Types
|
|
import Phi.Border
|
|
import Phi.Widget
|
|
import Phi.X11.Atoms
|
|
|
|
|
|
data TaskbarConfig = TaskbarConfig { taskbarFont :: !String
|
|
, taskMaxSize :: !Int
|
|
, showDesktops :: !Bool
|
|
, taskBorder :: !BorderConfig
|
|
, activeTaskBorder :: !BorderConfig
|
|
} deriving Show
|
|
|
|
defaultTaskbarConfig :: TaskbarConfig
|
|
defaultTaskbarConfig = TaskbarConfig { taskbarFont = "Sans 7"
|
|
, taskMaxSize = 150
|
|
, showDesktops = False
|
|
, taskBorder = defaultBorderConfig
|
|
, activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
|
|
}
|
|
|
|
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 [(Int, Surface)])
|
|
} deriving Show
|
|
|
|
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)])
|
|
| DesktopCountUpdate Int
|
|
| ActiveWindowUpdate Window
|
|
deriving (Show, Typeable)
|
|
|
|
instance WidgetClass Taskbar where
|
|
type WidgetData Taskbar = TaskbarState
|
|
|
|
initWidget (Taskbar _) phi dispvar = do
|
|
forkIO $ taskbarRunner phi dispvar
|
|
|
|
return $ TaskbarState 0 0 [] M.empty M.empty
|
|
|
|
|
|
minSize _ = 0
|
|
weight _ = 1
|
|
|
|
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
|
|
let windowWidth = min (taskMaxSize config) (w `div` windowCount)
|
|
|
|
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
|
|
|
|
case bestIcon h' icons 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
|
|
|
|
when (imageH < imageW) $
|
|
translate 0 $ (fromIntegral (imageW-imageH))/2
|
|
|
|
setSource pattern
|
|
paint
|
|
restore
|
|
|
|
Nothing -> return ()
|
|
|
|
_ -> return ()
|
|
|
|
|
|
handleMessage _ priv m = case (fromMessage m) of
|
|
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 -> [(Int, Surface)] -> Maybe Surface
|
|
bestIcon h icons = findBest $ sortBy compareIcons icons
|
|
where
|
|
compareIcons = flip (compare `on` fst)
|
|
|
|
findBest (a1:a2:ax) = if (fst a2) < h then Just $ snd a1 else findBest (a2:ax)
|
|
findBest [a] = Just $ snd a
|
|
findBest [] = Nothing
|
|
|
|
|
|
windowOnDesktop :: Int -> WindowState -> Bool
|
|
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
|
|
|
|
|
|
taskbarRunner :: Phi -> Display -> IO ()
|
|
taskbarRunner phi dispvar = do
|
|
(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 states icons
|
|
sendMessage phi $ DesktopCountUpdate desktopCount
|
|
sendMessage phi $ ActiveWindowUpdate activeWindow
|
|
return (windows, states, icons)
|
|
sendMessage phi Repaint
|
|
|
|
flip evalStateT (windows, states, icons) $ forever $ do
|
|
m <- receiveMessage phi
|
|
case (fromMessage m) of
|
|
Just event@XExtras.PropertyEvent {} ->
|
|
handlePropertyUpdate phi dispvar event
|
|
_ ->
|
|
return ()
|
|
|
|
handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, 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
|
|
, atom_NET_WM_STATE
|
|
]) $ withDisplay dispvar $ \disp -> do
|
|
let rootwin = Xlib.defaultRootWindow disp
|
|
if (window == rootwin)
|
|
then do
|
|
when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
|
|
activeWindow <- liftIO $ getActiveWindow disp atoms
|
|
sendMessage phi $ ActiveWindowUpdate activeWindow
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
|
|
desktopCount <- liftIO $ getDesktopCount disp atoms
|
|
sendMessage phi $ DesktopCountUpdate desktopCount
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_CLIENT_LIST atoms) $ do
|
|
(windows, windowStates, icons) <- get
|
|
(windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
|
|
|
|
when (windows /= windows') $ do
|
|
sendMessage phi $ WindowListUpdate windows' windowStates' icons'
|
|
sendMessage phi Repaint
|
|
put (windows', windowStates', icons')
|
|
|
|
else do
|
|
(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' icons
|
|
sendMessage phi Repaint
|
|
put (windows, windowStates', icons)
|
|
|
|
getDesktopCount :: Xlib.Display -> Atoms -> IO Int
|
|
getDesktopCount disp atoms =
|
|
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
|
|
|
|
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 -> M.Map Window [(Int, Surface)]
|
|
-> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, 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, M.fromList newWindowIcons)
|
|
where
|
|
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
|
|
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 (atomWM_NAME atoms) 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
|
|
where
|
|
unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
|
|
|
|
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)]
|
|
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
|
|
|
|
readIcons :: [CLong] -> IO [(Int, 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 $ (fromIntegral $ max width height, 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
|
|
transientForHint <- XExtras.getTransientForHint disp window
|
|
windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
|
|
|
|
return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states
|
|
, transientForHint /= Nothing
|
|
, elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK
|
|
, atom_NET_WM_WINDOW_TYPE_DESKTOP
|
|
, atom_NET_WM_WINDOW_TYPE_TOOLBAR
|
|
, atom_NET_WM_WINDOW_TYPE_MENU
|
|
, atom_NET_WM_WINDOW_TYPE_SPLASH
|
|
]
|
|
]
|
|
|
|
|
|
getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
|
|
getWindowList disp atoms windows = do
|
|
newWindows <- liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
|
|
return $ (filter (flip elem newWindows) windows) ++ (filter (not . flip elem windows) newWindows)
|
|
|
|
|
|
taskbar :: TaskbarConfig -> Widget
|
|
taskbar config = do
|
|
Widget $ Taskbar config
|