diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -14,6 +14,7 @@ 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 @@ -94,14 +95,13 @@ <> value WARNING ) -colorP :: Parser String -colorP = +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" - <> value "#000000" ) expandP :: Parser Bool @@ -142,12 +142,13 @@ -> Int32 -> [Int32] -> Priority - -> String + -> Maybe String -> Bool -> Bool -> Rational -> IO () -buildWindows pos align size padding monitors priority colorString expand startWatcher length = do +buildWindows pos align size padding monitors priority maybeColorString expand + startWatcher length = do Gtk.init Nothing logger <- getLogger "StatusNotifier" saveGlobalLogger $ setLevel priority logger @@ -155,60 +156,61 @@ 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 - } + 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 - } + 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 - } + tray <- + buildTray + TrayParams + { trayClient = client + , trayOrientation = orientation + , trayHost = host + , trayImageSize = Expand + , trayIconExpand = expand + , trayAlignment = align + } window <- Gtk.windowNew Gtk.WindowTypeToplevel setupStrutWindow config window - (Just <$> getColor colorString) >>= - Gtk.widgetOverrideBackgroundColor window [Gtk.StateFlagsNormal] + 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 } + buildWithConfig configBase {strutMonitor = Just monitor} if null monitors - then buildWithConfig configBase - else mapM_ runForMonitor monitors + then buildWithConfig configBase + else mapM_ runForMonitor monitors Gtk.main parser :: Parser (IO ()) @@ -227,6 +229,6 @@ main :: IO () main = join $ execParser $ info (helper <*> versionOption <*> parser) - ( fullDesc - <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray" - ) + ( fullDesc + <> progDesc "Run a standalone StatusNotifierItem/AppIndicator tray" + ) diff --git a/gtk-sni-tray.cabal b/gtk-sni-tray.cabal --- a/gtk-sni-tray.cabal +++ b/gtk-sni-tray.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.27.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: adb49a931647385ff48660ebc0445691dbbdb7a9f13d6bbe6bc65c939dbf1bcf +-- hash: 7df63c6c96e3fca85aa9675c23240c83d4a6deeedfdbd6b0a4ddd1295965abf8 name: gtk-sni-tray -version: 0.1.2.1 +version: 0.1.3.0 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at category: System @@ -18,7 +18,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md @@ -29,6 +28,7 @@ library exposed-modules: + StatusNotifier.TransparentWindow StatusNotifier.Tray other-modules: Paths_gtk_sni_tray @@ -37,11 +37,13 @@ build-depends: base >=4.7 && <5 , bytestring + , cairo , containers , dbus >=1.0.0 && <2.0.0 , directory , enclosed-exceptions >=1.0.0.1 , filepath + , gi-cairo , gi-dbusmenugtk3 , gi-gdk , gi-gdkpixbuf >=2.0.16 @@ -54,6 +56,7 @@ , status-notifier-item >=0.2.2.0 && <0.3.0.0 , text , transformers + , transformers-base >=0.4 , unix pkgconfig-depends: gtk+-3.0 diff --git a/src/StatusNotifier/TransparentWindow.hs b/src/StatusNotifier/TransparentWindow.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/TransparentWindow.hs @@ -0,0 +1,59 @@ +{-# 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 qualified GI.Cairo +import qualified GI.Gdk as Gdk +import qualified GI.Gtk as Gtk +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Internal (Render(runRender)) +import Graphics.Rendering.Cairo.Types (Cairo(Cairo)) + +-- | This function bridges gi-cairo with the hand-written cairo package. It +-- takes a `GI.Cairo.Context` (as it appears in gi-cairo), and a `Render` action +-- (as in the cairo lib), and renders the `Render` action into the given +-- context. +renderWithContext :: GI.Cairo.Context -> Render () -> IO () +renderWithContext ct r = + withManagedPtr ct $ \p -> runReaderT (runRender r) (Cairo (castPtr p)) + +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 + renderWithContext context $ do + setOperator OperatorSource + paint + setOperator OperatorOver + return False diff --git a/src/StatusNotifier/Tray.hs b/src/StatusNotifier/Tray.hs --- a/src/StatusNotifier/Tray.hs +++ b/src/StatusNotifier/Tray.hs @@ -38,6 +38,39 @@ trayLogger :: Priority -> String -> IO () trayLogger = logM "StatusNotifier.Tray" +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] @@ -90,7 +123,7 @@ pathExists <- doesDirectoryExist themePath if pathExists then do - fileNames <- catchAny (getDirectoryContents themePath) (const $ return []) + fileNames <- catchAny (listDirectory themePath) (const $ return []) trayLogger DEBUG $ printf "Found files in theme path %s" (show fileNames) return $ (themePath ) <$> find (isPrefixOf name) fileNames @@ -141,7 +174,7 @@ contextMap <- MV.newMVar Map.empty let getContext name = Map.lookup name <$> MV.readMVar contextMap - showInfo info = (show info { iconPixmaps = [] }) + showInfo info = show info { iconPixmaps = [] } getSize rectangle = case orientation of @@ -190,11 +223,10 @@ image <- Gtk.imageNew lastAllocation <- MV.newMVar Nothing - let setPixbuf rectangle = + let setPixbuf allocation = do - size <- getSize rectangle + size <- getSize allocation - allocation <- Gtk.widgetGetAllocation image actualWidth <- Gdk.getRectangleWidth allocation actualHeight <- Gdk.getRectangleHeight allocation @@ -210,13 +242,7 @@ (show actualHeight) (show requestResize) - if requestResize && actualWidth /= actualHeight - then do - trayLogger DEBUG "Requesting resize" - Gtk.widgetSetSizeRequest image size size - void (Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ - Gtk.widgetQueueResize image >> return False) - else do + when requestResize $ do trayLogger DEBUG "Requesting resize" pixBuf <- getInfo info serviceName >>= getScaledPixBufFromInfo size when (isNothing pixBuf) $ @@ -224,6 +250,14 @@ 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 @@ -281,9 +315,9 @@ (show $ info { iconPixmaps = []}) (show $ length $ iconPixmaps info) - getScaledPixBufFromInfo size info = runMaybeT $ do - pixBuf <- MaybeT $ getPixBufFromInfo size info - MaybeT $ pixbufScaleSimple pixBuf size size InterpTypeBilinear + getScaledPixBufFromInfo size info = + getPixBufFromInfo size info >>= + traverse (scalePixbufToSize size orientation) getPixBufFromInfo size info@ItemInfo { iconName = name