Some more work on the taskbar
This commit is contained in:
parent
c6e57070ab
commit
465d757986
8 changed files with 273 additions and 72 deletions
|
@ -4,6 +4,8 @@ module Phi.Border ( BorderWidth(..)
|
||||||
, simpleBorderWidth
|
, simpleBorderWidth
|
||||||
, BorderConfig(..)
|
, BorderConfig(..)
|
||||||
, defaultBorderConfig
|
, defaultBorderConfig
|
||||||
|
, drawBorder
|
||||||
|
, roundRectangle
|
||||||
, border
|
, border
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -76,41 +78,46 @@ instance WidgetClass Border where
|
||||||
height' = height - borderV m - 2*bw - borderV p
|
height' = height - borderV m - 2*bw - borderV p
|
||||||
|
|
||||||
render (Border config _) (BorderState widgetStates) w h = do
|
render (Border config _) (BorderState widgetStates) w h = do
|
||||||
newPath
|
drawBorder config 0 0 w h
|
||||||
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
|
|
||||||
|
|
||||||
clip
|
clip
|
||||||
renderWidgets widgetStates
|
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
|
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 :: BorderConfig -> [Widget] -> Widget
|
||||||
border config widgets = Widget $ Border config widgets
|
border config widgets = Widget $ Border config widgets
|
||||||
|
|
|
@ -12,6 +12,8 @@ module Phi.Phi ( Phi
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
import Control.Concurrent.Chan
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
|
|
||||||
data Phi = Phi (Chan Message)
|
data Phi = Phi (Chan Message)
|
||||||
|
@ -24,14 +26,14 @@ data DefaultMessage = Repaint deriving (Typeable, Show)
|
||||||
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
|
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
|
||||||
fromMessage (Message m) = cast m
|
fromMessage (Message m) = cast m
|
||||||
|
|
||||||
initPhi :: IO Phi
|
initPhi :: MonadIO m => m Phi
|
||||||
initPhi = liftM Phi newChan
|
initPhi = liftM Phi $ liftIO newChan
|
||||||
|
|
||||||
dupPhi :: Phi -> IO Phi
|
dupPhi :: MonadIO m => Phi -> m Phi
|
||||||
dupPhi (Phi chan) = liftM Phi $ dupChan chan
|
dupPhi (Phi chan) = liftM Phi $ liftIO $ dupChan chan
|
||||||
|
|
||||||
sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
|
sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
|
||||||
sendMessage (Phi chan) = writeChan chan . Message
|
sendMessage (Phi chan) = liftIO . writeChan chan . Message
|
||||||
|
|
||||||
receiveMessage :: Phi -> IO Message
|
receiveMessage :: MonadIO m => Phi -> m Message
|
||||||
receiveMessage (Phi chan) = readChan chan
|
receiveMessage (Phi chan) = liftIO $ readChan chan
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
|
|
||||||
module Phi.Widget ( Display(..)
|
module Phi.Widget ( Display(..)
|
||||||
, withDisplay
|
, withDisplay
|
||||||
|
, getAtoms
|
||||||
, Widget(..)
|
, Widget(..)
|
||||||
, WidgetClass(..)
|
, WidgetClass(..)
|
||||||
, WidgetState(..)
|
, WidgetState(..)
|
||||||
|
@ -14,6 +15,7 @@ module Phi.Widget ( Display(..)
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
|
|
||||||
|
@ -21,17 +23,21 @@ import qualified Graphics.X11.Xlib
|
||||||
import Graphics.Rendering.Cairo
|
import Graphics.Rendering.Cairo
|
||||||
|
|
||||||
import Phi.Phi
|
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 :: MonadIO m => Display -> (Graphics.X11.Xlib.Display -> m a) -> m a
|
||||||
withDisplay (Display dispvar) f = do
|
withDisplay (Display dispvar _) f = do
|
||||||
disp <- takeMVar dispvar
|
disp <- liftIO $ takeMVar dispvar
|
||||||
a <- f disp
|
a <- f disp
|
||||||
putMVar dispvar disp
|
liftIO $ putMVar dispvar disp
|
||||||
return a
|
return a
|
||||||
|
|
||||||
|
getAtoms :: Display -> Atoms
|
||||||
|
getAtoms (Display _ atoms) = atoms
|
||||||
|
|
||||||
|
|
||||||
class Show a => WidgetClass a where
|
class Show a => WidgetClass a where
|
||||||
type WidgetData a :: *
|
type WidgetData a :: *
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
|
||||||
|
|
||||||
module Phi.Widgets.Taskbar ( TaskbarConfig(..)
|
module Phi.Widgets.Taskbar ( TaskbarConfig(..)
|
||||||
, defaultTaskbarConfig
|
, defaultTaskbarConfig
|
||||||
|
@ -7,45 +7,225 @@ module Phi.Widgets.Taskbar ( TaskbarConfig(..)
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.State
|
||||||
|
import Control.Monad.Trans
|
||||||
|
|
||||||
|
import Data.Char
|
||||||
|
import Data.Maybe
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Data.Time.LocalTime
|
import qualified Data.Map as M
|
||||||
import Data.Time.Format
|
|
||||||
|
import Foreign.C.Types
|
||||||
|
|
||||||
import Graphics.Rendering.Cairo
|
import Graphics.Rendering.Cairo
|
||||||
|
|
||||||
import Graphics.Rendering.Pango.Cairo
|
import Graphics.Rendering.Pango.Cairo
|
||||||
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
|
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
|
||||||
import Graphics.Rendering.Pango.Layout
|
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.Phi
|
||||||
import Phi.Types
|
import Phi.Types
|
||||||
|
import Phi.Border
|
||||||
import Phi.Widget
|
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
|
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
|
||||||
|
, showDesktops = False
|
||||||
|
, taskBorder = defaultBorderConfig
|
||||||
|
, activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
|
||||||
|
}
|
||||||
|
|
||||||
data Taskbar = Taskbar TaskbarConfig deriving Show
|
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
|
instance WidgetClass Taskbar where
|
||||||
type WidgetData Taskbar = TaskbarState
|
type WidgetData Taskbar = TaskbarState
|
||||||
|
|
||||||
initWidget (Taskbar _) phi dispvar = do
|
initWidget (Taskbar _) phi dispvar = do
|
||||||
return TaskbarState
|
forkIO $ taskbarRunner phi dispvar
|
||||||
|
|
||||||
|
return $ TaskbarState 0 0 [] M.empty
|
||||||
|
|
||||||
|
|
||||||
minSize _ = 0
|
minSize _ = 0
|
||||||
weight _ = 1
|
weight _ = 1
|
||||||
|
|
||||||
render (Taskbar config) _ w h = do
|
render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do
|
||||||
return ()
|
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 :: TaskbarConfig -> Widget
|
||||||
taskbar config = do
|
taskbar config = do
|
||||||
|
|
|
@ -31,6 +31,7 @@ import qualified Phi.Widget as Widget
|
||||||
import Phi.X11.Atoms
|
import Phi.X11.Atoms
|
||||||
import qualified Phi.Bindings.Util as Util
|
import qualified Phi.Bindings.Util as Util
|
||||||
|
|
||||||
|
|
||||||
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
|
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 :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
|
||||||
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
|
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
|
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -88,10 +82,11 @@ runPhi xconfig config widgets = do
|
||||||
|
|
||||||
screens <- liftIO $ phiXScreenInfo xconfig disp
|
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
|
widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
|
||||||
|
|
||||||
withDisplayX dispvar $ \disp -> do
|
Widget.withDisplay dispvar $ \disp -> do
|
||||||
panels <- mapM (createPanel disp widgetStates) screens
|
panels <- mapM (createPanel disp widgetStates) screens
|
||||||
|
|
||||||
forM_ panels $ \panel -> do
|
forM_ panels $ \panel -> do
|
||||||
|
@ -105,7 +100,7 @@ runPhi xconfig config widgets = do
|
||||||
liftIO $ forkIO $ receiveEvents phi dispvar
|
liftIO $ forkIO $ receiveEvents phi dispvar
|
||||||
|
|
||||||
forever $ do
|
forever $ do
|
||||||
message <- liftIO $ receiveMessage phi
|
message <- receiveMessage phi
|
||||||
handleMessage dispvar message
|
handleMessage dispvar message
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
@ -120,13 +115,13 @@ handleMessage dispvar m = do
|
||||||
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
|
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
|
||||||
|
|
||||||
case (fromMessage m) of
|
case (fromMessage m) of
|
||||||
Just Repaint -> withDisplayX dispvar $ \disp ->
|
Just Repaint -> Widget.withDisplay dispvar $ \disp ->
|
||||||
updatePanels disp True
|
updatePanels disp True
|
||||||
_ ->
|
_ ->
|
||||||
case (fromMessage m) of
|
case (fromMessage m) of
|
||||||
Just ExposeEvent {} -> withDisplayX dispvar $ \disp ->
|
Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp ->
|
||||||
updatePanels disp False
|
updatePanels disp False
|
||||||
Just event@PropertyEvent {} -> withDisplayX dispvar $ \disp ->
|
Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp ->
|
||||||
handlePropertyUpdate disp event
|
handlePropertyUpdate disp event
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
|
@ -206,8 +201,8 @@ updateRootImage disp = do
|
||||||
let screen = defaultScreen disp
|
let screen = defaultScreen disp
|
||||||
visual = defaultVisual disp screen
|
visual = defaultVisual disp screen
|
||||||
rootwin = defaultRootWindow disp
|
rootwin = defaultRootWindow disp
|
||||||
pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
|
pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
|
||||||
\atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
|
\atom -> liftIO $ getWindowProperty32 disp atom rootwin
|
||||||
(_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
|
(_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
|
||||||
|
|
||||||
-- update surface size
|
-- update surface size
|
||||||
|
|
|
@ -2,9 +2,15 @@ module Phi.X11.AtomList ( atoms
|
||||||
) where
|
) where
|
||||||
|
|
||||||
atoms = [ "UTF8_STRING"
|
atoms = [ "UTF8_STRING"
|
||||||
|
, "WM_NAME"
|
||||||
, "_NET_WM_NAME"
|
, "_NET_WM_NAME"
|
||||||
, "_NET_WM_WINDOW_TYPE"
|
, "_NET_WM_WINDOW_TYPE"
|
||||||
|
, "_NET_WM_WINDOW_TYPE_NORMAL"
|
||||||
, "_NET_WM_WINDOW_TYPE_DOCK"
|
, "_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_DESKTOP"
|
||||||
, "_NET_WM_STATE"
|
, "_NET_WM_STATE"
|
||||||
, "_NET_WM_STATE_SKIP_PAGER"
|
, "_NET_WM_STATE_SKIP_PAGER"
|
||||||
|
@ -13,6 +19,9 @@ atoms = [ "UTF8_STRING"
|
||||||
, "_NET_WM_STATE_BELOW"
|
, "_NET_WM_STATE_BELOW"
|
||||||
, "_NET_WM_STRUT"
|
, "_NET_WM_STRUT"
|
||||||
, "_NET_WM_STRUT_PARTIAL"
|
, "_NET_WM_STRUT_PARTIAL"
|
||||||
|
, "_NET_ACTIVE_WINDOW"
|
||||||
|
, "_NET_NUMBER_OF_DESKTOPS"
|
||||||
|
, "_NET_CLIENT_LIST"
|
||||||
, "_MOTIF_WM_HINTS"
|
, "_MOTIF_WM_HINTS"
|
||||||
, "_XROOTPMAP_ID"
|
, "_XROOTPMAP_ID"
|
||||||
, "_XROOTMAP_ID"
|
, "_XROOTMAP_ID"
|
||||||
|
|
|
@ -11,7 +11,7 @@ maintainer: mschiffer@universe-factory.net
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base >= 4, template-haskell, mtl, time, old-locale, X11, cairo, pango
|
build-depends: base >= 4, template-haskell, 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,
|
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||||
Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
||||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
||||||
|
|
|
@ -12,7 +12,9 @@ main = do
|
||||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||||
[theTaskbar, brightBorder [theClock]]
|
[theTaskbar, brightBorder [theClock]]
|
||||||
where
|
where
|
||||||
theTaskbar = taskbar defaultTaskbarConfig
|
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
|
||||||
|
}
|
||||||
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
||||||
, lineSpacing = (-2)
|
, lineSpacing = (-2)
|
||||||
, clockSize = 75
|
, clockSize = 75
|
||||||
|
|
Reference in a new issue