Some more work on the taskbar

6 files changed, 269 insertions, 70 deletions

diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 1994724..0576f27 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -4,6 +4,8 @@ module Phi.Border ( BorderWidth(..)
                   , simpleBorderWidth
                   , BorderConfig(..)
                   , defaultBorderConfig
+                  , drawBorder
+                  , roundRectangle
                   , border
                   ) where
 
@@ -76,41 +78,46 @@ instance WidgetClass Border where
       height' = height - borderV m - 2*bw - borderV p
 
   render (Border config _) (BorderState widgetStates) w h = do
-    newPath
-    arc (x + width - radius) (y + radius) radius (-pi/2) 0
-    arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
-    arc (x + radius) (y + height - radius) radius (pi/2) pi
-    arc (x + radius) (y + radius) radius  pi (pi*3/2)
-    closePath
-    
-    save
-    setSourceRGBA fr fg fb fa
-    fillPreserve
-    
-    setSourceRGBA br bg bb ba
-    setLineWidth $ fromIntegral bw
-    strokePreserve
-    restore
-    
+    drawBorder config 0 0 w h
     clip
     renderWidgets widgetStates
     
-      where
-        m = margin config
-        bw = borderWidth config
-        p = padding config
-        radius = cornerRadius config
-        
-        x = (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
-        y = (fromIntegral $ borderTop m) + (fromIntegral bw)/2
-        width = fromIntegral $ w - borderH m - bw
-        height = fromIntegral $ h - borderV m - bw
-        
-        (br, bg, bb, ba) = borderColor config
-        (fr, fg, fb, fa) = backgroundColor config
-  
   handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
-    
+
+drawBorder :: BorderConfig -> Int -> Int -> Int -> Int -> Render ()
+drawBorder config dx dy w h = do
+  roundRectangle x y width height radius
+  
+  save
+  setSourceRGBA fr fg fb fa
+  fillPreserve
+  
+  setSourceRGBA br bg bb ba
+  setLineWidth $ fromIntegral bw
+  strokePreserve
+  restore
+    where
+      m = margin config
+      bw = borderWidth config
+      p = padding config
+      radius = cornerRadius config
+      
+      x = (fromIntegral dx) + (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
+      y = (fromIntegral dy) + (fromIntegral $ borderTop m) + (fromIntegral bw)/2
+      width = fromIntegral $ w - borderH m - bw
+      height = fromIntegral $ h - borderV m - bw
+      
+      (br, bg, bb, ba) = borderColor config
+      (fr, fg, fb, fa) = backgroundColor config
+
+roundRectangle :: Double -> Double -> Double -> Double -> Double -> Render ()
+roundRectangle x y width height radius = do
+  newPath
+  arc (x + width - radius) (y + radius) radius (-pi/2) 0
+  arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
+  arc (x + radius) (y + height - radius) radius (pi/2) pi
+  arc (x + radius) (y + radius) radius  pi (pi*3/2)
+  closePath
 
 border :: BorderConfig -> [Widget] -> Widget
 border config widgets = Widget $ Border config widgets
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index b517de6..3f4b59b 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -12,6 +12,8 @@ module Phi.Phi ( Phi
 
 import Control.Concurrent.Chan
 import Control.Monad
+import Control.Monad.IO.Class
+
 import Data.Typeable
 
 data Phi = Phi (Chan Message)
@@ -24,14 +26,14 @@ data DefaultMessage = Repaint deriving (Typeable, Show)
 fromMessage :: (Typeable a, Show a) => Message -> Maybe a
 fromMessage (Message m) = cast m
 
-initPhi :: IO Phi
-initPhi = liftM Phi newChan
+initPhi :: MonadIO m => m Phi
+initPhi = liftM Phi $ liftIO newChan
 
-dupPhi :: Phi -> IO Phi
-dupPhi (Phi chan) = liftM Phi $ dupChan chan
+dupPhi :: MonadIO m => Phi -> m Phi
+dupPhi (Phi chan) = liftM Phi $ liftIO $ dupChan chan
 
-sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
-sendMessage (Phi chan) = writeChan chan . Message
+sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
+sendMessage (Phi chan) = liftIO . writeChan chan . Message
 
-receiveMessage :: Phi -> IO Message
-receiveMessage (Phi chan) = readChan chan
+receiveMessage :: MonadIO m => Phi -> m Message
+receiveMessage (Phi chan) = liftIO $ readChan chan
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 9534c8c..218dea1 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -2,6 +2,7 @@
 
 module Phi.Widget ( Display(..)
                   , withDisplay
+                  , getAtoms
                   , Widget(..)
                   , WidgetClass(..)
                   , WidgetState(..)
@@ -14,6 +15,7 @@ module Phi.Widget ( Display(..)
 
 import Control.Concurrent.MVar
 import Control.Monad
+import Control.Monad.IO.Class
 
 import Data.Traversable
 
@@ -21,17 +23,21 @@ import qualified Graphics.X11.Xlib
 import Graphics.Rendering.Cairo
 
 import Phi.Phi
+import Phi.X11.Atoms
 
 
-newtype Display = Display (MVar Graphics.X11.Xlib.Display)
+data Display = Display (MVar Graphics.X11.Xlib.Display) Atoms
 
-withDisplay :: Display -> (Graphics.X11.Xlib.Display -> IO a) -> IO a
-withDisplay (Display dispvar) f = do
-  disp <- takeMVar dispvar
+withDisplay :: MonadIO m => Display -> (Graphics.X11.Xlib.Display -> m a) -> m a
+withDisplay (Display dispvar _) f = do
+  disp <- liftIO $ takeMVar dispvar
   a <- f disp
-  putMVar dispvar disp
+  liftIO $ putMVar dispvar disp
   return a
 
+getAtoms :: Display -> Atoms
+getAtoms (Display _ atoms) = atoms
+
 
 class Show a => WidgetClass a where
   type WidgetData a :: *
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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 4332352..8d037a8 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -31,6 +31,7 @@ import qualified Phi.Widget as Widget
 import Phi.X11.Atoms
 import qualified Phi.Bindings.Util as Util
 
+
 data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
                        }
 
@@ -63,13 +64,6 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
 runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
 runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 
-withDisplayX :: Widget.Display -> (Display -> PhiX a) -> PhiX a
-withDisplayX (Widget.Display dispvar) f = do
-  disp <- liftIO $ takeMVar dispvar
-  a <- f disp
-  liftIO $ putMVar dispvar disp
-  return a
-
 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
 
@@ -88,10 +82,11 @@ runPhi xconfig config widgets = do
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
     
-    dispvar <- liftM Widget.Display $ liftIO $ newMVar disp
+    dispmvar <- liftIO $ newMVar disp
+    let dispvar = Widget.Display dispmvar atoms
     widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
     
-    withDisplayX dispvar $ \disp -> do
+    Widget.withDisplay dispvar $ \disp -> do
       panels <- mapM (createPanel disp widgetStates) screens
       
       forM_ panels $ \panel -> do
@@ -105,7 +100,7 @@ runPhi xconfig config widgets = do
     liftIO $ forkIO $ receiveEvents phi dispvar
 
     forever $ do
-      message <- liftIO $ receiveMessage phi
+      message <- receiveMessage phi
       handleMessage dispvar message
   return ()
 
@@ -120,13 +115,13 @@ handleMessage dispvar m = do
   modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
   
   case (fromMessage m) of
-    Just Repaint -> withDisplayX dispvar $ \disp ->
+    Just Repaint -> Widget.withDisplay dispvar $ \disp ->
       updatePanels disp True
     _ ->
       case (fromMessage m) of
-        Just ExposeEvent {} -> withDisplayX dispvar $ \disp ->
+        Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp ->
           updatePanels disp False
-        Just event@PropertyEvent {} -> withDisplayX dispvar $ \disp ->
+        Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp ->
           handlePropertyUpdate disp event
         _ ->
           return ()
@@ -206,8 +201,8 @@ updateRootImage disp = do
   let screen = defaultScreen disp
       visual = defaultVisual disp screen
       rootwin = defaultRootWindow disp
-  pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
-            \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
+  pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
+            \atom -> liftIO $ getWindowProperty32 disp atom rootwin
   (_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
   
   -- update surface size
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index 258c89a..d1abb24 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -2,9 +2,15 @@ module Phi.X11.AtomList ( atoms
                         ) where
 
 atoms = [ "UTF8_STRING"
+        , "WM_NAME"
         , "_NET_WM_NAME"
         , "_NET_WM_WINDOW_TYPE"
+        , "_NET_WM_WINDOW_TYPE_NORMAL"
         , "_NET_WM_WINDOW_TYPE_DOCK"
+        , "_NET_WM_WINDOW_TYPE_DESKTOP"
+        , "_NET_WM_WINDOW_TYPE_TOOLBAR"
+        , "_NET_WM_WINDOW_TYPE_MENU"
+        , "_NET_WM_WINDOW_TYPE_SPLASH"
         , "_NET_WM_DESKTOP"
         , "_NET_WM_STATE"
         , "_NET_WM_STATE_SKIP_PAGER"
@@ -13,6 +19,9 @@ atoms = [ "UTF8_STRING"
         , "_NET_WM_STATE_BELOW"
         , "_NET_WM_STRUT"
         , "_NET_WM_STRUT_PARTIAL"
+        , "_NET_ACTIVE_WINDOW"
+        , "_NET_NUMBER_OF_DESKTOPS"
+        , "_NET_CLIENT_LIST"
         , "_MOTIF_WM_HINTS"
         , "_XROOTPMAP_ID"
         , "_XROOTMAP_ID"