diff options
Diffstat (limited to 'lib/Phi/Widgets/X11')
| -rw-r--r-- | lib/Phi/Widgets/X11/Systray.hs | 294 | ||||
| -rw-r--r-- | lib/Phi/Widgets/X11/Taskbar.hs | 649 |
2 files changed, 943 insertions, 0 deletions
diff --git a/lib/Phi/Widgets/X11/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs new file mode 100644 index 0000000..fffb181 --- /dev/null +++ b/lib/Phi/Widgets/X11/Systray.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} + +module Phi.Widgets.X11.Systray ( systray + ) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans + +import Data.Bits +import Data.IORef +import Data.Maybe +import Data.Typeable +import qualified Data.Map as M + +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Types + +import Graphics.X11.Xlib hiding (Display) +import qualified Graphics.X11.Xlib as Xlib +import Graphics.X11.Xlib.Extras + +import Phi.Bindings.Util +import Phi.Bindings.SystrayErrorHandler + +import Phi.Phi +import Phi.Types +import Phi.Widget +import Phi.X11.Atoms + + +data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq) + +instance Eq Phi where + _ == _ = True + +data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq + +data Systray = Systray deriving (Show, Eq) + +data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int + deriving (Show, Typeable) + + +instance Widget Systray SystrayState (RenderCache SystrayState) where + initWidget (Systray) phi dispvar screens = do + phi' <- dupPhi phi + forkIO $ systrayRunner phi' dispvar $ snd . head $ screens + + return $ SystrayState phi (fst . head $ screens) 0 [] + + initCache _ = createRenderCache $ \(SystrayState phi systrayScreen reset icons) x y w h screen -> do + when (screen == systrayScreen) $ do + forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do + let x' = x + i*(h+2) + sendMessage phi $ RenderIcon midParent window x' y h h + + setOperator OperatorClear + paint + + minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of + _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1 + | otherwise -> 0 + + weight _ = 0 + + render _ = renderCached + + + handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of + Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons) + Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons + _ -> case (fromMessage m) of + Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons + _ -> case (fromMessage m) of + Just ResetBackground -> SystrayState phi screen (reset+1) icons + _ -> priv + + +systrayRunner :: Phi -> Display -> Window -> IO () +systrayRunner phi dispvar panelWindow = do + let atoms = getAtoms dispvar + initSuccess <- withDisplay dispvar $ flip initSystray atoms + + case initSuccess of + Just xembedWindow -> flip evalStateT M.empty $ do + sendMessage phi HoldShutdown + + forever $ do + m <- receiveMessage phi + case (fromMessage m) of + Just event -> + handleEvent event phi dispvar panelWindow xembedWindow + _ -> + case (fromMessage m) of + Just (RenderIcon midParent window x y w h) -> do + withDisplay dispvar $ \disp -> do + liftIO $ flip catch (\_ -> return ()) $ do + sync disp False + setSystrayErrorHandler + + (_, x', y', w', h', _, _) <- getGeometry disp midParent + (_, x'', y'', w'', h'', _, _) <- getGeometry disp window + let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h' + || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h'' + + when resize $ do + moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h) + sync disp False + + clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True + + sync disp False + xSetErrorHandler + + lastErrorWindow <- liftIO $ getLastErrorWindow + when (lastErrorWindow == window) $ do + removeIcon phi disp True window + _ -> + case (fromMessage m) of + Just Shutdown -> do + windows <- gets M.keys + withDisplay dispvar $ \disp -> do + mapM_ (removeIcon phi disp True) windows + liftIO $ do + destroyWindow disp xembedWindow + sync disp False + sendMessage phi ReleaseShutdown + _ -> + return () + Nothing -> + return () + + +initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window) +initSystray disp atoms = do + currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms + + if currentSystrayWin /= 0 then do + pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $ + getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin + + putStrLn $ "Phi: another systray is running." ++ pid + + return Nothing + else do + xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0 + + -- orient horizontally + changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0] + + -- set visual + let rootwin = defaultRootWindow disp + screen = defaultScreen disp + visual = defaultVisual disp screen + visualID = visualIDFromVisual visual + changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID] + + xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime + systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms + if systrayWin /= xembedWin then do + destroyWindow disp xembedWin + putStrLn $ "Phi: can't initialize systray." + return Nothing + + else do + allocaXEvent $ \event -> do + putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0] + sendEvent disp rootwin False structureNotifyMask event + + return $ Just xembedWin + + +sYSTEM_TRAY_REQUEST_DOCK :: CInt +sYSTEM_TRAY_REQUEST_DOCK = 0 + +sYSTEM_TRAY_BEGIN_MESSAGE :: CInt +sYSTEM_TRAY_BEGIN_MESSAGE = 1 + +sYSTEM_TRAY_CANCEL_MESSAGE :: CInt +sYSTEM_TRAY_CANCEL_MESSAGE = 2 + +xEMBED_EMBEDDED_NOTIFY :: CInt +xEMBED_EMBEDDED_NOTIFY = 0 + +handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO () +handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do + let atoms = getAtoms dispvar + when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do + case messageData of + _:opcode:iconID:_ -> do + case True of + _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do + when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ fromIntegral iconID + + | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> + return () + + | otherwise -> do + liftIO $ putStrLn "Phi: unknown tray message" + return () + + + _ -> + return () + +handleEvent message@UnmapEvent { ev_window = window } phi dispvar panelWindow xembedWindow = + withDisplay dispvar $ \disp -> removeIcon phi disp True window + +handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow = + withDisplay dispvar $ \disp -> removeIcon phi disp False window + +handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow xembedWindow | ev_event_type message == reparentNotify = do + parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do + status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr + case status of + 0 -> + return 0 + _ -> do + childrenPtr <- peek childrenPtrPtr + when (childrenPtr /= nullPtr) $ + xFree childrenPtr >> return () + peek parentPtr + midParent <- gets $ M.lookup window + when (midParent /= Just parent) $ + withDisplay dispvar $ \disp -> removeIcon phi disp False window + return () + +handleEvent _ _ _ _ _ = return () + + +addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO () +addIcon phi disp atoms panelWindow window = do + removeIcon phi disp False window + + liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask + + midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0 + + liftIO $ do + setWindowBackgroundPixmap disp midParent 1 -- ParentRelative + + sync disp False + setSystrayErrorHandler + + reparentWindow disp window midParent 0 0 + + mapRaised disp midParent + mapWindow disp window + + allocaXEvent $ \event -> do + putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0] + sendEvent disp window False 0xFFFFFF event + + sync disp False + xSetErrorHandler + + errorWindow <- liftIO $ getLastErrorWindow + case True of + _ | errorWindow /= window -> do + sendMessage phi $ AddIcon midParent window + sendMessage phi Repaint + modify $ M.insert window midParent + | otherwise -> + liftIO $ destroyWindow disp midParent + + +removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO () +removeIcon phi disp reparent window = do + mmidParent <- gets $ M.lookup window + case mmidParent of + Just midParent -> do + sendMessage phi $ RemoveIcon window + sendMessage phi Repaint + liftIO $ do + selectInput disp window $ noEventMask + when reparent $ + reparentWindow disp window (defaultRootWindow disp) 0 0 + destroyWindow disp midParent + sync disp False + modify $ M.delete window + _ -> + return () + + +systray :: Systray +systray = Systray diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs new file mode 100644 index 0000000..07a7292 --- /dev/null +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} + +module Phi.Widgets.X11.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , DesktopStyle(..) + , TaskbarConfig(..) + , defaultTaskbarConfig + , Taskbar + , taskbar + ) where + +import Control.Arrow +import Control.Concurrent +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Trans + +import Data.Array.MArray +import Data.Bits +import Data.Char +import Data.Function +import Data.IORef +import Data.List +import Data.Maybe +import Data.Typeable +import Data.Unique +import Data.Word +import qualified Data.Accessor.Basic as A +import qualified Data.Accessor.Container as AC +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 Graphics.Rendering.Pango.Font + +import Graphics.XHB +import Graphics.XHB.Gen.Xproto + +import Codec.Binary.UTF8.String + +import Phi.Phi +import Phi.Types +import Phi.Border +import Phi.Widget +import Phi.X11 +import Phi.X11.Atoms +import Phi.X11.Util + + +newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () } +instance Eq IconStyle where + _ == _ = True + +idIconStyle :: IconStyle +idIconStyle = IconStyle $ flip withPatternForSurface setSource + +desaturateIconStyle :: Double -> IconStyle +desaturateIconStyle v = IconStyle $ \icon -> do + w <- imageSurfaceGetWidth icon + h <- imageSurfaceGetHeight icon + + renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do + renderWith surface $ do + setOperator OperatorAdd + withPatternForSurface icon setSource + paint + + setSourceRGB 0 0 0 + paint + + setOperator OperatorHslSaturation + setSourceRGBA 0 0 0 (1-v) + paint + + setOperator OperatorDestIn + withPatternForSurface icon setSource + paint + + withPatternForSurface surface setSource + + +downscaled :: Double -> Surface -> Render () +downscaled s surface = do + case True of + _ | s < 0.5 -> do + w <- imageSurfaceGetWidth surface + h <- imageSurfaceGetHeight surface + + renderWithSimilarSurface ContentColorAlpha (ceiling (fromIntegral w*s)) (ceiling (fromIntegral h*s)) $ \surface' -> do + renderWith surface' $ do + scale 0.5 0.5 + downscaled (2*s) surface + paint + withPatternForSurface surface' setSource + + | otherwise -> do + scale s s + withPatternForSurface surface setSource + + +data TaskStyle = TaskStyle { taskFont :: !String + , taskColor :: !Color + , taskBorder :: !BorderConfig + , taskIconStyle :: !IconStyle + } deriving Eq + +data DesktopStyle = DesktopStyle { desktopFont :: !String + , desktopLabelWidth :: !Int + , desktopLabelGap :: !Int + , desktopColor :: !Color + , desktopBorder :: !BorderConfig + } + +data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int + , normalTaskStyle :: !TaskStyle + , activeTaskStyle :: !TaskStyle + , desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle)) + } + +defaultStyle :: TaskStyle +defaultStyle = TaskStyle { taskFont = "Sans 8" + , taskColor = (0, 0, 0, 1) + , taskBorder = defaultBorderConfig { backgroundColor = (0.75, 0.75, 0.75, 1) } + , taskIconStyle = idIconStyle + } + +defaultTaskbarConfig :: TaskbarConfig +defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 + , normalTaskStyle = defaultStyle + , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }} + , desktopStyle = Nothing + } + +data Taskbar = Taskbar TaskbarConfig + +data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle] + , taskbarActiveWindow :: !WINDOW + , taskbarDesktopCount :: !Int + , taskbarCurrentDesktop :: !Int + , taskbarDesktopNames :: ![String] + , taskbarWindows :: ![WINDOW] + , taskbarWindowStates :: !(M.Map WINDOW WindowState) + } deriving Eq + +data Icon = Icon !Unique !Int !Surface +instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b +instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }" + +createIcon :: Int -> Surface -> IO Icon +createIcon size surface = do + id <- newUnique + return $ Icon id size surface + + +data WindowState = WindowState { windowTitle :: !String + , windowDesktop :: !Int + , windowVisible :: !Bool + , windowIcons :: ![Icon] + , windowGeometry :: !Rectangle + } deriving (Eq, Show) + +data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) + , renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface) + } + +createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached +renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached + + +newtype DesktopCache = DesktopCache (IOCache () ()) + +emptyWindowCache :: WindowCache +emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon + , renderWindowCached = createIOCache doRenderWindow + } + +data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache) + , windowCaches :: !(M.Map WINDOW WindowCache) + } + +-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant +liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a +liftT f m = do + s0 <- gets $ A.get f + (a,s1) <- lift $ runStateT m s0 + modify $ A.set f s1 + return a + +liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a +liftIOStateT m = do + s0 <- get + (a,s1) <- liftIO $ runStateT m s0 + put s1 + return a + +cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b +cached t = liftT t . liftIOStateT . runIOCache + +data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) + | DesktopCountUpdate !Int + | CurrentDesktopUpdate !Int + | DesktopNamesUpdate ![String] + | ActiveWindowUpdate !WINDOW + deriving (Typeable, Show) + +instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where + initWidget (Taskbar _) phi dispvar screens = do + phi' <- dupPhi phi + forkIO $ taskbarRunner phi' dispvar + + return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty + + initCache _ = M.empty + + minSize _ _ _ _ = 0 + weight _ = 1 + + render (Taskbar config) TaskbarState { taskbarScreens = screens + , taskbarActiveWindow = activeWindow + , taskbarDesktopCount = desktopCount + , taskbarCurrentDesktop = currentDesktop + , taskbarDesktopNames = desktopNames + , taskbarWindows = windows + , taskbarWindowStates = windowStates + } _ _ w h screen = do + let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens + screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows + desktopNumbers = take desktopCount $ zip [0..] (desktopNames ++ repeat "") + desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop . fst $ 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 + gap d ds = if null (snd $ desktops !! d) then 0 else desktopLabelGap ds + dleftwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} + -> (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) + + dlabelwidth d + gap d ds) $ dstyle d + 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 . fst) desktopNumbers + windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) + + surface <- liftIO $ createImageSurface FormatARGB32 w h + cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get + cache' <- renderWith surface $ flip execStateT cache $ do + lift $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + + flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do + let dstyle' = dstyle (fst desktop) + dx = dleftwidth (fst desktop) + (sum $ map dwidth $ take (fst desktop) [0..]) + nwindows*windowWidth + + case dstyle' of + Just ds -> do + let (r, g, b, a) = desktopColor ds + lift $ do + save + drawBorder (desktopBorder ds) (dx - dleftwidth (fst desktop)) 0 (dwidth (fst desktop) + windowWidth * length desktopWindows) h + clip + + setSourceRGBA r g b a + renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth (fst desktop) - gap (fst desktop) ds)) 0 (dlabelwidth (fst desktop)) h $ snd desktop + + restore + + forM_ (zip [0..] desktopWindows) $ \(i, window) -> do + let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config + h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) + mstate = M.lookup window windowStates + x = dx + i*windowWidth + y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) + + case mstate of + Just state -> do + windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h' + lift $ do + save + translate (fromIntegral $ x - 5) (fromIntegral $ y - 5) + withPatternForSurface windowSurface setSource + paint + restore + + Nothing -> return () + + _ -> return () + + return $ nwindows + length desktopWindows + put cache' + + return [(True, SurfaceSlice 0 surface)] + + + handleMessage _ priv m = case (fromMessage m) of + Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows + , taskbarWindowStates = windowStates + } + Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} + Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} + Just (DesktopNamesUpdate names) -> priv {taskbarDesktopNames = names} + Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} + _ -> case (fromMessage m) of + Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens} + _ -> priv + + +renderText :: String -> Int -> Int -> Int -> Int -> String -> Render () +renderText font x y w h text = do + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout $ "<span font='" ++ font ++ "'>" ++ (escapeMarkup text) ++ "</span>" + layoutSetWidth layout $ Just $ fromIntegral w + layoutSetEllipsize layout EllipsizeEnd + + layoutGetExtents layout + + + moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) + showLayout layout + +renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface +renderWindow state style w h = do + let h' = h - (borderV $ margin $ taskBorder style) + + scaledIcon <- cached createScaledIconCached' (windowIcons state, h') + cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h) + +doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface +doRenderWindow (title, scaledIcon, style, w, h) = do + let (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) + + surface <- createImageSurface FormatARGB32 (w+10) (h+10) + renderWith surface $ do + translate 5 5 + + save + drawBorder (taskBorder style) 0 0 w h + clip + + setSourceRGBA r g b a + renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title + + restore + + case scaledIcon of + Just (Icon _ _ icon) -> do + save + translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style) + withIconStyle (taskIconStyle style) icon + paint + restore + + _ -> return () + + return surface + + +createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon) +createScaledIcon (icons, h) = do + case bestIcon of + Just (Icon _ _ icon) -> do + scaledIcon <- createSimilarSurface icon ContentColorAlpha h h + renderWith scaledIcon $ do + imageW <- imageSurfaceGetWidth icon + imageH <- imageSurfaceGetHeight icon + + let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH) + + case () of + _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2) + | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0 + + downscaled scalef icon + paint + fmap Just $ createIcon h scaledIcon + + _ -> return Nothing + + where + bestIcon = listToMaybe $ sortBy compareIcons icons + compareIcons = flip (compare `on` (\(Icon _ size _) -> size)) + + +windowOnDesktop :: Int -> WindowState -> Bool +windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) + + +taskbarRunner :: Phi -> X11 -> IO () +taskbarRunner phi x11 = do + (windows, states) <- liftIO $ do + (windows, states) <- getWindowStates x11 M.empty + desktopCount <- getDesktopCount x11 + current <- getCurrentDesktop x11 + names <- getDesktopNames x11 + activeWindow <- getActiveWindow x11 + sendMessage phi $ WindowListUpdate windows states + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi $ ActiveWindowUpdate activeWindow + return (windows, states) + sendMessage phi Repaint + + flip evalStateT (windows, states) $ forever $ do + m <- receiveMessage phi + case (fromMessage m) of + Just (XEvent event) -> + handleEvent phi x11 event + _ -> + return () + + +handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleEvent phi x11 event = + case (fromEvent event) of + Just e -> handlePropertyNotifyEvent phi x11 e + Nothing -> case (fromEvent event) of + Just e -> handleConfigureNotifyEvent phi x11 e + Nothing -> return () + +handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do + let atoms = x11Atoms x11 + rootwin = root_SCREEN . x11Screen $ x11 + + when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW + , atom_NET_NUMBER_OF_DESKTOPS + , atom_NET_CURRENT_DESKTOP + , atom_NET_DESKTOP_NAMES + , atom_NET_CLIENT_LIST + , atom_NET_WM_ICON + , atomWM_NAME + , atom_NET_WM_NAME + , atom_NET_WM_DESKTOP + , atom_NET_WM_STATE + ]) $ do + if (window == rootwin) + then do + when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do + activeWindow <- liftIO $ getActiveWindow x11 + sendMessage phi $ ActiveWindowUpdate activeWindow + sendMessage phi Repaint + when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do + desktopCount <- liftIO $ getDesktopCount x11 + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi Repaint + when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do + current <- liftIO $ getCurrentDesktop x11 + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi Repaint + when (atom == atom_NET_DESKTOP_NAMES atoms) $ do + names <- liftIO $ getDesktopNames x11 + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi Repaint + when (atom == atom_NET_CLIENT_LIST atoms) $ do + (windows, windowStates) <- get + (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates + + when (windows /= windows') $ do + sendMessage phi $ WindowListUpdate windows' windowStates' + sendMessage phi Repaint + put (windows', windowStates') + + else do + (windows, windowStates) <- get + when (elem window windows) $ do + case () of + _ | (atom == atom_NET_WM_ICON atoms) -> do + icons <- liftIO $ getWindowIcons x11 window + let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + + | otherwise -> do + (name, desktop, visible) <- liftIO $ getWindowInfo x11 window + let mwindowState = M.lookup window windowStates + case mwindowState of + Just windowState -> do + let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible} + + when (windowState /= windowState') $ do + let windowStates' = M.insert window windowState' windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + Nothing -> + return () + + +handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do + let conn = x11Connection x11 + (windows, windowStates) <- get + when (elem window windows) $ do + let geom = fmap windowGeometry . M.lookup window $ windowStates + geom' <- liftIO $ getWindowGeometry x11 window + when (geom /= (Just geom')) $ do + let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + + +getDesktopCount :: X11 -> IO Int +getDesktopCount x11 = + liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_NUMBER_OF_DESKTOPS . x11Atoms $ x11) + +getCurrentDesktop :: X11 -> IO Int +getCurrentDesktop x11 = + liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11) + +getDesktopNames :: X11 -> IO [String] +getDesktopNames x11 = + liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11) + where + break' l = case dropWhile (== 0) l of + [] -> [] + l' -> w : break' l'' + where (w, l'') = break (== 0) l' + +getActiveWindow :: X11 -> IO WINDOW +getActiveWindow x11 = + liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11) + +getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) +getWindowStates x11 windowStates = do + windows <- getWindowList x11 + + let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows + + newWindowStates <- mapM getWindowState' windowStates' + + return (windows, M.fromList newWindowStates) + where + getWindowState' (window, Just windowState) = return (window, windowState) + getWindowState' (window, Nothing) = do + changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + windowState <- getWindowState x11 window + return (window, windowState) + +getWindowState :: X11 -> WINDOW -> IO WindowState +getWindowState x11 window = do + (name, workspace, visible) <- getWindowInfo x11 window + icons <- getWindowIcons x11 window + geom <- getWindowGeometry x11 window + + return $ WindowState { windowTitle = name + , windowDesktop = workspace + , windowVisible = visible + , windowIcons = icons + , windowGeometry = geom + } + +getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool) +getWindowInfo x11 window = do + let conn = x11Connection x11 + atoms = x11Atoms x11 + netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + wmname <- case netwmname of + Just name -> return name + Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + + workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms) + visible <- showWindow conn atoms window + + return (wmname, workspace, visible) + where + unsignedChr = chr . fromIntegral + +getWindowIcons :: X11 -> WINDOW -> IO [Icon] +getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe [] + + +readIcons :: [Word32] -> IO [Icon] +readIcons (width:height:iconData) = do + if ((fromIntegral $ length iconData) < (width*height)) then return [] else do + let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData + surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) + surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32) + forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e + + surfaceMarkDirty surface + + liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest) + +readIcons _ = return [] + +premultiply :: Word32 -> Word32 +premultiply c = a .|. r .|. g .|. b + where + amask = 0xFF000000 + rmask = 0x00FF0000 + gmask = 0x0000FF00 + bmask = 0x000000FF + + a = c .&. amask + pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask + + r = pm rmask + g = pm gmask + b = pm bmask + + +getWindowGeometry :: X11 -> WINDOW -> IO Rectangle +getWindowGeometry x11 window = + getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>= + return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height))) + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +showWindow :: Connection -> Atoms -> WINDOW -> IO Bool +showWindow conn atoms window = do + states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms) + transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms) + windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $ + getProperty32 conn window (atom_NET_WM_STATE atoms) + + return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states + , transientFor /= [] && transientFor /= [0] + , 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 :: X11 -> IO [WINDOW] +getWindowList x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11) + +taskbar :: TaskbarConfig -> Taskbar +taskbar = Taskbar |