Taskbar: show tasks

5 files changed, 162 insertions, 40 deletions

diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 0576f27..7de66ea 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -2,6 +2,8 @@
 
 module Phi.Border ( BorderWidth(..)
                   , simpleBorderWidth
+                  , borderH
+                  , borderV
                   , BorderConfig(..)
                   , defaultBorderConfig
                   , drawBorder
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index aa75258..c48321c 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -10,9 +10,14 @@ import Control.Monad
 import Control.Monad.State
 import Control.Monad.Trans
 
+import Data.Array.MArray
+import Data.Bits
 import Data.Char
+import Data.Function
+import Data.List
 import Data.Maybe
 import Data.Typeable
+import Data.Word
 import qualified Data.Map as M
 
 import Foreign.C.Types
@@ -21,6 +26,7 @@ import Graphics.Rendering.Cairo
 import Graphics.Rendering.Pango.Cairo
 import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
 import Graphics.Rendering.Pango.Layout
+import Graphics.Rendering.Pango.Font
 
 import Graphics.X11.Xlib (Window)
 import qualified Graphics.X11.Xlib as Xlib
@@ -35,14 +41,16 @@ import Phi.Widget
 import Phi.X11.Atoms
 
 
-data TaskbarConfig = TaskbarConfig { taskMaxSize  :: !Int
-                                   , showDesktops :: !Bool
-                                   , taskBorder   :: !BorderConfig
-                                   , activeTaskBorder   :: !BorderConfig
+data TaskbarConfig = TaskbarConfig { taskbarFont      :: !String
+                                   , taskMaxSize      :: !Int
+                                   , showDesktops     :: !Bool
+                                   , taskBorder       :: !BorderConfig
+                                   , activeTaskBorder :: !BorderConfig
                                    } deriving Show
 
 defaultTaskbarConfig :: TaskbarConfig
-defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
+defaultTaskbarConfig = TaskbarConfig { taskbarFont = "Sans 7"
+                                     , taskMaxSize = 150
                                      , showDesktops = False
                                      , taskBorder = defaultBorderConfig
                                      , activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
@@ -50,10 +58,14 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
 
 data Taskbar = Taskbar TaskbarConfig deriving Show
 
+instance Show Surface where
+  show _ = "Surface <?>"
+
 data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
                                  , taskbarDesktopCount :: !Int
                                  , taskbarWindows      :: ![Window]
                                  , taskbarWindowStates :: !(M.Map Window WindowState)
+                                 , taskbarWindowIcons ::  !(M.Map Window [Surface])
                                  } deriving Show
 
 data WindowState = WindowState { windowTitle   :: !String
@@ -61,7 +73,7 @@ data WindowState = WindowState { windowTitle   :: !String
                                , windowVisible :: !Bool
                                } deriving (Show, Eq)
 
-data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState)
+data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [Surface])
                     | DesktopCountUpdate Int
                     | ActiveWindowUpdate Window
                     deriving (Show, Typeable)
@@ -72,13 +84,13 @@ instance WidgetClass Taskbar where
   initWidget (Taskbar _) phi dispvar = do
     forkIO $ taskbarRunner phi dispvar
     
-    return $ TaskbarState 0 0 [] M.empty
+    return $ TaskbarState 0 0 [] M.empty M.empty
 
     
   minSize _ = 0
   weight _ = 1
   
-  render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do
+  render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = windowIcons} w h = do
     let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
         windowCount = sum $ map (length . snd) $ desktopWindows
     when (windowCount /= 0) $ do
@@ -86,46 +98,107 @@ instance WidgetClass Taskbar where
       
       forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
         let border = if window == activeWindow then activeTaskBorder config else taskBorder config
-        drawBorder border (i*windowWidth) 0 windowWidth h
+            leftBorder = (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border)
+            rightBorder = (borderRight $ margin border) + (borderWidth border) + (borderRight $ padding border)
+            h' = h - (borderV $ margin border)
+            mstate = M.lookup window windowStates
+            micons = M.lookup window windowIcons
+
+        case (mstate, micons) of
+          (Just state, Just icons) -> do
+            save
+            drawBorder border (i*windowWidth) 0 windowWidth h
+            clip
+            
+            setSourceRGB 1 1 1
+            renderText config (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
+            
+            restore
+            
+            icon' <- liftIO $ bestIcon h' icons
+            case icon' of
+              Just icon -> withPatternForSurface icon $ \pattern -> do
+                save
+                translate (fromIntegral $  i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin border)
+                imageW <- imageSurfaceGetWidth icon
+                imageH <- imageSurfaceGetHeight icon
+                let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
+                scale scalef scalef
+                setSource pattern
+                paint
+                restore
+                
+              Nothing -> return ()
+          
+          _ -> return ()
+        
   
   handleMessage _ priv m = case (fromMessage m) of
-    Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates}
+    Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons}
     Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
     Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
     _ -> priv
 
 
+renderText :: TaskbarConfig -> Int -> Int -> Int -> Int -> String -> Render ()
+renderText config x y w h text = do
+  layout <- createLayout ""
+  (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
+    layoutSetMarkup layout $ "<span font='" ++ (taskbarFont config) ++ "'>" ++ (escapeMarkup text) ++ "</span>"
+    layoutSetWidth layout $ Just $ fromIntegral w
+    layoutSetEllipsize layout EllipsizeEnd
+    
+    layoutGetExtents layout
+  
+  
+  moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
+  showLayout layout
+
+bestIcon :: Int -> [Surface] -> IO (Maybe Surface)
+bestIcon h icons = do
+  imageSizes <- forM icons $ \icon -> liftM2 (,) (return icon) $ liftM2 max (imageSurfaceGetWidth icon) (imageSurfaceGetHeight icon)
+  let sortedIcons = sortBy compareIcons imageSizes
+  return $ findBest sortedIcons
+    where
+      compareIcons a b = (compare `on` snd) b a
+      
+      findBest (a1:a2:ax) = if (snd a2) < h then Just $ fst a1 else findBest (a2:ax)
+      findBest [a] = Just $ fst a
+      findBest [] = Nothing
+
+
 windowOnDesktop :: Int -> WindowState -> Bool
 windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
 
 
 taskbarRunner :: Phi -> Display -> IO ()
 taskbarRunner phi dispvar = do
-  (windows, tasks) <- liftIO $ withDisplay dispvar $ \disp -> do
-    (windows, tasks) <- getWindowStates disp (getAtoms dispvar) [] M.empty
+  (windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do
+    (windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty
     desktopCount <- getDesktopCount disp (getAtoms dispvar) 
     activeWindow <- getActiveWindow disp (getAtoms dispvar) 
-    sendMessage phi $ WindowListUpdate windows tasks
+    sendMessage phi $ WindowListUpdate windows states icons
     sendMessage phi $ DesktopCountUpdate desktopCount
     sendMessage phi $ ActiveWindowUpdate activeWindow
-    return (windows, tasks)
+    return (windows, states, icons)
   sendMessage phi Repaint
   
-  flip evalStateT (windows, tasks) $ forever $ do
+  flip evalStateT (windows, states, icons) $ forever $ do
     m <- receiveMessage phi
     case (fromMessage m) of
       Just event@XExtras.PropertyEvent {} -> 
         handlePropertyUpdate phi dispvar event
       _ ->
         return ()
-            
-handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
+
+handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [Surface]) IO ()
 handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
   let atoms = getAtoms dispvar
   
   when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
                                   , atom_NET_NUMBER_OF_DESKTOPS
                                   , atom_NET_CLIENT_LIST
+                                  , atom_NET_WM_ICON
                                   , atom_NET_WM_NAME
                                   , atomWM_NAME
                                   , atom_NET_WM_DESKTOP
@@ -143,25 +216,33 @@ handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom,
         sendMessage phi $ DesktopCountUpdate desktopCount
         sendMessage phi Repaint
       when (atom == atom_NET_CLIENT_LIST atoms) $ do
-        (windows, windowStates) <- get
-        (windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates
+        (windows, windowStates, icons) <- get
+        (windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
         
-        when (windows /= windows' || windowStates /= windowStates') $ do
-          sendMessage phi $ WindowListUpdate windows' windowStates'
+        when (windows /= windows') $ do
+          sendMessage phi $ WindowListUpdate windows' windowStates' icons'
           sendMessage phi Repaint
-          put (windows', windowStates')
+          put (windows', windowStates', icons')
     
       else do
-      (windows, windowStates) <- get
+      (windows, windowStates, icons) <- get
       when (elem window windows) $ do
-        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'
+        when (atom == atom_NET_WM_ICON atoms) $ do
+          icon <- liftIO $ getWindowIcons disp atoms window
+          let icons' = M.insert window icon icons
+          sendMessage phi $ WindowListUpdate windows windowStates icons'
           sendMessage phi Repaint
-          put (windows, windowStates')
+          put (windows, windowStates, icons')
+        
+        when (atom /= atom_NET_WM_ICON atoms) $ do
+          let windowState = M.lookup window windowStates
+          windowState' <- liftIO $ getWindowState disp atoms window
+          
+          when (windowState /= (Just windowState')) $ do
+            let windowStates' = M.insert window windowState' windowStates
+            sendMessage phi $ WindowListUpdate windows windowStates' icons
+            sendMessage phi Repaint
+            put (windows, windowStates', icons)
 
 getDesktopCount :: Xlib.Display -> Atoms -> IO Int
 getDesktopCount disp atoms =
@@ -171,24 +252,29 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
 getActiveWindow disp atoms =
   liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
 
-getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
-getWindowStates disp atoms oldWindows windowStates = do
+getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [Surface] -> IO ([Window], M.Map Window WindowState, M.Map Window [Surface])
+getWindowStates disp atoms oldWindows windowStates windowIcons = do
   windows <- getWindowList disp atoms oldWindows
   
   let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
+      windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
   
   newWindowStates <- mapM getWindowState' windowStates'
+  newWindowIcons <- mapM getWindowIcons' windowIcons'
   
-  return (windows, M.fromList newWindowStates)
+  return (windows, M.fromList newWindowStates, M.fromList newWindowIcons)
     where
-      rootwin = Xlib.defaultRootWindow disp
-      
       getWindowState' (window, Just windowState) = return (window, windowState) 
       getWindowState' (window, Nothing) = do
         windowState <- getWindowState disp atoms window
         return (window, windowState)
+      
+      getWindowIcons' (window, Just icons) = return (window, icons)
+      getWindowIcons' (window, Nothing) = do
+        icons <- getWindowIcons disp atoms window
+        return (window, icons)
 
-getWindowState :: Xlib.Display -> Atoms -> Window -> IO  WindowState
+getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
 getWindowState disp atoms window = do
   Xlib.selectInput disp window Xlib.propertyChangeMask
   netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
@@ -204,6 +290,39 @@ getWindowState disp atoms window = do
     where
       unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
 
+getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Surface]
+getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
+
+readIcons :: [CLong] -> IO [Surface]
+readIcons (width:height:iconData) = do
+  if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
+    let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
+    icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
+    surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
+    forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
+    
+    surfaceMarkDirty icon
+  
+    moreIcons <- readIcons rest
+    return $ icon:moreIcons
+
+readIcons _ = return []
+
+premultiply :: Word32 -> Word32
+premultiply c = a .|. r .|. g .|. b
+  where
+    amask = 0xFF000000
+    rmask = 0x00FF0000
+    gmask = 0x0000FF00
+    bmask = 0x000000FF
+    
+    a = c .&. amask
+    pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask
+    
+    r = pm rmask
+    g = pm gmask
+    b = pm bmask
+
 showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
 showWindow disp atoms window = do
   states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
@@ -219,7 +338,7 @@ showWindow disp atoms window = do
                                                       , atom_NET_WM_WINDOW_TYPE_SPLASH
                                                       ]
                     ]
-  
+
 
 getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
 getWindowList disp atoms windows = do
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index d1abb24..dc5eac1 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -12,6 +12,7 @@ atoms = [ "UTF8_STRING"
         , "_NET_WM_WINDOW_TYPE_MENU"
         , "_NET_WM_WINDOW_TYPE_SPLASH"
         , "_NET_WM_DESKTOP"
+        , "_NET_WM_ICON"
         , "_NET_WM_STATE"
         , "_NET_WM_STATE_SKIP_PAGER"
         , "_NET_WM_STATE_SKIP_TASKBAR"
diff --git a/phi.cabal b/phi.cabal
index 142a87d..ea33c35 100644
--- a/phi.cabal
+++ b/phi.cabal
@@ -11,7 +11,7 @@ maintainer:          mschiffer@universe-factory.net
 build-type:          Simple
 
 library
-  build-depends:     base >= 4, template-haskell, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
+  build-depends:     base >= 4, template-haskell, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
   exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
                      Phi.Widgets.Clock, Phi.Widgets.Taskbar
   other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
diff --git a/src/Phi.hs b/src/Phi.hs
index d9ea396..a14ddab 100644
--- a/src/Phi.hs
+++ b/src/Phi.hs
@@ -12,8 +12,8 @@ main = do
   runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
     [theTaskbar, brightBorder [theClock]]
     where
-      theTaskbar = taskbar defaultTaskbarConfig { taskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (0.9, 0.9, 0.9, 0.65) (0.45, 0.45, 0.45, 0.8) 5 0
-                                                , activeTaskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (1, 1, 1, 0.65) (0, 0, 0, 0.8) 5 0
+      theTaskbar = taskbar defaultTaskbarConfig { taskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.65) (0.45, 0.45, 0.45, 0.8) 5 0
+                                                , activeTaskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 5 0 5) (1, 1, 1, 0.65) (0, 0, 0, 0.8) 5 0
                                                 }
       theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
                                           , lineSpacing = (-2)