gtk-sni-tray-0.1.6.0/0000755000000000000000000000000007346545000012376 5ustar0000000000000000gtk-sni-tray-0.1.6.0/ChangeLog.md0000755000000000000000000000006407346545000014552 0ustar0000000000000000# Changelog for gtk-sni-tray ## Unreleased changes gtk-sni-tray-0.1.6.0/LICENSE0000644000000000000000000000277107346545000013412 0ustar0000000000000000Copyright Author name here (c) 2018 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Author name here nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. gtk-sni-tray-0.1.6.0/README.md0000755000000000000000000000410007346545000013653 0ustar0000000000000000gtk-sni-tray =============== gtk-sni-tray provides a [StatusNotifierHost](https://www.freedesktop.org/wiki/Specifications/StatusNotifierItem/StatusNotifierHost/) widget written using the gtk+3 bindings for haskell provided by [gi-gtk](https://hackage.haskell.org/package/gi-gtk). It also provides a simple standalone executable, `gtk-sni-tray-standalone`, that is configured with command line arguments. This executable will run the aforementioned widget by itself in a strut window, on each monitor for each it is requested. taffybar ---------- It is generally recommeneded that you use this widget through [taffybar](https://github.com/travitch/taffybar) with [this module](https://github.com/travitch/taffybar/blob/master/src/System/Taffybar/Widget/SNITray.hs), which will allow you to combine it with other useful widgets, and will give more flexibility in configuration. StatusNotifierWatcher -------------------------- By default, it is assumed that you are running an isolated StatusNotifierWatcher daemon. [status-notifier-item](https://github.com/IvanMalison/status-notifier-item) provides a StatusNotifierWatcher executable that you can use for this purpose. If you get an error like ``` MethodError {methodErrorName = ErrorName "org.freedesktop.DBus.Error.ServiceUnknown", methodErrorSerial = Serial 7, methodErrorSender = Just (BusName "org.freedesktop.DBus"), methodErrorDestination = Just (BusName ":1.549"), methodErrorBody = [Variant "The name org.kde.StatusNotifierWatcher was not provided by any .service files"]} ``` when you start `gtk-sni-tray-standalone` it is probably because you have not started a StatusNotifierWatcher on your system. You can solve this problem by passing the `--watcher` flag to `gtk-sni-tray-standalone`, but this is not recommeneded, because many SNI processes do not monitor for new watcher processes, and so may not immediately register when this new watcher is started. Installation --------------- Both [`stack`](https://www.haskell.org/cabal/download.html) and [`cabal`](https://www.haskell.org/cabal/download.html) can be used to install gtk-sni-tray. gtk-sni-tray-0.1.6.0/Setup.hs0000644000000000000000000000005607346545000014033 0ustar0000000000000000import Distribution.Simple main = defaultMain gtk-sni-tray-0.1.6.0/app/0000755000000000000000000000000007346545000013156 5ustar0000000000000000gtk-sni-tray-0.1.6.0/app/Main.hs0000644000000000000000000001524107346545000014401 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad import DBus.Client import Data.Int import Data.Maybe import Data.Ratio import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Version (showVersion) import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut import Options.Applicative import qualified StatusNotifier.Host.Service as Host import StatusNotifier.TransparentWindow import StatusNotifier.Tray import System.Log.Logger import System.Posix.Process import Text.Printf import Paths_gtk_sni_tray (version) positionP :: Parser StrutPosition positionP = fromMaybe TopPos <$> optional ( flag' TopPos ( long "top" <> help "Position the bar at the top of the screen" ) <|> flag' BottomPos ( long "bottom" <> help "Position the bar at the bottom of the screen" ) <|> flag' LeftPos ( long "left" <> help "Position the bar on the left side of the screen" ) <|> flag' RightPos ( long "right" <> help "Position the bar on the right side of the screen" )) alignmentP :: Parser StrutAlignment alignmentP = fromMaybe Center <$> optional ( flag' Beginning ( long "beginning" <> help "Use beginning alignment" ) <|> flag' Center ( long "center" <> help "Use center alignment" ) <|> flag' End ( long "end" <> help "Use end alignment" )) sizeP :: Parser Int32 sizeP = option auto ( long "size" <> short 's' <> help "Set the size of the bar" <> value 30 <> metavar "SIZE" ) paddingP :: Parser Int32 paddingP = option auto ( long "padding" <> short 'p' <> help "Set the padding of the bar" <> value 0 <> metavar "PADDING" ) monitorNumberP :: Parser [Int32] monitorNumberP = many $ option auto ( long "monitor" <> short 'm' <> help "Display a tray bar on the given monitor" <> metavar "MONITOR" ) logP :: Parser Priority logP = option auto ( long "log-level" <> short 'l' <> help "Set the log level" <> metavar "LEVEL" <> value WARNING ) colorP :: Parser (Maybe String) colorP = optional $ strOption ( long "color" <> short 'c' <> help "Set the background color of the tray; See https://developer.gnome.org/gdk3/stable/gdk3-RGBA-Colors.html#gdk-rgba-parse for acceptable values" <> metavar "COLOR" ) expandP :: Parser Bool expandP = switch ( long "expand" <> help "Let icons expand into the space allocated to the tray" <> short 'e' ) startWatcherP :: Parser Bool startWatcherP = switch ( long "watcher" <> short 'w' <> help "Start a Watcher to handle SNI registration if one does not exist" ) barLengthP :: Parser Rational barLengthP = option auto ( long "length" <> help "Set the proportion of the screen that the tray bar should occupy -- values are parsed as haskell rationals (e.g. 1 % 2)" <> value 1 ) overlayScaleP :: Parser Rational overlayScaleP = option auto ( long "overlay-scale" <> short 'o' <> help "The proportion of the tray icon's size that should be set for overlay icons." <> value (5 % 7) ) getColor colorString = do rgba <- Gdk.newZeroRGBA colorParsed <- Gdk.rGBAParse rgba (T.pack colorString) unless colorParsed $ do logM "StatusNotifier.Tray" WARNING "Failed to parse provided color" void $ Gdk.rGBAParse rgba "#000000" return rgba buildWindows :: StrutPosition -> StrutAlignment -> Int32 -> Int32 -> [Int32] -> Priority -> Maybe String -> Bool -> Bool -> Rational -> Rational -> IO () buildWindows pos align size padding monitors priority maybeColorString expand startWatcher length overlayScale = do Gtk.init Nothing logger <- getLogger "StatusNotifier" saveGlobalLogger $ setLevel priority logger client <- connectSession logger <- getRootLogger pid <- getProcessID -- Okay to use a forced pattern here because we want to die if this fails anyway Just host <- Host.build Host.defaultParams { Host.dbusClient = Just client , Host.uniqueIdentifier = printf "standalone-%s" $ show pid , Host.startWatcher = startWatcher } let c1 = defaultStrutConfig { strutPosition = pos , strutAlignment = align , strutXPadding = padding , strutYPadding = padding } defaultRatio = ScreenRatio length configBase = case pos of TopPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} BottomPos -> c1 {strutHeight = ExactSize size, strutWidth = defaultRatio} RightPos -> c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} LeftPos -> c1 {strutHeight = defaultRatio, strutWidth = ExactSize size} buildWithConfig config = do let orientation = case strutPosition config of TopPos -> Gtk.OrientationHorizontal BottomPos -> Gtk.OrientationHorizontal _ -> Gtk.OrientationVertical tray <- buildTray TrayParams { trayClient = client , trayOrientation = orientation , trayHost = host , trayImageSize = Expand , trayIconExpand = expand , trayAlignment = align , trayOverlayScale = overlayScale } window <- Gtk.windowNew Gtk.WindowTypeToplevel setupStrutWindow config window maybe (makeWindowTransparent window) (getColor >=> Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal] . Just) maybeColorString Gtk.containerAdd window tray Gtk.widgetShowAll window runForMonitor monitor = buildWithConfig configBase {strutMonitor = Just monitor} if null monitors then buildWithConfig configBase else mapM_ runForMonitor monitors Gtk.main parser :: Parser (IO ()) parser = buildWindows <$> positionP <*> alignmentP <*> sizeP <*> paddingP <*> monitorNumberP <*> logP <*> colorP <*> expandP <*> startWatcherP <*> barLengthP <*> overlayScaleP versionOption :: Parser (a -> a) versionOption = infoOption (printf "gtk-sni-tray-standalone %s" $ showVersion version) ( long "version" <> help "Show the version number of gtk-sni-tray" ) main :: IO () main = join $ execParser $ info (helper <*> versionOption <*> parser) ( fullDesc <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray" ) gtk-sni-tray-0.1.6.0/gtk-sni-tray.cabal0000644000000000000000000000421407346545000015714 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- -- hash: 9ae75bcf04140e891f7319a5d4f55a83c2a0aa11aee489abb939acfb3853eb0d name: gtk-sni-tray version: 0.1.6.0 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at category: System homepage: https://github.com/IvanMalison/gtk-sni-tray#readme bug-reports: https://github.com/IvanMalison/gtk-sni-tray/issues author: Ivan Malison maintainer: IvanMalison@gmail.com copyright: 2018 Ivan Malison license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head type: git location: https://github.com/IvanMalison/gtk-sni-tray library exposed-modules: StatusNotifier.TransparentWindow StatusNotifier.Tray other-modules: Paths_gtk_sni_tray hs-source-dirs: src build-depends: base >=4.7 && <5 , bytestring , containers , dbus >=1.0.0 && <2.0.0 , directory , enclosed-exceptions >=1.0.0.1 , filepath , gi-cairo , gi-cairo-connector , gi-cairo-render , gi-dbusmenugtk3 , gi-gdk , gi-gdkpixbuf >=2.0.16 , gi-glib , gi-gtk >=3.0.21 , gtk-strut >=0.1.2.1 , haskell-gi >=0.21.2 , haskell-gi-base >=0.21.1 , hslogger , status-notifier-item >=0.3.0.1 && <0.4.0.0 , text , transformers , transformers-base >=0.4 , unix pkgconfig-depends: gtk+-3.0 default-language: Haskell2010 executable gtk-sni-tray-standalone main-is: Main.hs other-modules: Paths_gtk_sni_tray hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , dbus >=1.0.0 && <2.0.0 , dbus-hslogger >=0.1.0.1 && <0.2.0.0 , gi-gdk , gi-gtk >=3.0.21 , gtk-sni-tray , gtk-strut , hslogger , optparse-applicative , status-notifier-item >=0.3.0.0 && <0.4.0.0 , text , unix default-language: Haskell2010 gtk-sni-tray-0.1.6.0/src/StatusNotifier/0000755000000000000000000000000007346545000016150 5ustar0000000000000000gtk-sni-tray-0.1.6.0/src/StatusNotifier/TransparentWindow.hs0000644000000000000000000000330507346545000022176 0ustar0000000000000000{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : StatusNotifier.TransparentWindow -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- Make a window transparent. Approach adapted from python code from -- https://stackoverflow.com/questions/3908565/how-to-make-gtk-window-background-transparent/33294727#33294727 ----------------------------------------------------------------------------- module StatusNotifier.TransparentWindow where import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.GI.Base import Foreign.Ptr (castPtr) import GI.Cairo hiding (OperatorOver, OperatorSource) import GI.Cairo.Render import GI.Cairo.Render.Connector import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk makeWindowTransparent :: MonadIO m => Gtk.Window -> m () makeWindowTransparent window = do screen <- Gtk.widgetGetScreen window visual <- Gdk.screenGetRgbaVisual screen Gtk.widgetSetVisual window visual Gtk.setWidgetAppPaintable window True _ <- Gtk.onWidgetDraw window transparentDraw return () transparentDraw :: Gtk.WidgetDrawCallback transparentDraw context = do rGBA <- Gdk.newZeroRGBA Gdk.setRGBAAlpha rGBA 0.0 Gdk.setRGBABlue rGBA 1.0 Gdk.setRGBARed rGBA 1.0 Gdk.setRGBAGreen rGBA 1.0 Gdk.cairoSetSourceRgba context rGBA flip renderWithContext context $ do setOperator OperatorSource paint setOperator OperatorOver return False gtk-sni-tray-0.1.6.0/src/StatusNotifier/Tray.hs0000644000000000000000000004026407346545000017431 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} module StatusNotifier.Tray where import Control.Concurrent.MVar as MV import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import DBus.Client import qualified DBus.Internal.Types as DBusTypes import qualified Data.ByteString as BS import Data.Coerce import Data.Int import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import Data.Ord import qualified Data.Text as T import qualified GI.DbusmenuGtk3.Objects.Menu as DM import qualified GI.GLib as GLib import GI.GLib.Structs.Bytes import qualified GI.Gdk as Gdk import GI.Gdk.Enums import GI.Gdk.Objects.Screen import GI.GdkPixbuf.Enums import GI.GdkPixbuf.Objects.Pixbuf import qualified GI.Gtk as Gtk import GI.Gtk.Flags import GI.Gtk.Objects.IconTheme import Graphics.UI.GIGtkStrut import StatusNotifier.Host.Service import qualified StatusNotifier.Item.Client as IC import System.Directory import System.FilePath import System.Log.Logger import Text.Printf trayLogger :: Priority -> String -> IO () trayLogger = logM "StatusNotifier.Tray" logItemInfo :: ItemInfo -> String -> IO () logItemInfo info message = trayLogger INFO $ printf "%s - %s pixmap count: %s" message (show $ info { iconPixmaps = []}) (show $ length $ iconPixmaps info) getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32) getScaledWidthHeight shouldTargetWidth targetSize width height = let getRatio :: Int32 -> Rational getRatio toScale = fromIntegral targetSize / fromIntegral toScale getOther :: Int32 -> Int32 -> Int32 getOther toScale other = floor $ getRatio toScale * fromIntegral other in if shouldTargetWidth then (targetSize, getOther width height) else (getOther height width, targetSize) scalePixbufToSize :: Int32 -> Gtk.Orientation -> Pixbuf -> IO Pixbuf scalePixbufToSize size orientation pixbuf = do width <- pixbufGetWidth pixbuf height <- pixbufGetHeight pixbuf let warnAndReturnOrig = trayLogger WARNING "Unable to scale pixbuf" >> return pixbuf targetWidth = case orientation of Gtk.OrientationHorizontal -> False _ -> True (scaledWidth, scaledHeight) = getScaledWidthHeight targetWidth size width height trayLogger DEBUG $ printf "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s" (show size) (show width) (show height) (show scaledWidth) (show scaledHeight) trayLogger DEBUG $ printf "targetW: %s, targetH: %s" (show scaledWidth) (show scaledHeight) maybe warnAndReturnOrig return =<< pixbufScaleSimple pixbuf scaledWidth scaledHeight InterpTypeBilinear themeLoadFlags :: [IconLookupFlags] themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] getThemeWithDefaultFallbacks :: String -> IO IconTheme getThemeWithDefaultFallbacks themePath = do themeForIcon <- iconThemeNew defaultTheme <- iconThemeGetDefault _ <- runMaybeT $ do screen <- MaybeT screenGetDefault lift $ iconThemeSetScreen themeForIcon screen filePaths <- iconThemeGetSearchPath defaultTheme iconThemeAppendSearchPath themeForIcon themePath mapM_ (iconThemeAppendSearchPath themeForIcon) filePaths return themeForIcon getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf) getIconPixbufByName size name themePath = do trayLogger DEBUG $ printf "Getting Pixbuf from name for %s" name let nonEmptyThemePath = themePath >>= (\x -> if x == "" then Nothing else Just x) themeForIcon <- maybe iconThemeGetDefault getThemeWithDefaultFallbacks nonEmptyThemePath let panelName = T.pack $ printf "%s-panel" name hasPanelIcon <- iconThemeHasIcon themeForIcon panelName hasIcon <- iconThemeHasIcon themeForIcon name if hasIcon || hasPanelIcon then do let targetName = if hasPanelIcon then panelName else name trayLogger DEBUG $ printf "Found icon %s in theme" name iconThemeLoadIcon themeForIcon targetName size themeLoadFlags else do trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name -- Try to load the icon as a filepath let nameString = T.unpack name fileExists <- doesFileExist nameString maybeFile <- if fileExists then return $ Just nameString else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath sequenceA $ pixbufNewFromFile <$> maybeFile getIconPathFromThemePath :: String -> String -> IO (Maybe String) getIconPathFromThemePath name themePath = if name == "" then return Nothing else do trayLogger DEBUG $ printf "Trying to load icon %s as filepath with theme path %s" name themePath pathExists <- doesDirectoryExist themePath if pathExists then do fileNames <- catchAny (listDirectory themePath) (const $ return []) trayLogger DEBUG $ printf "Found files in theme path %s" (show fileNames) return $ (themePath ) <$> find (isPrefixOf name) fileNames else return Nothing getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO Pixbuf getIconPixbufFromByteString width height byteString = do trayLogger DEBUG "Getting Pixbuf from bytestring" bytes <- bytesNew $ Just byteString let bytesPerPixel = 4 rowStride = width * bytesPerPixel sampleBits = 8 pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride data ItemContext = ItemContext { contextName :: DBusTypes.BusName , contextMenu :: Maybe DM.Menu , contextImage :: Gtk.Image , contextButton :: Gtk.EventBox } data TrayImageSize = Expand | TrayImageSize Int32 data TrayParams = TrayParams { trayHost :: Host , trayClient :: Client , trayOrientation :: Gtk.Orientation , trayImageSize :: TrayImageSize , trayIconExpand :: Bool , trayAlignment :: StrutAlignment , trayOverlayScale :: Rational } buildTray :: TrayParams -> IO Gtk.Box buildTray TrayParams { trayHost = Host { itemInfoMap = getInfoMap , addUpdateHandler = addUHandler , removeUpdateHandler = removeUHandler } , trayClient = client , trayOrientation = orientation , trayImageSize = imageSize , trayIconExpand = shouldExpand , trayAlignment = alignment , trayOverlayScale = overlayScale } = do trayLogger INFO "Building tray" trayBox <- Gtk.boxNew orientation 0 contextMap <- MV.newMVar Map.empty let getContext name = Map.lookup name <$> MV.readMVar contextMap showInfo info = show info { iconPixmaps = [] } getSize rectangle = case orientation of Gtk.OrientationHorizontal -> Gdk.getRectangleHeight rectangle _ -> Gdk.getRectangleWidth rectangle getInfo def name = fromMaybe def . Map.lookup name <$> getInfoMap updateIconFromInfo info@ItemInfo { itemServiceName = name } = getContext name >>= updateIcon where updateIcon Nothing = updateHandler ItemAdded info updateIcon (Just ItemContext { contextImage = image } ) = do size <- case imageSize of TrayImageSize size -> return size Expand -> Gtk.widgetGetAllocation image >>= getSize getScaledPixBufFromInfo size info >>= let handlePixbuf mpbuf = if isJust mpbuf then Gtk.imageSetFromPixbuf image mpbuf else trayLogger WARNING $ printf "Failed to get pixbuf for %s" $ showInfo info in handlePixbuf getTooltipText ItemInfo { itemToolTip = Just (_, _, titleText, fullText )} | titleText == fullText = fullText | titleText == "" = fullText | fullText == "" = titleText | otherwise = printf "%s: %s" titleText fullText getTooltipText _ = "" setTooltipText widget info = Gtk.widgetSetTooltipText widget $ Just $ T.pack $ getTooltipText info updateHandler ItemAdded info@ItemInfo { menuPath = pathForMenu , itemServiceName = serviceName , itemServicePath = servicePath } = do let serviceNameStr = coerce serviceName servicePathStr = coerce servicePath :: String serviceMenuPathStr = coerce <$> pathForMenu logText = printf "Adding widget for %s - %s" serviceNameStr servicePathStr trayLogger INFO logText button <- Gtk.eventBoxNew image <- case imageSize of Expand -> do image <- Gtk.imageNew lastAllocation <- MV.newMVar Nothing let setPixbuf allocation = do size <- getSize allocation actualWidth <- Gdk.getRectangleWidth allocation actualHeight <- Gdk.getRectangleHeight allocation requestResize <- MV.modifyMVar lastAllocation $ \previous -> let thisTime = Just (size, actualWidth, actualHeight) in return (thisTime, thisTime /= previous) trayLogger DEBUG $ printf "Allocating image size %s, width %s, \ \ height %s, resize %s" (show size) (show actualWidth) (show actualHeight) (show requestResize) when requestResize $ do trayLogger DEBUG "Requesting resize" pixBuf <- getInfo info serviceName >>= getScaledPixBufFromInfo size when (isNothing pixBuf) $ trayLogger WARNING $ printf "Got null pixbuf for info %s" $ showInfo info Gtk.imageSetFromPixbuf image pixBuf void $ traverse (\pb -> do width <- pixbufGetWidth pb height <- pixbufGetHeight pb Gtk.widgetSetSizeRequest image width height) pixBuf void (Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ Gtk.widgetQueueResize image >> return False) _ <- Gtk.onWidgetSizeAllocate image setPixbuf return image TrayImageSize size -> do pixBuf <- getScaledPixBufFromInfo size info Gtk.imageNewFromPixbuf pixBuf Gtk.widgetGetStyleContext image >>= flip Gtk.styleContextAddClass "tray-icon-image" Gtk.containerAdd button image setTooltipText button info maybeMenu <- sequenceA $ DM.menuNew (T.pack serviceNameStr) . T.pack <$> serviceMenuPathStr let context = ItemContext { contextName = serviceName , contextMenu = maybeMenu , contextImage = image , contextButton = button } popupItemForMenu menu = Gtk.menuPopupAtWidget menu image GravitySouthWest GravityNorthWest Nothing popupItemMenu = maybe activateItem popupItemForMenu maybeMenu >> return False activateItem = void $ IC.activate client serviceName servicePath 0 0 _ <- Gtk.onWidgetButtonPressEvent button $ const popupItemMenu MV.modifyMVar_ contextMap $ return . Map.insert serviceName context Gtk.widgetShowAll button let packFn = case alignment of End -> Gtk.boxPackEnd _ -> Gtk.boxPackStart packFn trayBox button shouldExpand True 0 updateHandler ItemRemoved ItemInfo { itemServiceName = name } = getContext name >>= removeWidget where removeWidget Nothing = trayLogger INFO "Attempt to remove widget with unrecognized service name." removeWidget (Just ItemContext { contextButton = widgetToRemove }) = do Gtk.containerRemove trayBox widgetToRemove MV.modifyMVar_ contextMap $ return . Map.delete name updateHandler IconUpdated i = updateIconFromInfo i updateHandler OverlayIconUpdated i = updateIconFromInfo i updateHandler ToolTipUpdated info@ItemInfo { itemServiceName = name } = void $ getContext name >>= traverse (flip setTooltipText info . contextButton) updateHandler _ _ = return () maybeAddOverlayToPixbuf size info pixbuf = do runMaybeT $ do let overlayHeight = floor (fromIntegral size * overlayScale) overlayPixbuf <- MaybeT $ getOverlayPixBufFromInfo overlayHeight info >>= traverse (scalePixbufToSize overlayHeight Gtk.OrientationHorizontal) lift $ do actualOHeight <- getPixbufHeight overlayPixbuf actualOWidth <- getPixbufWidth overlayPixbuf mainHeight <- getPixbufHeight pixbuf mainWidth <- getPixbufWidth pixbuf pixbufComposite overlayPixbuf pixbuf 0 0 -- Top left corner actualOWidth actualOHeight -- Overlay size 0 0 -- Offset 1.0 1.0 -- Scale InterpTypeBilinear -- InterpType 255 -- Source image alpha return pixbuf getScaledPixBufFromInfo size info = getPixBufFromInfo size info >>= traverse (scalePixbufToSize size orientation >=> maybeAddOverlayToPixbuf size info) getPixBufFromInfo size info@ItemInfo { iconName = name , iconThemePath = mpath , iconPixmaps = pixmaps } = getPixBufFrom size name mpath pixmaps getOverlayPixBufFromInfo size info@ItemInfo { overlayIconName = name , iconThemePath = mpath , overlayIconPixmaps = pixmaps } = getPixBufFrom size (fromMaybe "" name) mpath pixmaps getPixBufFrom size name mpath pixmaps = do let tooSmall (w, h, _) = w < size || h < size largeEnough = filter (not . tooSmall) pixmaps orderer (w1, h1, _) (w2, h2, _) = case comparing id w1 w2 of EQ -> comparing id h1 h2 a -> a selectedPixmap = if null largeEnough then maximumBy orderer pixmaps else minimumBy orderer largeEnough getFromPixmaps (w, h, p) = if BS.length p == 0 then Nothing else Just $ getIconPixbufFromByteString w h p if null pixmaps then getIconPixbufByName size (T.pack name) mpath else sequenceA $ getFromPixmaps selectedPixmap uiUpdateHandler updateType info = void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ updateHandler updateType info >> return False handlerId <- addUHandler uiUpdateHandler _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId return trayBox