Core is independent of X11 now

2 files changed, 943 insertions, 0 deletions

diff --git a/lib/Phi/Widgets/X11/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs
new file mode 100644
index 0000000..fffb181
--- /dev/null
+++ b/lib/Phi/Widgets/X11/Systray.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
+
+module Phi.Widgets.X11.Systray ( systray
+                               ) where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+
+import Data.Bits
+import Data.IORef
+import Data.Maybe
+import Data.Typeable
+import qualified Data.Map as M
+
+import Foreign.C.Types
+import Foreign.Marshal
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.Cairo
+import Graphics.Rendering.Cairo.Types
+
+import Graphics.X11.Xlib hiding (Display)
+import qualified Graphics.X11.Xlib as Xlib
+import Graphics.X11.Xlib.Extras
+
+import Phi.Bindings.Util
+import Phi.Bindings.SystrayErrorHandler
+
+import Phi.Phi
+import Phi.Types
+import Phi.Widget
+import Phi.X11.Atoms
+
+
+data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq)
+
+instance Eq Phi where
+  _ == _ = True
+
+data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq
+
+data Systray = Systray deriving (Show, Eq)
+
+data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int
+                      deriving (Show, Typeable)
+
+
+instance Widget Systray SystrayState (RenderCache SystrayState) where
+  initWidget (Systray) phi dispvar screens = do
+    phi' <- dupPhi phi
+    forkIO $ systrayRunner phi' dispvar $ snd . head $ screens
+    
+    return $ SystrayState phi (fst . head $ screens) 0 []
+  
+  initCache _ = createRenderCache $ \(SystrayState phi systrayScreen reset icons) x y w h screen -> do
+    when (screen == systrayScreen) $ do
+      forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
+        let x' = x + i*(h+2)
+        sendMessage phi $ RenderIcon midParent window x' y h h
+    
+    setOperator OperatorClear
+    paint
+  
+  minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of 
+    _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1
+      | otherwise -> 0
+
+  weight _ = 0
+  
+  render _ = renderCached
+
+  
+  handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of
+    Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons)
+    Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
+    _ -> case (fromMessage m) of
+      Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons
+      _ -> case (fromMessage m) of
+        Just ResetBackground -> SystrayState phi screen (reset+1) icons
+        _ ->  priv
+
+
+systrayRunner :: Phi -> Display -> Window -> IO ()
+systrayRunner phi dispvar panelWindow = do
+  let atoms = getAtoms dispvar
+  initSuccess <- withDisplay dispvar $ flip initSystray atoms
+  
+  case initSuccess of
+    Just xembedWindow -> flip evalStateT M.empty $ do
+      sendMessage phi HoldShutdown
+      
+      forever $ do
+        m <- receiveMessage phi
+        case (fromMessage m) of
+          Just event ->
+            handleEvent event phi dispvar panelWindow xembedWindow
+          _ ->
+            case (fromMessage m) of
+              Just (RenderIcon midParent window x y w h) -> do
+                withDisplay dispvar $ \disp -> do
+                  liftIO $ flip catch (\_ -> return ()) $ do
+                    sync disp False
+                    setSystrayErrorHandler
+                    
+                    (_, x', y', w', h', _, _) <- getGeometry disp midParent
+                    (_, x'', y'', w'', h'', _, _) <- getGeometry disp window
+                    let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
+                                 || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h''
+                    
+                    when resize $ do
+                      moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+                      moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h)
+                      sync disp False
+                    
+                    clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
+                      
+                    sync disp False
+                    xSetErrorHandler
+                  
+                  lastErrorWindow <- liftIO $ getLastErrorWindow
+                  when (lastErrorWindow == window) $ do
+                    removeIcon phi disp True window
+              _ ->
+                case (fromMessage m) of
+                  Just Shutdown -> do
+                    windows <- gets M.keys
+                    withDisplay dispvar $ \disp -> do
+                      mapM_ (removeIcon phi disp True) windows
+                      liftIO $ do
+                        destroyWindow disp xembedWindow
+                        sync disp False
+                      sendMessage phi ReleaseShutdown
+                  _ ->
+                    return ()
+    Nothing ->
+      return ()
+
+
+initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window)
+initSystray disp atoms = do
+  currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
+  
+  if currentSystrayWin /= 0 then do
+    pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $
+           getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin
+    
+    putStrLn $ "Phi: another systray is running." ++ pid
+    
+    return Nothing
+    else do
+    xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0
+    
+    -- orient horizontally
+    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0]
+    
+    -- set visual
+    let rootwin = defaultRootWindow disp
+        screen = defaultScreen disp
+        visual = defaultVisual disp screen
+        visualID = visualIDFromVisual visual
+    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID]
+    
+    xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime
+    systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
+    if systrayWin /= xembedWin then do
+      destroyWindow disp xembedWin
+      putStrLn $ "Phi: can't initialize systray."
+      return Nothing
+      
+      else do
+      allocaXEvent $ \event -> do
+        putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0]
+        sendEvent disp rootwin False structureNotifyMask event
+      
+      return $ Just xembedWin
+
+
+sYSTEM_TRAY_REQUEST_DOCK :: CInt
+sYSTEM_TRAY_REQUEST_DOCK = 0
+
+sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
+sYSTEM_TRAY_BEGIN_MESSAGE = 1
+
+sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
+sYSTEM_TRAY_CANCEL_MESSAGE = 2
+
+xEMBED_EMBEDDED_NOTIFY :: CInt
+xEMBED_EMBEDDED_NOTIFY = 0
+
+handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
+handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do
+  let atoms = getAtoms dispvar
+  when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
+    case messageData of
+      _:opcode:iconID:_ -> do
+        case True of
+          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
+            when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ fromIntegral iconID
+          
+            | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
+            return ()
+            
+            | otherwise -> do
+            liftIO $ putStrLn "Phi: unknown tray message"
+            return ()
+        
+          
+      _ ->
+        return ()
+
+handleEvent message@UnmapEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
+  withDisplay dispvar $ \disp -> removeIcon phi disp True window
+
+handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
+  withDisplay dispvar $ \disp -> removeIcon phi disp False window
+
+handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow xembedWindow | ev_event_type message == reparentNotify = do
+  parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do
+    status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr
+    case status of
+      0 ->
+        return 0
+      _ -> do
+        childrenPtr <- peek childrenPtrPtr
+        when (childrenPtr /= nullPtr) $
+          xFree childrenPtr >> return ()
+        peek parentPtr
+  midParent <- gets $ M.lookup window
+  when (midParent /= Just parent) $
+    withDisplay dispvar $ \disp -> removeIcon phi disp False window
+  return ()
+
+handleEvent _ _ _ _ _ = return ()
+
+
+addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
+addIcon phi disp atoms panelWindow window = do
+  removeIcon phi disp False window
+  
+  liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
+  
+  midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
+  
+  liftIO $ do
+    setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
+    
+    sync disp False
+    setSystrayErrorHandler
+    
+    reparentWindow disp window midParent 0 0
+    
+    mapRaised disp midParent
+    mapWindow disp window
+    
+    allocaXEvent $ \event -> do
+      putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0]
+      sendEvent disp window False 0xFFFFFF event
+    
+    sync disp False
+    xSetErrorHandler
+  
+  errorWindow <- liftIO $ getLastErrorWindow
+  case True of
+    _ | errorWindow /= window -> do
+      sendMessage phi $ AddIcon midParent window
+      sendMessage phi Repaint
+      modify $ M.insert window midParent
+      | otherwise ->
+      liftIO $ destroyWindow disp midParent
+
+
+removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO ()
+removeIcon phi disp reparent window = do
+  mmidParent <- gets $ M.lookup window
+  case mmidParent of
+    Just midParent -> do
+      sendMessage phi $ RemoveIcon window
+      sendMessage phi Repaint
+      liftIO $ do
+        selectInput disp window $ noEventMask
+        when reparent $
+          reparentWindow disp window (defaultRootWindow disp) 0 0
+        destroyWindow disp midParent
+        sync disp False
+      modify $ M.delete window
+    _ ->
+      return ()
+
+
+systray :: Systray
+systray = Systray
diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs
new file mode 100644
index 0000000..07a7292
--- /dev/null
+++ b/lib/Phi/Widgets/X11/Taskbar.hs
@@ -0,0 +1,649 @@
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
+
+module Phi.Widgets.X11.Taskbar ( IconStyle
+                               , idIconStyle
+                               , desaturateIconStyle
+                               , TaskStyle(..)
+                               , DesktopStyle(..)
+                               , TaskbarConfig(..)
+                               , defaultTaskbarConfig
+                               , Taskbar
+                               , taskbar
+                               ) where
+
+import Control.Arrow
+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.XHB
+import Graphics.XHB.Gen.Xproto
+
+import Codec.Binary.UTF8.String
+
+import Phi.Phi
+import Phi.Types
+import Phi.Border
+import Phi.Widget
+import Phi.X11
+import Phi.X11.Atoms
+import Phi.X11.Util
+
+
+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           :: ![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 :: !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 ![WINDOW] !(M.Map WINDOW WindowState)
+                    | DesktopCountUpdate !Int
+                    | CurrentDesktopUpdate !Int
+                    | DesktopNamesUpdate ![String]
+                    | ActiveWindowUpdate !WINDOW
+                    deriving (Typeable, Show)
+
+instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where
+  initWidget (Taskbar _) phi dispvar screens = do
+    phi' <- dupPhi phi
+    forkIO $ taskbarRunner phi' dispvar
+    
+    return $ TaskbarState (map fst screens) (fromXid xidNone) 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 -> X11 -> IO ()
+taskbarRunner phi x11 = do
+  (windows, states) <- liftIO $ do
+    (windows, states) <- getWindowStates x11 M.empty
+    desktopCount <- getDesktopCount x11
+    current <- getCurrentDesktop x11
+    names <- getDesktopNames x11
+    activeWindow <- getActiveWindow x11
+    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 (XEvent event) ->
+        handleEvent phi x11 event
+      _ ->
+        return ()
+
+
+handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
+handleEvent phi x11 event =
+  case (fromEvent event) of
+    Just e -> handlePropertyNotifyEvent phi x11 e
+    Nothing -> case (fromEvent event) of
+      Just e -> handleConfigureNotifyEvent phi x11 e
+      Nothing -> return ()
+
+handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
+handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do
+  let atoms = x11Atoms x11
+      rootwin = root_SCREEN . x11Screen $ x11
+      
+  when (elem atom $ 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
+                                  , atomWM_NAME
+                                  , atom_NET_WM_NAME
+                                  , atom_NET_WM_DESKTOP
+                                  , atom_NET_WM_STATE
+                                  ]) $ do
+    if (window == rootwin)
+      then do
+      when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
+        activeWindow <- liftIO $ getActiveWindow x11
+        sendMessage phi $ ActiveWindowUpdate activeWindow
+        sendMessage phi Repaint
+      when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
+        desktopCount <- liftIO $ getDesktopCount x11
+        sendMessage phi $ DesktopCountUpdate desktopCount
+        sendMessage phi Repaint
+      when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do
+        current <- liftIO $ getCurrentDesktop x11
+        sendMessage phi $ CurrentDesktopUpdate current
+        sendMessage phi Repaint
+      when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
+        names <- liftIO $ getDesktopNames x11
+        sendMessage phi $ DesktopNamesUpdate names
+        sendMessage phi Repaint
+      when (atom == atom_NET_CLIENT_LIST atoms) $ do
+        (windows, windowStates) <- get
+        (windows', windowStates') <- liftIO $ getWindowStates x11 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 x11 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 x11 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 ()
+
+
+handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
+handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do
+  let conn = x11Connection x11
+  (windows, windowStates) <- get
+  when (elem window windows) $  do
+    let geom = fmap windowGeometry . M.lookup window $ windowStates
+    geom' <- liftIO $ getWindowGeometry x11 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')
+
+
+getDesktopCount :: X11 -> IO Int
+getDesktopCount x11 =
+  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_NUMBER_OF_DESKTOPS . x11Atoms $ x11)
+
+getCurrentDesktop :: X11 -> IO Int
+getCurrentDesktop x11 =
+  liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11)
+
+getDesktopNames :: X11 -> IO [String]
+getDesktopNames x11 =
+  liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11)
+  where
+    break' l = case dropWhile (== 0) l of
+      [] -> []
+      l' -> w : break' l''
+        where (w, l'') = break (== 0) l'
+
+getActiveWindow :: X11 -> IO WINDOW
+getActiveWindow x11 =
+  liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11)
+
+getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState)
+getWindowStates x11 windowStates = do
+  windows <- getWindowList x11
+  
+  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
+        changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
+        windowState <- getWindowState x11 window
+        return (window, windowState)
+
+getWindowState :: X11 -> WINDOW -> IO WindowState
+getWindowState x11 window = do
+  (name, workspace, visible) <- getWindowInfo x11 window
+  icons <- getWindowIcons x11 window
+  geom <- getWindowGeometry x11 window
+  
+  return $ WindowState { windowTitle = name 
+                       , windowDesktop = workspace 
+                       , windowVisible = visible 
+                       , windowIcons = icons
+                       , windowGeometry = geom
+                       }
+
+getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool)
+getWindowInfo x11 window = do
+  let conn = x11Connection x11
+      atoms = x11Atoms x11
+  netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
+  wmname <- case netwmname of
+    Just name -> return name
+    Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
+  
+  workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms)
+  visible <- showWindow conn atoms window
+  
+  return (wmname, workspace, visible)
+    where
+      unsignedChr = chr . fromIntegral
+
+getWindowIcons :: X11 -> WINDOW -> IO [Icon]
+getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe []
+
+
+readIcons :: [Word32] -> 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 :: X11 -> WINDOW -> IO Rectangle
+getWindowGeometry x11 window =
+  getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>=
+  return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height)))
+    where
+      fi :: (Integral a, Num b) => a -> b
+      fi = fromIntegral
+
+showWindow :: Connection -> Atoms -> WINDOW -> IO Bool
+showWindow conn atoms window = do
+  states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms)
+  transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms)
+  windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $
+                getProperty32 conn window (atom_NET_WM_STATE atoms)
+  
+  return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states 
+                    , transientFor /= [] && transientFor /= [0]
+                    , 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 :: X11 -> IO [WINDOW]
+getWindowList x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11)
+
+taskbar :: TaskbarConfig -> Taskbar
+taskbar = Taskbar