From 4d519acbd48fa400f09e4705251a0dbf45c6876e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 19:15:23 +0200 Subject: Core is independent of X11 now --- lib/Phi/Widgets/AlphaBox.hs | 8 +- lib/Phi/Widgets/Clock.hs | 8 +- lib/Phi/Widgets/Systray.hs | 294 ------------------- lib/Phi/Widgets/Taskbar.hs | 641 ---------------------------------------- lib/Phi/Widgets/X11/Systray.hs | 294 +++++++++++++++++++ lib/Phi/Widgets/X11/Taskbar.hs | 649 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 951 insertions(+), 943 deletions(-) delete mode 100644 lib/Phi/Widgets/Systray.hs delete mode 100644 lib/Phi/Widgets/Taskbar.hs create mode 100644 lib/Phi/Widgets/X11/Systray.hs create mode 100644 lib/Phi/Widgets/X11/Taskbar.hs (limited to 'lib/Phi/Widgets') diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index 6f989ea..59f8aea 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -13,11 +13,11 @@ import Control.Monad.State.Strict import Graphics.Rendering.Cairo -data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +data AlphaBox w s c d = (Widget w s c d) => AlphaBox !Double !w -data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c +data AlphaBoxCache w s c d = (Widget w s c d) => AlphaBoxCache !c -instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where +instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d) d where initWidget (AlphaBox _ w) = initWidget w initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w @@ -47,6 +47,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where handleMessage (AlphaBox _ w) = handleMessage w -alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c +alphaBox :: (Widget w s c d) => Double -> w -> AlphaBox w s c d alphaBox = AlphaBox diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 9282432..26b777f 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 -data Clock = Clock !ClockConfig deriving (Show, Eq) +data Clock d = Clock !ClockConfig deriving (Show, Eq) deriving instance Eq ZonedTime @@ -42,7 +42,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) -instance Widget Clock ClockState (RenderCache ClockState) where +instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where initWidget (Clock _) phi _ _ = do forkIO $ forever $ do time <- getZonedTime @@ -85,6 +85,6 @@ instance Widget Clock ClockState (RenderCache ClockState) where _ -> priv -clock :: ClockConfig -> Clock +clock :: ClockConfig -> Clock d clock config = do - Clock config \ No newline at end of file + Clock config diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs deleted file mode 100644 index 27a5e34..0000000 --- a/lib/Phi/Widgets/Systray.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} - -module Phi.Widgets.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/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs deleted file mode 100644 index f0a8196..0000000 --- a/lib/Phi/Widgets/Taskbar.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} - -module Phi.Widgets.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.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) 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 $ "" ++ (escapeMarkup text) ++ "" - 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 -> Display -> IO () -taskbarRunner phi dispvar = do - (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do - (windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty - desktopCount <- getDesktopCount disp (getAtoms dispvar) - current <- getCurrentDesktop disp (getAtoms dispvar) - names <- getDesktopNames disp (getAtoms dispvar) - activeWindow <- getActiveWindow disp (getAtoms dispvar) - 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 dispvar event - _ -> - return () - - -handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleEvent phi dispvar event = - case (fromEvent event) of - Just e -> handlePropertyNotifyEvent phi dispvar e - Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent phi dispvar e - Nothing -> return () - -handlePropertyNotifyEvent :: Phi -> Display -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do - let atoms = getAtoms dispvar - - 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 - ]) $ withDisplay dispvar $ \conn -> do - let rootwin = getRoot conn - if (window == rootwin) - then do - when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do - activeWindow <- liftIO $ getActiveWindow conn atoms - sendMessage phi $ ActiveWindowUpdate activeWindow - sendMessage phi Repaint - when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do - desktopCount <- liftIO $ getDesktopCount conn atoms - sendMessage phi $ DesktopCountUpdate desktopCount - sendMessage phi Repaint - when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do - current <- liftIO $ getCurrentDesktop conn atoms - sendMessage phi $ CurrentDesktopUpdate current - sendMessage phi Repaint - when (atom == atom_NET_DESKTOP_NAMES atoms) $ do - names <- liftIO $ getDesktopNames conn atoms - sendMessage phi $ DesktopNamesUpdate names - sendMessage phi Repaint - when (atom == atom_NET_CLIENT_LIST atoms) $ do - (windows, windowStates) <- get - (windows', windowStates') <- liftIO $ getWindowStates conn atoms 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 conn atoms 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 conn atoms 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 -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do - (windows, windowStates) <- get - when (elem window windows) $ withDisplay dispvar $ \conn -> do - let geom = fmap windowGeometry . M.lookup window $ windowStates - geom' <- liftIO $ getWindowGeometry conn 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 :: Connection -> Atoms -> IO Int -getDesktopCount conn atoms = - liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_NUMBER_OF_DESKTOPS atoms) - -getCurrentDesktop :: Connection -> Atoms -> IO Int -getCurrentDesktop conn atoms = - liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms) - -getDesktopNames :: Connection -> Atoms -> IO [String] -getDesktopNames conn atoms = - liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms) - where - break' l = case dropWhile (== 0) l of - [] -> [] - l' -> w : break' l'' - where (w, l'') = break (== 0) l' - -getActiveWindow :: Connection -> Atoms -> IO WINDOW -getActiveWindow conn atoms = - liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms) - -getWindowStates :: Connection -> Atoms -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) -getWindowStates conn atoms windowStates = do - windows <- getWindowList conn atoms - - 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 conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] - windowState <- getWindowState conn atoms window - return (window, windowState) - -getWindowState :: Connection -> Atoms -> WINDOW -> IO WindowState -getWindowState conn atoms window = do - (name, workspace, visible) <- getWindowInfo conn atoms window - icons <- getWindowIcons conn atoms window - geom <- getWindowGeometry conn window - - return $ WindowState { windowTitle = name - , windowDesktop = workspace - , windowVisible = visible - , windowIcons = icons - , windowGeometry = geom - } - -getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool) -getWindowInfo conn atoms window = do - 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 :: Connection -> Atoms -> WINDOW -> IO [Icon] -getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= 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 :: Connection -> WINDOW -> IO RECTANGLE -getWindowGeometry conn window = - getGeometry conn (fromXid . toXid $ window) >>= getReply >>= return . ((const $ MkRECTANGLE 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> MkRECTANGLE x y width height)) - -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 :: Connection -> Atoms -> IO [WINDOW] -getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms) - -taskbar :: TaskbarConfig -> Taskbar -taskbar = Taskbar 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 $ "" ++ (escapeMarkup text) ++ "" + 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 -- cgit v1.2.3