gtk-sni-tray 0.1.2.1 → 0.1.3.0
raw patch · 4 files changed
+166/−68 lines, 4 filesdep +cairodep +gi-cairodep +transformers-base
Dependencies added: cairo, gi-cairo, transformers-base
Files
- app/Main.hs +51/−49
- gtk-sni-tray.cabal +7/−4
- src/StatusNotifier/TransparentWindow.hs +59/−0
- src/StatusNotifier/Tray.hs +49/−15
app/Main.hs view
@@ -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"+ )
gtk-sni-tray.cabal view
@@ -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 <https://github.com/IvanMalison/gtk-sni-tray#readme> 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
+ src/StatusNotifier/TransparentWindow.hs view
@@ -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
src/StatusNotifier/Tray.hs view
@@ -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