path: root/lib/Phi/Widgets/Taskbar.hs

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

module Phi.Widgets.Taskbar ( IconStyle
                           , idIconStyle
                           , desaturateIconStyle
                           , TaskStyle(..)
                           , DesktopStyle(..)
                           , TaskbarConfig(..)
                           , defaultTaskbarConfig
                           , Taskbar
                           , 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.IORef
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


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
  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 (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"
                         , 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 deriving (Show, Eq)

instance Show Surface where
  show _ = "Surface <?>"

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

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)
                    | DesktopCountUpdate !Int
                    | CurrentDesktopUpdate !Int
                    | ActiveWindowUpdate !Window
                    deriving (Show, Typeable)

instance Show (IORef a) where
  show _ = "IORef <?>"

instance Widget Taskbar TaskbarState () 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

    
  minSize _ _ _ _ = 0
  weight _ = 1
  
  render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
                                       , taskbarDesktopCount = desktopCount
                                       , 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
        desktopNumbers = take desktopCount [0..]
        desktops       = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop 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 desktopNumbers
        windowWidth    = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
    
    surface <- createImageSurface FormatARGB32 w h
    renderWith surface $ do
      setOperator OperatorClear
      paint

      setOperator OperatorOver

      flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
        let dstyle' = dstyle desktop
            dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
        
        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
            
            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'
            
                _ -> return ()
        
          _ -> return ()
      
        return $ nwindows + length desktopWindows
    
    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 (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
    Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
    Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
    _ -> 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

renderTask :: WindowState -> [(Int, Surface)] -> IORef (Maybe (Int, Surface)) -> TaskStyle -> Int -> Int -> Int -> Int -> Render ()
renderTask state icons scaledIconRef 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
  
  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
  
  case scaledIcon of
    Just icon -> do
      save
      translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
      taskIconStyle style icon
      paint
      restore
    
    _ -> return ()
                

createScaledIcon :: [(Int, Surface)] -> Int -> Render (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
          
        _ -> return Nothing
  
  where
    bestIcon = fmap snd . listToMaybe $ sortBy compareIcons icons
    compareIcons = flip (compare `on` fst)


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


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
    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 $ DesktopCountUpdate desktopCount
    sendMessage phi $ CurrentDesktopUpdate current
    sendMessage phi $ ActiveWindowUpdate activeWindow
    return (windows, states, icons, scaledIcons, windowScreens)
  sendMessage phi Repaint
  
  flip evalStateT (windows, states, icons, scaledIcons, windowScreens) $ 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, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle) IO ()
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
  let atoms = getAtoms dispvar
  let screens = getScreens dispvar
  
  when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
                                                 , atom_NET_NUMBER_OF_DESKTOPS
                                                 , atom_NET_CURRENT_DESKTOP
                                                 , 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_CLIENT_LIST atoms) $ do
        (windows, windowStates, icons, scaledIcons, windowScreens) <- get
        (windows', windowStates', icons', scaledIcons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windowStates icons scaledIcons windowScreens
        
        when (windows /= windows') $ do
          sendMessage phi $ WindowListUpdate windows' windowStates' icons' scaledIcons' windowScreens'
          sendMessage phi Repaint
          put (windows', windowStates', icons', scaledIcons', windowScreens')
    
      else do
      (windows, windowStates, icons, scaledIcons, windowScreens) <- 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
            sendMessage phi Repaint
            put (windows, windowStates', icons, scaledIcons, windowScreens)

handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
  let screens = getScreens dispvar

  (windows, windowStates, icons, scaledIcons, windowScreens) <- get
  when (elem window windows) $ withDisplay dispvar $ \disp -> do
    let screen = M.lookup window windowScreens
    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'
      sendMessage phi Repaint
      put (windows, windowStates, icons, scaledIcons, windowScreens')

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

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
  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)
    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)
      
      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
  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
    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 [0..]) $ \(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


getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle
getWindowScreen disp screens window = flip catch (\_ -> return $ head screens) $ do
  (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
  (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
  
  case ret of
    True -> do
      let windowRect = Xlib.Rectangle x y width height
          screen = maximumBy (compare `on` unionArea windowRect) screens
      return screen
    False ->
      return $ head screens
    

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