diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,12 @@ ## Unreleased +## 0.2.1.2 - 2026-05-13 +- Clean up compiler warnings in the standalone executable and tray modules. +- Require refreshed companion packages: + `dbus-menu >= 0.1.3.3`, `gtk-scaling-image >= 0.1.0.1`, + `gtk-strut >= 0.1.4.1`, and `status-notifier-item >= 0.3.2.14`. + ## 0.2.1.1 - Require `status-notifier-item >= 0.3.2.13` so tray consumers pick up the diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,21 +1,24 @@ -import Distribution.Simple -import Distribution.Simple.Setup (ConfigFlags(..), fromFlagOrDefault) -import Distribution.Verbosity (Verbosity, normal) -import Distribution.Simple.Utils (die') -import System.Exit (ExitCode(..)) -import System.Process (readProcessWithExitCode) -import Control.Exception (try, IOException) +{-# LANGUAGE TupleSections #-} + +import Control.Exception (IOException, try) import Data.List (intercalate) import Data.Maybe (isJust) +import Distribution.Simple +import Distribution.Simple.Setup (ConfigFlags (..), fromFlagOrDefault) +import Distribution.Simple.Utils (die') +import Distribution.Verbosity (Verbosity, normal) import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) main :: IO () main = - defaultMainWithHooks simpleUserHooks - { confHook = \pkg flags -> do - preflightPkgConfig (fromFlagOrDefault normal (configVerbosity flags)) - confHook simpleUserHooks pkg flags - } + defaultMainWithHooks + simpleUserHooks + { confHook = \pkg flags -> do + preflightPkgConfig (fromFlagOrDefault normal (configVerbosity flags)) + confHook simpleUserHooks pkg flags + } preflightPkgConfig :: Verbosity -> IO () preflightPkgConfig verbosity = do @@ -26,29 +29,32 @@ -- gtk-layer-shell on Wayland, but we don't want to prevent building the -- library when that optional dependency is unavailable. let required = ["gtk+-3.0"] - present <- mapM (\p -> (\ok -> (p, ok)) <$> pkgConfigExists p) required + present <- mapM (\p -> (p,) <$> pkgConfigExists p) required let missing = [p | (p, ok) <- present, not ok] if null missing - then pure () - else do - inDirenv <- isJust <$> lookupEnv "DIRENV_DIR" - let nixHint = - if inDirenv - then "If you just changed Nix inputs, try: `direnv reload`" - else intercalate " " [ "If you're using Nix, enter the dev shell:" - , "`nix develop` (or `direnv allow` + `direnv reload`)." - ] - msg = unlines - [ "Missing system dependencies required via pkg-config:" - , " " ++ intercalate ", " missing - , "" - , "This package needs `pkg-config` to find its C dependencies." - , "If you are building the standalone executable for Wayland, you will also need: gtk-layer-shell-0" - , "" - , nixHint - , "Otherwise, install the development packages for your distro (and pkg-config)." - ] - die' verbosity msg + then pure () + else do + inDirenv <- isJust <$> lookupEnv "DIRENV_DIR" + let nixHint = + if inDirenv + then "If you just changed Nix inputs, try: `direnv reload`" + else + unwords + [ "If you're using Nix, enter the dev shell:", + "`nix develop` (or `direnv allow` + `direnv reload`)." + ] + msg = + unlines + [ "Missing system dependencies required via pkg-config:", + " " ++ intercalate ", " missing, + "", + "This package needs `pkg-config` to find its C dependencies.", + "If you are building the standalone executable for Wayland, you will also need: gtk-layer-shell-0", + "", + nixHint, + "Otherwise, install the development packages for your distro (and pkg-config)." + ] + die' verbosity msg pkgConfigExists :: String -> IO Bool pkgConfigExists name = do diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ module Main where import Control.Monad -import qualified DBus as DBus +import qualified DBus import DBus.Client import Data.Char (toLower) import Data.Int @@ -115,7 +115,9 @@ reserveSpace = do supported <- GtkLayerShell.isSupported unless supported $ - logM "StatusNotifier.StandaloneWindow" WARNING $ + logM + "StatusNotifier.StandaloneWindow" + WARNING "Wayland detected, but gtk-layer-shell is not supported; falling back to a regular toplevel window" when supported $ do Gtk.windowSetDecorated window False @@ -211,7 +213,7 @@ ExactSize h -> h ScreenRatio p -> floor $ p * fromIntegral availableHeight - clampNonNegative x = if x < 0 then 0 else x + clampNonNegative x = max x 0 centerOffset availSize size = clampNonNegative $ (availSize - size) `div` 2 endOffset availSize size = @@ -623,10 +625,14 @@ logRuntimeInfo backendChoice backend watcherPresent <- hasStatusNotifierWatcher client unless watcherPresent $ do - logM "StatusNotifier" WARNING $ + logM + "StatusNotifier" + WARNING "No StatusNotifierWatcher found on D-Bus (org.kde.StatusNotifierWatcher). Tray will likely be empty." unless startWatcher $ - logM "StatusNotifier" WARNING $ + logM + "StatusNotifier" + WARNING "Start a watcher first (recommended) or run with --watcher to start one in-process." _ <- getRootLogger pid <- getProcessID @@ -722,7 +728,7 @@ Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock case backend of BackendX11 -> - when (not noStrut) $ setupStrutWindow config window + unless noStrut $ setupStrutWindow config window BackendWayland -> setupLayerShellWindow config window (not noStrut) maybe diff --git a/gtk-sni-tray.cabal b/gtk-sni-tray.cabal --- a/gtk-sni-tray.cabal +++ b/gtk-sni-tray.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gtk-sni-tray -version: 0.2.1.1 +version: 0.2.1.2 synopsis: A standalone StatusNotifierItem/AppIndicator tray description: Please see the README on Github at category: System @@ -42,7 +42,7 @@ , bytestring >=0.10 && <0.13 , containers >=0.5 && <0.8 , dbus ==1.* - , dbus-menu >=0.1.3.2 && <0.2 + , dbus-menu >=0.1.3.3 && <0.2 , directory >=1.2 && <1.4 , enclosed-exceptions >=1.0.0.1 && <1.1 , filepath >=1.3 && <1.6 @@ -55,12 +55,12 @@ , gi-glib ==2.0.* , gi-gobject ==2.0.* , gi-gtk3 ==3.0.* - , gtk-scaling-image ==0.1.* - , gtk-strut >=0.1.4 && <0.2 + , gtk-scaling-image >=0.1.0.1 && <0.2 + , gtk-strut >=0.1.4.1 && <0.2 , haskell-gi >=0.21.2 && <0.27 , haskell-gi-base >=0.21.1 && <0.27 , hslogger >=1.2 && <1.4 - , status-notifier-item >=0.3.2.13 && <0.4 + , status-notifier-item >=0.3.2.14 && <0.4 , text >=1.2 && <2.2 , transformers >=0.4 && <0.7 , transformers-base ==0.4.* @@ -78,7 +78,7 @@ base , containers , dbus - , dbus-hslogger >=0.1.0.1 && <0.2 + , dbus-hslogger >=0.1.1.1 && <0.2 , gi-gdk3 , gi-gtk-layer-shell ==0.1.* , gi-gtk3 diff --git a/src/StatusNotifier/Icon/Pixbuf.hs b/src/StatusNotifier/Icon/Pixbuf.hs --- a/src/StatusNotifier/Icon/Pixbuf.hs +++ b/src/StatusNotifier/Icon/Pixbuf.hs @@ -112,10 +112,10 @@ validFormat = bytesPerPixel == 3 || bytesPerPixel == 4 readChannel :: Ptr Word8 -> Int -> IO Word8 - readChannel p off = peekByteOff p off + readChannel = peekByteOff writeChannel :: Ptr Word8 -> Int -> Word8 -> IO () - writeChannel p off v = pokeByteOff p off v + writeChannel = pokeByteOff if width <= 0 || height <= 0 || not validFormat || BS.null pixelsBs then pure () diff --git a/src/StatusNotifier/TransparentWindow.hs b/src/StatusNotifier/TransparentWindow.hs --- a/src/StatusNotifier/TransparentWindow.hs +++ b/src/StatusNotifier/TransparentWindow.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : StatusNotifier.TransparentWindow -- Copyright : (c) Ivan A. Malison @@ -13,16 +16,15 @@ -- -- 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 GI.Cairo.Render -import GI.Cairo.Render.Connector +import Control.Monad.IO.Class +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 :: (MonadIO m) => Gtk.Window -> m () makeWindowTransparent window = do screen <- Gtk.widgetGetScreen window visual <- Gdk.screenGetRgbaVisual screen diff --git a/src/StatusNotifier/Tray.hs b/src/StatusNotifier/Tray.hs --- a/src/StatusNotifier/Tray.hs +++ b/src/StatusNotifier/Tray.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module StatusNotifier.Tray where @@ -162,9 +162,9 @@ -- Avoid relying on iconThemeHasIcon: it can be overly strict when fallback -- loading is enabled. Just try to load and fall back if it fails. let tryLoad :: T.Text -> IO (Maybe Pixbuf) - tryLoad iconName = + tryLoad themedName = catchAny - (iconThemeLoadIcon themeForIcon iconName size themeLoadFlags) + (iconThemeLoadIcon themeForIcon themedName size themeLoadFlags) (const $ pure Nothing) themedPixbuf <- do @@ -183,8 +183,8 @@ maybeFile <- if fileExists then return $ Just nameString - else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath - fmap join $ sequenceA $ safePixbufNewFromFile <$> maybeFile + else join <$> traverse (getIconPathFromThemePath nameString) themePath + join <$> traverse safePixbufNewFromFile maybeFile getIconPathFromThemePath :: String -> String -> IO (Maybe String) getIconPathFromThemePath name themePath = @@ -249,7 +249,7 @@ type TrayClickHook = TrayClickContext -> IO TrayClickDecision -data TrayEventHooks = TrayEventHooks +newtype TrayEventHooks = TrayEventHooks { trayClickHook :: Maybe TrayClickHook } @@ -263,7 +263,7 @@ trayItemMatcherPredicate :: ItemInfo -> Bool } -data TrayPriorityConfig = TrayPriorityConfig +newtype TrayPriorityConfig = TrayPriorityConfig { trayPriorityMatchers :: [TrayItemMatcher] } @@ -319,11 +319,11 @@ trayMatchAny :: [TrayItemMatcher] -> TrayItemMatcher trayMatchAny matchers = mkTrayItemMatcher "any" $ \info -> - any (\matcher -> trayItemMatcherPredicate matcher info) matchers + any (`trayItemMatcherPredicate` info) matchers trayMatchAll :: [TrayItemMatcher] -> TrayItemMatcher trayMatchAll matchers = mkTrayItemMatcher "all" $ \info -> - all (\matcher -> trayItemMatcherPredicate matcher info) matchers + all (`trayItemMatcherPredicate` info) matchers trayMatchNot :: TrayItemMatcher -> TrayItemMatcher trayMatchNot matcher = @@ -577,9 +577,9 @@ getPriorityIndex info = fromMaybe (length priorityMatchers) - (findIndex (\matcher -> trayItemMatcherPredicate matcher info) priorityMatchers) + (findIndex (`trayItemMatcherPredicate` info) priorityMatchers) - reorderTrayByPriority = when (not (null priorityMatchers)) $ do + reorderTrayByPriority = unless (null priorityMatchers) $ do infoMap <- getInfoMap let orderedInfos = sortOn @@ -625,11 +625,11 @@ ContextMap.reserveContext serviceName contexts in pure (newContexts, reserved) forM_ reservation $ - \reservation -> + \reservedContext -> flip onException ( MV.modifyMVar_ contextMap $ - pure . ContextMap.cancelReservation serviceName reservation + pure . ContextMap.cancelReservation serviceName reservedContext ) $ do let serviceNameStr = (coerce serviceName :: String) @@ -770,7 +770,7 @@ popupGtkMenu gtkMenu currentEvent return False traverse_ - ( \action -> case action of + ( \case Activate -> runAsync "Activate" $ void $ @@ -860,12 +860,9 @@ ( \d -> catchAny (void $ IC.scroll client serviceName servicePath delta d) - ( \e -> - trayLogger WARNING $ - printf - "Scroll failed for %s: %s" - (coerce serviceName :: String) - (show e) + ( trayLogger WARNING + . printf "Scroll failed for %s: %s" (coerce serviceName :: String) + . show ) ) direction' @@ -873,7 +870,7 @@ didFinalize <- MV.modifyMVar contextMap $ \contexts -> let (finalized, newContexts) = - ContextMap.setReadyContext serviceName reservation context contexts + ContextMap.setReadyContext serviceName reservedContext context contexts in pure (newContexts, finalized) if didFinalize @@ -894,11 +891,6 @@ serviceNameStr servicePathStr Gtk.widgetDestroy eventBox - updateHandler ItemAdded ItemInfo {itemServiceName = serviceName} = - trayLogger DEBUG $ - printf - "Skipping duplicate tray add for %s while a widget is pending or ready." - (coerce serviceName :: String) updateHandler ItemRemoved ItemInfo {itemServiceName = name} = MV.modifyMVar contextMap removeContext >>= removeWidget where