phi/lib/Phi/Widgets/Taskbar.hs

{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}

module Phi.Widgets.Taskbar ( IconStyle
                           , idIconStyle
                           , desaturateIconStyle
                           , TaskStyle(..)
                           , DesktopStyle(..)
                           , TaskbarConfig(..)
                           , defaultTaskbarConfig
                           , Taskbar
                           , taskbar
                           ) where

import Control.Concurrent
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Trans

import Data.Array.MArray
import Data.Bits
import Data.Char
import Data.Function
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

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


newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () }
instance Eq IconStyle where
  _ == _ = True

idIconStyle :: IconStyle
idIconStyle = IconStyle $ flip withPatternForSurface setSource

desaturateIconStyle :: Double -> IconStyle
desaturateIconStyle v = IconStyle $ \icon -> do
  w <- imageSurfaceGetWidth icon
  h <- imageSurfaceGetHeight icon
  
  renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do
    renderWith surface $ do
      setOperator OperatorAdd
      withPatternForSurface icon setSource
      paint
      
      setSourceRGB 0 0 0
      paint
      
      setOperator OperatorHslSaturation
      setSourceRGBA 0 0 0 (1-v)
      paint
      
      setOperator OperatorDestIn
      withPatternForSurface icon setSource
      paint
    
    withPatternForSurface surface setSource


downscaled :: Double -> Surface -> Render ()
downscaled s surface = do
  case True of
    _ | s < 0.5 -> do
      w <- imageSurfaceGetWidth surface
      h <- imageSurfaceGetHeight surface
      
      renderWithSimilarSurface ContentColorAlpha (ceiling (fromIntegral w*s)) (ceiling (fromIntegral h*s)) $ \surface' -> do
        renderWith surface' $ do
          scale 0.5 0.5
          downscaled (2*s) surface
          paint
        withPatternForSurface surface' setSource
      
      | otherwise -> do
      scale s s
      withPatternForSurface surface setSource


data TaskStyle = TaskStyle { taskFont      :: !String
                           , taskColor     :: !Color
                           , taskBorder    :: !BorderConfig
                           , taskIconStyle :: !IconStyle
                           } deriving Eq

data DesktopStyle = DesktopStyle { desktopFont       :: !String
                                 , desktopLabelWidth :: !Int
                                 , desktopLabelGap   :: !Int
                                 , desktopColor      :: !Color
                                 , desktopBorder     :: !BorderConfig
                                 }

data TaskbarConfig = TaskbarConfig { taskMaxSize      :: !Int
                                   , normalTaskStyle  :: !TaskStyle
                                   , activeTaskStyle  :: !TaskStyle
                                   , desktopStyle     :: !(Maybe (DesktopStyle, DesktopStyle))
                                   }

defaultStyle :: TaskStyle
defaultStyle = TaskStyle { taskFont = "Sans 8"
                         , taskColor = (0, 0, 0, 1)
                         , taskBorder = defaultBorderConfig { backgroundColor = (0.75, 0.75, 0.75, 1) }
                         , taskIconStyle = idIconStyle
                         }

defaultTaskbarConfig :: TaskbarConfig
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
                                     , normalTaskStyle = defaultStyle
                                     , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }}
                                     , desktopStyle = Nothing
                                     }

data Taskbar = Taskbar TaskbarConfig

data TaskbarState = TaskbarState { taskbarScreens           :: ![Xlib.Rectangle]
                                 , taskbarActiveWindow      :: !Window
                                 , taskbarDesktopCount      :: !Int
                                 , taskbarCurrentDesktop    :: !Int
                                 , taskbarDesktopNames      :: ![String]
                                 , taskbarWindows           :: ![Window]
                                 , taskbarWindowStates      :: !(M.Map Window WindowState)
                                 } 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
                               , windowIcons    :: ![Icon]
                               , windowGeometry :: !Xlib.Rectangle
                               } deriving (Eq, Show)

data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
                               , renderWindowCached     :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface)
                               }

createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached


newtype DesktopCache = DesktopCache (IOCache () ())

emptyWindowCache :: WindowCache
emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon
                               , renderWindowCached     = createIOCache doRenderWindow
                               }

data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
                                 , windowCaches  :: !(M.Map Window WindowCache)
                                 }

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

cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b
cached t = liftT t . liftIOStateT . runIOCache

data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
                    | DesktopCountUpdate !Int
                    | CurrentDesktopUpdate !Int
                    | DesktopNamesUpdate ![String]
                    | ActiveWindowUpdate !Window
                    deriving (Typeable, Show)

instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
  initWidget (Taskbar _) phi dispvar screens = do
    phi' <- dupPhi phi
    forkIO $ taskbarRunner phi' dispvar
    
    return $ TaskbarState (map fst screens) 0 0 (-1) [] [] M.empty
  
  initCache _ = M.empty
    
  minSize _ _ _ _ = 0
  weight _ = 1
  
  render (Taskbar config) TaskbarState { taskbarScreens = screens
                                       , taskbarActiveWindow = activeWindow
                                       , taskbarDesktopCount = desktopCount
                                       , taskbarCurrentDesktop = currentDesktop
                                       , taskbarDesktopNames = desktopNames
                                       , taskbarWindows = windows
                                       , taskbarWindowStates = windowStates
                                       } _ _ w h screen = do
    let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens
        screenWindows  = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
        desktopNumbers = take desktopCount $ zip [0..] (desktopNames ++ repeat "")
        desktops       = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop . fst $ desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
        
        windowCount    = sum $ map (length . snd) $ desktops
        
        dstyle d       = fmap (if d == currentDesktop then snd else fst) $ desktopStyle config
        dlabelwidth d  = fromMaybe 0 $ fmap desktopLabelWidth $ dstyle d
        gap d ds       = if null (snd $ desktops !! d) then 0 else desktopLabelGap ds
        dleftwidth d   = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border}
                                             -> (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border)
                                                + dlabelwidth d + gap d ds) $ dstyle d
        dwidth d       = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border}
                                             -> (borderH $ margin border) + 2*(borderWidth border) + (borderH $ padding border)
                                                + dlabelwidth d + gap d ds) $ dstyle d
        
        desktopsWidth  = sum $ map (dwidth . fst) desktopNumbers
        windowWidth    = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
    
    surface <- liftIO $ createImageSurface FormatARGB32 w h
    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 (fst desktop)
            dx = dleftwidth (fst desktop) + (sum $ map dwidth $ take (fst desktop) [0..]) + nwindows*windowWidth
        
        case dstyle' of
          Just ds -> do
            let (r, g, b, a) = desktopColor ds
            lift $ do
              save
              drawBorder (desktopBorder ds) (dx - dleftwidth (fst desktop)) 0 (dwidth (fst desktop) + windowWidth * length desktopWindows) h
              clip
              
              setSourceRGBA r g b a
              renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth (fst desktop) - gap (fst desktop) ds)) 0 (dlabelwidth (fst desktop)) h $ snd desktop
              
              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
                  x = dx + i*windowWidth
                  y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
              
              case mstate of
                Just state -> do
                  windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h'
                  lift $ do
                    save
                    translate (fromIntegral $ x - 5) (fromIntegral $ y - 5)
                    withPatternForSurface windowSurface setSource
                    paint
                    restore
            
                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) -> priv { taskbarWindows = windows
                                                         , taskbarWindowStates = windowStates
                                                         }
    Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
    Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
    Just (DesktopNamesUpdate names) -> priv {taskbarDesktopNames = names}
    Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
    _ -> case (fromMessage m) of
      Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens}
      _ -> priv


renderText :: String -> Int -> Int -> Int -> Int -> String -> Render ()
renderText font x y w h text = do
  layout <- createLayout ""
  (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
    layoutSetMarkup layout $ "<span font='" ++ font ++ "'>" ++ (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

renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface
renderWindow state style w h = do
  let h' = h - (borderV $ margin $ taskBorder style)
  
  scaledIcon <- cached createScaledIconCached' (windowIcons state, h')
  cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h)

doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface
doRenderWindow (title, scaledIcon, style, 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)
  
  surface <- createImageSurface FormatARGB32 (w+10) (h+10)
  renderWith surface $ do
    translate 5 5
    
    save
    drawBorder (taskBorder style) 0 0 w h
    clip
    
    setSourceRGBA r g b a
    renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title
    
    restore
    
    case scaledIcon of
      Just (Icon _ _ icon) -> do
        save
        translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style)
        withIconStyle (taskIconStyle style) icon
        paint
        restore
    
      _ -> return ()
  
  return surface
                

createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon)
createScaledIcon (icons, h) = do
  case bestIcon of
    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
      fmap Just $ createIcon h scaledIcon
          
    _ -> return Nothing
  
  where
    bestIcon = listToMaybe $ sortBy compareIcons icons
    compareIcons = flip (compare `on` (\(Icon _ size _) -> size))


windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)


taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do
  (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
    (windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
    desktopCount <- getDesktopCount disp (getAtoms dispvar) 
    current <- getCurrentDesktop disp (getAtoms dispvar) 
    names <- getDesktopNames disp (getAtoms dispvar)
    activeWindow <- getActiveWindow disp (getAtoms dispvar) 
    sendMessage phi $ WindowListUpdate windows states
    sendMessage phi $ DesktopCountUpdate desktopCount
    sendMessage phi $ CurrentDesktopUpdate current
    sendMessage phi $ DesktopNamesUpdate names
    sendMessage phi $ ActiveWindowUpdate activeWindow
    return (windows, states)
  sendMessage phi Repaint
  
  flip evalStateT (windows, states) $ forever $ do
    m <- receiveMessage phi
    case (fromMessage m) of
      Just event ->
        handleEvent phi dispvar event
      _ ->
        return ()

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
  
  when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
                                                 , atom_NET_NUMBER_OF_DESKTOPS
                                                 , atom_NET_CURRENT_DESKTOP
                                                 , atom_NET_DESKTOP_NAMES
                                                 , atom_NET_CLIENT_LIST
                                                 , atom_NET_WM_ICON
                                                 , atom_NET_WM_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_CURRENT_DESKTOP atoms) $ do
        current <- liftIO $ getCurrentDesktop disp atoms
        sendMessage phi $ CurrentDesktopUpdate current
        sendMessage phi Repaint
      when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
        names <- liftIO $ getDesktopNames disp atoms
        sendMessage phi $ DesktopNamesUpdate names
        sendMessage phi Repaint
      when (atom == atom_NET_CLIENT_LIST atoms) $ do
        (windows, windowStates) <- get
        (windows', windowStates') <- liftIO $ getWindowStates disp atoms windowStates
        
        when (windows /= windows') $ do
          sendMessage phi $ WindowListUpdate windows' windowStates'
          sendMessage phi Repaint
          put (windows', windowStates')
    
      else do
      (windows, windowStates) <- get
      when (elem window windows) $ do
        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')
        
            | 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
  (windows, windowStates) <- get
  when (elem window windows) $ withDisplay dispvar $ \disp -> do
    let geom = fmap windowGeometry . M.lookup window $  windowStates
    geom' <- liftIO $ getWindowGeometry disp window
    when (geom /= (Just geom')) $ do
      let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates
      sendMessage phi $ WindowListUpdate windows windowStates'
      sendMessage phi Repaint
      put (windows, windowStates')

handleEvent _ _ _ = return ()


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

getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int
getCurrentDesktop disp atoms =
  liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_CURRENT_DESKTOP atoms) $ Xlib.defaultRootWindow disp

getDesktopNames :: Xlib.Display -> Atoms -> IO [String]
getDesktopNames disp atoms =
  liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ XExtras.getWindowProperty8 disp (atom_NET_DESKTOP_NAMES atoms) $ Xlib.defaultRootWindow disp
  where
    break' l = case dropWhile (== 0) l of
      [] -> []
      l' -> w : break' l''
        where (w, l'') = break (== 0) l'

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 -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
getWindowStates disp atoms windowStates = do
  windows <- getWindowList disp atoms
  
  let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
  
  newWindowStates <- mapM getWindowState' windowStates'
  
  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
        return (window, windowState)

getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
getWindowState disp atoms window = do
  (name, workspace, visible) <- getWindowInfo disp atoms window
  icons <- getWindowIcons disp atoms window
  geom <- getWindowGeometry disp window
  
  return $ WindowState { windowTitle = name 
                       , windowDesktop = workspace 
                       , windowVisible = visible 
                       , windowIcons = icons
                       , windowGeometry = geom
                       }

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 (wmname, workspace, visible)
    where
      unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))

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 [Icon]
readIcons (width:height:iconData) = do
  if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
    let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
    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 surface
    
    liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest)

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


getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle
getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
  (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
  (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
  
  return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
    

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 -> IO [Window]
getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp

taskbar :: TaskbarConfig -> Taskbar
taskbar = Taskbar