diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 3.2.1 + +## Bug Fixes + + * The workspaces widget now listens on the additional EWMH properties that it + needs to in order to properly update things when the active window changes. + This problem likely only emerged recently because xmonad has recently become + much more conservative about emitting change events (#454). + + * The workspaces widget listens for changes to window geometry (similar to + above) (#456). + # 3.2.0 ## New Features diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) (2011-2018), Tristan Ravitch +Copyright (c) (2011-2019), Tristan Ravitch, Ivan Malison All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,63 +2,119 @@ ![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) -Taffybar is a gtk+3 [(through gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop +Taffybar is a gtk+3 [(through +gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop information bar, intended primarily for use with XMonad, though it can also function alongside other EWMH compliant window managers. It is similar in spirit to xmobar, but it differs in that it gives up some simplicity for a reasonable helping of eye candy. -Prerequisites -------------- +Before Installing +----------------- -Taffybar has a number of non-haskell dependencies. It is recommended that you -follow the installation instructions for -[haskell-gi](https://github.com/haskell-gi/haskell-gi) before attempting to -install taffybar. +The installation method, and procedure that must be followed depends on whether +or not you intend to setup a new haskell project and use `startTaffybar`, or if +you want to use the `dyreTaffybar` approach. It is important for you to read +this section so you can understand what all of that means before you decide how +you want to install taffybar. -In addition the the dependencies needed by haskell-gi, taffybar also needs the -equivalent of `libdbusmenu-gtk3-dev` and `libgirepository1.0-dev` on Debian. +### Taffybar is a library -Installation ------------- +As with window managers like XMonad and dwm, taffybar is most appropriately +described as a library that allows you to build an executable that is customized +to your tastes. This means that taffybar must be installed alongside a haskell +compiler (ghc) that can compile the user's configuration source file. -Taffybar itself can be installed in a number of different ways: +### The taffybar binary and `startTaffybar` vs `dyreTaffybar` -### Stack +Taffybar can be started from your configuration file in two different ways: -Though it is admittedly a bit complicated to set up properly, using stack is the -preferred approach for installing taffybar, because it makes the build process -stable and repeatable. Even if you are unfamiliar with stack, or even haskell in -general, you should be able to get things working by using the taffybar's -quick-start script: +#### `dyreTaffybar` -``` -curl -sSL https://raw.githubusercontent.com/taffybar/taffybar/master/quick-start.sh | bash -``` +The `dyreTaffybar` entry point to taffybar uses the [dyre +library](https://github.com/willdonnelly/dyre) to automatically recompile your +taffybar configuration whenever it detects that it has changed. The binary that +is distributed with taffybar does nothing more than call this entry point. The +main downside of this approach is that it does not allow the user to use any +sort of project files for their configuration, and they must have any packages +that are necessary for compilation of their configuration available in their +global ghc environment. -This script will clone the taffybar repository into a subdirectory of the -default taffybar configuration directory, and copy the example cabal, stack and -taffybar.hs files into the same location. It will then install a binary -`my-taffybar` to `$HOME/.local/bin`, which can be executed to run taffybar. Note -that with this approach, running the `taffybar` binary WILL NOT work; you must -run the binary that is produced by the stack build in your local directory. The -name of the binary can be changed in the cabal file in the taffybar -configuration directory. +#### `startTaffybar` -#### Running with stack +The `startTaffybar` entry point to taffybar simply starts taffybar with the +provided configuration. The user binary will not be automatically recompiled +when source files change. The advantage of using `startTaffybar` directly is +that you can use that in the main function of a cabal project. -When you build with stack, it is recommended that you start taffybar with -`startTaffybar` rather than `dyreTaffybar`, and use -https://github.com/yamadapc/stack-run to execute the custom executable specified -by your cabal and stack files. The maintainers have plans for a better solution -(that does not require the user to use stack-run themselves) in [#158](https://github.com/taffybar/taffybar/issues/158). +Distribution Packaging +---------------------- +Several linux distributions package taffybar +([nixos](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix), +[arch/aur](https://aur.archlinux.org/packages/taffybar/), +[debian](https://aur.archlinux.org/packages/taffybar/)). Of these, only the +NixOS distribution is officially supported by the maintainers. Using any of the +others should be pretty similar to using a bare cabal installation of taffybar. +#### NixOS + +If you wish to use the NixOS package for taffybar, make sure that you are using +the +[module](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix), +and not simply the haskellPackage for taffybar. If you need to add additional +haskell packages to the environment that compiles your taffybar.hs you will need +to invoke that module and use the packages parameter to allow this. + +Installation From Hackage/Source +-------------------------------- + +### Prerequisites + +If you are not using distribution packaging of taffybar or the nix package +manager (it will handle getting all the necessary packages for you), you will +need to install all of taffybar's non-haskell dependencies manually. + +Start by making sure you have installed everything that is needed for [haskell-gi](https://github.com/haskell-gi/haskell-gi). Taffybar also needs the +equivalent of `libdbusmenu-gtk3-dev` and `libgirepository1.0-dev` on Debian. + +You can also get some idea of what the necessary dependencies are by looking at +the nix section of the stack.yaml file in the taffybar repository. + ### Cabal Cabal installation is a simple matter of installing taffybar from hackage: ``` cabal install taffybar ``` + +You do not need to do this if you are using the project approach with cabal. + +### The project approach +The project approach to installing/using taffybar involves maintaining a small +haskell project that produces the users taffybar binary. No matter which package +manager you choose to use you will need to make a .cabal file for this project. +It is recommended that you use [this +example](https://github.com/taffybar/taffybar/blob/master/example/my-taffybar.cabal) +as a template. In that example, the users configuration resides in the file +`taffybar.hs` in the same directory, but that can be changed as needed. As of +right now, `dyreTaffybar` is incompatible with this approach because dyre simply +calls ghc directly. + +### Cabal + +Simply run `cabal new-install` to install the binary. + +### Stack + +With stack, you will also need to maintain a stack.yaml file. Run `stack +install` to install the binary. See [this +example](https://github.com/taffybar/taffybar/blob/master/example/stack.yaml) + +### Nix + +You will need to add default.nix file to your package. See [this +example](https://github.com/taffybar/taffybar/blob/master/example/default.nix) + Configuration ------------- diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,9 +5,11 @@ import Data.Semigroup ((<>)) import Data.Version import Options.Applicative +import System.Directory import System.Log.Logger import System.Taffybar import System.Taffybar.Context +import System.Taffybar.Example import Text.Printf import Paths_taffybar (version) @@ -35,6 +37,19 @@ ( fullDesc <> progDesc "Start taffybar, recompiling if necessary" ) + logger <- getLogger "System.Taffybar" saveGlobalLogger $ setLevel logLevel logger - dyreTaffybar defaultTaffybarConfig + + taffyFilepath <- getTaffyFile "taffybar.hs" + configurationExists <- doesFileExist taffyFilepath + + if configurationExists + -- XXX: The configuration record here does not get used, this just calls in to dyre. + then dyreTaffybar defaultTaffybarConfig + else do + logM "System.Taffybar" WARNING $ + ( printf "No taffybar configuration file found at %s." taffyFilepath + ++ " Starting with example configuration." + ) + startTaffybar exampleTaffybarConfig diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -10,31 +10,32 @@ ----------------------------------------------------------------------------- module System.Taffybar ( - -- * Detail - -- - -- | This is a system status bar meant for use with window managers like - -- XMonad. It is similar to xmobar, but with more visual flare and a different - -- widget set. Contributed widgets are more than welcome. The bar is drawn - -- using gtk and cairo. It is actually the simplest possible thing that could - -- plausibly work: you give Taffybar a list of GTK widgets and it will render - -- them in a horizontal bar for you (taking care of ugly details like - -- reserving strut space so that window managers don't put windows over it). + -- | Taffybar is a system status bar meant for use with window managers like + -- XMonad and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use + -- more heavy weight GUI in the form of gtk+ rather than the mostly textual + -- approach favored by the latter. This allows it to provide features like an + -- SNI system tray, and a workspace widget with window icons. -- - -- This is the real main module. The default bar should be customized to taste - -- in the config file (~/.config/taffybar/taffybar.hs). Typically, this means - -- adding widgets to the default config. A default configuration file is - -- included in the distribution, but the essentials are covered here. -- * Config File + -- | + -- The interface that taffybar provides to the end user is roughly as follows: + -- you give Taffybar a list of ([Taffy]IO actions that build) gtk+ widgets and + -- it renders them in a horizontal bar for you (taking care of ugly details + -- like reserving strut space so that window managers don't put windows over + -- it). -- - -- | The config file is just a Haskell source file that is compiled at startup - -- (if it has changed) to produce a custom executable with the desired set of - -- widgets. You will want to import this module along with the modules of any - -- widgets you want to add to the bar. Note, you can define any widgets that - -- you want in your config file or other libraries. Taffybar only cares that - -- you give it some GTK widgets to display. + -- | The config file in which you specify the gtk+ widgets to render is just a + -- Haskell source file which is used to produce a custom executable with the + -- desired set of widgets. This approach requires that taffybar be installed + -- as a haskell library (not merely as an executable), and that the ghc + -- compiler be available for recompiling the configuration. The upshot of this + -- approach is that taffybar's behavior and widget set are not limited to the + -- set of widgets provided by the library, because custom code and widgets can + -- be provided to taffybar for instantiation and execution. -- - -- Below is a fairly typical example: + -- The following code snippet is a simple example of what a taffybar + -- configuration might look like (also see @src/System/Taffybar/Example.hs@): -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import System.Taffybar @@ -52,43 +53,43 @@ -- > let cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)] -- > , graphLabel = Just "cpu" -- > } - -- > clock = textClockNew Nothing "%a %b %_d %H:%M" 1 + -- > clock = textClockNew defaultClockConfig -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback -- > workspaces = workspacesNew defaultWorkspacesConfig -- > simpleConfig = defaultSimpleTaffyConfig -- > { startWidgets = [ workspaces ] -- > , endWidgets = [ sniTrayNew, clock, cpu ] -- > } - -- > simpleTaffybar simpleConfig + -- > startTaffybar $ simpleTaffybar simpleConfig -- -- This configuration creates a bar with four widgets. On the left is a widget -- that shows information about the workspace configuration. The rightmost - -- widget is the system tray, with a clock and then a CPU graph. The clock is - -- formatted using standard strftime-style format strings (see the clock - -- module). Note that the clock is colored using Pango markup (again, see the - -- clock module). + -- widget is the system tray, with a clock and then a CPU graph. -- -- The CPU widget plots two graphs on the same widget: total CPU use in green -- and then system CPU use in a kind of semi-transparent purple on top of the -- green. -- -- It is important to note that the widget lists are *not* [Widget]. They are - -- actually [TaffyIO Widget] since the bar needs to construct them after performing - -- some GTK initialization. + -- actually [TaffyIO Widget] since the bar needs to construct them after + -- performing some GTK initialization. -- - -- ** A note about taffybar's dependency on DBus: - -- | + -- * Taffybar and DBus + -- + -- | Taffybar has a strict dependency on dbus, so you must ensure that it is + -- started before starting taffybar. + -- -- * If you start your window manager using a graphical login manager like gdm - -- or kdm, DBus should be started automatically for you. + -- or kdm, DBus should be started rautomatically for you. -- -- * If you start xmonad with a different graphical login manager that does - -- not start DBus for you automatically, put the line @eval \`dbus-launch - -- --auto-syntax\`@ into your ~\/.xsession *before* xmonad and taffybar are - -- started. This command sets some environment variables that the two must - -- agree on. + -- not start DBus for you automatically, put the line @eval \`dbus-launch + -- --auto-syntax\`@ into your ~\/.xsession *before* xmonad and taffybar are + -- started. This command sets some environment variables that the two must + -- agree on. -- -- * If you start xmonad via @startx@ or a similar command, add the - -- above command to ~\/.xinitrc + -- above command to ~\/.xinitrc -- * Colors -- @@ -98,10 +99,11 @@ -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking. -- For an idea of the customizations you can make, see -- . - taffybarDyreParams - , dyreTaffybar - , startTaffybar + dyreTaffybar , dyreTaffybarMain + , getTaffyFile + , startTaffybar + , taffybarDyreParams ) where import qualified Config.Dyre as Dyre @@ -151,8 +153,8 @@ IO.hPutStrLn IO.stderr ("Error: " ++ err) exitFailure -getDefaultConfigFile :: String -> IO FilePath -getDefaultConfigFile name = do +getDataFile :: String -> IO FilePath +getDataFile name = do dataDir <- getDataDir return (dataDir name) @@ -174,9 +176,12 @@ Gtk.styleContextAddProviderForScreen scr taffybarProvider 800 return taffybarProvider +getTaffyFile :: String -> IO FilePath +getTaffyFile = getUserConfigFile "taffybar" + getDefaultCSSPaths :: IO [FilePath] getDefaultCSSPaths = do - defaultUserConfig <- getUserConfigFile "taffybar" "taffybar.css" + defaultUserConfig <- getTaffyFile "taffybar.css" return [defaultUserConfig] -- | Start taffybar with the provided 'TaffybarConfig'. Because this function @@ -193,9 +198,9 @@ _ <- initThreads _ <- Gtk.init Nothing GIThreading.setCurrentThreadAsGUIThread - defaultConfig <- getDefaultConfigFile "taffybar.css" + defaultCSS <- getDataFile "taffybar.css" cssPaths <- maybe getDefaultCSSPaths (return . return) $ cssPath config - _ <- startCSS $ defaultConfig:cssPaths + _ <- startCSS $ defaultCSS:cssPaths _ <- buildContext config Gtk.main diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs --- a/src/System/Taffybar/Context.hs +++ b/src/System/Taffybar/Context.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Reader import qualified DBus.Client as DBus import Data.Data +import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List import qualified Data.Map as M @@ -36,6 +37,7 @@ import Data.Unique import qualified GI.Gdk import qualified GI.GdkX11 as GdkX11 +import GI.GdkX11.Objects.X11Window import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut import StatusNotifier.TransparentWindow @@ -50,8 +52,8 @@ logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.Context" -logT :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO () -logT p m = lift $ logIO p m +logC :: MonadIO m => System.Log.Logger.Priority -> String -> m () +logC p = liftIO . logIO p type Taffy m v = MonadIO m => ReaderT Context m v type TaffyIO v = ReaderT Context IO v @@ -101,17 +103,38 @@ , errorMsg = Nothing } +-- | A "Context" value holds all of the state associated with a single running +-- instance of taffybar. It is typically accessed from a widget constructor +-- through the "TaffyIO" monad transformer stack. data Context = Context - { x11ContextVar :: MV.MVar X11Context + { + -- | The X11Context that will be used to service X11Property requests. + x11ContextVar :: MV.MVar X11Context + -- | The handlers which will be evaluated against incoming X11 events. , listeners :: MV.MVar SubscriptionList + -- | A collection of miscellaneous peices of state which are keyed by their + -- types. Most new peices of state should go here, rather than in a new field + -- in "Context". State stored here is typically accessed through + -- "getStateDefault". , contextState :: MV.MVar (M.Map TypeRep Value) + -- | Used to track the windows that taffybar is currently controlling, and + -- which "BarConfig" objects they are associated with. , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)] + -- | The shared user session "DBus.Client". , sessionDBusClient :: DBus.Client + -- | The shared system session "DBus.Client". , systemDBusClient :: DBus.Client + -- | The action that will be evaluated to get the bar configs associated with + -- each active monitor taffybar should run on. , getBarConfigs :: BarConfigGetter + -- | Populated with the BarConfig that resulted in the creation of a given + -- widget, when its constructor is called. This lets widgets access thing like + -- who their neighbors are. Note that the value of "contextBarConfig" is + -- different for widgets belonging to bar windows on differnt monitors. , contextBarConfig :: Maybe BarConfig } +-- | Build the "Context" for a taffybar process. buildContext :: TaffybarConfig -> IO Context buildContext TaffybarConfig { dbusClientParam = maybeDBus @@ -145,11 +168,11 @@ -- whatever it pleases. (runReaderT forceRefreshTaffyWindows context)) flip runReaderT context $ do - logT DEBUG "Starting X11 Handler" + logC DEBUG "Starting X11 Handler" startX11EventHandler - logT DEBUG "Running startup hook" + logC DEBUG "Running startup hook" startup - logT DEBUG "Queing build windows command" + logC DEBUG "Queing build windows command" refreshTaffyWindows logIO DEBUG "Context build finished" return context @@ -157,8 +180,6 @@ buildEmptyContext :: IO Context buildEmptyContext = buildContext defaultTaffybarConfig -instance GdkX11.IsX11Window GI.Gdk.Window - buildBarWindow :: Context -> BarConfig -> IO Gtk.Window buildBarWindow context barConfig = do let thisContext = context { contextBarConfig = Just barConfig } @@ -199,14 +220,18 @@ runX11Context context () $ void $ runMaybeT $ do gdkWindow <- MaybeT $ Gtk.widgetGetWindow window - xid <- GdkX11.x11WindowGetXid gdkWindow + xid <- GdkX11.x11WindowGetXid =<< liftIO (unsafeCastTo X11Window gdkWindow) + logC DEBUG $ printf "Lowering X11 window %s" $ show xid lift $ doLowerWindow (fromIntegral xid) return window +-- | Use the "barConfigGetter" field of "Context" to get the set of taffybar +-- windows that should active. Will avoid recreating windows if there is already +-- a window with the appropriate geometry and "BarConfig". refreshTaffyWindows :: TaffyIO () refreshTaffyWindows = liftReader postGUIASync $ do - logT DEBUG "Refreshing windows" + logC DEBUG "Refreshing windows" ctx <- ask windowsVar <- asks existingWindows @@ -247,7 +272,7 @@ return $ newWindowPairs ++ remainingWindows lift $ MV.modifyMVar_ windowsVar rebuildWindows - logT DEBUG "Finished refreshing windows" + logC DEBUG "Finished refreshing windows" return () forceRefreshTaffyWindows :: TaffyIO () @@ -302,22 +327,28 @@ (return . (contextStateMap,)) (currentValue >>= fromValue) +-- | A version of "forkIO" in "TaffyIO". taffyFork :: ReaderT r IO () -> ReaderT r IO () taffyFork = void . liftReader forkIO startX11EventHandler :: Taffy IO () startX11EventHandler = taffyFork $ do c <- ask - -- The event loop needs its own X11Context to separately handle communications - -- from the X server. + -- XXX: The event loop needs its own X11Context to separately handle + -- communications from the X server. We deliberately avoid using the context + -- from x11ContextVar here. lift $ withDefaultCtx $ eventLoop (\e -> runReaderT (handleX11Event e) c) +-- | Remove the listener associated with the provided "Unique" from the +-- collection of listeners. unsubscribe :: Unique -> Taffy IO () unsubscribe identifier = do listenersVar <- asks listeners lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst) +-- | Subscribe to all incoming events on the X11 event loop. The returned +-- "Unique" value can be used to unregister the listener using "unsuscribe". subscribeToAll :: Listener -> Taffy IO Unique subscribeToAll listener = do identifier <- lift newUnique @@ -330,8 +361,10 @@ lift $ MV.modifyMVar_ listenersVar (return . addListener) return identifier -subscribeToEvents :: [String] -> Listener -> Taffy IO Unique -subscribeToEvents eventNames listener = do +-- | Subscribe to X11 "PropertyEvent"s where the property changed is in the +-- provided list. +subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique +subscribeToPropertyEvents eventNames listener = do eventAtoms <- mapM (runX11 . getAtom) eventNames let filteredListener event@PropertyEvent { ev_atom = atom } = when (atom `elem` eventAtoms) $ diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs --- a/src/System/Taffybar/DBus/Toggle.hs +++ b/src/System/Taffybar/DBus/Toggle.hs @@ -19,6 +19,7 @@ import qualified Control.Concurrent.MVar as MV import Control.Exception import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -35,7 +36,7 @@ import System.Environment.XDG.BaseDir import System.FilePath.Posix import System.Log.Logger -import System.Taffybar.Context hiding (logIO, logT) +import System.Taffybar.Context hiding (logIO) import Text.Printf import Text.Read ( readMaybe ) @@ -54,8 +55,8 @@ logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.DBus.Toggle" -logT :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO () -logT p m = lift $ logIO p m +logT :: MonadIO m => System.Log.Logger.Priority -> String -> m () +logT p = liftIO . logIO p getActiveMonitorNumber :: MaybeT IO Int getActiveMonitorNumber = do diff --git a/src/System/Taffybar/Example.hs b/src/System/Taffybar/Example.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Example.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Example +-- Copyright : (c) Ivan A. Malison +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ivan A. Malison +-- Stability : unstable +-- Portability : unportable +----------------------------------------------------------------------------- +module System.Taffybar.Example where + +-- XXX: in an actual taffybar.hs configuration file, you will need the module +-- name to be Main, and you would need to have a main function defined at the +-- top level, e.g. +-- +-- > main = dyreTaffybar exampleTaffybarConfig + +import System.Taffybar.Context (TaffybarConfig(..)) +import System.Taffybar.Hooks +import System.Taffybar.Information.CPU +import System.Taffybar.Information.Memory +import System.Taffybar.SimpleConfig +import System.Taffybar.Widget +import System.Taffybar.Widget.Generic.PollingGraph + +transparent, yellow1, yellow2, green1, green2, taffyBlue + :: (Double, Double, Double, Double) +transparent = (0.0, 0.0, 0.0, 0.0) +yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0) +yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0) +green1 = (0, 1, 0, 1) +green2 = (1, 0, 1, 0.5) +taffyBlue = (0.129, 0.588, 0.953, 1) + +myGraphConfig, netCfg, memCfg, cpuCfg :: GraphConfig +myGraphConfig = + defaultGraphConfig + { graphPadding = 0 + , graphBorderWidth = 0 + , graphWidth = 75 + , graphBackgroundColor = transparent + } + +netCfg = myGraphConfig + { graphDataColors = [yellow1, yellow2] + , graphLabel = Just "net" + } + +memCfg = myGraphConfig + { graphDataColors = [taffyBlue] + , graphLabel = Just "mem" + } + +cpuCfg = myGraphConfig + { graphDataColors = [green1, green2] + , graphLabel = Just "cpu" + } + +memCallback :: IO [Double] +memCallback = do + mi <- parseMeminfo + return [memoryUsedRatio mi] + +cpuCallback :: IO [Double] +cpuCallback = do + (_, systemLoad, totalLoad) <- cpuLoad + return [totalLoad, systemLoad] + +exampleTaffybarConfig :: TaffybarConfig +exampleTaffybarConfig = + let myWorkspacesConfig = + defaultWorkspacesConfig + { minIcons = 1 + , widgetGap = 0 + , showWorkspaceFn = hideEmpty + } + workspaces = workspacesNew myWorkspacesConfig + cpu = pollingGraphNew cpuCfg 0.5 cpuCallback + mem = pollingGraphNew memCfg 1 memCallback + net = networkGraphNew netCfg Nothing + clock = textClockNewWith defaultClockConfig + layout = layoutNew defaultLayoutConfig + windowsW = windowsNew defaultWindowsConfig + -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher + -- for a better way to set up the sni tray + tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt + myConfig = defaultSimpleTaffyConfig + { startWidgets = + workspaces : map (>>= buildContentsBox) [ layout, windowsW ] + , endWidgets = map (>>= buildContentsBox) + [ batteryIconNew + , clock + , tray + , cpu + , mem + , net + , mpris2New + ] + , barPosition = Top + , barPadding = 10 + , barHeight = 50 + , widgetSpacing = 0 + } + in withBatteryRefresh $ withLogServer $ + withToggleServer $ toTaffyConfig myConfig diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs --- a/src/System/Taffybar/Hooks.hs +++ b/src/System/Taffybar/Hooks.hs @@ -6,7 +6,6 @@ , getChromeTabImageDataTable , getX11WindowToChromeTabId , refreshBatteriesOnPropChange - , setTaffyLogFormatter ) where import BroadcastChan diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs --- a/src/System/Taffybar/Information/Chrome.hs +++ b/src/System/Taffybar/Information/Chrome.hs @@ -13,7 +13,7 @@ import qualified GI.GdkPixbuf as Gdk import Prelude import System.Log.Logger -import System.Taffybar.Context hiding (logIO, logT) +import System.Taffybar.Context hiding (logIO) import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 import Text.Read hiding (lift) @@ -94,7 +94,7 @@ logIO DEBUG (show newMap) return newMap handleEvent _ = return () - _ <- subscribeToEvents ["_NET_WM_NAME"] handleEvent + _ <- subscribeToPropertyEvents [ewmhWMName] handleEvent return tabMapVar tabIDRegex :: Regex diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs --- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs +++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs @@ -22,51 +22,65 @@ module System.Taffybar.Information.EWMHDesktopInfo ( EWMHIcon(..) , EWMHIconData - , WorkspaceIdx(..) - , X11Window -- re-exported from X11DesktopInfo - , X11WindowHandle + , WorkspaceId(..) + , X11Window + , allEWMHProperties + , ewmhActiveWindow + , ewmhClientList + , ewmhCurrentDesktop + , ewmhDesktopNames + , ewmhNumberOfDesktops + , ewmhStateHidden + , ewmhWMClass + , ewmhWMDesktop + , ewmhWMIcon + , ewmhWMName + , ewmhWMName2 + , ewmhWMState + , ewmhWMStateHidden , focusWindow , getActiveWindow , getCurrentWorkspace , getVisibleWorkspaces , getWindowClass , getWindowIconsData + , getWindowMinimized + , getWindowState + , getWindowStateProperty , getWindowTitle , getWindows , getWorkspace , getWorkspaceNames - , isWindowUrgent -- re-exported from X11DesktopInfo + , isWindowUrgent , parseWindowClasses , switchOneWorkspace , switchToWorkspace - , withDefaultCtx -- re-exported from X11DesktopInfo + , withDefaultCtx , withEWMHIcons ) where import Control.Applicative +import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Data.List import Data.List.Split import Data.Maybe import Data.Tuple import Data.Word -import Debug.Trace import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable -import System.Taffybar.Information.SafeX11 +import System.Log.Logger +import System.Taffybar.Information.SafeX11 hiding (logHere) +import System.Taffybar.Information.X11DesktopInfo import Prelude -import System.Taffybar.Information.X11DesktopInfo - --- | Convenience alias for a pair of the form (props, window), where props is a --- tuple of the form (workspace index, window title, window class), and window --- is the internal ID of an open window. -type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window) +logHere :: MonadIO m => Priority -> String -> m () +logHere p = liftIO . logM "System.Taffybar.Information.EWMHDesktopInfo" p -newtype WorkspaceIdx = WSIdx Int - deriving (Show, Read, Ord, Eq) +newtype WorkspaceId = WorkspaceId Int deriving (Show, Read, Ord, Eq) -- A super annoying detail of the XGetWindowProperty interface is that: "If the -- returned format is 32, the returned data is represented as a long array and @@ -77,6 +91,40 @@ -- appropriately. type PixelsWordType = Word64 +type EWMHProperty = String + +ewmhActiveWindow, ewmhClientList, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty +ewmhActiveWindow = "_NET_ACTIVE_WINDOW" +ewmhClientList = "_NET_CLIENT_LIST" +ewmhCurrentDesktop = "_NET_CURRENT_DESKTOP" +ewmhDesktopNames = "_NET_DESKTOP_NAMES" +ewmhNumberOfDesktops = "_NET_NUMBER_OF_DESKTOPS" +ewmhStateHidden = "_NET_WM_STATE_HIDDEN" +ewmhWMClass = "WM_CLASS" +ewmhWMDesktop = "_NET_WM_DESKTOP" +ewmhWMIcon = "_NET_WM_ICON" +ewmhWMName = "_NET_WM_NAME" +ewmhWMName2 = "WM_NAME" +ewmhWMState = "_NET_WM_STATE" +ewmhWMStateHidden = "_NET_WM_STATE_HIDDEN" + +allEWMHProperties :: [EWMHProperty] +allEWMHProperties = + [ ewmhActiveWindow + , ewmhClientList + , ewmhCurrentDesktop + , ewmhDesktopNames + , ewmhNumberOfDesktops + , ewmhStateHidden + , ewmhWMClass + , ewmhWMDesktop + , ewmhWMIcon + , ewmhWMName + , ewmhWMName2 + , ewmhWMState + , ewmhWMStateHidden + ] + type EWMHIconData = (ForeignPtr PixelsWordType, Int) data EWMHIcon = EWMHIcon @@ -85,15 +133,33 @@ , ewmhPixelsARGB :: Ptr PixelsWordType } deriving (Show, Eq) +getWindowStateProperty :: String -> X11Window -> X11Property Bool +getWindowStateProperty property window = + not . null <$> getWindowState window [property] --- | Retrieve the index of the current workspace in the desktop, --- starting from 0. -getCurrentWorkspace :: X11Property WorkspaceIdx -getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP" +getWindowState :: X11Window -> [String] -> X11Property [String] +getWindowState window request = do + let getAsLong s = fromIntegral <$> getAtom s + integers <- mapM getAsLong request + properties <- fetch getWindowProperty32 (Just window) ewmhWMState + let integerToString = zip integers request + present = intersect integers $ fromMaybe [] properties + presentStrings = map (`lookup` integerToString) present + return $ catMaybes presentStrings +-- | Get a bool reflecting whether window with provided X11Window is minimized +-- or not. +getWindowMinimized :: X11Window -> X11Property Bool +getWindowMinimized = getWindowStateProperty ewmhStateHidden + +-- | Retrieve the index of the current workspace in the desktop, starting from +-- 0. +getCurrentWorkspace :: X11Property WorkspaceId +getCurrentWorkspace = WorkspaceId <$> readAsInt Nothing ewmhCurrentDesktop + -- | Retrieve the indexes of all currently visible workspaces -- with the active workspace at the head of the list. -getVisibleWorkspaces :: X11Property [WorkspaceIdx] +getVisibleWorkspaces :: X11Property [WorkspaceId] getVisibleWorkspaces = do vis <- getVisibleTags allNames <- map swap <$> getWorkspaceNames @@ -102,15 +168,15 @@ -- | Return a list with the names of all the workspaces currently -- available. -getWorkspaceNames :: X11Property [(WorkspaceIdx, String)] -getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES" - where go = zip [WSIdx i | i <- [0..]] +getWorkspaceNames :: X11Property [(WorkspaceId, String)] +getWorkspaceNames = go <$> readAsListOfString Nothing ewmhDesktopNames + where go = zip [WorkspaceId i | i <- [0..]] -- | Ask the window manager to switch to the workspace with the given -- index, starting from 0. -switchToWorkspace :: WorkspaceIdx -> X11Property () -switchToWorkspace (WSIdx idx) = do - cmd <- getAtom "_NET_CURRENT_DESKTOP" +switchToWorkspace :: WorkspaceId -> X11Property () +switchToWorkspace (WorkspaceId idx) = do + cmd <- getAtom ewmhCurrentDesktop sendCommandEvent cmd (fromIntegral idx) -- | Move one workspace up or down from the current workspace @@ -120,29 +186,29 @@ switchToWorkspace $ if dir then getPrev cur end else getNext cur end -- | Check for corner case and switch one workspace up -getPrev :: WorkspaceIdx -> Int -> WorkspaceIdx -getPrev (WSIdx idx) end - | idx > 0 = WSIdx $ idx-1 - | otherwise = WSIdx end +getPrev :: WorkspaceId -> Int -> WorkspaceId +getPrev (WorkspaceId idx) end + | idx > 0 = WorkspaceId $ idx-1 + | otherwise = WorkspaceId end -- | Check for corner case and switch one workspace down -getNext :: WorkspaceIdx -> Int -> WorkspaceIdx -getNext (WSIdx idx) end - | idx < end = WSIdx $ idx+1 - | otherwise = WSIdx 0 +getNext :: WorkspaceId -> Int -> WorkspaceId +getNext (WorkspaceId idx) end + | idx < end = WorkspaceId $ idx+1 + | otherwise = WorkspaceId 0 -- | Get the title of the given X11 window. getWindowTitle :: X11Window -> X11Property String getWindowTitle window = do let w = Just window - prop <- readAsString w "_NET_WM_NAME" + prop <- readAsString w ewmhWMName case prop of - "" -> readAsString w "WM_NAME" + "" -> readAsString w ewmhWMName2 _ -> return prop -- | Get the class of the given X11 window. getWindowClass :: X11Window -> X11Property String -getWindowClass window = readAsString (Just window) "WM_CLASS" +getWindowClass window = readAsString (Just window) ewmhWMClass parseWindowClasses :: String -> [String] parseWindowClasses = filter (not . null) . splitOn "\NUL" @@ -151,7 +217,7 @@ getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData) getWindowIconsData window = do dpy <- getDisplay - atom <- getAtom "_NET_WM_ICON" + atom <- getAtom ewmhWMIcon lift $ rawGetWindowPropertyBytes 32 dpy atom window -- | Operate on the data contained in 'EWMHIconData' in the easier to interact @@ -164,12 +230,11 @@ withEWMHIcons (fptr, size) action = withForeignPtr fptr ((>>= action) . parseIcons size) --- | Split icon raw integer data into EWMHIcons. --- Each icon raw data is an integer for width, --- followed by height, --- followed by exactly (width*height) ARGB pixels, --- optionally followed by the next icon. --- This function should not be made public, because its return value contains +-- | Split icon raw integer data into EWMHIcons. Each icon raw data is an +-- integer for width, followed by height, followed by exactly (width*height) +-- ARGB pixels, optionally followed by the next icon. +-- +-- XXX: This function should not be made public, because its return value contains -- (sub)pointers whose allocation we do not control. parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon] parseIcons 0 _ = return [] @@ -186,26 +251,27 @@ , ewmhPixelsARGB = pixelsPtr } getRes newSize - | newSize < 0 = trace "This should not happen parseIcons" return [] - | otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going + | newSize < 0 = + logHere ERROR "Attempt to recurse on negative value in parseIcons" + >> return [] + | otherwise = (thisIcon :) <$> parseIcons newSize newArr getRes $ totalSize - fromIntegral (thisSize + 2) --- Get the window that currently has focus if such a window exists +-- | Get the window that currently has focus if such a window exists. getActiveWindow :: X11Property (Maybe X11Window) -getActiveWindow = - listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW" +getActiveWindow = listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow --- | Return a list of all windows +-- | Return a list of all @X11Window@s. getWindows :: X11Property [X11Window] -getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST" +getWindows = readAsListOfWindow Nothing ewmhClientList -- | Return the index (starting from 0) of the workspace on which the given -- window is being displayed. -getWorkspace :: X11Window -> X11Property WorkspaceIdx -getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP" +getWorkspace :: X11Window -> X11Property WorkspaceId +getWorkspace window = WorkspaceId <$> readAsInt (Just window) ewmhWMDesktop -- | Ask the window manager to give focus to the given window. focusWindow :: X11Window -> X11Property () focusWindow wh = do - cmd <- getAtom "_NET_ACTIVE_WINDOW" + cmd <- getAtom ewmhActiveWindow sendWindowEvent cmd (fromIntegral wh) diff --git a/src/System/Taffybar/Information/MPRIS2.hs b/src/System/Taffybar/Information/MPRIS2.hs --- a/src/System/Taffybar/Information/MPRIS2.hs +++ b/src/System/Taffybar/Information/MPRIS2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonoLocalBinds #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.MPRIS2 diff --git a/src/System/Taffybar/Information/SafeX11.hs b/src/System/Taffybar/Information/SafeX11.hs --- a/src/System/Taffybar/Information/SafeX11.hs +++ b/src/System/Taffybar/Information/SafeX11.hs @@ -33,12 +33,12 @@ getWindowProperty16, getWindowProperty32, xGetWMHints, getWMHints, refreshKeyboardMapping) import Prelude -import System.IO import System.IO.Unsafe import System.Log.Logger import System.Timeout import Text.Printf +logHere :: Priority -> String -> IO () logHere = logM "System.Taffybar.Information.SafeX11" foreign import ccall safe "XlibExtras.h XGetWMHints" diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs --- a/src/System/Taffybar/Information/X11DesktopInfo.hs +++ b/src/System/Taffybar/Information/X11DesktopInfo.hs @@ -24,13 +24,12 @@ , X11Window , doLowerWindow , eventLoop + , fetch , getAtom , getDefaultCtx , getDisplay , getPrimaryOutputNumber , getVisibleTags - , getWindowState - , getWindowStateProperty , isWindowUrgent , postX11RequestSyncProp , readAsInt @@ -58,20 +57,22 @@ import Graphics.X11.Xlib.Extras hiding (getWindowProperty8, getWindowProperty32, getWMHints) import Graphics.X11.Xrandr -import Prelude import System.Taffybar.Information.SafeX11 +import Prelude + data X11Context = X11Context { contextDisplay :: Display , _contextRoot :: Window , atomCache :: MV.MVar [(String, Atom)] } + type X11Property a = ReaderT X11Context IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a]) --- | Put the current display and root window objects inside a Reader --- transformer for further computation. +-- | Put the current display and root window objects inside a Reader transformer +-- for further computation. withDefaultCtx :: X11Property a -> IO a withDefaultCtx fun = do ctx <- getDefaultCtx @@ -79,12 +80,13 @@ closeDisplay (contextDisplay ctx) return res +-- | An X11Property that returns the @Display@ object stored in the X11Context. getDisplay :: X11Property Display getDisplay = contextDisplay <$> ask --- | Retrieve the property of the given window (or the root window, --- if Nothing) with the given name as a value of type Int. If that --- property hasn't been set, then return -1. +-- | Retrieve the property of the given window (or the root window, if Nothing) +-- with the given name as a value of type Int. If that property hasn't been set, +-- then return -1. readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property Int @@ -94,9 +96,9 @@ Just (x:_) -> return (fromIntegral x) _ -> return (-1) --- | Retrieve the property of the given window (or the root window, --- if Nothing) with the given name as a list of Ints. If that --- property hasn't been set, then return an empty list. +-- | Retrieve the property of the given window (or the root window, if Nothing) +-- with the given name as a list of Ints. If that property hasn't been set, then +-- return an empty list. readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [Int] @@ -106,9 +108,9 @@ Just xs -> return (map fromIntegral xs) _ -> return [] --- | Retrieve the property of the given window (or the root window, --- if Nothing) with the given name as a String. If the property --- hasn't been set, then return an empty string. +-- | Retrieve the property of the given window (or the root window, if Nothing) +-- with the given name as a String. If the property hasn't been set, then return +-- an empty string. readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property String @@ -118,9 +120,9 @@ Just xs -> return . UTF8.decode . map fromIntegral $ xs _ -> return [] --- | Retrieve the property of the given window (or the root window, --- if Nothing) with the given name as a list of Strings. If the --- property hasn't been set, then return an empty list. +-- | Retrieve the property of the given window (or the root window, if Nothing) +-- with the given name as a list of Strings. If the property hasn't been set, +-- then return an empty list. readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [String] @@ -132,9 +134,9 @@ where parse = endBy "\0" . UTF8.decode . map fromIntegral --- | Retrieve the property of the given window (or the root window, --- if Nothing) with the given name as a list of X11 Window IDs. If --- the property hasn't been set, then return an empty list. +-- | Retrieve the property of the given window (or the root window, if Nothing) +-- with the given name as a list of X11 Window IDs. If the property hasn't been +-- set, then return an empty list. readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [X11Window] @@ -144,15 +146,15 @@ Just xs -> return $ map fromIntegral xs _ -> return [] --- | Determine whether the \"urgent\" flag is set in the WM_HINTS of --- the given window. +-- | Determine whether the \"urgent\" flag is set in the WM_HINTS of the given +-- window. isWindowUrgent :: X11Window -> X11Property Bool isWindowUrgent window = do hints <- fetchWindowHints window return $ testBit (wmh_flags hints) urgencyHintBit --- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set --- by the PagerHints hook provided by Taffybar (see module documentation for +-- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set by +-- the PagerHints hook provided by Taffybar (see module documentation for -- instructions on how to do this), or an empty list of strings if the -- PagerHints hook is not available. getVisibleTags :: X11Property [String] @@ -170,10 +172,9 @@ return ((s, atom):currentCache, atom) maybe updateCacheAction return a --- | Spawn a new thread and listen inside it to all incoming events, --- invoking the given function to every event of type @MapNotifyEvent@ that --- arrives, and subscribing to all events of this type emitted by newly --- created windows. +-- | Spawn a new thread and listen inside it to all incoming events, invoking +-- the given function to every event of type @MapNotifyEvent@ that arrives, and +-- subscribing to all events of this type emitted by newly created windows. eventLoop :: (Event -> IO ()) -> X11Property () eventLoop dispatch = do (X11Context d w _) <- ask @@ -187,9 +188,9 @@ _ -> return () dispatch event --- | Emit a \"command\" event with one argument for the X server. This is --- used to send events that can be received by event hooks in the XMonad --- process and acted upon in that context. +-- | Emit a \"command\" event with one argument for the X server. This is used +-- to send events that can be received by event hooks in the XMonad process and +-- acted upon in that context. sendCommandEvent :: Atom -> Atom -> X11Property () sendCommandEvent cmd arg = do (X11Context dpy root _) <- ask @@ -201,7 +202,7 @@ (X11Context dpy root _) <- ask sendCustomEvent dpy cmd cmd root win --- | Build a new X11Context containing the current X11 display and its root +-- | Build a new @X11Context@ containing the current X11 display and its root -- window. getDefaultCtx :: IO X11Context getDefaultCtx = do @@ -210,19 +211,6 @@ cache <- MV.newMVar [] return $ X11Context d w cache -getWindowStateProperty :: X11Window -> String -> X11Property Bool -getWindowStateProperty window property = not . null <$> getWindowState window [property] - -getWindowState :: X11Window -> [String] -> X11Property [String] -getWindowState window request = do - let getAsLong s = fromIntegral <$> getAtom s - integers <- mapM getAsLong request - properties <- fetch getWindowProperty32 (Just window) "_NET_WM_STATE" - let integerToString = zip integers request - present = intersect integers $ fromMaybe [] properties - presentStrings = map (`lookup` integerToString) present - return $ catMaybes presentStrings - -- | Apply the given function to the given window in order to obtain the X11 -- property with the given name, or Nothing if no such property can be read. fetch :: (Integral a) @@ -241,8 +229,8 @@ (X11Context d _ _) <- ask liftIO $ getWMHints d window --- | Emit an event of type @ClientMessage@ that can be listened to and --- consumed by XMonad event hooks. +-- | Emit an event of type @ClientMessage@ that can be listened to and consumed +-- by XMonad event hooks. sendCustomEvent :: Display -> Atom -> Atom @@ -256,18 +244,23 @@ sendEvent dpy root False structureNotifyMask e sync dpy False +-- | Post the provided X11Property to taffybar's dedicated X11 thread, and wait +-- for the result. The provided default value will be returned in the case of an +-- error. postX11RequestSyncProp :: X11Property a -> a -> X11Property a postX11RequestSyncProp prop def = do c <- ask let action = runReaderT prop c lift $ postX11RequestSyncDef def action +-- | X11Property which reflects whether or not the provided RROutput is active. isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool isActiveOutput sres output = do (X11Context display _ _) <- ask maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0 +-- | Return all the active RR outputs. getActiveOutputs :: X11Property [RROutput] getActiveOutputs = do (X11Context display rootw _) <- ask @@ -283,6 +276,7 @@ outputs <- getActiveOutputs return $ primary `elemIndex` outputs +-- | Move the X11Windows to the bottom of the X11 window stack. doLowerWindow :: X11Window -> X11Property () doLowerWindow window = asks contextDisplay >>= lift . flip lowerWindow window diff --git a/src/System/Taffybar/Information/XDG/DesktopEntry.hs b/src/System/Taffybar/Information/XDG/DesktopEntry.hs --- a/src/System/Taffybar/Information/XDG/DesktopEntry.hs +++ b/src/System/Taffybar/Information/XDG/DesktopEntry.hs @@ -25,7 +25,6 @@ , deOnlyShowIn , existingDirs , getDefaultConfigHome - , getDefaultDataHome , getDirectoryEntriesDefault , getDirectoryEntry , getDirectoryEntryDefault @@ -41,13 +40,13 @@ import Data.List import Data.Maybe import System.Directory -import System.Environment import System.FilePath.Posix import System.Log.Logger import System.Posix.Files import Text.Printf import Text.Read (readMaybe) +logHere :: Priority -> String -> IO () logHere = logM "System.Taffybar.Information.XDG.DesktopEntry" data DesktopEntryType = Application | Link | Directory @@ -61,23 +60,8 @@ h <- getHomeDirectory return $ h ".config" -getDefaultDataHome :: IO FilePath -getDefaultDataHome = do - h <- getHomeDirectory - return $ h ".local" "share" - - --- XXX: We really ought to use --- https://hackage.haskell.org/package/directory-1.3.2.2/docs/System-Directory.html#v:getXdgDirectory getXDGDataDirs :: IO [FilePath] -getXDGDataDirs = do - dataHome <- lookupEnv "XDG_DATA_HOME" >>= maybe getDefaultDataHome return - dataDirs <- map normalise . splitSearchPath . fromMaybe "" <$> - lookupEnv "XDG_DATA_DIRS" - nubBy equalFilePath <$> - existingDirs ( dataHome:dataDirs - ++ ["/usr/local/share", "/usr/share"] - ) +getXDGDataDirs = getXdgDirectoryList XdgDataDirs -- | Desktop Entry. All attributes (key-value-pairs) are stored in an -- association list. @@ -206,8 +190,8 @@ readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry) readDesktopEntry filePath = doReadDesktopEntry >>= either logWarning (return . Just) where - logWarning error = - logHere WARNING (printf "Failed to parse desktop entry at %s" filePath) >> + logWarning err = + logHere WARNING (printf "Failed to parse desktop entry at %s: error: %s" filePath (show err)) >> return Nothing doReadDesktopEntry = runExceptT $ do result <- (join $ liftIO $ CF.readfile CF.emptyCP filePath) >>= diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs --- a/src/System/Taffybar/Information/XDG/Protocol.hs +++ b/src/System/Taffybar/Information/XDG/Protocol.hs @@ -18,12 +18,13 @@ module System.Taffybar.Information.XDG.Protocol ( XDGMenu(..) , DesktopEntryCondition(..) - , readXDGMenu - , matchesCondition - , getXDGDesktop - , getDirectoryDirs , getApplicationEntries + , getDirectoryDirs , getPreferredLanguages + , getXDGDesktop + , getXDGMenuFilenames + , matchesCondition + , readXDGMenu ) where import Control.Applicative @@ -45,25 +46,6 @@ import Text.XML.Light import Text.XML.Light.Helpers --- Environment Variables - --- | Produce a list of config locations to search, starting with --- XDG_CONFIG_HOME (or $HOME/.config) and XDG_CONFIG_DIRS, with --- fallback to /etc/xdg -getXDGConfigDirs :: IO [String] -getXDGConfigDirs = do - mXdgConfigHome <- fromMaybe "" <$> - lookupEnv "XDG_CONFIG_HOME" - xdgConfigHome <- if null mXdgConfigHome - then getDefaultConfigHome - else return mXdgConfigHome - xdgConfigDirs <- maybe [] splitSearchPath <$> - lookupEnv "XDG_CONFIG_DIRS" - let xdgDirs = if null xdgConfigDirs - then ["/etc/xdg/"] - else xdgConfigDirs - existingDirs $ map normalise $ xdgConfigHome : xdgDirs - getXDGMenuPrefix :: IO (Maybe String) getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX" @@ -74,7 +56,7 @@ -- 'Just "mate-"'). -> IO [FilePath] getXDGMenuFilenames mMenuPrefix = do - configDirs <- getXDGConfigDirs + configDirs <- getXdgDirectoryList XdgConfigDirs maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix let maybeAddDash t = if last t == '-' then t else t ++ "-" dashedPrefix = maybe "" maybeAddDash maybePrefix diff --git a/src/System/Taffybar/LogFormatter.hs b/src/System/Taffybar/LogFormatter.hs --- a/src/System/Taffybar/LogFormatter.hs +++ b/src/System/Taffybar/LogFormatter.hs @@ -18,6 +18,8 @@ import System.IO import Data.Monoid +import Prelude + setColor :: Color -> String setColor color = setSGRCode [SetColor Foreground Vivid color] @@ -34,15 +36,17 @@ reset :: String reset = setSGRCode [Reset] +colorize :: Color -> String -> String colorize color txt = setColor color <> txt <> reset taffyLogFormatter :: LogFormatter a -taffyLogFormatter _ (priority, msg) name = +taffyLogFormatter _ (level, msg) name = return $ printf "%s %s - %s" colorizedPriority colorizedName msg - where priorityColor = priorityToColor priority + where priorityColor = priorityToColor level colorizedPriority = colorize priorityColor - ("[" <> show priority <> "]") + ("[" <> show level <> "]") colorizedName = colorize Green name +taffyLogHandler :: IO (GenericHandler Handle) taffyLogHandler = setFormatter <$> streamHandler stderr DEBUG where setFormatter h = h { formatter = taffyLogFormatter } diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs --- a/src/System/Taffybar/Util.hs +++ b/src/System/Taffybar/Util.hs @@ -125,8 +125,7 @@ where combineOptions v v1 = maybeTCombine (a v v1) (b v v1) catchGErrorsAsLeft :: IO a -> IO (Either GError a) -catchGErrorsAsLeft action = catch (Right <$> action) mkLeft - where mkLeft err = return $ Left err +catchGErrorsAsLeft action = catch (Right <$> action) (return . Left) safePixbufNewFromFile :: FilePath -> IO (Either GError Gdk.Pixbuf) safePixbufNewFromFile filepath = diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs --- a/src/System/Taffybar/Widget.hs +++ b/src/System/Taffybar/Widget.hs @@ -4,33 +4,28 @@ , module System.Taffybar.Widget.Battery -- * "System.Taffybar.Widget.CPUMonitor" - , cpuMonitorNew + , module System.Taffybar.Widget.CPUMonitor -- * "System.Taffybar.Widget.CommandRunner" - , commandRunnerNew + , module System.Taffybar.Widget.CommandRunner -- * "System.Taffybar.Widget.Decorators" , module System.Taffybar.Widget.Decorators -- * "System.Taffybar.Widget.DiskIOMonitor" - , dioMonitorNew + , module System.Taffybar.Widget.DiskIOMonitor -- * "System.Taffybar.Widget.FSMonitor" - , fsMonitorNew + , module System.Taffybar.Widget.FSMonitor -- * "System.Taffybar.Widget.FreedesktopNotifications" - , Notification(..) - , NotificationConfig(..) - , defaultNotificationConfig - , notifyAreaNew + , module System.Taffybar.Widget.FreedesktopNotifications -- * "System.Taffybar.Widget.Layout" - , LayoutConfig(..) - , defaultLayoutConfig - , layoutNew + , module System.Taffybar.Widget.Layout -- * "System.Taffybar.Widget.MPRIS2" - , mpris2New + , module System.Taffybar.Widget.MPRIS2 -- * "System.Taffybar.Widget.NetworkGraph" , module System.Taffybar.Widget.NetworkGraph @@ -42,7 +37,7 @@ , module System.Taffybar.Widget.SimpleClock -- * "System.Taffybar.Widget.SimpleCommandButton" - , simpleCommandButtonNew + , module System.Taffybar.Widget.SimpleCommandButton -- * "System.Taffybar.Widget.Text.CPUMonitor" , module System.Taffybar.Widget.Text.CPUMonitor @@ -54,19 +49,10 @@ , module System.Taffybar.Widget.Text.NetworkMonitor -- * "System.Taffybar.Widget.Weather" - , WeatherConfig(..) - , WeatherInfo(..) - , WeatherFormatter(WeatherFormatter) - , weatherNew - , weatherCustomNew - , defaultWeatherConfig + , module System.Taffybar.Widget.Weather -- * "System.Taffybar.Widget.Windows" - , windowsNew - , WindowsConfig(..) - , defaultWindowsConfig - , truncatedGetActiveLabel - , truncatedGetMenuLabel + , module System.Taffybar.Widget.Windows -- * "System.Taffybar.Widget.Workspaces" , module System.Taffybar.Widget.Workspaces diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs --- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs +++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs @@ -49,6 +49,8 @@ import qualified GI.Pango as Pango import System.Taffybar.Util +import Prelude + -- | A simple structure representing a Freedesktop notification data Notification = Notification { noteAppName :: Text diff --git a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs --- a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs +++ b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs @@ -6,6 +6,7 @@ import Control.Monad.IO.Class import Data.Int import Data.Maybe +import qualified Data.Text as T import qualified GI.Gdk as Gdk import GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk @@ -166,3 +167,21 @@ (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation)) orientation return image + +-- | Make a new "Gtk.MenuItem" that has both a label and an icon. +imageMenuItemNew + :: MonadIO m + => T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem +imageMenuItemNew labelText pixbufGetter = do + box <- Gtk.boxNew Gtk.OrientationHorizontal 0 + label <- Gtk.labelNew $ Just labelText + image <- Gtk.imageNew + void $ autoSizeImage image pixbufGetter Gtk.OrientationHorizontal + item <- Gtk.menuItemNew + Gtk.containerAdd box image + Gtk.containerAdd box label + Gtk.containerAdd item box + Gtk.widgetSetHalign box Gtk.AlignStart + Gtk.widgetSetHalign image Gtk.AlignStart + Gtk.widgetSetValign box Gtk.AlignFill + return item diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs --- a/src/System/Taffybar/Widget/Generic/Graph.hs +++ b/src/System/Taffybar/Widget/Generic/Graph.hs @@ -1,15 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} --- | This is a graph widget inspired by the widget of the same name in --- Awesome (the window manager). It plots a series of data points --- similarly to a bar graph. This version must be explicitly fed data --- with 'graphAddSample'. For a more automated version, see --- 'PollingGraph'. +-- | This is a graph widget inspired by the widget of the same name in Awesome +-- (the window manager). It plots a series of data points similarly to a bar +-- graph. This version must be explicitly fed data with 'graphAddSample'. For a +-- more automated version, see 'PollingGraph'. -- --- Like Awesome, this graph can plot multiple data sets in one widget. --- The data sets are plotted in the order provided by the caller. +-- Like Awesome, this graph can plot multiple data sets in one widget. The data +-- sets are plotted in the order provided by the caller. -- --- Note: all of the data fed to this widget should be in the range --- [0,1]. +-- Note: all of the data fed to this widget should be in the range [0,1]. module System.Taffybar.Widget.Generic.Graph ( -- * Types GraphHandle @@ -49,14 +47,14 @@ type RGBA = (Double, Double, Double, Double) --- | The style of the graph. Generally, you will want to draw all 'Area' graphs first, and then all 'Line' graphs. +-- | The style of the graph. Generally, you will want to draw all 'Area' graphs +-- first, and then all 'Line' graphs. data GraphStyle = Area -- ^ Thea area below the value is filled | Line -- ^ The values are connected by a line (one pixel wide) --- | The configuration options for the graph. The padding is the --- number of pixels reserved as blank space around the widget in each --- direction. +-- | The configuration options for the graph. The padding is the number of +-- pixels reserved as blank space around the widget in each direction. data GraphConfig = GraphConfig { -- | Number of pixels of padding on each side of the graph widget graphPadding :: Int @@ -95,8 +93,8 @@ , graphDirection = LEFT_TO_RIGHT } --- | Add a data point to the graph for each of the tracked data sets. --- There should be as many values in the list as there are data sets. +-- | Add a data point to the graph for each of the tracked data sets. There +-- should be as many values in the list as there are data sets. graphAddSample :: GraphHandle -> [Double] -> IO () graphAddSample (GH mv) rawData = do s <- readMVar mv @@ -134,14 +132,14 @@ C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad) C.fill - -- Draw a frame around the widget area - -- (unless equal to background color, which likely means the user does not - -- want a frame) + -- Draw a frame around the widget area (unless equal to background color, + -- which likely means the user does not want a frame) when (graphBorderWidth cfg > 0) $ do let p = fromIntegral (graphBorderWidth cfg) C.setLineWidth p C.setSourceRGBA frameR frameG frameB frameA - C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw - 2 * fpad - p) (fh - 2 * fpad - p) + C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) + (fw - 2 * fpad - p) (fh - 2 * fpad - p) C.stroke @@ -154,16 +152,17 @@ let pad = fromIntegral $ graphPadding cfg let framePad = fromIntegral $ graphBorderWidth cfg - -- Make the new origin be inside the frame and then scale the - -- drawing area so that all operations in terms of width and height - -- are inside the drawn frame. + -- Make the new origin be inside the frame and then scale the drawing area so + -- that all operations in terms of width and height are inside the drawn + -- frame. C.translate (pad + framePad) (pad + framePad) let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h C.scale xS yS -- If right-to-left direction is requested, apply an horizontal inversion - -- transformation with an offset to the right equal to the width of the widget. + -- transformation with an offset to the right equal to the width of the + -- widget. when (graphDirection cfg == RIGHT_TO_LEFT) $ C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0 @@ -190,7 +189,8 @@ C.stroke - sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg) + sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) + (graphDataStyles cfg) drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawBorder mv drawArea = do @@ -227,7 +227,8 @@ } Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1) - _ <- Gtk.onWidgetDraw drawArea (\ctx -> renderWithContext (drawGraph mv drawArea) ctx >> return True) + _ <- Gtk.onWidgetDraw drawArea $ \ctx -> renderWithContext + (drawGraph mv drawArea) ctx >> return True box <- Gtk.boxNew Gtk.OrientationHorizontal 1 case graphLabel cfg of diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs --- a/src/System/Taffybar/Widget/Layout.hs +++ b/src/System/Taffybar/Widget/Layout.hs @@ -80,7 +80,7 @@ markup <- formatLayout config (T.pack layout) lift $ Gtk.labelSetMarkup label markup - subscription <- subscribeToEvents [xLayoutProp] callback + subscription <- subscribeToPropertyEvents [xLayoutProp] callback do ebox <- Gtk.eventBoxNew diff --git a/src/System/Taffybar/Widget/SimpleCommandButton.hs b/src/System/Taffybar/Widget/SimpleCommandButton.hs --- a/src/System/Taffybar/Widget/SimpleCommandButton.hs +++ b/src/System/Taffybar/Widget/SimpleCommandButton.hs @@ -35,12 +35,13 @@ -- Now you can use @cmdButton@ like any other Taffybar widget. -- | Creates a new simple command button. -simpleCommandButtonNew :: MonadIO m => - T.Text -- ^ Contents of the button's label. - -> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path - -> m Widget +simpleCommandButtonNew + :: MonadIO m + => T.Text -- ^ Contents of the button's label. + -> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path + -> m Widget simpleCommandButtonNew txt cmd = do - but <- buttonNewWithLabel txt - _ <- onButtonClicked but $ spawnCommand (T.unpack cmd) >> return () - toWidget but + button <- buttonNewWithLabel txt + _ <- onButtonClicked button $ spawnCommand (T.unpack cmd) >> return () + toWidget button diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs --- a/src/System/Taffybar/Widget/Util.hs +++ b/src/System/Taffybar/Widget/Util.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Util --- Copyright : (c) José A. Romero L. +-- Copyright : (c) Ivan Malison -- License : BSD3-style (see LICENSE) -- --- Maintainer : José A. Romero L. +-- Maintainer : Ivan Malison -- Stability : unstable -- Portability : unportable -- @@ -20,10 +21,11 @@ import Data.Functor ( ($>) ) import Data.Int import qualified Data.Text as T +import qualified GI.Gdk as D import qualified GI.GdkPixbuf.Objects.Pixbuf as GI import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import GI.Gtk as Gtk -import qualified GI.Gdk as D +import StatusNotifier.Tray (scalePixbufToSize) import System.FilePath.Posix import System.Taffybar.Information.XDG.DesktopEntry import System.Taffybar.Util @@ -64,7 +66,7 @@ where getWindow :: IO (Maybe Window) getWindow = do - windowGType <- gobjectType (undefined :: Window) + windowGType <- gobjectType @Window Just ancestor <- Gtk.widgetGetAncestor widget windowGType castTo Window ancestor @@ -122,10 +124,17 @@ ] getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf) -getImageForDesktopEntry size entry = fmap join $ traverse run $ deIcon entry - where run iconName = - maybeTCombine (loadPixbufByName size $ T.pack iconName) - (getPixbufFromFilePath iconName) +getImageForDesktopEntry size de = getImageForMaybeIconName (T.pack <$> deIcon de) size + +getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf) +getImageForMaybeIconName mIconName size = + join <$> (sequenceA $ flip getImageForIconName size <$> mIconName) + +getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf) +getImageForIconName iconName size = + maybeTCombine (loadPixbufByName size $ iconName) + (getPixbufFromFilePath (T.unpack iconName) >>= + traverse (scalePixbufToSize size Gtk.OrientationHorizontal)) loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf) loadPixbufByName size name = do diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs --- a/src/System/Taffybar/Widget/Windows.hs +++ b/src/System/Taffybar/Widget/Windows.hs @@ -71,7 +71,9 @@ let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label title activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle - subscription <- subscribeToEvents ["_NET_ACTIVE_WINDOW"] activeWindowUpdatedCallback + subscription <- + subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass] + activeWindowUpdatedCallback _ <- liftReader (Gtk.onWidgetUnrealize label) (unsubscribe subscription) context <- ask diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs --- a/src/System/Taffybar/Widget/Workspaces.hs +++ b/src/System/Taffybar/Widget/Workspaces.hs @@ -24,8 +24,9 @@ import Control.Monad.Trans.Reader import Control.RateLimit import qualified Data.Foldable as F +import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int -import Data.List (intersect, sortBy) +import Data.List (intersect, sortBy, (\\)) import qualified Data.Map as M import Data.Maybe import qualified Data.MultiMap as MM @@ -79,15 +80,15 @@ data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window] data Workspace = Workspace - { workspaceIdx :: WorkspaceIdx + { workspaceIdx :: WorkspaceId , workspaceName :: String , workspaceState :: WorkspaceState , windows :: [WindowData] } deriving (Show, Eq) data WorkspacesContext = WorkspacesContext - { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC) - , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace) + { controllersVar :: MV.MVar (M.Map WorkspaceId WWC) + , workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace) , workspacesWidget :: Gtk.Box , workspacesConfig :: WorkspacesConfig , taffyContext :: Context @@ -177,14 +178,7 @@ , showWorkspaceFn = const True , borderWidth = 2 , iconSort = sortWindowsByPosition - , updateEvents = - [ "WM_HINTS" - , "_NET_CURRENT_DESKTOP" - , "_NET_DESKTOP_NAMES" - , "_NET_NUMBER_OF_DESKTOPS" - , "_NET_WM_DESKTOP" - , "_NET_WM_STATE_HIDDEN" - ] + , updateEvents = allEWMHProperties \\ [ewmhWMIcon] , updateRateLimitMicroseconds = 100000 , urgentWorkspaceState = False } @@ -201,45 +195,45 @@ ctx <- ask lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify -updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceIdx Workspace) +updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace) updateWorkspacesVar = do workspacesRef <- asks workspacesVar updateVar workspacesRef buildWorkspaceData getWorkspaceToWindows :: - [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window) + [X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window) getWorkspaceToWindows = foldM (\theMap window -> MM.insert <$> getWorkspace window <*> pure window <*> pure theMap) MM.empty -getWindowData :: [X11Window] +getWindowData :: Maybe X11Window -> [X11Window] -> X11Window -> X11Property WindowData -getWindowData activeWindows urgentWindows window = do +getWindowData activeWindow urgentWindows window = do wTitle <- getWindowTitle window wClass <- getWindowClass window - wMinimized <- getWindowStateProperty window "_NET_WM_STATE_HIDDEN" + wMinimized <- getWindowMinimized window return WindowData { windowId = window , windowTitle = wTitle , windowClass = wClass , windowUrgent = window `elem` urgentWindows - , windowActive = window `elem` activeWindows + , windowActive = Just window == activeWindow , windowMinimized = wMinimized } -buildWorkspaceData :: M.Map WorkspaceIdx Workspace - -> WorkspacesIO (M.Map WorkspaceIdx Workspace) +buildWorkspaceData :: M.Map WorkspaceId Workspace + -> WorkspacesIO (M.Map WorkspaceId Workspace) buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do names <- getWorkspaceNames wins <- getWindows workspaceToWindows <- getWorkspaceToWindows wins urgentWindows <- filterM isWindowUrgent wins - activeWindows <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW" + activeWindow <- getActiveWindow active:visible <- getVisibleWorkspaces let getWorkspaceState idx ws | idx == active = Active @@ -252,7 +246,7 @@ foldM (\theMap (idx, name) -> do let ws = MM.lookup idx workspaceToWindows - windowInfos <- mapM (getWindowData activeWindows urgentWindows) ws + windowInfos <- mapM (getWindowData activeWindow urgentWindows) ws return $ M.insert idx @@ -287,10 +281,10 @@ -- widgets appear out of order, in the switcher, by acting as an empty -- place holder when the actual widget is hidden. hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0 - parent <- Gtk.widgetGetParent workspaceWidget - if isJust parent - then Gtk.widgetReparent workspaceWidget hbox - else Gtk.containerAdd hbox workspaceWidget + void $ Gtk.widgetGetParent workspaceWidget >>= + traverse (unsafeCastTo Gtk.Box) >>= + traverse (flip Gtk.containerRemove workspaceWidget) + Gtk.containerAdd hbox workspaceWidget Gtk.containerAdd cont hbox workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget @@ -310,13 +304,21 @@ runReaderT updateAllWorkspaceWidgets context updateHandler <- onWorkspaceUpdate context iconHandler <- onIconsChanged context - (workspaceSubscription, iconSubscription) <- + let doUpdate = lift . updateHandler + handleConfigureEvents e@(ConfigureEvent {}) = doUpdate e + handleConfigureEvents _ = return () + (workspaceSubscription, iconSubscription, geometrySubscription) <- flip runReaderT tContext $ sequenceT - ( subscribeToEvents (updateEvents cfg) $ lift . updateHandler - , subscribeToEvents ["_NET_WM_ICON"] (lift . onIconChanged iconHandler) + ( subscribeToPropertyEvents (updateEvents cfg) $ doUpdate + , subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler) + , subscribeToAll handleConfigureEvents ) let doUnsubscribe = flip runReaderT tContext $ - mapM_ unsubscribe [iconSubscription, workspaceSubscription] + mapM_ unsubscribe + [ iconSubscription + , workspaceSubscription + , geometrySubscription + ] _ <- Gtk.onWidgetUnrealize cont doUnsubscribe _ <- widgetSetClassGI cont "workspaces" Gtk.toWidget cont @@ -366,7 +368,7 @@ (M.lookup (workspaceIdx ws) controllersMap) >>= maybe (return ()) action -doWidgetUpdate :: (WorkspaceIdx -> WWC -> WorkspacesIO WWC) -> WorkspacesIO () +doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO () doWidgetUpdate updateController = do c@WorkspacesContext { controllersVar = controllersRef } <- ask lift $ MV.modifyMVar_ controllersRef $ \controllers -> do @@ -791,7 +793,7 @@ WorkspaceButtonController {button = ebox, buttonWorkspace = workspace, contentsController = cc} -switch :: (MonadIO m) => WorkspacesContext -> WorkspaceIdx -> m Bool +switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool switch ctx idx = do liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx return True diff --git a/src/System/Taffybar/Widget/XDGMenu/Menu.hs b/src/System/Taffybar/Widget/XDGMenu/Menu.hs --- a/src/System/Taffybar/Widget/XDGMenu/Menu.hs +++ b/src/System/Taffybar/Widget/XDGMenu/Menu.hs @@ -37,7 +37,7 @@ , fmSubmenus :: [Menu] , fmEntries :: [MenuEntry] , fmOnlyUnallocated :: Bool - } deriving (Show) + } deriving (Eq, Show) -- | Displayable menu entry data MenuEntry = MenuEntry diff --git a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs --- a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs +++ b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs @@ -26,12 +26,11 @@ import Control.Monad import Control.Monad.IO.Class import qualified Data.Text as T -import GI.GdkPixbuf -import GI.Gtk hiding (Menu) -import System.Directory -import System.FilePath.Posix +import GI.Gtk hiding (Menu, imageMenuItemNew) import System.Log.Logger import System.Process +import System.Taffybar.Widget.Generic.AutoSizeImage +import System.Taffybar.Widget.Util import System.Taffybar.Widget.XDGMenu.Menu -- $usage @@ -43,22 +42,22 @@ -- > main = do -- > let menu = menuWidgetNew $ Just "PREFIX-" -- --- The menu will look for a file named "PREFIX-applications.menu" in --- the (subdirectory "menus" of the) directories specified by the --- environment variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If --- XDG_CONFIG_HOME is not set or empty then $HOME/.config is used, if --- XDG_CONFIG_DIRS is not set or empty then "/etc/xdg" is used). If --- no prefix is given (i.e. if you pass Nothing) then the value of the --- environment variable XDG_MENU_PREFIX is used, if it is set. If --- taffybar is running inside a desktop environment like Mate, Gnome, --- XFCE etc. the environment variables XDG_CONFIG_DIRS and --- XDG_MENU_PREFIX should be set and you may create the menu like --- this: +-- The menu will look for a file named "PREFIX-applications.menu" in the +-- (subdirectory "menus" of the) directories specified by the environment +-- variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If XDG_CONFIG_HOME is not set +-- or empty then $HOME/.config is used, if XDG_CONFIG_DIRS is not set or empty +-- then "/etc/xdg" is used). If no prefix is given (i.e. if you pass Nothing) +-- then the value of the environment variable XDG_MENU_PREFIX is used, if it is +-- set. If taffybar is running inside a desktop environment like Mate, Gnome, +-- XFCE etc. the environment variables XDG_CONFIG_DIRS and XDG_MENU_PREFIX +-- should be set and you may create the menu like this: -- -- > let menu = menuWidgetNew Nothing -- -- Now you can use @menu@ as any other Taffybar widget. +logHere :: Priority -> String -> IO () +logHere = logM "System.Taffybar.Widget.XDGMenu.MenuWidget" -- | Add a desktop entry to a gtk menu by appending a gtk menu item. addItem :: (IsMenuShell msc) => @@ -66,61 +65,39 @@ -> MenuEntry -- ^ Desktop entry -> IO () addItem ms de = do - item <- imageMenuItemNewWithLabel (feName de) + item <- imageMenuItemNew (feName de) (getImageForMaybeIconName (feIcon de)) setWidgetTooltipText item (feComment de) - setIcon item (T.unpack <$> feIcon de) menuShellAppend ms item _ <- onMenuItemActivate item $ do let cmd = feCommand de - logM "System.Taffybar.Widget.XDGMenu.MenuWidget" DEBUG $ "Launching '" ++ cmd ++ "'" + logHere DEBUG $ "Launching '" ++ cmd ++ "'" _ <- spawnCommand cmd return () return () --- | Add an xdg menu to a gtk menu by appending gtk menu items and --- submenus. -addMenu :: (IsMenuShell msc) => - msc -- ^ GTK menu - -> Menu -- ^ menu - -> IO () +-- | Add an xdg menu to a gtk menu by appending gtk menu items and submenus. +addMenu + :: (IsMenuShell msc) + => msc -- ^ A GTK menu + -> Menu -- ^ A menu object + -> IO () addMenu ms fm = do let subMenus = fmSubmenus fm items = fmEntries fm when (not (null items) || not (null subMenus)) $ do - item <- imageMenuItemNewWithLabel (T.pack $ fmName fm) - setIcon item (fmIcon fm) + item <- imageMenuItemNew (T.pack $ fmName fm) + (getImageForMaybeIconName (T.pack <$> fmIcon fm)) menuShellAppend ms item subMenu <- menuNew menuItemSetSubmenu item (Just subMenu) mapM_ (addMenu subMenu) subMenus mapM_ (addItem subMenu) items -setIcon :: ImageMenuItem -> Maybe String -> IO () -setIcon _ Nothing = return () -setIcon item (Just iconName) = do - iconTheme <- iconThemeGetDefault - hasIcon <- iconThemeHasIcon iconTheme (T.pack iconName) - mImg <- if hasIcon - then Just <$> imageNewFromIconName (Just $ T.pack iconName) (fromIntegral $ fromEnum IconSizeMenu) - else if isAbsolute iconName - then - do - ex <- doesFileExist iconName - if ex - then do let defaultSize = 24 -- FIXME should auto-adjust to font size - pb <- pixbufNewFromFileAtScale iconName - defaultSize defaultSize True - Just <$> imageNewFromPixbuf (Just pb) - else return Nothing - else return Nothing - case mImg of - Just img -> imageMenuItemSetImage item (Just img) - Nothing -> logM "System.Taffybar.Widget.XDGMenu.MenuWidget" WARNING $ "Icon not found: " ++ iconName - -- | Create a new XDG Menu Widget. -menuWidgetNew :: MonadIO m => Maybe String -- ^ menu name, must end with a dash, - -- e.g. "mate-" or "gnome-" - -> m GI.Gtk.Widget +menuWidgetNew + :: MonadIO m + => Maybe String -- ^ menu name, must end with a dash, e.g. "mate-" or "gnome-" + -> m GI.Gtk.Widget menuWidgetNew mMenuPrefix = liftIO $ do mb <- menuBarNew m <- buildMenu mMenuPrefix diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,5 +1,5 @@ name: taffybar -version: 3.2.0 +version: 3.2.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE @@ -16,14 +16,13 @@ extra-source-files: README.md CHANGELOG.md - taffybar.hs.example dbus-xml/org.freedesktop.UPower.Device.xml dbus-xml/org.freedesktop.UPower.xml dbus-xml/org.mpris.MediaPlayer2.Player.xml dbus-xml/org.mpris.MediaPlayer2.xml description: - Taffybar is a gtk+3 (through gtk2hs) based desktop information bar, intended + Taffybar is a gtk+3 (through gi-gtk) based desktop information bar, intended primarily for use with XMonad, though it can also function alongside other EWMH compliant window managers. It is similar in spirit to xmobar, but it differs in that it gives up some simplicity for a reasonable helping of eye candy. @@ -36,6 +35,7 @@ default-extensions: TupleSections StandaloneDeriving + MonoLocalBinds default-language: Haskell2010 build-depends: base > 3 && < 5 @@ -43,7 +43,7 @@ , HStringTemplate >= 0.8 && < 0.9 , X11 >= 1.5.0.1 , ansi-terminal - , broadcast-chan >= 0.2.0.0 + , broadcast-chan >= 0.2.0.2 , bytestring , containers , dbus >= 1.2.1 && < 2.0.0 @@ -65,8 +65,8 @@ , gi-pango , gtk-sni-tray >= 0.1.5.0 , gtk-strut >= 0.1.2.1 - , haskell-gi >= 0.21.2 - , haskell-gi-base >= 0.21.1 + , haskell-gi >= 0.22.6 + , haskell-gi-base >= 0.22.2 , hslogger , http-client >= 0.5 , http-client-tls @@ -108,6 +108,7 @@ , System.Taffybar.Context , System.Taffybar.DBus , System.Taffybar.DBus.Toggle + , System.Taffybar.Example , System.Taffybar.Hooks , System.Taffybar.Information.Battery , System.Taffybar.Information.CPU @@ -175,6 +176,7 @@ executable taffybar default-language: Haskell2010 build-depends: base > 3 && < 5 + , directory , hslogger , optparse-applicative , taffybar diff --git a/taffybar.css b/taffybar.css --- a/taffybar.css +++ b/taffybar.css @@ -13,9 +13,9 @@ .taffy-window * { /* - This removes any existing styling from UI elements. Taffybar will not cohere - with your gtk theme. - */ + This removes any existing styling from UI elements. Taffybar will not + cohere with your gtk theme. + */ all: unset; font-family: "Noto Sans", sans-serif; @@ -82,7 +82,7 @@ } .window-icon-container.inactive .window-icon { - padding: 0px; + padding: 0px; } .window-icon-container.minimized .window-icon { diff --git a/taffybar.hs.example b/taffybar.hs.example deleted file mode 100644 --- a/taffybar.hs.example +++ /dev/null @@ -1,90 +0,0 @@ --- -*- mode:haskell -*- -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import System.Taffybar -import System.Taffybar.Hooks -import System.Taffybar.Information.CPU -import System.Taffybar.Information.Memory -import System.Taffybar.SimpleConfig -import System.Taffybar.Widget -import System.Taffybar.Widget.Generic.PollingGraph -import System.Taffybar.Widget.Generic.PollingLabel -import System.Taffybar.Widget.Util -import System.Taffybar.Widget.Workspaces - -transparent = (0.0, 0.0, 0.0, 0.0) -yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0) -yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0) -green1 = (0, 1, 0, 1) -green2 = (1, 0, 1, 0.5) -taffyBlue = (0.129, 0.588, 0.953, 1) - -myGraphConfig = - defaultGraphConfig - { graphPadding = 0 - , graphBorderWidth = 0 - , graphWidth = 75 - , graphBackgroundColor = transparent - } - -netCfg = myGraphConfig - { graphDataColors = [yellow1, yellow2] - , graphLabel = Just "net" - } - -memCfg = myGraphConfig - { graphDataColors = [taffyBlue] - , graphLabel = Just "mem" - } - -cpuCfg = myGraphConfig - { graphDataColors = [green1, green2] - , graphLabel = Just "cpu" - } - -memCallback :: IO [Double] -memCallback = do - mi <- parseMeminfo - return [memoryUsedRatio mi] - -cpuCallback = do - (_, systemLoad, totalLoad) <- cpuLoad - return [totalLoad, systemLoad] - -main = do - let myWorkspacesConfig = - defaultWorkspacesConfig - { minIcons = 1 - , widgetGap = 0 - , showWorkspaceFn = hideEmpty - } - workspaces = workspacesNew myWorkspacesConfig - cpu = pollingGraphNew cpuCfg 0.5 cpuCallback - mem = pollingGraphNew memCfg 1 memCallback - net = networkGraphNew netCfg Nothing - clock = textClockNewWith defaultClockConfig - layout = layoutNew defaultLayoutConfig - windows = windowsNew defaultWindowsConfig - -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher - -- for a better way to set up the sni tray - tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt - myConfig = defaultSimpleTaffyConfig - { startWidgets = - workspaces : map (>>= buildContentsBox) [ layout, windows ] - , endWidgets = map (>>= buildContentsBox) - [ batteryIconNew - , clock - , tray - , cpu - , mem - , net - , mpris2New - ] - , barPosition = Top - , barPadding = 10 - , barHeight = 50 - , widgetSpacing = 0 - } - dyreTaffybar $ withBatteryRefresh $ withLogServer $ withToggleServer $ - toTaffyConfig myConfig