Some more work on the taskbar
This commit is contained in:
parent
c6e57070ab
commit
465d757986
8 changed files with 273 additions and 72 deletions
|
|
@ -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 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
|
||||
|
|
|
|||
Reference in a new issue