Taskbar: Sort windows by screen
This commit is contained in:
parent
8854f0aec4
commit
b66d6690d8
6 changed files with 175 additions and 110 deletions
|
|
@ -79,10 +79,10 @@ instance WidgetClass Border where
|
|||
width' = width - borderH m - 2*bw - borderH p
|
||||
height' = height - borderV m - 2*bw - borderV p
|
||||
|
||||
render (Border config _) (BorderState widgetStates) w h = do
|
||||
render (Border config _) (BorderState widgetStates) w h screen = do
|
||||
drawBorder config 0 0 w h
|
||||
clip
|
||||
renderWidgets widgetStates
|
||||
renderWidgets widgetStates screen
|
||||
|
||||
handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
module Phi.Widget ( Display(..)
|
||||
, withDisplay
|
||||
, getAtoms
|
||||
, getScreens
|
||||
, unionArea
|
||||
, Widget(..)
|
||||
, WidgetClass(..)
|
||||
, WidgetState(..)
|
||||
|
|
@ -19,24 +21,42 @@ import Control.Monad.IO.Class
|
|||
|
||||
import Data.Traversable
|
||||
|
||||
import qualified Graphics.X11.Xlib
|
||||
import qualified Graphics.X11.Xlib as Xlib
|
||||
import Graphics.Rendering.Cairo
|
||||
|
||||
import Phi.Phi
|
||||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data Display = Display (MVar Graphics.X11.Xlib.Display) Atoms
|
||||
data Display = Display (MVar Xlib.Display) Atoms [Xlib.Rectangle]
|
||||
|
||||
withDisplay :: MonadIO m => Display -> (Graphics.X11.Xlib.Display -> m a) -> m a
|
||||
withDisplay (Display dispvar _) f = do
|
||||
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
|
||||
withDisplay (Display dispvar _ _) f = do
|
||||
disp <- liftIO $ takeMVar dispvar
|
||||
a <- f disp
|
||||
liftIO $ putMVar dispvar disp
|
||||
return a
|
||||
|
||||
getAtoms :: Display -> Atoms
|
||||
getAtoms (Display _ atoms) = atoms
|
||||
getAtoms (Display _ atoms _) = atoms
|
||||
|
||||
getScreens :: Display -> [Xlib.Rectangle]
|
||||
getScreens (Display _ _ screens) = screens
|
||||
|
||||
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
|
||||
unionArea a b = fromIntegral $ uw*uh
|
||||
where
|
||||
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
||||
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
||||
|
||||
Xlib.Rectangle ax1 ay1 aw ah = a
|
||||
Xlib.Rectangle bx1 by1 bw bh = b
|
||||
|
||||
ax2 = ax1 + fromIntegral aw
|
||||
ay2 = ay1 + fromIntegral ah
|
||||
|
||||
bx2 = bx1 + fromIntegral bw
|
||||
by2 = by1 + fromIntegral bh
|
||||
|
||||
|
||||
class Show a => WidgetClass a where
|
||||
|
|
@ -52,7 +72,7 @@ class Show a => WidgetClass a where
|
|||
layout :: a -> WidgetData a -> Int -> Int -> WidgetData a
|
||||
layout _ priv _ _ = priv
|
||||
|
||||
render :: a -> WidgetData a -> Int -> Int -> Render ()
|
||||
render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> Render ()
|
||||
|
||||
handleMessage :: a -> WidgetData a -> Message -> WidgetData a
|
||||
handleMessage _ priv _ = priv
|
||||
|
|
@ -102,16 +122,16 @@ layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widg
|
|||
nneg :: (Num a, Ord a) => a -> a
|
||||
nneg x = max 0 x
|
||||
|
||||
renderWidgets :: [WidgetState] -> Render ()
|
||||
renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget
|
||||
, stateX = x
|
||||
, stateY = y
|
||||
, stateWidth = w
|
||||
, stateHeight = h
|
||||
, statePrivateData = priv } -> do
|
||||
renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render ()
|
||||
renderWidgets widgets screen = forM_ widgets $ \WidgetState { stateWidget = widget
|
||||
, stateX = x
|
||||
, stateY = y
|
||||
, stateWidth = w
|
||||
, stateHeight = h
|
||||
, statePrivateData = priv } -> do
|
||||
save
|
||||
translate (fromIntegral x) (fromIntegral y)
|
||||
render widget priv w h
|
||||
render widget priv w h screen
|
||||
restore
|
||||
|
||||
handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
|
||||
|
|
@ -127,7 +147,7 @@ instance WidgetClass Separator where
|
|||
|
||||
minSize (Separator s _) = s
|
||||
weight (Separator _ w) = w
|
||||
render _ _ _ _ = return ()
|
||||
render _ _ _ _ _ = return ()
|
||||
|
||||
separator :: Int -> Float -> Widget
|
||||
separator s w = Widget $ Separator s w
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ instance WidgetClass Clock where
|
|||
|
||||
minSize (Clock config ) = clockSize config
|
||||
|
||||
render (Clock config) (ClockState time) w h = do
|
||||
render (Clock config) (ClockState time) w h _ = do
|
||||
time <- liftIO getZonedTime
|
||||
let (r, g, b, a) = fontColor config
|
||||
str = formatTime defaultTimeLocale (clockFormat config) time
|
||||
|
|
|
|||
|
|
@ -122,6 +122,7 @@ data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
|
|||
, taskbarWindows :: ![Window]
|
||||
, taskbarWindowStates :: !(M.Map Window WindowState)
|
||||
, taskbarWindowIcons :: !(M.Map Window [(Int, Surface)])
|
||||
, taskbarWindowScreens :: !(M.Map Window Xlib.Rectangle)
|
||||
} deriving Show
|
||||
|
||||
data WindowState = WindowState { windowTitle :: !String
|
||||
|
|
@ -129,7 +130,7 @@ data WindowState = WindowState { windowTitle :: !String
|
|||
, windowVisible :: !Bool
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)])
|
||||
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)]) (M.Map Window Xlib.Rectangle)
|
||||
| DesktopCountUpdate Int
|
||||
| CurrentDesktopUpdate Int
|
||||
| ActiveWindowUpdate Window
|
||||
|
|
@ -141,7 +142,7 @@ instance WidgetClass Taskbar where
|
|||
initWidget (Taskbar _) phi dispvar = do
|
||||
forkIO $ taskbarRunner phi dispvar
|
||||
|
||||
return $ TaskbarState 0 0 (-1) [] M.empty M.empty
|
||||
return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty
|
||||
|
||||
|
||||
minSize _ = 0
|
||||
|
|
@ -153,9 +154,11 @@ instance WidgetClass Taskbar where
|
|||
, taskbarWindows = windows
|
||||
, taskbarWindowStates = windowStates
|
||||
, taskbarWindowIcons = windowIcons
|
||||
} w h = do
|
||||
let desktopNumbers = take desktopCount [0..]
|
||||
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) desktopNumbers
|
||||
, taskbarWindowScreens = windowScreens
|
||||
} w h screen = do
|
||||
let screenWindows = filter ((== Just screen) . flip M.lookup windowScreens) windows
|
||||
desktopNumbers = take desktopCount [0..]
|
||||
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
|
||||
windowCount = sum $ map (length . snd) $ desktops
|
||||
dstyle d = fmap (if d == currentDesktop then snd else fst) $ desktopStyle config
|
||||
dlabelwidth d = fromMaybe 0 $ fmap desktopLabelWidth $ dstyle d
|
||||
|
|
@ -166,75 +169,73 @@ instance WidgetClass Taskbar where
|
|||
dwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border}
|
||||
-> (borderH $ margin border) + 2*(borderWidth border) + (borderH $ padding border)
|
||||
+ dlabelwidth d + gap d ds) $ dstyle d
|
||||
desktopsWidth = sum $ map dwidth desktopNumbers
|
||||
windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
|
||||
|
||||
when (windowCount /= 0) $ do
|
||||
let desktopsWidth = sum $ map dwidth desktopNumbers
|
||||
windowWidth = min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
|
||||
flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
|
||||
let dstyle' = dstyle desktop
|
||||
dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
|
||||
|
||||
flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
|
||||
let dstyle' = dstyle desktop
|
||||
dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
|
||||
case dstyle' of
|
||||
Just ds -> do
|
||||
let (r, g, b, a) = desktopColor ds
|
||||
save
|
||||
drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
|
||||
clip
|
||||
|
||||
case dstyle' of
|
||||
Just ds -> do
|
||||
let (r, g, b, a) = desktopColor ds
|
||||
setSourceRGBA r g b a
|
||||
renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
|
||||
|
||||
restore
|
||||
_ -> return ()
|
||||
|
||||
forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
|
||||
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
|
||||
(r, g, b, a) = taskColor style
|
||||
leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
|
||||
rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
|
||||
h' = h - (borderV $ margin $ taskBorder style)
|
||||
mstate = M.lookup window windowStates
|
||||
micons = M.lookup window windowIcons
|
||||
x = dx + i*windowWidth
|
||||
|
||||
case (mstate, micons) of
|
||||
(Just state, Just icons) -> do
|
||||
save
|
||||
drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
|
||||
drawBorder (taskBorder style) x 0 windowWidth h
|
||||
clip
|
||||
|
||||
setSourceRGBA r g b a
|
||||
renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
|
||||
renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
|
||||
|
||||
restore
|
||||
|
||||
case bestIcon h' icons of
|
||||
Just icon -> do
|
||||
save
|
||||
translate (fromIntegral $ x + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
|
||||
imageW <- imageSurfaceGetWidth icon
|
||||
imageH <- imageSurfaceGetHeight icon
|
||||
|
||||
let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
|
||||
scale scalef scalef
|
||||
|
||||
when (imageH < imageW) $
|
||||
translate 0 $ (fromIntegral (imageW-imageH))/2
|
||||
|
||||
taskIconStyle style icon
|
||||
paint
|
||||
restore
|
||||
|
||||
Nothing -> return ()
|
||||
|
||||
_ -> return ()
|
||||
|
||||
forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
|
||||
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
|
||||
(r, g, b, a) = taskColor style
|
||||
leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
|
||||
rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
|
||||
h' = h - (borderV $ margin $ taskBorder style)
|
||||
mstate = M.lookup window windowStates
|
||||
micons = M.lookup window windowIcons
|
||||
x = dx + i*windowWidth
|
||||
|
||||
case (mstate, micons) of
|
||||
(Just state, Just icons) -> do
|
||||
save
|
||||
drawBorder (taskBorder style) x 0 windowWidth h
|
||||
clip
|
||||
|
||||
setSourceRGBA r g b a
|
||||
renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
|
||||
|
||||
restore
|
||||
|
||||
case bestIcon h' icons of
|
||||
Just icon -> do
|
||||
save
|
||||
translate (fromIntegral $ x + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
|
||||
imageW <- imageSurfaceGetWidth icon
|
||||
imageH <- imageSurfaceGetHeight icon
|
||||
|
||||
let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
|
||||
scale scalef scalef
|
||||
|
||||
when (imageH < imageW) $
|
||||
translate 0 $ (fromIntegral (imageW-imageH))/2
|
||||
|
||||
taskIconStyle style icon
|
||||
paint
|
||||
restore
|
||||
|
||||
Nothing -> return ()
|
||||
|
||||
_ -> return ()
|
||||
|
||||
return $ nwindows + length desktopWindows
|
||||
return $ nwindows + length desktopWindows
|
||||
|
||||
|
||||
handleMessage _ priv m = case (fromMessage m) of
|
||||
Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons}
|
||||
Just (WindowListUpdate windows windowStates icons screens) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons, taskbarWindowScreens = screens}
|
||||
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
|
||||
Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
|
||||
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
|
||||
|
|
@ -267,29 +268,31 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
|
|||
|
||||
taskbarRunner :: Phi -> Display -> IO ()
|
||||
taskbarRunner phi dispvar = do
|
||||
(windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do
|
||||
(windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty
|
||||
let screens = getScreens dispvar
|
||||
(windows, states, icons, windowScreens) <- liftIO $ withDisplay dispvar $ \disp -> do
|
||||
(windows, states, icons, windowScreens) <- getWindowStates disp screens (getAtoms dispvar) [] M.empty M.empty M.empty
|
||||
desktopCount <- getDesktopCount disp (getAtoms dispvar)
|
||||
current <- getCurrentDesktop disp (getAtoms dispvar)
|
||||
activeWindow <- getActiveWindow disp (getAtoms dispvar)
|
||||
sendMessage phi $ WindowListUpdate windows states icons
|
||||
sendMessage phi $ WindowListUpdate windows states icons windowScreens
|
||||
sendMessage phi $ DesktopCountUpdate desktopCount
|
||||
sendMessage phi $ CurrentDesktopUpdate current
|
||||
sendMessage phi $ ActiveWindowUpdate activeWindow
|
||||
return (windows, states, icons)
|
||||
return (windows, states, icons, windowScreens)
|
||||
sendMessage phi Repaint
|
||||
|
||||
flip evalStateT (windows, states, icons) $ forever $ do
|
||||
flip evalStateT (windows, states, icons, windowScreens) $ forever $ do
|
||||
m <- receiveMessage phi
|
||||
case (fromMessage m) of
|
||||
Just event@XExtras.PropertyEvent {} ->
|
||||
handlePropertyUpdate phi dispvar event
|
||||
Just event ->
|
||||
handleEvent phi dispvar event
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)]) IO ()
|
||||
handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
|
||||
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window Xlib.Rectangle) IO ()
|
||||
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
|
||||
let atoms = getAtoms dispvar
|
||||
let screens = getScreens dispvar
|
||||
|
||||
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
, atom_NET_NUMBER_OF_DESKTOPS
|
||||
|
|
@ -317,23 +320,23 @@ handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom,
|
|||
sendMessage phi $ CurrentDesktopUpdate current
|
||||
sendMessage phi Repaint
|
||||
when (atom == atom_NET_CLIENT_LIST atoms) $ do
|
||||
(windows, windowStates, icons) <- get
|
||||
(windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
|
||||
(windows, windowStates, icons, windowScreens) <- get
|
||||
(windows', windowStates', icons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windows windowStates icons windowScreens
|
||||
|
||||
when (windows /= windows') $ do
|
||||
sendMessage phi $ WindowListUpdate windows' windowStates' icons'
|
||||
sendMessage phi $ WindowListUpdate windows' windowStates' icons' windowScreens'
|
||||
sendMessage phi Repaint
|
||||
put (windows', windowStates', icons')
|
||||
put (windows', windowStates', icons', windowScreens')
|
||||
|
||||
else do
|
||||
(windows, windowStates, icons) <- get
|
||||
(windows, windowStates, icons, windowScreens) <- get
|
||||
when (elem window windows) $ do
|
||||
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 $ WindowListUpdate windows windowStates icons' windowScreens
|
||||
sendMessage phi Repaint
|
||||
put (windows, windowStates, icons')
|
||||
put (windows, windowStates, icons', windowScreens)
|
||||
|
||||
when (atom /= atom_NET_WM_ICON atoms) $ do
|
||||
let windowState = M.lookup window windowStates
|
||||
|
|
@ -341,14 +344,31 @@ handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom,
|
|||
|
||||
when (windowState /= (Just windowState')) $ do
|
||||
let windowStates' = M.insert window windowState' windowStates
|
||||
sendMessage phi $ WindowListUpdate windows windowStates' icons
|
||||
sendMessage phi $ WindowListUpdate windows windowStates' icons windowScreens
|
||||
sendMessage phi Repaint
|
||||
put (windows, windowStates', icons)
|
||||
put (windows, windowStates', icons, windowScreens)
|
||||
|
||||
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
|
||||
let screens = getScreens dispvar
|
||||
|
||||
(windows, windowStates, icons, windowScreens) <- get
|
||||
when (elem window windows) $ withDisplay dispvar $ \disp -> do
|
||||
let screen = M.lookup window windowScreens
|
||||
screen' <- liftIO $ getWindowScreen disp screens window
|
||||
when (screen /= (Just screen')) $ do
|
||||
let windowScreens' = M.insert window screen' windowScreens
|
||||
sendMessage phi $ WindowListUpdate windows windowStates icons windowScreens'
|
||||
sendMessage phi Repaint
|
||||
put (windows, windowStates, icons, windowScreens')
|
||||
|
||||
handleEvent _ _ _ = return ()
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int
|
||||
getCurrentDesktop disp atoms =
|
||||
liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_CURRENT_DESKTOP atoms) $ Xlib.defaultRootWindow disp
|
||||
|
|
@ -357,21 +377,24 @@ 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 -> M.Map Window [(Int, Surface)]
|
||||
-> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)])
|
||||
getWindowStates disp atoms oldWindows windowStates windowIcons = do
|
||||
getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [(Int, Surface)] -> M.Map Window Xlib.Rectangle
|
||||
-> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window Xlib.Rectangle)
|
||||
getWindowStates disp screens atoms oldWindows windowStates windowIcons windowScreens = 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
|
||||
windowScreens' = map (\w -> (w, M.lookup w windowScreens)) windows
|
||||
|
||||
newWindowStates <- mapM getWindowState' windowStates'
|
||||
newWindowIcons <- mapM getWindowIcons' windowIcons'
|
||||
newWindowScreens <- mapM getWindowScreen' windowScreens'
|
||||
|
||||
return (windows, M.fromList newWindowStates, M.fromList newWindowIcons)
|
||||
return (windows, M.fromList newWindowStates, M.fromList newWindowIcons, M.fromList newWindowScreens)
|
||||
where
|
||||
getWindowState' (window, Just windowState) = return (window, windowState)
|
||||
getWindowState' (window, Nothing) = do
|
||||
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
|
||||
windowState <- getWindowState disp atoms window
|
||||
return (window, windowState)
|
||||
|
||||
|
|
@ -380,9 +403,14 @@ getWindowStates disp atoms oldWindows windowStates windowIcons = do
|
|||
icons <- getWindowIcons disp atoms window
|
||||
return (window, icons)
|
||||
|
||||
getWindowScreen' (window, Just screen) = return (window, screen)
|
||||
getWindowScreen' (window, Nothing) = do
|
||||
screen <- getWindowScreen disp screens window
|
||||
return (window, screen)
|
||||
|
||||
|
||||
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
|
||||
|
|
@ -399,6 +427,7 @@ getWindowState disp atoms window = do
|
|||
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)]
|
||||
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
|
||||
|
||||
|
||||
readIcons :: [CLong] -> IO [(Int, Surface)]
|
||||
readIcons (width:height:iconData) = do
|
||||
if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
|
||||
|
|
@ -429,6 +458,21 @@ premultiply c = a .|. r .|. g .|. b
|
|||
g = pm gmask
|
||||
b = pm bmask
|
||||
|
||||
|
||||
getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle
|
||||
getWindowScreen disp screens window = do
|
||||
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
|
||||
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
|
||||
|
||||
case ret of
|
||||
True -> do
|
||||
let windowRect = Xlib.Rectangle x y width height
|
||||
screen = maximumBy (compare `on` unionArea windowRect) screens
|
||||
return screen
|
||||
False ->
|
||||
return $ head screens
|
||||
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ runPhi xconfig config widgets = do
|
|||
screens <- liftIO $ phiXScreenInfo xconfig disp
|
||||
|
||||
dispmvar <- liftIO $ newMVar disp
|
||||
let dispvar = Widget.Display dispmvar atoms
|
||||
let dispvar = Widget.Display dispmvar atoms screens
|
||||
widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
|
||||
|
||||
Widget.withDisplay dispvar $ \disp -> do
|
||||
|
|
@ -172,7 +172,7 @@ updatePanels disp redraw = do
|
|||
setSource pattern
|
||||
paint
|
||||
restore
|
||||
Widget.renderWidgets layoutedWidgets
|
||||
Widget.renderWidgets layoutedWidgets $ panelScreenArea panel
|
||||
|
||||
return panel'
|
||||
|
||||
|
|
|
|||
11
src/Phi.hs
11
src/Phi.hs
|
|
@ -12,15 +12,16 @@ main = do
|
|||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
[theTaskbar, brightBorder [theClock]]
|
||||
where
|
||||
normalTaskBorder = BorderConfig (BorderWidth 2 (-4) 2 7) 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 = normalTaskBorder {borderColor = (1, 1, 1, 0.65), backgroundColor = (0, 0, 0, 0.8)}
|
||||
normalTaskBorder = BorderConfig (BorderWidth 2 (-3) 2 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 1) 5 0
|
||||
activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
|
||||
, backgroundColor = (0, 0, 0, 1)
|
||||
}
|
||||
normalDesktopBorder = normalTaskBorder { margin = BorderWidth 2 3 2 3
|
||||
, padding = BorderWidth 0 2 0 2
|
||||
, borderColor = (0.75, 0.75, 0.75, 0.5)
|
||||
, borderColor = (0.7, 0.7, 0.7, 0.8)
|
||||
, backgroundColor = (1, 1, 1, 0.8)
|
||||
}
|
||||
currentDesktopBorder = normalDesktopBorder { borderColor = (0.75, 0.75, 0.75, 0.8)
|
||||
, backgroundColor = (0.2, 0.2, 0.2, 0.9)
|
||||
currentDesktopBorder = normalDesktopBorder { backgroundColor = (0.2, 0.2, 0.2, 0.8)
|
||||
}
|
||||
taskStyle = TaskStyle { taskFont = "Sans 7"
|
||||
, taskColor = (1, 1, 1, 1)
|
||||
|
|
|
|||
Reference in a new issue