Some more work on the taskbar

1 files changed, 191 insertions, 11 deletions

diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index a32c5d2..aa75258 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
 
 module Phi.Widgets.Taskbar ( TaskbarConfig(..)
                            , defaultTaskbarConfig
@@ -7,45 +7,225 @@ module Phi.Widgets.Taskbar ( TaskbarConfig(..)
 
 import Control.Concurrent
 import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
 
+import Data.Char
+import Data.Maybe
 import Data.Typeable
-import Data.Time.LocalTime
-import Data.Time.Format
+import qualified Data.Map as M
 
-import Graphics.Rendering.Cairo
+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 System.Locale
+import Graphics.X11.Xlib (Window)
+import qualified Graphics.X11.Xlib as Xlib
+import qualified Graphics.X11.Xlib.Extras as XExtras
+
+import Codec.Binary.UTF8.String
 
 import Phi.Phi
 import Phi.Types
+import Phi.Border
 import Phi.Widget
+import Phi.X11.Atoms
 
 
-data TaskbarConfig = TaskbarConfig deriving Show
+data TaskbarConfig = TaskbarConfig { taskMaxSize  :: !Int
+                                   , showDesktops :: !Bool
+                                   , taskBorder   :: !BorderConfig
+                                   , activeTaskBorder   :: !BorderConfig
+                                   } deriving Show
 
 defaultTaskbarConfig :: TaskbarConfig
-defaultTaskbarConfig = TaskbarConfig
+defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
+                                     , showDesktops = False
+                                     , taskBorder = defaultBorderConfig
+                                     , activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
+                                     }
 
 data Taskbar = Taskbar TaskbarConfig deriving Show
 
-data TaskbarState = TaskbarState deriving Show
+data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
+                                 , taskbarDesktopCount :: !Int
+                                 , taskbarWindows      :: ![Window]
+                                 , taskbarWindowStates :: !(M.Map Window WindowState)
+                                 } deriving Show
+
+data WindowState = WindowState { windowTitle   :: !String
+                               , windowDesktop :: !Int
+                               , windowVisible :: !Bool
+                               } deriving (Show, Eq)
+
+data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState)
+                    | DesktopCountUpdate Int
+                    | ActiveWindowUpdate Window
+                    deriving (Show, Typeable)
 
 instance WidgetClass Taskbar where
   type WidgetData Taskbar = TaskbarState
   
   initWidget (Taskbar _) phi dispvar = do
-    return TaskbarState
+    forkIO $ taskbarRunner phi dispvar
+    
+    return $ TaskbarState 0 0 [] M.empty
 
     
   minSize _ = 0
   weight _ = 1
   
-  render (Taskbar config) _ w h = do
-    return ()
+  render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do
+    let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
+        windowCount = sum $ map (length . snd) $ desktopWindows
+    when (windowCount /= 0) $ do
+      let windowWidth = min (taskMaxSize config) (w `div` windowCount)
+      
+      forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
+        let border = if window == activeWindow then activeTaskBorder config else taskBorder config
+        drawBorder border (i*windowWidth) 0 windowWidth h
+  
+  handleMessage _ priv m = case (fromMessage m) of
+    Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates}
+    Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
+    Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
+    _ -> priv
+
+
+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
+    desktopCount <- getDesktopCount disp (getAtoms dispvar) 
+    activeWindow <- getActiveWindow disp (getAtoms dispvar) 
+    sendMessage phi $ WindowListUpdate windows tasks
+    sendMessage phi $ DesktopCountUpdate desktopCount
+    sendMessage phi $ ActiveWindowUpdate activeWindow
+    return (windows, tasks)
+  sendMessage phi Repaint
+  
+  flip evalStateT (windows, tasks) $ 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 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_NAME
+                                  , atomWM_NAME
+                                  , atom_NET_WM_DESKTOP
+                                  , atom_NET_WM_STATE
+                                  ]) $ withDisplay dispvar $ \disp -> do
+    let rootwin = Xlib.defaultRootWindow disp
+    if (window == rootwin)
+      then do
+      when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
+        activeWindow <- liftIO $ getActiveWindow disp atoms
+        sendMessage phi $ ActiveWindowUpdate activeWindow
+        sendMessage phi Repaint
+      when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
+        desktopCount <- liftIO $ getDesktopCount disp atoms
+        sendMessage phi $ DesktopCountUpdate desktopCount
+        sendMessage phi Repaint
+      when (atom == atom_NET_CLIENT_LIST atoms) $ do
+        (windows, windowStates) <- get
+        (windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates
+        
+        when (windows /= windows' || windowStates /= windowStates') $ do
+          sendMessage phi $ WindowListUpdate windows' windowStates'
+          sendMessage phi Repaint
+          put (windows', windowStates')
+    
+      else do
+      (windows, windowStates) <- 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'
+          sendMessage phi Repaint
+          put (windows, windowStates')
+
+getDesktopCount :: Xlib.Display -> Atoms -> IO Int
+getDesktopCount disp atoms =
+  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
+
+getActiveWindow :: Xlib.Display -> Atoms -> IO Window
+getActiveWindow disp atoms =
+  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
+
+getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
+getWindowStates disp atoms oldWindows windowStates = do
+  windows <- getWindowList disp atoms oldWindows
+  
+  let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
+  
+  newWindowStates <- mapM getWindowState' windowStates'
+  
+  return (windows, M.fromList newWindowStates)
+    where
+      rootwin = Xlib.defaultRootWindow disp
+      
+      getWindowState' (window, Just windowState) = return (window, windowState) 
+      getWindowState' (window, Nothing) = do
+        windowState <- getWindowState disp atoms window
+        return (window, 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
+  wmname <- case netwmname of
+    Just name -> return name
+    Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp (atomWM_NAME atoms) window
+  
+  workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
+  
+  visible <- showWindow disp atoms window
+  
+  return $ WindowState wmname workspace visible
+    where
+      unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
+
+showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
+showWindow disp atoms window = do
+  states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
+  transientForHint <- XExtras.getTransientForHint disp window
+  windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
+  
+  return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states 
+                    , transientForHint /= Nothing
+                    , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK 
+                                                      , atom_NET_WM_WINDOW_TYPE_DESKTOP 
+                                                      , atom_NET_WM_WINDOW_TYPE_TOOLBAR 
+                                                      , atom_NET_WM_WINDOW_TYPE_MENU 
+                                                      , atom_NET_WM_WINDOW_TYPE_SPLASH
+                                                      ]
+                    ]
+  
+
+getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
+getWindowList disp atoms windows = do
+  newWindows <- liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
+  return $ (filter (flip elem newWindows) windows) ++ (filter (not . flip elem windows) newWindows)
+
 
 taskbar :: TaskbarConfig -> Widget
 taskbar config = do