taffybar 3.3.0 → 4.0.0
raw patch · 36 files changed
+1359/−406 lines, 36 filesdep +aesondep +conduitdep +data-defaultdep ~dyre
Dependencies added: aeson, conduit, data-default, http-conduit
Dependency ranges changed: dyre
Files
- CHANGELOG.md +92/−1
- README.md +2/−2
- app/Main.hs +3/−1
- src/System/Taffybar.hs +26/−22
- src/System/Taffybar/Context.hs +118/−32
- src/System/Taffybar/DBus/Toggle.hs +4/−7
- src/System/Taffybar/Example.hs +8/−7
- src/System/Taffybar/Hooks.hs +18/−5
- src/System/Taffybar/Information/Battery.hs +17/−6
- src/System/Taffybar/Information/Chrome.hs +1/−1
- src/System/Taffybar/Information/Crypto.hs +120/−0
- src/System/Taffybar/Information/EWMHDesktopInfo.hs +10/−2
- src/System/Taffybar/Information/MPRIS2.hs +2/−1
- src/System/Taffybar/SimpleConfig.hs +44/−24
- src/System/Taffybar/Util.hs +35/−7
- src/System/Taffybar/Widget.hs +9/−3
- src/System/Taffybar/Widget/Battery.hs +68/−19
- src/System/Taffybar/Widget/Crypto.hs +142/−0
- src/System/Taffybar/Widget/Decorators.hs +0/−30
- src/System/Taffybar/Widget/FreedesktopNotifications.hs +6/−3
- src/System/Taffybar/Widget/Generic/ChannelGraph.hs +3/−0
- src/System/Taffybar/Widget/Generic/ChannelWidget.hs +6/−1
- src/System/Taffybar/Widget/Generic/Graph.hs +20/−10
- src/System/Taffybar/Widget/Generic/PollingGraph.hs +14/−4
- src/System/Taffybar/Widget/Layout.hs +5/−1
- src/System/Taffybar/Widget/MPRIS2.hs +203/−83
- src/System/Taffybar/Widget/NetworkGraph.hs +65/−10
- src/System/Taffybar/Widget/SNITray.hs +41/−30
- src/System/Taffybar/Widget/SimpleClock.hs +8/−4
- src/System/Taffybar/Widget/Text/MemoryMonitor.hs +35/−13
- src/System/Taffybar/Widget/Util.hs +50/−11
- src/System/Taffybar/Widget/Weather.hs +4/−4
- src/System/Taffybar/Widget/Windows.hs +9/−3
- src/System/Taffybar/Widget/Workspaces.hs +98/−14
- src/System/Taffybar/Widget/WttrIn.hs +60/−36
- taffybar.cabal +13/−9
CHANGELOG.md view
@@ -1,14 +1,103 @@+# 4.0.0++## Breaking Changes++ * `simpleTaffybar` now starts taffybar using `startTaffybar` instead of+ `dyreTaffybar`. Use `simpleDyreTaffybar` to start taffybar with+ `dyreTaffybar` as before.++ * The `cssPath` fields in 'SimpleTaffyConfig' and 'TaffybarConfig' have been+ renamed to `cssPaths` and have type `[FilePath]` instead of `Maybe Filepath`.++ * The module `System.Taffybar.Widget.Decorators` has been removed. The+ functions that were in that module can now be found in+ `System.Taffybar.Widget.Util`.++ * The `barHeight` property of `SimpleTaffyConfig` is now a `StrutSize`. This+ means that in addition to specifying an exact pixel count for the height of+ taffybar, it is also possible to specify a fraction of the screen that it+ should occupy. See the docs for `StrutSize` for more details.++## New Features++ * A new module `System.Taffybar.Widget.Crypto` that contains widgets that display+ the prices of crypto assets with icons was added.++ * `textBatteryNewLabelAction` provides a version of the text battery widget to+ which a custom label updater function can be provided.++ * The textual battery widget now applies classes according to its charge level+ that can be used to style the battery text with css.++ * A generalized interface to the text battery widget that accepts an arbitrary+ update function is available at `textBatteryNewLabelAction`.++ * New workspace widget builder `buildLabelOverlayController` that overlays the+ workspace label on top of the the workspace icons.++ * It is now possible to customize the player widgets of the MPRIS2 Widget by+ using the new function `mpris2NewWithConfig`.++ * Classes are added to the MPRIS2 Widget to indicate whether or not it has+ visible player children.++ * The default MPRIS2 player widget now sends the play pause message to the+ relevant player when clicked.++ * New `pollingGraphNewWithTooltip` that allows to specify a tooltip.++ * New `networkGraphNewWith` that allows to configure a tooltip format, scaling+ and network interfaces via function.++ * New `showMemoryInfo` exposed from `MemoryMonitor` that can be used to format+ tooltips.++ * Swap variables are added to `MemoryMonitor`.++ * Many types have `Default` instances.++ * Window titles are shown on hover.++ * Allow sorting workspace window icons by _NET_CLIENT_LIST_STACKING.++## Changes++ * Graph labels are now overlayed on top of the graph instead of placed beside+ them.++ * MPRIS2 Widgets will remain visible when their players are in the paused state.++ * `getSongInfo` now doesn't automatically return `Nothing` when `xesam:artist`+ is missing. This makes the MPRIS2 Widget display in more situations than+ before.++ * Network graph will have a tooltip by default.++ * The SNI Tray will respect `ItemIsMenu` property to handle mouse left click.++## Bug Fixes++ * Center widgets will now properly expand vertically.++ * Errors, including icon missing from theme errors, in workspace pixbuf getters+ are now handled gracefully.++ * A workaround to properly display the chrome icon in MPRIS was added.+ # 3.3.0 ## Bug Fixes -* Compatibility with newer versions of GHC.+ * Compatibility with newer versions of GHC. ## New Features * A wttr.in widget was added.+ * Make memoryAvailable action available inside the Text MemoryMonitor widget.+ * The SNI Tray supports triggering Activate and SecondaryActivate on icons.+ * Better formatting for Text MemoryMonitor Widget # 3.2.2@@ -16,7 +105,9 @@ ## Bug Fixes * Solve space leaks on `updateSamples` and `getDeviceUpDown` (#472).+ * Prevent crash when using mpris2New and librsvg is not available (#478).+ * Fixed compilation issues that appear when using ghc 8.8. # 3.2.1
README.md view
@@ -1,6 +1,6 @@-# Taffybar [](https://travis-ci.org/taffybar/taffybar) [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://github.com/taffybar/taffybar/labels/help%20wanted) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE)+# Taffybar -+ [](https://hackage.haskell.org/package/taffybar) [](https://github.com/taffybar/taffybar/compare/latest-release...master) [](http://stackage.org/lts/package/taffybar) [](http://stackage.org/nightly/package/taffybar) [](https://github.com/taffybar/taffybar/labels/help%20wanted) [](https://matrix.to/#/#taffybar:matrix.org) [](https://gitter.im/taffybar/Lobby) [](https://github.com/taffybar/taffybar/blob/master/LICENSE)  Taffybar is a gtk+3 [(through gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop
app/Main.hs view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | This is just a stub executable that uses dyre to read the config file and -- recompile itself. module Main ( main ) where +import Data.Default (def) import Data.Semigroup ((<>)) import Data.Version import Options.Applicative@@ -46,7 +48,7 @@ if configurationExists -- XXX: The configuration record here does not get used, this just calls in to dyre.- then dyreTaffybar defaultTaffybarConfig+ then dyreTaffybar def else do logM "System.Taffybar" WARNING $ ( printf "No taffybar configuration file found at %s." taffyFilepath
src/System/Taffybar.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar@@ -38,6 +39,7 @@ -- configuration might look like (also see "System.Taffybar.Example"): -- -- > {-# LANGUAGE OverloadedStrings #-}+ -- > import Data.Default (def) -- > import System.Taffybar -- > import System.Taffybar.Information.CPU -- > import System.Taffybar.SimpleConfig@@ -50,13 +52,14 @@ -- > return [ totalLoad, systemLoad ] -- > -- > main = do- -- > let cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]- -- > , graphLabel = Just "cpu"- -- > }- -- > clock = textClockNewWith defaultClockConfig+ -- > let cpuCfg = def+ -- > { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]+ -- > , graphLabel = Just "cpu"+ -- > }+ -- > clock = textClockNewWith def -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback- -- > workspaces = workspacesNew defaultWorkspacesConfig- -- > simpleConfig = defaultSimpleTaffyConfig+ -- > workspaces = workspacesNew def+ -- > simpleConfig = def -- > { startWidgets = [ workspaces ] -- > , endWidgets = [ sniTrayNew, clock, cpu ] -- > }@@ -142,11 +145,8 @@ -- | The parameters that are passed to Dyre when taffybar is invoked with -- 'dyreTaffybar'. taffybarDyreParams =- Dyre.defaultParams- { Dyre.projectName = "taffybar"- , Dyre.realMain = dyreTaffybarMain- , Dyre.showError = showError- , Dyre.ghcOpts = ["-threaded", "-rtsopts"]+ (Dyre.newParams "taffybar" dyreTaffybarMain showError)+ { Dyre.ghcOpts = ["-threaded", "-rtsopts"] , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"] } @@ -158,6 +158,7 @@ showError :: TaffybarConfig -> String -> TaffybarConfig showError cfg msg = cfg { errorMsg = Just msg } +-- | The main function that should be run by dyre given a TaffybarConfig. dyreTaffybarMain :: TaffybarConfig -> IO () dyreTaffybarMain cfg = case errorMsg cfg of@@ -172,7 +173,7 @@ return (dataDir </> name) startCSS :: [FilePath] -> IO Gtk.CssProvider-startCSS cssPaths = do+startCSS cssFilePaths = do -- Override the default GTK theme path settings. This causes the -- bar (by design) to ignore the real GTK theme and just use the -- provided minimal theme to set the background and text colors.@@ -183,7 +184,7 @@ doesFileExist filePath >>= flip when (Gtk.cssProviderLoadFromPath taffybarProvider (T.pack filePath)) - mapM_ loadIfExists cssPaths+ mapM_ loadIfExists cssFilePaths Just scr <- Gdk.screenGetDefault Gtk.styleContextAddProviderForScreen scr taffybarProvider 800@@ -197,23 +198,26 @@ defaultUserConfig <- getTaffyFile "taffybar.css" return [defaultUserConfig] --- | Start taffybar with the provided 'TaffybarConfig'. Because this function--- will not handle recompiling taffybar automatically when taffybar.hs is--- updated, it is generally recommended that end users use 'dyreTaffybar'--- instead. If automatic recompilation is handled by another mechanism such as--- stack or a custom user script or not desired for some reason, it is--- perfectly fine to use this function.+-- | Start taffybar with the provided 'TaffybarConfig'. This function will not+-- handle recompiling taffybar automatically when taffybar.hs is updated. If you+-- would like this feature, use 'dyreTaffybar' instead. If automatic+-- recompilation is handled by another mechanism such as stack or a custom user+-- script or not desired for some reason, it is perfectly fine (and probably+-- better) to use this function. startTaffybar :: TaffybarConfig -> IO () startTaffybar config = do- updateGlobalLogger "" $ removeHandler+ updateGlobalLogger "" removeHandler setTaffyLogFormatter "System.Taffybar" setTaffyLogFormatter "StatusNotifier" _ <- initThreads _ <- Gtk.init Nothing GIThreading.setCurrentThreadAsGUIThread defaultCSS <- getDataFile "taffybar.css"- cssPaths <- maybe getDefaultCSSPaths (return . return) $ cssPath config- _ <- startCSS $ defaultCSS:cssPaths+ cssPathsToLoad <-+ if null $ cssPaths config+ then getDefaultCSSPaths+ else return $ cssPaths config+ _ <- startCSS $ defaultCSS:cssPathsToLoad _ <- buildContext config Gtk.main
src/System/Taffybar/Context.hs view
@@ -14,9 +14,37 @@ -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable+--+-- The "System.Taffybar.Context" module provides the core functionality of the+-- taffybar library. It gets its name from the 'Context' record, which stores+-- runtime information and objects, which are used by many of the widgets that+-- taffybar provides. 'Context' is typically accessed through the 'Reader'+-- interface of 'TaffyIO'. ----------------------------------------------------------------------------- -module System.Taffybar.Context where+module System.Taffybar.Context+ ( Context(..)+ , TaffybarConfig(..)+ , Taffy+ , TaffyIO+ , BarConfig(..)+ , BarConfigGetter+ , appendHook+ , buildContext+ , buildEmptyContext+ , defaultTaffybarConfig+ , getState+ , getStateDefault+ , putState+ , forceRefreshTaffyWindows+ , refreshTaffyWindows+ , runX11+ , runX11Def+ , subscribeToAll+ , subscribeToPropertyEvents+ , taffyFork+ , unsubscribe+ ) where import Control.Arrow ((&&&)) import Control.Concurrent (forkIO)@@ -29,10 +57,12 @@ import Control.Monad.Trans.Reader import qualified DBus.Client as DBus import Data.Data+import Data.Default (Default(..)) import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List import qualified Data.Map as M+import qualified Data.Text as T import Data.Tuple.Select import Data.Tuple.Sequence import Data.Unique@@ -56,8 +86,13 @@ logC :: MonadIO m => System.Log.Logger.Priority -> String -> m () logC p = liftIO . logIO p -type Taffy m v = MonadIO m => ReaderT Context m v+-- | 'Taffy' is a monad transformer that provides 'Reader' for 'Context'.+type Taffy m v = ReaderT Context m v++-- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the+-- type of most widgets and callback in taffybar. type TaffyIO v = ReaderT Context IO v+ type Listener = Event -> Taffy IO () type SubscriptionList = [(Unique, Listener)] data Value = forall t. Typeable t => Value t@@ -69,12 +104,20 @@ else Nothing +-- | 'BarConfig' specifies the configuration for a single taffybar window. data BarConfig = BarConfig- { strutConfig :: StrutConfig+ {+ -- | The strut configuration to use for the bar+ strutConfig :: StrutConfig+ -- | The amount of spacing in pixels between bar widgets , widgetSpacing :: Int32+ -- | Constructors for widgets that should be placed at the beginning of the bar. , startWidgets :: [TaffyIO Gtk.Widget]+ -- | Constructors for widgets that should be placed in the center of the bar. , centerWidgets :: [TaffyIO Gtk.Widget]+ -- | Constructors for widgets that should be placed at the end of the bar. , endWidgets :: [TaffyIO Gtk.Widget]+ -- | A unique identifier for the bar, that can be used e.g. when toggling. , barId :: Unique } @@ -83,27 +126,47 @@ type BarConfigGetter = TaffyIO [BarConfig] +-- | 'TaffybarConfig' provides an advanced interface for configuring taffybar.+-- Through the 'getBarConfigsParam', it is possible to specify different+-- taffybar configurations depending on the number of monitors present, and even+-- to specify different taffybar configurations for each monitor. data TaffybarConfig = TaffybarConfig- { dbusClientParam :: Maybe DBus.Client+ {+ -- | An optional dbus client to use.+ dbusClientParam :: Maybe DBus.Client+ -- | Hooks that should be executed at taffybar startup. , startupHook :: TaffyIO ()+ -- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element+ -- describes a taffybar window that should be spawned. , getBarConfigsParam :: BarConfigGetter- , cssPath :: Maybe FilePath+ -- | A list of 'FilePath' each of which should be loaded as css files at+ -- startup.+ , cssPaths :: [FilePath]+ -- | A field used (only) by dyre to provide an error message. , errorMsg :: Maybe String } ++-- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given+-- 'TaffybarConfig'. appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig appendHook hook config = config { startupHook = startupHook config >> hook } +-- | Default values for a 'TaffybarConfig'. Not usuable without at least+-- properly setting 'getBarConfigsParam'. defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { dbusClientParam = Nothing , startupHook = return () , getBarConfigsParam = return []- , cssPath = Nothing+ , cssPaths = [] , errorMsg = Nothing } +instance Default TaffybarConfig where+ def = defaultTaffybarConfig+ -- | 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.@@ -113,25 +176,25 @@ 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".+ -- | A collection of miscellaneous pieces of state which are keyed by their+ -- types. Most new pieces 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.+ -- which 'BarConfig' objects they are associated with. , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]- -- | The shared user session "DBus.Client".+ -- | The shared user session 'DBus.Client'. , sessionDBusClient :: DBus.Client- -- | The shared system session "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.+ -- who their neighbors are. Note that the value of 'contextBarConfig' is+ -- different for widgets belonging to bar windows on different monitors. , contextBarConfig :: Maybe BarConfig } @@ -163,7 +226,7 @@ } _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>= (lift . GI.Gdk.displayGetDefaultScreen) >>=- (lift . flip GI.Gdk.afterScreenMonitorsChanged+ (lift . (\x y -> GI.Gdk.afterScreenMonitorsChanged y x) -- XXX: We have to do a force refresh here because there is no -- way to reliably move windows, since the window manager can do -- whatever it pleases.@@ -178,8 +241,11 @@ logIO DEBUG "Context build finished" return context +-- | Build an empty taffybar context. This function is mostly useful for+-- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in+-- a repl). buildEmptyContext :: IO Context-buildEmptyContext = buildContext defaultTaffybarConfig+buildEmptyContext = buildContext def buildBarWindow :: Context -> BarConfig -> IO Gtk.Window buildBarWindow context barConfig = do@@ -189,9 +255,16 @@ show $ strutConfig barConfig window <- Gtk.windowNew Gtk.WindowTypeToplevel- box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig+ box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $+ widgetSpacing barConfig _ <- widgetSetClassGI box "taffy-box"- centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig+ centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $+ fromIntegral $ widgetSpacing barConfig++ _ <- widgetSetClassGI centerBox "center-box"+ Gtk.widgetSetVexpand centerBox True+ Gtk.setWidgetValign centerBox Gtk.AlignFill+ Gtk.setWidgetHalign centerBox Gtk.AlignCenter Gtk.boxSetCenterWidget box (Just centerBox) setupStrutWindow (strutConfig barConfig) window@@ -199,18 +272,24 @@ _ <- widgetSetClassGI window "taffy-window" - let addWidgetWith widgetAdd buildWidget =- runReaderT buildWidget thisContext >>= widgetAdd- addToStart widget = Gtk.boxPackStart box widget False False 0- addToEnd widget = Gtk.boxPackEnd box widget False False 0- addToCenter widget = Gtk.boxPackStart centerBox widget False False 0+ let addWidgetWith widgetAdd (count, buildWidget) =+ runReaderT buildWidget thisContext >>= widgetAdd count+ addToStart count widget = do+ _ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int)+ Gtk.boxPackStart box widget False False 0+ addToEnd count widget = do+ _ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int)+ Gtk.boxPackEnd box widget False False 0+ addToCenter count widget = do+ _ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int)+ Gtk.boxPackStart centerBox widget False False 0 logIO DEBUG "Building start widgets"- mapM_ (addWidgetWith addToStart) (startWidgets barConfig)+ mapM_ (addWidgetWith addToStart) $ zip [1..] (startWidgets barConfig) logIO DEBUG "Building center widgets"- mapM_ (addWidgetWith addToCenter) (centerWidgets barConfig)+ mapM_ (addWidgetWith addToCenter) $ zip [1..] (centerWidgets barConfig) logIO DEBUG "Building end widgets"- mapM_ (addWidgetWith addToEnd) (endWidgets barConfig)+ mapM_ (addWidgetWith addToEnd) $ zip [1..] (endWidgets barConfig) makeWindowTransparent window @@ -276,6 +355,8 @@ logC DEBUG "Finished refreshing windows" return () +-- | Forcibly refresh taffybar windows, even if there are existing windows that+-- correspond to the uniques in the bar configs yielded by 'barConfigGetter'. forceRefreshTaffyWindows :: TaffyIO () forceRefreshTaffyWindows = asks existingWindows >>= lift . flip MV.modifyMVar_ deleteWindows >>@@ -288,21 +369,26 @@ asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b asksContextVar getter = asks getter >>= lift . MV.readMVar +-- | Run a function needing an X11 connection in 'TaffyIO'. runX11 :: X11Property a -> TaffyIO a runX11 action = asksContextVar x11ContextVar >>= lift . runReaderT action +-- | Use 'runX11' together with 'postX11RequestSyncProp' on the provided+-- property. Return the provided default if 'Nothing' is returned+-- 'postX11RequestSyncProp'. runX11Def :: a -> X11Property a -> TaffyIO a-runX11Def def prop = runX11 $ postX11RequestSyncProp prop def+runX11Def dflt prop = runX11 $ postX11RequestSyncProp prop dflt runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a-runX11Context context def prop =- liftIO $ runReaderT (runX11Def def prop) context+runX11Context context dflt prop =+ liftIO $ runReaderT (runX11Def dflt prop) context +-- | Get a state value by type from the 'contextState' field of 'Context'. getState :: forall t. Typeable t => Taffy IO (Maybe t) getState = do stateMap <- asksContextVar contextState- let maybeValue = M.lookup (typeOf (undefined :: t)) stateMap+ let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap return $ maybeValue >>= fromValue -- | Like "putState", but avoids aquiring a lock if the value is already in the@@ -319,7 +405,7 @@ contextVar <- asks contextState ctx <- ask lift $ MV.modifyMVar contextVar $ \contextStateMap ->- let theType = typeOf (undefined :: t)+ let theType = typeRep (Proxy :: Proxy t) currentValue = M.lookup theType contextStateMap insertAndReturn value = (M.insert theType (Value value) contextStateMap, value)
src/System/Taffybar/DBus/Toggle.hs view
@@ -33,10 +33,10 @@ import Graphics.UI.GIGtkStrut import Prelude import System.Directory-import System.Environment.XDG.BaseDir import System.FilePath.Posix import System.Log.Logger-import System.Taffybar.Context hiding (logIO)+import System.Taffybar.Context+import System.Taffybar.Util import Text.Printf import Text.Read ( readMaybe ) @@ -90,11 +90,8 @@ taffybarToggleInterface :: InterfaceName taffybarToggleInterface = "taffybar.toggle" -taffyDir :: IO FilePath-taffyDir = getUserDataDir "taffybar"- toggleStateFile :: IO FilePath-toggleStateFile = (</> "toggle_state.dat") <$> taffyDir+toggleStateFile = (</> "toggle_state.dat") <$> taffyStateDir newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool)) @@ -115,7 +112,7 @@ exportTogglesInterface = do TogglesMVar enabledVar <- getTogglesVar ctx <- ask- lift $ taffyDir >>= createDirectoryIfMissing True+ lift $ taffyStateDir >>= createDirectoryIfMissing True stateFile <- lift toggleStateFile let toggleTaffyOnMon fn mon = flip runReaderT ctx $ do lift $ MV.modifyMVar_ enabledVar $ \numToEnabled -> do
src/System/Taffybar/Example.hs view
@@ -17,6 +17,7 @@ -- -- > main = dyreTaffybar exampleTaffybarConfig +import Data.Default (def) import System.Taffybar.Context (TaffybarConfig(..)) import System.Taffybar.Hooks import System.Taffybar.Information.CPU@@ -36,7 +37,7 @@ myGraphConfig, netCfg, memCfg, cpuCfg :: GraphConfig myGraphConfig =- defaultGraphConfig+ def { graphPadding = 0 , graphBorderWidth = 0 , graphWidth = 75@@ -71,7 +72,7 @@ exampleTaffybarConfig :: TaffybarConfig exampleTaffybarConfig = let myWorkspacesConfig =- defaultWorkspacesConfig+ def { minIcons = 1 , widgetGap = 0 , showWorkspaceFn = hideEmpty@@ -80,13 +81,13 @@ cpu = pollingGraphNew cpuCfg 0.5 cpuCallback mem = pollingGraphNew memCfg 1 memCallback net = networkGraphNew netCfg Nothing- clock = textClockNewWith defaultClockConfig- layout = layoutNew defaultLayoutConfig- windowsW = windowsNew defaultWindowsConfig+ clock = textClockNewWith def+ layout = layoutNew def+ windowsW = windowsNew def -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher -- for a better way to set up the sni tray tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt- myConfig = defaultSimpleTaffyConfig+ myConfig = def { startWidgets = workspaces : map (>>= buildContentsBox) [ layout, windowsW ] , endWidgets = map (>>= buildContentsBox)@@ -100,7 +101,7 @@ ] , barPosition = Top , barPadding = 10- , barHeight = 50+ , barHeight = ExactSize 50 , widgetSpacing = 0 } in withBatteryRefresh $ withLogServer $
src/System/Taffybar/Hooks.hs view
@@ -7,6 +7,8 @@ -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable+--+-- This module provides various startup hooks that can be added to 'TaffyConfig'. ----------------------------------------------------------------------------- module System.Taffybar.Hooks@@ -35,34 +37,45 @@ import System.Taffybar.LogFormatter import System.Taffybar.Util -newtype NetworkInfoChan = NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))])+-- | The type of the channel that provides network information in taffybar.+newtype NetworkInfoChan =+ NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))]) -buildInfoChan :: Double -> IO NetworkInfoChan-buildInfoChan interval = do+-- | Build a 'NetworkInfoChan' that refreshes at the provided interval.+buildNetworkInfoChan :: Double -> IO NetworkInfoChan+buildNetworkInfoChan interval = do chan <- newBroadcastChan _ <- forkIO $ monitorNetworkInterfaces interval (void . writeBChan chan) return $ NetworkInfoChan chan +-- | Get the 'NetworkInfoChan' from 'Context', creating it if it does not exist. getNetworkChan :: TaffyIO NetworkInfoChan-getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0+getNetworkChan = getStateDefault $ lift $ buildNetworkInfoChan 2.0 +-- | Set the log formatter used in the taffybar process setTaffyLogFormatter :: String -> IO () setTaffyLogFormatter loggerName = do handler <- taffyLogHandler updateGlobalLogger loggerName $ setHandlers [handler] +-- | Add 'refreshrefreshBatteriesOnPropChange' to the 'startupHook' of the+-- provided 'TaffybarConfig'. withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange +-- | Load the 'DesktopEntry' cache from 'Context' state. getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry) getDirectoryEntriesByClassName = getStateDefault readDirectoryEntriesDefault +-- | Update the 'DesktopEntry' cache every 60 seconds. updateDirectoryEntriesCache :: TaffyIO () updateDirectoryEntriesCache = ask >>= \ctx -> void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $- putState readDirectoryEntriesDefault+ void $ putState readDirectoryEntriesDefault +-- | Read 'DesktopEntry' values into a 'MM.Multimap', where they are indexed by+-- the class name specified in the 'DesktopEntry'. readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry) readDirectoryEntriesDefault = lift $ indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault
src/System/Taffybar/Information/Battery.hs view
@@ -1,10 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}--- | This is a simple library to query the Linux UPower daemon (via DBus) for--- battery information.+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.Battery+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides functions for querying battery information using the+-- UPower dbus, as well as a "BroadcastChan" system for allowing multiple+-- readers to receive 'BatteryState' updates without duplicating requests.+----------------------------------------------------------------------------- module System.Taffybar.Information.Battery- (- -- * Types- BatteryInfo(..)+ ( BatteryInfo(..) , BatteryState(..) , BatteryTechnology(..) , BatteryType(..)@@ -201,7 +211,8 @@ -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects-monitorDisplayBattery :: [String] -> TaffyIO (BroadcastChan In BatteryInfo, MVar BatteryInfo)+monitorDisplayBattery ::+ [String] -> TaffyIO (BroadcastChan In BatteryInfo, MVar BatteryInfo) monitorDisplayBattery propertiesToMonitor = do lift $ batteryLog DEBUG "Starting Battery Monitor" client <- asks systemDBusClient
src/System/Taffybar/Information/Chrome.hs view
@@ -13,7 +13,7 @@ import qualified GI.GdkPixbuf as Gdk import Prelude import System.Log.Logger-import System.Taffybar.Context hiding (logIO)+import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 import Text.Read hiding (lift)
+ src/System/Taffybar/Information/Crypto.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.Crypto+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides utility functions for retrieving data about crypto+-- assets.+-----------------------------------------------------------------------------+module System.Taffybar.Information.Crypto where++import BroadcastChan+import Control.Concurrent+import Control.Exception.Enclosed (catchAny)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import qualified Data.Aeson.Key as Key+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Map as M+import Data.Maybe+import Data.Proxy+import qualified Data.Text as T+import GHC.TypeLits+import Network.HTTP.Simple hiding (Proxy)+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.Util+import Text.Printf++getSymbolToCoinGeckoId :: MonadIO m => m (M.Map T.Text T.Text)+getSymbolToCoinGeckoId = do+ let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false"+ request = parseRequest_ uri+ bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do+ liftIO $ logM "System.Taffybar.Information.Crypto" WARNING $+ printf "Error fetching coins list from coin gecko %s" $ show e+ return ""+ let coinInfos :: [CoinGeckoInfo]+ coinInfos = fromMaybe [] $ decode bodyText++ return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } ->+ (theSymbol, theId)) coinInfos++newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map T.Text T.Text)++newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double }++newtype CryptoPriceChannel (a :: Symbol) =+ CryptoPriceChannel (BroadcastChan In CryptoPriceInfo, MVar CryptoPriceInfo)++getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a)+getCryptoPriceChannel = do+ -- XXX: This is a gross hack that is needed to avoid deadlock+ symbolToId <- getStateDefault $ SymbolToCoinGeckoId <$> getSymbolToCoinGeckoId+ getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId++data CoinGeckoInfo =+ CoinGeckoInfo { identifier :: T.Text, symbol :: T.Text }+ deriving (Show)++instance FromJSON CoinGeckoInfo where+ parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol")++buildCryptoPriceChannel ::+ forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)+buildCryptoPriceChannel delay (SymbolToCoinGeckoId symbolToId) = do+ let initialBackoff = delay+ chan <- newBroadcastChan+ var <- liftIO $ newMVar $ CryptoPriceInfo 0.0+ backoffVar <- liftIO $ newMVar initialBackoff++ let doWrites info = do+ _ <- swapMVar var info+ _ <- writeBChan chan info+ _ <- swapMVar backoffVar initialBackoff+ return ()++ let symbolPair = T.pack $ symbolVal (Proxy :: Proxy a)+ (symbolName:inCurrency:_) = T.splitOn "-" symbolPair++ case M.lookup (T.toLower symbolName) symbolToId of+ Nothing -> liftIO $ logM "System.Taffybar.Information.Crypto"+ WARNING $ printf "Symbol %s not found in coin gecko list" symbolName+ Just cgIdentifier ->+ void $ foreverWithVariableDelay $+ catchAny (liftIO $ getLatestPrice cgIdentifier (T.toLower inCurrency) >>=+ maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do+ logPrintF "System.Taffybar.Information.Crypto"+ WARNING "Error when fetching crypto price: %s" e+ modifyMVar backoffVar $ \current ->+ return (min (current * 2) delay, current)++ return $ CryptoPriceChannel (chan, var)++getLatestPrice :: MonadIO m => T.Text -> T.Text -> m (Maybe Double)+getLatestPrice tokenId inCurrency = do+ let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"+ tokenId inCurrency+ request = parseRequest_ uri+ bodyText <- getResponseBody <$> httpLBS request+ return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency))++getCryptoMeta :: MonadIO m => String -> String -> m LBS.ByteString+getCryptoMeta cmcAPIKey symbolName = do+ let headers = [("X-CMC_PRO_API_KEY", BS.fromString cmcAPIKey)] :: RequestHeaders+ uri = printf "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s"+ symbolName+ request = setRequestHeaders headers $ parseRequest_ uri+ getResponseBody <$> httpLBS request
src/System/Taffybar/Information/EWMHDesktopInfo.hs view
@@ -27,6 +27,7 @@ , allEWMHProperties , ewmhActiveWindow , ewmhClientList+ , ewmhClientListStacking , ewmhCurrentDesktop , ewmhDesktopNames , ewmhNumberOfDesktops@@ -49,6 +50,7 @@ , getWindowStateProperty , getWindowTitle , getWindows+ , getWindowsStacking , getWorkspace , getWorkspaceNames , isWindowUrgent@@ -93,9 +95,10 @@ type EWMHProperty = String -ewmhActiveWindow, ewmhClientList, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty+ewmhActiveWindow, ewmhClientList, ewmhClientListStacking, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty ewmhActiveWindow = "_NET_ACTIVE_WINDOW" ewmhClientList = "_NET_CLIENT_LIST"+ewmhClientListStacking = "_NET_CLIENT_LIST_STACKING" ewmhCurrentDesktop = "_NET_CURRENT_DESKTOP" ewmhDesktopNames = "_NET_DESKTOP_NAMES" ewmhNumberOfDesktops = "_NET_NUMBER_OF_DESKTOPS"@@ -112,6 +115,7 @@ allEWMHProperties = [ ewmhActiveWindow , ewmhClientList+ , ewmhClientListStacking , ewmhCurrentDesktop , ewmhDesktopNames , ewmhNumberOfDesktops@@ -261,9 +265,13 @@ getActiveWindow :: X11Property (Maybe X11Window) getActiveWindow = listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow --- | Return a list of all @X11Window@s.+-- | Return a list of all @X11Window@s, sorted by initial mapping order, oldest to newest. getWindows :: X11Property [X11Window] getWindows = readAsListOfWindow Nothing ewmhClientList++-- | Return a list of all @X11Window@s, sorted in stacking order, bottom-to-top.+getWindowsStacking :: X11Property [X11Window]+getWindowsStacking = readAsListOfWindow Nothing ewmhClientListStacking -- | Return the index (starting from 0) of the workspace on which the given -- window is being displayed.
src/System/Taffybar/Information/MPRIS2.hs view
@@ -14,6 +14,7 @@ module System.Taffybar.Information.MPRIS2 where +import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except@@ -68,6 +69,6 @@ getSongInfo :: M.Map String DBus.Variant -> Maybe (String, [String]) getSongInfo songData = do let lookupVariant k = M.lookup k songData >>= DBus.fromVariant- artists <- lookupVariant "xesam:artist"+ artists <- lookupVariant "xesam:artist" <|> pure [] title <- lookupVariant "xesam:title" return (title, artists)
src/System/Taffybar/SimpleConfig.hs view
@@ -7,20 +7,26 @@ -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable+--+-- This module defines a simpler, but less flexible config system than the one+-- offered in "System.Taffybar.Context". ----------------------------------------------------------------------------- module System.Taffybar.SimpleConfig ( SimpleTaffyConfig(..) , Position(..) , defaultSimpleTaffyConfig+ , simpleDyreTaffybar , simpleTaffybar , toTaffyConfig , useAllMonitors , usePrimaryMonitor+ , StrutSize(..) ) where import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.Trans.Class+import Data.Default (Default(..)) import Data.List import Data.Maybe import Data.Unique@@ -33,33 +39,33 @@ import System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..)) import System.Taffybar.Util --- | The side of the monitor at which taffybar should be displayed.+-- | An ADT representing the edge of the monitor along which taffybar should be+-- displayed. data Position = Top | Bottom deriving (Show, Eq) -- | A configuration object whose interface is simpler than that of -- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more--- advanced interface, you should stick to this one.+-- advanced interface, you should stick to using this one. data SimpleTaffyConfig = SimpleTaffyConfig {- -- | The xinerama/xrandr monitor number to put the bar on (default: PrimaryMonitor)+ -- | The monitor number to put the bar on (default: 'usePrimaryMonitor') monitorsAction :: TaffyIO [Int]- -- | Number of pixels to reserve for the bar- , barHeight :: Int+ -- | Number of pixels to reserve for the bar (default: 30)+ , barHeight :: StrutSize -- | Number of additional pixels to reserve for the bar strut (default: 0) , barPadding :: Int- -- | The position of the bar on the screen (default: Top)+ -- | The position of the bar on the screen (default: 'Top') , barPosition :: Position- -- | The number of pixels between widgets+ -- | The number of pixels between widgets (default: 5) , widgetSpacing :: Int- -- | Widget constructors whose output are placed at the beginning of the bar+ -- | Widget constructors whose outputs are placed at the beginning of the bar , startWidgets :: [TaffyIO Gtk.Widget]- -- | Widget constructors whose output are placed in the center of the bar+ -- | Widget constructors whose outputs are placed in the center of the bar , centerWidgets :: [TaffyIO Gtk.Widget]- -- | Widget constructors whose output are placed at the end of the bar+ -- | Widget constructors whose outputs are placed at the end of the bar , endWidgets :: [TaffyIO Gtk.Widget]- -- | Optional path to CSS stylesheet (loaded in addition to stylesheet found- -- in XDG data directory).- , cssPath :: Maybe FilePath+ -- | List of paths to CSS stylesheets that should be loaded at startup.+ , cssPaths :: [FilePath] -- | Hook to run at taffybar startup. , startupHook :: TaffyIO () }@@ -70,24 +76,29 @@ defaultSimpleTaffyConfig :: SimpleTaffyConfig defaultSimpleTaffyConfig = SimpleTaffyConfig { monitorsAction = useAllMonitors- , barHeight = 30+ , barHeight = ScreenRatio $ 1 / 27 , barPadding = 0 , barPosition = Top , widgetSpacing = 5 , startWidgets = [] , centerWidgets = [] , endWidgets = []- , cssPath = Nothing+ , cssPaths = [] , startupHook = return () } +instance Default SimpleTaffyConfig where+ def = defaultSimpleTaffyConfig++-- | Convert a 'SimpleTaffyConfig' into a 'StrutConfig' that can be used with+-- gtk-strut. toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig-toStrutConfig SimpleTaffyConfig { barHeight = size+toStrutConfig SimpleTaffyConfig { barHeight = height , barPadding = padding , barPosition = pos } monitor = defaultStrutConfig- { strutHeight = ExactSize $ fromIntegral size+ { strutHeight = height , strutYPadding = fromIntegral padding , strutXPadding = fromIntegral padding , strutAlignment = Center@@ -114,11 +125,13 @@ newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)]) +-- | Convert a 'SimpleTaffyConfig' into a 'BC.TaffybarConfig' that can be used+-- with 'startTaffybar' or 'dyreTaffybar'. toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffyConfig conf =- defaultTaffybarConfig+ def { BC.getBarConfigsParam = configGetter- , BC.cssPath = cssPath conf+ , BC.cssPaths = cssPaths conf , BC.startupHook = startupHook conf } where@@ -144,21 +157,28 @@ lift $ MV.modifyMVar configsVar lookupAndUpdate --- | Start taffybar using 'SimpleTaffybarConfig'.+-- | Start taffybar using dyre with a 'SimpleTaffybarConfig'.+simpleDyreTaffybar :: SimpleTaffyConfig -> IO ()+simpleDyreTaffybar conf = dyreTaffybar $ toTaffyConfig conf++-- | Start taffybar with a 'SimpleTaffybarConfig'. simpleTaffybar :: SimpleTaffyConfig -> IO ()-simpleTaffybar conf = dyreTaffybar $ toTaffyConfig conf+simpleTaffybar conf = startTaffybar $ toTaffyConfig conf getMonitorCount :: IO Int getMonitorCount =- fromIntegral <$> (screenGetDefault >>= maybe (return 0) (screenGetDisplay >=> displayGetNMonitors))+ fromIntegral <$> (screenGetDefault >>= maybe (return 0)+ (screenGetDisplay >=> displayGetNMonitors)) --- | Display a taffybar window on all monitors.+-- | Supply this value for 'monitorsAction' to display the taffybar window on+-- all monitors. useAllMonitors :: TaffyIO [Int] useAllMonitors = lift $ do count <- getMonitorCount return [0..count-1] --- | Display the taffybar window on the primary monitor.+-- | Supply this value for 'monitorsAction' to display the taffybar window only+-- on the primary monitor. usePrimaryMonitor :: TaffyIO [Int] usePrimaryMonitor = return . fromMaybe 0 <$> lift (withDefaultCtx getPrimaryOutputNumber)
src/System/Taffybar/Util.hs view
@@ -13,27 +13,35 @@ module System.Taffybar.Util where +import Conduit import Control.Applicative import Control.Arrow ((&&&)) import Control.Concurrent import Control.Exception.Base import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader-import Data.Maybe import Data.Either.Combinators import Data.GI.Base.GError+import Control.Exception.Enclosed (catchAny) import qualified Data.GI.Gtk.Threading as Gtk+import Data.Maybe import qualified Data.Text as T import Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import Network.HTTP.Simple+import System.Directory+import System.Environment.XDG.BaseDir import System.Exit (ExitCode (..))+import System.FilePath.Posix import System.Log.Logger import qualified System.Process as P import Text.Printf ++taffyStateDir :: IO FilePath+taffyStateDir = getUserDataDir "taffybar"+ liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b liftReader modifier action =@@ -87,12 +95,18 @@ ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr -- | Execute the provided IO action at the provided interval.-foreverWithDelay :: RealFrac d => d -> IO a -> IO ThreadId+foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId foreverWithDelay delay action =- foreverWithVariableDelay $ action >> return delay+ foreverWithVariableDelay $ safeAction >> return delay+ where safeAction =+ catchAny action $ \e ->+ logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e -foreverWithVariableDelay :: RealFrac d => IO d -> IO ThreadId-foreverWithVariableDelay action = forkIO $ action >>= delayThenAction+-- | Execute the provided IO action, and use the value it returns to decide how+-- long to wait until executing it again. The value returned by the action is+-- interpreted as a number of seconds.+foreverWithVariableDelay :: (MonadIO m, RealFrac d) => IO d -> m ThreadId+foreverWithVariableDelay action = liftIO $ forkIO $ action >>= delayThenAction where delayThenAction delay = threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction @@ -150,8 +164,22 @@ printf "Failed to load icon from filepath %s" filepath return result +downloadURIToPath :: Request -> FilePath -> IO ()+downloadURIToPath uri filepath =+ createDirectoryIfMissing True directory >>+ runConduitRes (httpSource uri getResponseBody .| sinkFile filepath)+ where (directory, _) = splitFileName filepath+ postGUIASync :: IO () -> IO () postGUIASync = Gtk.postGUIASync postGUISync :: IO () -> IO () postGUISync = Gtk.postGUISync++anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool+anyM _ [] = return False+anyM p (x:xs) = do+ q <- p x+ if q+ then return True+ else anyM p xs
src/System/Taffybar/Widget.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module System.Taffybar.Widget ( module System.Taffybar.Widget.Util -- * "System.Taffybar.Widget.Battery"@@ -9,8 +11,10 @@ -- * "System.Taffybar.Widget.CommandRunner" , module System.Taffybar.Widget.CommandRunner - -- * "System.Taffybar.Widget.Decorators"- , module System.Taffybar.Widget.Decorators+#ifdef WIDGET_CRYPTO+ -- * "System.Taffybar.Widget.Crypto"+ , module System.Taffybar.Widget.Crypto+#endif -- * "System.Taffybar.Widget.DiskIOMonitor" , module System.Taffybar.Widget.DiskIOMonitor@@ -64,7 +68,9 @@ import System.Taffybar.Widget.Battery import System.Taffybar.Widget.CPUMonitor import System.Taffybar.Widget.CommandRunner-import System.Taffybar.Widget.Decorators+#ifdef WIDGET_CRYPTO+import System.Taffybar.Widget.Crypto+#endif import System.Taffybar.Widget.DiskIOMonitor import System.Taffybar.Widget.FSMonitor import System.Taffybar.Widget.FreedesktopNotifications
src/System/Taffybar/Widget/Battery.hs view
@@ -10,23 +10,26 @@ -- Stability : unstable -- Portability : unportable ----- This module provides battery widgets using the UPower system--- service.------ Currently it reports only the first battery it finds. If it does not find a--- battery, it just returns an obnoxious widget with warning text in it. Battery--- hotplugging is not supported. These more advanced features could be supported--- if there is interest.+-- This module provides battery widgets that are queried using the UPower dbus+-- service. To avoid duplicating all information requests for each battery+-- widget displayed (if using a multi-head configuration or multiple battery+-- widgets), these widgets use the "BroadcastChan" based system for receiving+-- updates defined in "System.Taffybar.Information.Battery". ------------------------------------------------------------------------------module System.Taffybar.Widget.Battery ( textBatteryNew, batteryIconNew ) where+module System.Taffybar.Widget.Battery+ ( batteryIconNew+ , textBatteryNew+ , textBatteryNewWithLabelAction+ ) where import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader+import Data.Default (Default(..)) import Data.Int (Int64) import qualified Data.Text as T-import GI.Gtk+import GI.Gtk as Gtk import Prelude import StatusNotifier.Tray (scalePixbufToSize) import System.Taffybar.Context@@ -34,6 +37,7 @@ import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.Widget.Util hiding (themeLoadFlags) import Text.Printf import Text.StringTemplate @@ -85,19 +89,64 @@ -- string where $percentage$ is replaced with the percentage of battery -- remaining and $time$ is replaced with the time until the battery is fully -- charged/discharged.-textBatteryNew- :: String -- ^ Display format- -> TaffyIO Widget-textBatteryNew format = do+textBatteryNew :: String -> TaffyIO Widget+textBatteryNew format = textBatteryNewWithLabelAction labelSetter+ where labelSetter label info = do+ setBatteryStateClasses def label info+ labelSetMarkup label $+ formatBattInfo (getBatteryWidgetInfo info) format++data BatteryClassesConfig = BatteryClassesConfig+ { batteryHighThreshold :: Double+ , batteryLowThreshold :: Double+ , batteryCriticalThreshold :: Double+ }++defaultBatteryClassesConfig :: BatteryClassesConfig+defaultBatteryClassesConfig =+ BatteryClassesConfig+ { batteryHighThreshold = 80+ , batteryLowThreshold = 20+ , batteryCriticalThreshold = 5+ }++instance Default BatteryClassesConfig where+ def = defaultBatteryClassesConfig++setBatteryStateClasses ::+ MonadIO m => BatteryClassesConfig -> Gtk.Label -> BatteryInfo -> m ()+setBatteryStateClasses config label info = do+ case batteryState info of+ BatteryStateCharging -> addClassIfMissing "charging" label >>+ removeClassIfPresent "discharging" label+ BatteryStateDischarging -> addClassIfMissing "discharging" label >>+ removeClassIfPresent "charging" label+ _ -> removeClassIfPresent "charging" label >>+ removeClassIfPresent "discharging" label++ classIf "high" $ percentage >= batteryHighThreshold config+ classIf "low" $ percentage <= batteryLowThreshold config+ classIf "critical" $ percentage <= batteryCriticalThreshold config+ where percentage = batteryPercentage info+ classIf klass condition =+ if condition+ then addClassIfMissing klass label+ else removeClassIfPresent klass label++-- | Like `textBatteryNew` but provides a more general way to update the label+-- widget. The argument provided is an action that is used to update the text+-- label given a 'BatteryInfo' object describing the state of the battery.+textBatteryNewWithLabelAction ::+ (Gtk.Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget+textBatteryNewWithLabelAction labelSetter = do chan <- getDisplayBatteryChan ctx <- ask- let getLabelText info = formatBattInfo (getBatteryWidgetInfo info) format- getBatteryInfoIO = runReaderT getDisplayBatteryInfo ctx liftIO $ do- label <- getLabelText <$> getBatteryInfoIO >>= labelNew . Just- let setMarkup text = postGUIASync $ labelSetMarkup label text- updateWidget = setMarkup . getLabelText- void $ onWidgetRealize label $ getLabelText <$> getBatteryInfoIO >>= setMarkup+ label <- labelNew Nothing+ let updateWidget =+ postGUIASync . flip runReaderT ctx . labelSetter label+ void $ onWidgetRealize label $+ runReaderT getDisplayBatteryInfo ctx >>= updateWidget toWidget =<< channelWidgetNew label chan updateWidget themeLoadFlags :: [IconLookupFlags]
+ src/System/Taffybar/Widget/Crypto.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Crypto+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides widgets for tracking the price of crypto currency+-- assets.+-----------------------------------------------------------------------------+module System.Taffybar.Widget.Crypto where++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Data.Aeson+import Data.Aeson.Types+import qualified Data.Aeson.Key as Key+import qualified Data.ByteString.Lazy as LBS+import Data.List.Split+import Data.Maybe+import Data.Proxy+import qualified Data.Text+import GHC.TypeLits+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import Network.HTTP.Simple hiding (Proxy)+import System.FilePath.Posix+import System.Taffybar.Context+import System.Taffybar.Information.Crypto hiding (symbol)+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.AutoSizeImage+import System.Taffybar.Widget.Generic.ChannelWidget+import System.Taffybar.WindowIcon+import Text.Printf++-- | Extends 'cryptoPriceLabel' with an icon corresponding to the symbol of the+-- purchase crypto that will appear to the left of the price label. See the+-- docstring for 'getCryptoPixbuf' for details about how this icon is retrieved.+-- As with 'cryptoPriceLabel', this function must be invoked with a type+-- application with the type string that expresses the symbol of the relevant+-- token and the underlying currency its price should be expressed in. See the+-- docstring of 'cryptoPriceLabel' for details about the exact format that this+-- string should take.+cryptoPriceLabelWithIcon :: forall a. KnownSymbol a => TaffyIO Gtk.Widget+cryptoPriceLabelWithIcon = do+ label <- cryptoPriceLabel @a+ let symbolPair = symbolVal (Proxy :: Proxy a)+ symbol = head $ splitOn "-" symbolPair+ hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0++ ctx <- ask+ let refresh =+ const $ flip runReaderT ctx $+ fromMaybe <$> pixBufFromColor 10 0 <*> getCryptoPixbuf symbol+ image <- autoSizeImageNew refresh Gtk.OrientationHorizontal++ Gtk.containerAdd hbox image+ Gtk.containerAdd hbox label++ Gtk.toWidget hbox++newtype CMCAPIKey = CMCAPIKey String++-- | Set the coinmarketcap.com api key that will be used for retrieving crypto+-- icons that are not cached. This should occur before any attempts to retrieve+-- crypto icons happen. The easiest way to call this appropriately is to set it+-- as a 'startupHook'.+setCMCAPIKey :: String -> TaffyIO CMCAPIKey+setCMCAPIKey key =+ getStateDefault $ return $ CMCAPIKey key++-- | Build a label that will reflect the price of some token in some currency in+-- the coingecko API. This function accepts these valuesas a type parameter with+-- kind 'String' of the form `(symbol for asset being purchased)-(currency the+-- price should be expressed in)`. For example, the product string for the price+-- of bitcoin quoted in U.S. dollars is "BTC-USD". You can invoke this function+-- by enabling the TypeApplications language extension and passing the string+-- associated with the asset that you want to track as follows:+--+-- > cryptoPriceLabel @"BTC-USD"+cryptoPriceLabel :: forall a. KnownSymbol a => TaffyIO Gtk.Widget+cryptoPriceLabel = getCryptoPriceChannel @a >>= cryptoPriceLabel'++cryptoPriceLabel' :: CryptoPriceChannel a -> TaffyIO Gtk.Widget+cryptoPriceLabel' (CryptoPriceChannel (chan, var)) = do+ label <- Gtk.labelNew Nothing+ let updateWidget CryptoPriceInfo { lastPrice = cryptoPrice } =+ postGUIASync $ Gtk.labelSetMarkup label $+ Data.Text.pack $ show cryptoPrice+ void $ Gtk.onWidgetRealize label $+ readMVar var >>= updateWidget+ Gtk.toWidget =<< channelWidgetNew label chan updateWidget++cryptoIconsDir :: IO FilePath+cryptoIconsDir = (</> "crypto_icons") <$> taffyStateDir++pathForCryptoSymbol :: String -> IO FilePath+pathForCryptoSymbol symbol =+ (</> printf "%s.png" symbol) <$> cryptoIconsDir++-- | Retrieve a pixbuf image corresponding to the provided crypto symbol. The+-- image used will be retrieved from the file with the name `(pricesymbol).png`+-- from the directory defined by 'cryptoIconsDir'. If a file is not found there+-- and an an api key for coinmarketcap.com has been set using 'setCMCAPIKey', an+-- icon will be automatically be retrieved from coinmarketcap.com.+getCryptoPixbuf :: String -> TaffyIO (Maybe Gdk.Pixbuf)+getCryptoPixbuf = getCryptoIconFromCache <||> getCryptoIconFromCMC++getCryptoIconFromCache :: MonadIO m => String -> m (Maybe Gdk.Pixbuf)+getCryptoIconFromCache symbol = liftIO $+ pathForCryptoSymbol symbol >>= safePixbufNewFromFile++getCryptoIconFromCMC :: String -> TaffyIO (Maybe Gdk.Pixbuf)+getCryptoIconFromCMC symbol =+ runMaybeT $ do+ CMCAPIKey cmcAPIKey <- MaybeT getState+ MaybeT $ lift $ getCryptoIconFromCMC' cmcAPIKey symbol++getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf)+getCryptoIconFromCMC' cmcAPIKey symbol = do+ jsonText <- getCryptoMeta cmcAPIKey symbol+ let uri = getIconURIFromJSON symbol jsonText >>= parseRequest . Data.Text.unpack+ path <- pathForCryptoSymbol symbol+ maybe (return ()) (`downloadURIToPath` path) uri+ safePixbufNewFromFile path++getIconURIFromJSON :: String -> LBS.ByteString -> Maybe Data.Text.Text+getIconURIFromJSON symbol jsonText =+ decode jsonText >>= parseMaybe+ ((.: "data") >=> (.: Key.fromString symbol) >=> (.: "logo"))
− src/System/Taffybar/Widget/Decorators.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module System.Taffybar.Widget.Decorators where--import Control.Monad.IO.Class-import qualified GI.Gtk as Gtk-import System.Taffybar.Widget.Util---- | Wrap a widget with two container boxes. The inner box will have the class--- "InnerPad", and the outer box will have the class "OuterPad". These boxes can--- be used to add padding between the outline of the widget and its contents, or--- for the purpose of displaying a different background behind the widget.-buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget-buildPadBox contents = liftIO $ do- innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0- outerBox <- Gtk.eventBoxNew- Gtk.containerAdd innerBox contents- Gtk.containerAdd outerBox innerBox- _ <- widgetSetClassGI innerBox "inner-pad"- _ <- widgetSetClassGI outerBox "outer-pad"- Gtk.widgetShow outerBox- Gtk.widgetShow innerBox- Gtk.toWidget outerBox--buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget-buildContentsBox widget = liftIO $ do- contents <- Gtk.boxNew Gtk.OrientationHorizontal 0- Gtk.containerAdd contents widget- _ <- widgetSetClassGI contents "contents"- Gtk.widgetShowAll contents- Gtk.toWidget contents >>= buildPadBox
src/System/Taffybar/Widget/FreedesktopNotifications.hs view
@@ -4,12 +4,11 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for freedesktop notifications -- (<http://developer.gnome.org/notification-spec/>). Currently it is--- somewhat ugly, but the format is somewhat configurable. A visual--- overhaul of the widget is coming.+-- somewhat ugly, but the format is somewhat configurable. -- -- The widget only displays one notification at a time and -- notifications are cancellable.-+-- -- The notificationDaemon thread handles new notifications -- and cancellation requests, adding or removing the notification -- to or from the queue. It additionally starts a timeout thread@@ -35,6 +34,7 @@ import Control.Monad.IO.Class import DBus import DBus.Client+import Data.Default ( Default(..) ) import Data.Foldable import Data.Int ( Int32 ) import Data.Map ( Map )@@ -234,6 +234,9 @@ , notificationMaxLength = 100 , notificationFormatter = defaultFormatter }++instance Default NotificationConfig where+ def = defaultNotificationConfig -- | Create a new notification area with the given configuration. notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget
src/System/Taffybar/Widget/Generic/ChannelGraph.hs view
@@ -8,6 +8,9 @@ import GI.Gtk import System.Taffybar.Widget.Generic.Graph +-- | Given a 'BroadcastChan' and an action to consume that broadcast chan and+-- turn it into graphable values, build a graph that will update as values are+-- broadcast over the channel. channelGraphNew :: MonadIO m => GraphConfig -> BroadcastChan In a -> (a -> IO [Double]) -> m GI.Gtk.Widget
src/System/Taffybar/Widget/Generic/ChannelWidget.hs view
@@ -7,7 +7,12 @@ import Data.Foldable (traverse_) import GI.Gtk -channelWidgetNew :: (MonadIO m, IsWidget w) => w -> BroadcastChan In a -> (a -> IO ()) -> m w+-- | Given a widget, a 'BroadcastChan' and a function that consumes the values+-- yielded by the channel that is in 'IO', connect the function to the+-- 'BroadcastChan' on a dedicated haskell thread.+channelWidgetNew ::+ (MonadIO m, IsWidget w) =>+ w -> BroadcastChan In a -> (a -> IO ()) -> m w channelWidgetNew widget channel updateWidget = do void $ onWidgetRealize widget $ do ourChan <- newBChanListener channel
src/System/Taffybar/Widget/Generic/Graph.hs view
@@ -2,7 +2,7 @@ -- | 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'.+-- more automated version, see "System.Taffybar.Widgets.Generic.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.@@ -23,6 +23,7 @@ import Control.Concurrent import Control.Monad ( when ) import Control.Monad.IO.Class+import Data.Default ( Default(..) ) import Data.Foldable ( mapM_ ) import Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) import qualified Data.Sequence as S@@ -45,6 +46,7 @@ data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq) +-- 'RGBA' represents a color with a transparency. type RGBA = (Double, Double, Double, Double) -- | The style of the graph. Generally, you will want to draw all 'Area' graphs@@ -93,6 +95,9 @@ , graphDirection = LEFT_TO_RIGHT } +instance Default GraphConfig where+ def = defaultGraphConfig+ -- | 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 ()@@ -231,16 +236,21 @@ (drawGraph mv drawArea) ctx >> return True box <- Gtk.boxNew Gtk.OrientationHorizontal 1 - case graphLabel cfg of- Nothing -> return ()- Just lbl -> do- l <- Gtk.labelNew (Nothing :: Maybe T.Text)- Gtk.labelSetMarkup l lbl- Gtk.boxPackStart box l False False 0 Gtk.widgetSetVexpand drawArea True Gtk.widgetSetVexpand box True Gtk.boxPackStart box drawArea True True 0- Gtk.widgetShowAll box- giBox <- Gtk.toWidget box- return (giBox, GH mv)++ widget <- case graphLabel cfg of+ Nothing -> Gtk.toWidget box+ Just labelText -> do+ overlay <- Gtk.overlayNew+ label <- Gtk.labelNew Nothing+ Gtk.labelSetMarkup label labelText+ Gtk.containerAdd overlay box+ Gtk.overlayAddOverlay overlay label+ Gtk.toWidget overlay++ Gtk.widgetShowAll widget++ return (widget, GH mv)
src/System/Taffybar/Widget/Generic/PollingGraph.hs view
@@ -8,6 +8,7 @@ GraphStyle(..), -- * Constructors and accessors pollingGraphNew,+ pollingGraphNewWithTooltip, defaultGraphConfig ) where @@ -15,14 +16,15 @@ import qualified Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class+import qualified Data.Text as T import GI.Gtk import System.Taffybar.Util import System.Taffybar.Widget.Generic.Graph -pollingGraphNew+pollingGraphNewWithTooltip :: MonadIO m- => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget-pollingGraphNew cfg pollSeconds action = liftIO $ do+ => GraphConfig -> Double -> IO ([Double], Maybe T.Text) -> m GI.Gtk.Widget+pollingGraphNewWithTooltip cfg pollSeconds action = liftIO $ do (graphWidget, graphHandle) <- graphNew cfg _ <- onWidgetRealize graphWidget $ do@@ -30,7 +32,15 @@ esample <- E.tryAny action case esample of Left _ -> return ()- Right sample -> graphAddSample graphHandle sample+ Right (sample, tooltipStr) -> do+ graphAddSample graphHandle sample+ widgetSetTooltipMarkup graphWidget tooltipStr void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget++pollingGraphNew+ :: MonadIO m+ => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget+pollingGraphNew cfg pollSeconds action =+ pollingGraphNewWithTooltip cfg pollSeconds $ fmap (, Nothing) action
src/System/Taffybar/Widget/Layout.hs view
@@ -26,6 +26,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader+import Data.Default (Default(..)) import qualified Data.Text as T import qualified GI.Gtk as Gtk import GI.Gdk@@ -49,7 +50,7 @@ -- -- > import System.Taffybar.Widget.Layout -- > main = do--- > let los = layoutSwitcherNew defaultLayoutConfig+-- > let los = layoutSwitcherNew def -- -- now you can use @los@ as any other Taffybar widget. @@ -59,6 +60,9 @@ defaultLayoutConfig :: LayoutConfig defaultLayoutConfig = LayoutConfig return++instance Default LayoutConfig where+ def = defaultLayoutConfig -- | Name of the X11 events to subscribe, and of the hint to look for for -- the name of the current layout.
src/System/Taffybar/Widget/MPRIS2.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.MPRIS2@@ -13,7 +15,7 @@ -- can find the MPRIS2 specification here at -- (<https://specifications.freedesktop.org/mpris-spec/latest/>). ------------------------------------------------------------------------------module System.Taffybar.Widget.MPRIS2 ( mpris2New ) where+module System.Taffybar.Widget.MPRIS2 where import Control.Arrow import qualified Control.Concurrent.MVar as MV@@ -24,18 +26,21 @@ import Control.Monad.Trans.Reader import DBus import DBus.Client-import DBus.Internal.Types import qualified DBus.TH as DBus-import Data.Coerce+import Data.Default (Default(..))+import Data.GI.Base.Overloading (IsDescendantOf)+import Data.Int import Data.List+import qualified Data.Map as M import qualified Data.Text as T-import qualified GI.Gtk as Gtk import qualified GI.GLib as G+import GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import System.Environment.XDG.DesktopEntry import System.Log.Logger import System.Taffybar.Context-import System.Taffybar.DBus.Client.MPRIS2+import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus import System.Taffybar.Information.MPRIS2-import System.Environment.XDG.DesktopEntry import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Util@@ -45,97 +50,204 @@ mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m () mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2" +-- | A type representing a function that produces an IO action that adds the+-- provided widget to some container.+type WidgetAdder a m =+ (IsDescendantOf Gtk.Widget a+ , MonadIO m+ , Gtk.GObject a+ ) => a -> m ()++-- | The type of a customization function that is used to update a widget with+-- the provided now playing info. The type a should be the internal state used+-- for the widget (typically just references to the child widgets that may need+-- to be updated ). When the provided value is nothing, it means that the widget+-- does not exist yet and it should be instantiated. When the provided+-- NowPlaying value is Nothing, the dbus client is no longer, and typically the+-- widget should be hidden.+type UpdateMPRIS2PlayerWidget a =+ (forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a++-- | Configuration for an MPRIS2 Widget+data MPRIS2Config a =+ MPRIS2Config+ {+ -- | A function that will be used to wrap the outer MPRIS2 grid widget+ mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget+ -- | This function will be called to instantiate and update the player widgets+ -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`+ -- for more details.+ , updatePlayerWidget :: UpdateMPRIS2PlayerWidget a+ }++defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget+defaultMPRIS2Config =+ MPRIS2Config+ { mprisWidgetWrapper = return+ , updatePlayerWidget = simplePlayerWidget def+ }+ data MPRIS2PlayerWidget = MPRIS2PlayerWidget { playerLabel :: Gtk.Label- , playerGrid :: Gtk.Grid+ , playerWidget :: Gtk.Widget } -mpris2New :: TaffyIO Gtk.Widget-mpris2New = asks sessionDBusClient >>= \client -> lift $ do- grid <- Gtk.gridNew- vFillCenter grid- playerWidgetsVar <- MV.newMVar []+data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig+ { setNowPlayingLabel :: NowPlaying -> IO T.Text+ , showPlayerWidgetFn :: NowPlaying -> IO Bool+ }++defaultPlayerConfig :: SimpleMPRIS2PlayerConfig+defaultPlayerConfig = SimpleMPRIS2PlayerConfig+ { setNowPlayingLabel = playingText 20 30+ , showPlayerWidgetFn =+ \NowPlaying { npStatus = status } -> return $ status /= "Stopped"+ }++instance Default SimpleMPRIS2PlayerConfig where+ def = defaultPlayerConfig++makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b+makeExcept errorString actionBuilder =+ ExceptT . fmap (maybeToEither errorString) . actionBuilder++loadIconAtSize ::+ Client -> BusName -> Int32 -> IO Gdk.Pixbuf+loadIconAtSize client busName size = let- newPlayerWidget :: BusName -> IO MPRIS2PlayerWidget- newPlayerWidget busName =- do- let loadDefault size = loadIcon size "play.svg"- >>= either failure return- where failure err =- mprisLog WARNING "Failed to load default image: %s" err >>- pixBufFromColor size 0- logErrorAndLoadDefault size err =- mprisLog WARNING "Failed to get MPRIS icon: %s" err >>- mprisLog WARNING "MPRIS failure for: %s" busName >>- loadDefault size- makeExcept ::- String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b- makeExcept errorString actionBuilder =- ExceptT . fmap (maybeToEither errorString) . actionBuilder- loadIconAtSize size =- either (logErrorAndLoadDefault size) return =<< runExceptT- ( ExceptT (left show <$> getDesktopEntry client busName)- >>= makeExcept "Failed to get desktop entry"- getDirectoryEntryDefault- >>= makeExcept "Failed to get image"- (getImageForDesktopEntry size)- )+ failure err =+ mprisLog WARNING "Failed to load default image: %s" err >>+ pixBufFromColor size 0+ loadDefault =+ loadIcon size "play.svg" >>= either failure return+ logErrorAndLoadDefault err =+ mprisLog WARNING "Failed to get MPRIS icon: %s" err >>+ mprisLog WARNING "MPRIS failure for: %s" busName >>+ loadDefault+ chromeSpecialCase l@(Left _) =+ if "chrom" `isInfixOf` formatBusName busName+ then Right "google-chrome" else l+ chromeSpecialCase x = x+ in+ either logErrorAndLoadDefault return =<<+ runExceptT (ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName)+ >>= makeExcept "Failed to get desktop entry"+ getDirectoryEntryDefault+ >>= makeExcept "Failed to get image"+ (getImageForDesktopEntry size)) - image <- autoSizeImageNew loadIconAtSize Gtk.OrientationHorizontal- playerBox <- Gtk.gridNew- label <- Gtk.labelNew Nothing+-- | This is the default player widget constructor that is used to build mpris+-- widgets. It provides only an icon and NowPlaying text.+simplePlayerWidget ::+ SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget - Gtk.containerAdd playerBox image- Gtk.containerAdd playerBox label- vFillCenter playerBox+simplePlayerWidget _ _+ (Just p@MPRIS2PlayerWidget { playerWidget = widget })+ Nothing =+ lift $ Gtk.widgetHide widget >> return p - Gtk.containerAdd grid playerBox- Gtk.widgetSetVexpand playerBox True- Gtk.widgetHide playerBox- return MPRIS2PlayerWidget {playerLabel = label, playerGrid = playerBox}+simplePlayerWidget c addToParent Nothing+ np@(Just NowPlaying { npBusName = busName }) = do+ ctx <- ask+ client <- asks sessionDBusClient+ lift $ do+ mprisLog DEBUG "Building widget for %s" busName+ image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal+ playerBox <- Gtk.gridNew+ label <- Gtk.labelNew Nothing+ ebox <- Gtk.eventBoxNew+ _ <- Gtk.onWidgetButtonPressEvent ebox $+ const $ MPRIS2DBus.playPause client busName >> return True+ Gtk.containerAdd playerBox image+ Gtk.containerAdd playerBox label+ Gtk.containerAdd ebox playerBox+ vFillCenter playerBox+ addToParent ebox+ Gtk.widgetSetVexpand playerBox True+ Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName+ Gtk.widgetShowAll ebox+ Gtk.widgetHide ebox+ widget <- Gtk.toWidget ebox+ let widgetData =+ MPRIS2PlayerWidget { playerLabel = label, playerWidget = widget }+ flip runReaderT ctx $+ simplePlayerWidget c addToParent (Just widgetData) np - updatePlayerWidget- children- nowPlaying@NowPlaying- { npBusName = busName- , npStatus = status- } =- case lookup busName children of- Nothing -> do- playerWidget <- newPlayerWidget busName- setNowPlaying playerWidget- return $ (busName, playerWidget):children- Just playerWidget -> setNowPlaying playerWidget >> return children- where setNowPlaying- MPRIS2PlayerWidget- { playerLabel = label- , playerGrid = playerBox- } = do- logPrintF "System.Taffybar.Widget.MPRIS2"- DEBUG "Setting state %s" nowPlaying- Gtk.labelSetMarkup label =<< playingText 20 30 nowPlaying- if status == "Playing"- then Gtk.widgetShowAll playerBox- else Gtk.widgetHide playerBox+simplePlayerWidget config _+ (Just w@MPRIS2PlayerWidget+ { playerLabel = label+ , playerWidget = widget+ }) (Just nowPlaying) = lift $ do+ mprisLog DEBUG "Setting state %s" nowPlaying+ Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying+ shouldShow <- showPlayerWidgetFn config nowPlaying+ if shouldShow+ then Gtk.widgetShowAll widget+ else Gtk.widgetHide widget+ return w +simplePlayerWidget _ _ _ _ =+ mprisLog WARNING "widget update called with no widget or %s"+ ("nowplaying" :: String) >> return undefined++-- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor.+mpris2New :: TaffyIO Gtk.Widget+mpris2New = mpris2NewWithConfig defaultMPRIS2Config++-- | Construct a new MPRIS2 widget with the provided configuration.+mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget+mpris2NewWithConfig config = ask >>= \ctx -> asks sessionDBusClient >>= \client -> lift $ do+ grid <- Gtk.gridNew+ outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config+ vFillCenter grid+ playerWidgetsVar <- MV.newMVar M.empty+ let+ updateWidget = updatePlayerWidget config updatePlayerWidgets nowPlayings playerWidgets = do- newWidgets <- foldM updatePlayerWidget playerWidgets nowPlayings- let existingBusNames = map npBusName nowPlayings- noInfoPlayerWidgets =- filter ((`notElem` existingBusNames) . fst) newWidgets- mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets- return newWidgets+ let+ updateWidgetFromNP np@NowPlaying { npBusName = busName } =+ (busName,) <$> updateWidget (Gtk.containerAdd grid)+ (M.lookup busName playerWidgets) (Just np)+ activeBusNames = map npBusName nowPlayings+ existingBusNames = M.keys playerWidgets+ inactiveBusNames = existingBusNames \\ activeBusNames+ callForNoPlayingAvailable busName =+ updateWidget (Gtk.containerAdd grid)+ (M.lookup busName playerWidgets) Nothing - updatePlayerWidgetsVar nowPlayings = postGUIASync $- MV.modifyMVar_ playerWidgetsVar $ updatePlayerWidgets nowPlayings+ -- Invoke the widgets with no NowPlaying so they can hide etc.+ mapM_ callForNoPlayingAvailable inactiveBusNames+ -- Update all the other widgets+ updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings+ return $ M.union updatedWidgets playerWidgets - doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar+ updatePlayerWidgetsVar nowPlayings = postGUISync $+ MV.modifyMVar_ playerWidgetsVar $ flip runReaderT ctx .+ updatePlayerWidgets nowPlayings++ setPlayingClass = do+ anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid+ if anyVisible+ then do+ addClassIfMissing "visible-children" outerWidget+ removeClassIfPresent "no-visible-children" outerWidget+ else do+ addClassIfMissing "no-visible-children" outerWidget+ removeClassIfPresent "visible-children" outerWidget++ doUpdate = do+ nowPlayings <- getNowPlayingInfo client+ updatePlayerWidgetsVar nowPlayings+ setPlayingClass+ signalCallback _ _ _ _ = doUpdate+ propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" } handleNameOwnerChanged _ name _ _ = do- busNames <- map (coerce . fst) <$> MV.readMVar playerWidgetsVar- when (name `elem` busNames) doUpdate+ playerWidgets <- MV.readMVar playerWidgetsVar+ busName <- parseBusName name+ when (busName `M.member` playerWidgets) doUpdate _ <- Gtk.onWidgetRealize grid $ do updateHandler <-@@ -145,13 +257,21 @@ doUpdate void $ Gtk.onWidgetUnrealize grid $ removeMatch client updateHandler >> removeMatch client nameHandler+ Gtk.widgetShow grid- Gtk.toWidget grid+ setPlayingClass+ return outerWidget +-- | Generate now playing text with the artist truncated to a maximum given by+-- the first provided int, and the song title truncated to a maximum given by+-- the second provided int. playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} = G.markupEscapeText formattedText (-1)- where formattedText = T.pack $ printf+ where truncatedTitle = truncateString songMax title+ formattedText = T.pack $ if null artists+ then truncatedTitle+ else printf "%s - %s" (truncateString artistMax $ intercalate "," artists)- (truncateString songMax title)+ truncatedTitle
src/System/Taffybar/Widget/NetworkGraph.hs view
@@ -1,23 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.NetworkGraph+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides a channel based network graph widget.+-----------------------------------------------------------------------------+ module System.Taffybar.Widget.NetworkGraph where +import Data.Default (Default(..))+import Data.Foldable (for_) import qualified GI.Gtk+import GI.Gtk.Objects.Widget (widgetSetTooltipMarkup) import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network+import System.Taffybar.Util (postGUIASync) import System.Taffybar.Widget.Generic.ChannelGraph+import System.Taffybar.Widget.Generic.ChannelWidget import System.Taffybar.Widget.Generic.Graph+import System.Taffybar.Widget.Text.NetworkMonitor -logScale :: Double -> Double -> Double -> Double-logScale base maxValue value =- logBase base (min value maxValue) / actualMax- where actualMax = logBase base maxValue+-- | 'NetworkGraphConfig' configures the network graph widget.+data NetworkGraphConfig = NetworkGraphConfig+ { networkGraphGraphConfig :: GraphConfig -- ^ The configuration of the graph itself.+ -- | A tooltip format string, together with the precision that should be used+ -- for numbers in the string.+ , networkGraphTooltipFormat :: Maybe (String, Int)+ -- | A function to scale the y axis of the network config. The default is+ -- `logBase $ 2 ** 32`.+ , networkGraphScale :: Double -> Double+ -- | A filter function that determines whether a given interface will be+ -- included in the network stats.+ , interfacesFilter :: String -> Bool+ } +-- | Default configuration paramters for the network graph.+defaultNetworkGraphConfig :: NetworkGraphConfig+defaultNetworkGraphConfig = NetworkGraphConfig+ { networkGraphGraphConfig = def+ , networkGraphTooltipFormat = Just (defaultNetFormat, 3)+ , networkGraphScale = logBase $ 2 ** 32+ , interfacesFilter = const True+ }++instance Default NetworkGraphConfig where+ def = defaultNetworkGraphConfig++-- | 'networkGraphNew' instantiates a network graph widget from a 'GraphConfig'+-- and a list of interfaces. networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget-networkGraphNew config interfaces = do+networkGraphNew config interfaces =+ networkGraphNewWith def+ { networkGraphGraphConfig = config+ , interfacesFilter = maybe (const True) (flip elem) interfaces+ }++-- | 'networkGraphNewWith' instantiates a network graph widget from a+-- 'NetworkGraphConfig'.+networkGraphNewWith :: NetworkGraphConfig -> TaffyIO GI.Gtk.Widget+networkGraphNewWith config = do NetworkInfoChan chan <- getNetworkChan- let filterFn = maybe (const True) (flip elem) interfaces- getUpDown = sumSpeeds . map snd . filter (filterFn . fst)- toLogScale = logScale 2 (2 ** 32)- toSample (up, down) = map (toLogScale . fromRational) [up, down]+ let getUpDown = sumSpeeds . map snd . filter (interfacesFilter config . fst)+ toSample (up, down) = map (networkGraphScale config . fromRational) [up, down] sampleBuilder = return . toSample . getUpDown- channelGraphNew config chan sampleBuilder+ widget <- channelGraphNew (networkGraphGraphConfig config) chan sampleBuilder+ for_ (networkGraphTooltipFormat config) $ \(format, precision) ->+ channelWidgetNew widget chan $ \speedInfo ->+ let (up, down) = sumSpeeds $ map snd speedInfo+ tooltip = showInfo format precision (fromRational down, fromRational up)+ in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip+ return widget
src/System/Taffybar/Widget/SNITray.hs view
@@ -8,23 +8,28 @@ -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable------------------------------------------------------------------------------ ----- A widget to display the system tray.------ This widget only supports the newer StatusNotifierItem (SNI) protocol;--- older xembed applets will not be visible. AppIndicator is also a valid--- implementation of SNI.+-- This module exports functions for the construction of+-- StatusNotifierItem/AppIndicator tray widgets, supplied by the+-- "StatusNotifier.Tray" module from the gtk-sni-tray library. These widgets do+-- not support the older XEMBED protocol, although bridges like+-- xembed-sni-proxy do allow sni trays to provide limited support for XEMBED+-- tray icons. ----- Additionally, it does not handle recognising new tray applets. Instead it is+-- Unless 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is used it is -- necessary to run status-notifier-watcher from the -- [status-notifier-item](https://github.com/taffybar/status-notifier-item)--- package early on system startup.--- In case this is not possiblle,--- 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt is available, but--- this may not necessarily be able to pick up everything.+-- package before starting taffybar when using the functions defined in this+-- module. Using 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is+-- generally not recommended, because it can lead to issues with the+-- registration of tray icons if taffybar crashes/restarts, or if tray icon+-- providing applications are ever started before taffybar.+----------------------------------------------------------------------------- -module System.Taffybar.Widget.SNITray where+module System.Taffybar.Widget.SNITray+ ( TrayParams+ , module System.Taffybar.Widget.SNITray+ ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Reader@@ -36,21 +41,18 @@ import System.Taffybar.Widget.Util import Text.Printf -getHost :: Bool -> TaffyIO H.Host-getHost startWatcher = getStateDefault $ do- pid <- lift getProcessID- client <- asks sessionDBusClient- Just host <- lift $ H.build H.defaultParams- { H.dbusClient = Just client- , H.uniqueIdentifier = printf "taffybar-%s" $ show pid- , H.startWatcher = startWatcher- }- return host+-- | Build a new StatusNotifierItem tray that will share a host with any other+-- trays that are constructed automatically+sniTrayNew :: TaffyIO GI.Gtk.Widget+sniTrayNew = sniTrayNewFromParams defaultTrayParams --- | Build a new StatusNotifierItem tray from the provided parameters+-- | Build a new StatusNotifierItem tray from the provided 'TrayParams'. sniTrayNewFromParams :: TrayParams -> TaffyIO GI.Gtk.Widget-sniTrayNewFromParams params = getHost False >>= sniTrayNewFromHostParams params+sniTrayNewFromParams params =+ getTrayHost False >>= sniTrayNewFromHostParams params +-- | Build a new StatusNotifierItem tray from the provided 'TrayParams' and+-- 'H.Host'. sniTrayNewFromHostParams :: TrayParams -> H.Host -> TaffyIO GI.Gtk.Widget sniTrayNewFromHostParams params host = do client <- asks sessionDBusClient@@ -60,15 +62,24 @@ GI.Gtk.widgetShowAll tray GI.Gtk.toWidget tray --- | Build a new StatusNotifierItem tray that will share a host with any other--- trays that are constructed automatically-sniTrayNew :: TaffyIO GI.Gtk.Widget-sniTrayNew = sniTrayNewFromParams defaultTrayParams- -- | Build a new StatusNotifierItem tray that also starts its own watcher, -- without depending on status-notifier-icon. This will not register applets -- started before the watcher is started. sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt =- getHost True >>= sniTrayNewFromHostParams defaultTrayParams+ getTrayHost True >>= sniTrayNewFromHostParams defaultTrayParams++-- | Get a 'H.Host' from 'TaffyIO' internal state, that can be used to construct+-- SNI tray widgets. The boolean parameter determines whether or not a watcher+-- will be started the first time 'getTrayHost' is invoked.+getTrayHost :: Bool -> TaffyIO H.Host+getTrayHost startWatcher = getStateDefault $ do+ pid <- lift getProcessID+ client <- asks sessionDBusClient+ Just host <- lift $ H.build H.defaultParams+ { H.dbusClient = Just client+ , H.uniqueIdentifier = printf "taffybar-%s" $ show pid+ , H.startWatcher = startWatcher+ }+ return host
src/System/Taffybar/Widget/SimpleClock.hs view
@@ -10,6 +10,7 @@ ) where import Control.Monad.IO.Class+import Data.Default ( Default(..) ) import Data.Maybe import qualified Data.Text as T import Data.Time.Calendar ( toGregorian )@@ -62,10 +63,10 @@ textClockNew userLocale format interval = textClockNewWith cfg where- cfg = defaultClockConfig { clockTimeLocale = userLocale- , clockFormatString = format- , clockUpdateStrategy = ConstantInterval interval- }+ cfg = def { clockTimeLocale = userLocale+ , clockFormatString = format+ , clockUpdateStrategy = ConstantInterval interval+ } data ClockUpdateStrategy = ConstantInterval Double@@ -87,6 +88,9 @@ , clockFormatString = "%a %b %_d %r" , clockUpdateStrategy = RoundedTargetInterval 5 0.0 }++instance Default ClockConfig where+ def = defaultClockConfig systemGetTZ :: IO TimeZone systemGetTZ = setTZ >> getCurrentTimeZone
src/System/Taffybar/Widget/Text/MemoryMonitor.hs view
@@ -1,6 +1,7 @@-module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew) where+module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew, showMemoryInfo) where import Control.Monad.IO.Class ( MonadIO )+import qualified Data.Text as T import qualified Text.StringTemplate as ST import System.Taffybar.Information.Memory import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )@@ -10,22 +11,43 @@ -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds). textMemoryMonitorNew :: MonadIO m- => String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "available".+ => String -- ^ Format. You can use variables: "used", "total", "free", "buffer",+ -- "cache", "rest", "available", "swapUsed", "swapTotal", "swapFree". -> Double -- ^ Polling period in seconds. -> m GI.Gtk.Widget textMemoryMonitorNew fmt period = do- label <- pollingLabelNew period callback+ label <- pollingLabelNew period (showMemoryInfo fmt 3 <$> parseMeminfo) GI.Gtk.toWidget label- where- callback = do- info <- parseMeminfo- let template = ST.newSTMP fmt- let labels = ["used", "total", "free", "buffer", "cache", "rest", "available"]- let actions = [memoryUsed, memoryTotal, memoryFree, memoryBuffer, memoryCache, memoryRest, memoryAvailable]- actions' = map ((toAuto 3).) actions- let stats = [f info | f <- actions']- let template' = ST.setManyAttrib (zip labels stats) template- return $ ST.render template'++showMemoryInfo :: String -> Int -> MemoryInfo -> T.Text+showMemoryInfo fmt prec info =+ let template = ST.newSTMP fmt+ labels = [ "used"+ , "total"+ , "free"+ , "buffer"+ , "cache"+ , "rest"+ , "available"+ , "swapUsed"+ , "swapTotal"+ , "swapFree"+ ]+ actions = [ memoryUsed+ , memoryTotal+ , memoryFree+ , memoryBuffer+ , memoryCache+ , memoryRest+ , memoryAvailable+ , memorySwapUsed+ , memorySwapTotal+ , memorySwapFree+ ]+ actions' = map (toAuto prec .) actions+ stats = [f info | f <- actions']+ template' = ST.setManyAttrib (zip labels stats) template+ in ST.render template' toAuto :: Int -> Double -> String toAuto prec value = printf "%.*f%s" p v unit
src/System/Taffybar/Widget/Util.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -21,6 +22,7 @@ import Control.Monad.IO.Class import Data.Bifunctor ( first ) import Data.Functor ( ($>) )+import Data.GI.Base.Overloading (IsDescendantOf) import Data.Int import qualified Data.Text as T import qualified GI.Gdk as D@@ -28,8 +30,8 @@ import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize)-import System.FilePath.Posix import System.Environment.XDG.DesktopEntry+import System.FilePath.Posix import System.Taffybar.Util import Text.Printf @@ -103,7 +105,7 @@ -> String -- ^ Background color. -> String -- ^ Contents. -> String-colorize fg bg = printf "<span%s%s>%s</span>" (attr "fg" fg) (attr "bg" bg)+colorize fg bg = printf "<span%s%s>%s</span>" (attr ("fg" :: String) fg :: String) (attr ("bg" :: String) bg :: String) where attr name value | null value = "" | otherwise = printf " %scolor=\"%s\"" name value@@ -130,11 +132,11 @@ getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForMaybeIconName mIconName size =- join <$> (sequenceA $ flip getImageForIconName size <$> mIconName)+ join <$> sequenceA (flip getImageForIconName size <$> mIconName) getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForIconName iconName size =- maybeTCombine (loadPixbufByName size $ iconName)+ maybeTCombine (loadPixbufByName size iconName) (getPixbufFromFilePath (T.unpack iconName) >>= traverse (scalePixbufToSize size Gtk.OrientationHorizontal)) @@ -162,18 +164,55 @@ fmap (handleResult . first show) $ catchGErrorsAsLeft $ PB.pixbufNewFromFileAtScale name (-1) height True where-#if MIN_VERSION_gi_gdkpixbuf(2,0,26)- handleResult = join . fmap (maybe (Left "gdk function returned NULL") Right)-#else- handleResult = id-#endif+ handleResult = (maybe (Left "gdk function returned NULL") Right =<<) loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf) loadIcon height name =- ((</> "icons" </> name) <$> getDataDir) >>=- pixbufNewFromFileAtScaleByHeight height+ getDataDir >>=+ pixbufNewFromFileAtScaleByHeight height . (</> "icons" </> name) setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w setMinWidth width widget = liftIO $ do Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1) return widget++addClassIfMissing ::+ (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()+addClassIfMissing klass widget = do+ context <- Gtk.widgetGetStyleContext widget+ Gtk.styleContextHasClass context klass >>=+ (`when` Gtk.styleContextAddClass context klass) . not++removeClassIfPresent ::+ (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()+removeClassIfPresent klass widget = do+ context <- Gtk.widgetGetStyleContext widget+ Gtk.styleContextHasClass context klass >>=+ (`when` Gtk.styleContextRemoveClass context klass)++-- | Wrap a widget with two container boxes. The inner box will have the class+-- "inner-pad", and the outer box will have the class "outer-pad". These boxes+-- can be used to add padding between the outline of the widget and its+-- contents, or for the purpose of displaying a different background behind the+-- widget.+buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget+buildPadBox contents = liftIO $ do+ innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0+ outerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0+ Gtk.setWidgetValign innerBox Gtk.AlignFill+ Gtk.setWidgetValign outerBox Gtk.AlignFill+ Gtk.containerAdd innerBox contents+ Gtk.containerAdd outerBox innerBox+ _ <- widgetSetClassGI innerBox "inner-pad"+ _ <- widgetSetClassGI outerBox "outer-pad"+ Gtk.widgetShow outerBox+ Gtk.widgetShow innerBox+ Gtk.toWidget outerBox++buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget+buildContentsBox widget = liftIO $ do+ contents <- Gtk.boxNew Gtk.OrientationHorizontal 0+ Gtk.containerAdd contents widget+ _ <- widgetSetClassGI contents "contents"+ Gtk.widgetShowAll contents+ Gtk.toWidget contents >>= buildPadBox
src/System/Taffybar/Widget/Weather.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}--- | This module defines a simple textual weather widget that polls --- NOAA for weather data. To find your weather station, you can use +-- | This module defines a simple textual weather widget that polls+-- NOAA for weather data. To find your weather station, you can use -- either of the following:--- --- <https://www.weather.gov/tg/siteloc> +--+-- <https://www.weather.gov/tg/siteloc> -- <https://cnrfc.noaa.gov/metar.php> -- -- For example, Madison, WI is KMSN.
src/System/Taffybar/Widget/Windows.hs view
@@ -19,6 +19,7 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader+import Data.Default (Default(..)) import Data.Maybe import qualified Data.Text as T import GI.GLib (markupEscapeText)@@ -44,7 +45,8 @@ defaultGetActiveLabel :: TaffyIO T.Text defaultGetActiveLabel = do- label <- fromMaybe "" <$> (runX11Def Nothing getActiveWindow >>= traverse defaultGetMenuLabel)+ label <- fromMaybe "" <$> (runX11Def Nothing getActiveWindow >>=+ traverse defaultGetMenuLabel) markupEscapeText label (-1) truncatedGetActiveLabel :: Int -> TaffyIO T.Text@@ -62,6 +64,9 @@ , getActiveLabel = truncatedGetActiveLabel 35 } +instance Default WindowsConfig where+ def = defaultWindowsConfig+ -- | Create a new Windows widget that will use the given Pager as -- its source of events. windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget@@ -74,7 +79,7 @@ subscription <- subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass] activeWindowUpdatedCallback- _ <- liftReader (Gtk.onWidgetUnrealize label) (unsubscribe subscription)+ _ <- liftReader (\x -> Gtk.onWidgetUnrealize label x) (unsubscribe subscription) context <- ask @@ -94,7 +99,8 @@ forM_ windowIds $ \windowId -> lift $ do labelText <- runReaderT (getMenuLabel config windowId) context- let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >> return True+ let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >>+ return True item <- Gtk.menuItemNewWithLabel labelText _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback Gtk.menuShellAppend menu item
src/System/Taffybar/Widget/Workspaces.hs view
@@ -17,16 +17,18 @@ import Control.Arrow ((&&&)) import Control.Concurrent import qualified Control.Concurrent.MVar as MV+import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.RateLimit+import Data.Default (Default(..)) import qualified Data.Foldable as F import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int-import Data.List (intersect, sortBy, (\\))+import Data.List (elemIndex, intersect, sortBy, (\\)) import qualified Data.Map as M import Data.Maybe import qualified Data.MultiMap as MM@@ -48,7 +50,6 @@ import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util-import System.Taffybar.Widget.Decorators import System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage) import System.Taffybar.Widget.Util import System.Taffybar.WindowIcon@@ -100,7 +101,7 @@ liftContext action = asks taffyContext >>= lift . runReaderT action liftX11Def :: a -> X11Property a -> WorkspacesIO a-liftX11Def def prop = liftContext $ runX11Def def prop+liftX11Def dflt prop = liftContext $ runX11Def dflt prop setWorkspaceWidgetStatusClass :: (MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m ()@@ -150,8 +151,6 @@ WorkspacesConfig { widgetBuilder :: ControllerConstructor , widgetGap :: Int- , underlineHeight :: Int- , underlinePadding :: Int , maxIcons :: Maybe Int , minIcons :: Int , getWindowIconPixbuf :: WindowIconPixbufGetter@@ -169,8 +168,6 @@ WorkspacesConfig { widgetBuilder = buildButtonController defaultBuildContentsController , widgetGap = 0- , underlineHeight = 4- , underlinePadding = 1 , maxIcons = Nothing , minIcons = 0 , getWindowIconPixbuf = defaultGetWindowIconPixbuf@@ -183,6 +180,9 @@ , urgentWorkspaceState = False } +instance Default WorkspacesConfig where+ def = defaultWorkspacesConfig+ hideEmpty :: Workspace -> Bool hideEmpty Workspace { workspaceState = Empty } = False hideEmpty _ = True@@ -457,6 +457,24 @@ wLog DEBUG (printf "Updating %s icons." $ show idx) >> updateWidget c (IconUpdate $ Set.toList wids)) +initializeWWC ::+ WorkspaceWidgetController a => a -> Workspace -> ReaderT WorkspacesContext IO WWC+initializeWWC controller ws =+ WWC <$> updateWidget controller (WorkspaceUpdate ws)++-- | A WrappingController can be used to wrap some child widget with another+-- abitrary widget.+data WrappingController = WrappingController+ { wrappedWidget :: Gtk.Widget+ , wrappedController :: WWC+ }++instance WorkspaceWidgetController WrappingController where+ getWidget = lift . Gtk.toWidget . wrappedWidget+ updateWidget wc update = do+ updated <- updateWidget (wrappedController wc) update+ return wc { wrappedController = updated }+ data WorkspaceContentsController = WorkspaceContentsController { containerWidget :: Gtk.Widget , contentsControllers :: [WWC]@@ -477,12 +495,59 @@ { containerWidget = widget , contentsControllers = controllers }- WWC <$> updateWidget tempController (WorkspaceUpdate ws)+ initializeWWC tempController ws defaultBuildContentsController :: ControllerConstructor defaultBuildContentsController = buildContentsController [buildLabelController, buildIconController] +bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor+bottomLeftAlignedBoxWrapper boxClass constructor ws = do+ controller <- constructor ws+ widget <- getWidget controller+ ebox <- Gtk.eventBoxNew+ _ <- widgetSetClassGI ebox boxClass+ Gtk.widgetSetHalign ebox Gtk.AlignStart+ Gtk.widgetSetValign ebox Gtk.AlignEnd+ Gtk.containerAdd ebox widget+ wrapped <- Gtk.toWidget ebox+ let wrappingController = WrappingController+ { wrappedWidget = wrapped+ , wrappedController = controller+ }+ initializeWWC wrappingController ws++buildLabelOverlayController :: ControllerConstructor+buildLabelOverlayController =+ buildOverlayContentsController+ [buildIconController]+ [bottomLeftAlignedBoxWrapper "overlay-box" buildLabelController]++buildOverlayContentsController ::+ [ControllerConstructor] -> [ControllerConstructor] -> ControllerConstructor+buildOverlayContentsController mainConstructors overlayConstructors ws = do+ controllers <- mapM ($ ws) mainConstructors+ overlayControllers <- mapM ($ ws) overlayConstructors+ ctx <- ask+ tempController <- lift $ do+ mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0+ mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents)+ controllers+ outerBox <- Gtk.toWidget mainContents >>= buildPadBox+ _ <- widgetSetClassGI mainContents "contents"+ overlay <- Gtk.overlayNew+ Gtk.containerAdd overlay outerBox+ mapM_ (flip runReaderT ctx . getWidget >=>+ Gtk.overlayAddOverlay overlay) overlayControllers++ widget <- Gtk.toWidget overlay+ return+ WorkspaceContentsController+ { containerWidget = widget+ , contentsControllers = controllers ++ overlayControllers+ }+ initializeWWC tempController ws+ instance WorkspaceWidgetController WorkspaceContentsController where getWidget = return . containerWidget updateWidget cc update = do@@ -505,7 +570,7 @@ lbl <- Gtk.labelNew Nothing _ <- widgetSetClassGI lbl "workspace-label" return LabelController { label = lbl }- WWC <$> updateWidget tempController (WorkspaceUpdate ws)+ initializeWWC tempController ws instance WorkspaceWidgetController LabelController where getWidget = lift . Gtk.toWidget . label@@ -586,7 +651,7 @@ return IconController {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}- WWC <$> updateWidget tempController (WorkspaceUpdate ws)+ initializeWWC tempController ws instance WorkspaceWidgetController IconController where getWidget = lift . Gtk.toWidget . iconsContainer@@ -617,16 +682,22 @@ constantScaleWindowIconPixbufGetter constantSize getter = const $ scaledWindowIconPixbufGetter getter constantSize +handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter+handleIconGetterException getter =+ \size windowData -> catchAny (getter size windowData) $ \e -> do+ wLog WARNING $ printf "Failed to get window icon for %s: %s" (show windowData) (show e)+ return Nothing+ getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter-getWindowIconPixbufFromEWMH size windowData =+getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData -> runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData) getWindowIconPixbufFromClass :: WindowIconPixbufGetter-getWindowIconPixbufFromClass size windowData =+getWindowIconPixbufFromClass = handleIconGetterException $ \size windowData -> lift $ getWindowIconFromClasses size (windowClass windowData) getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter-getWindowIconPixbufFromDesktopEntry size windowData =+getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size windowData -> getWindowIconFromDesktopEntryByClasses size (windowClass windowData) getWindowIconPixbufFromChrome :: WindowIconPixbufGetter@@ -667,6 +738,7 @@ lift $ maybe (return Nothing) getPixbufFromFilePath $ getCustomIconPath wdata +-- | Sort windows by top-left corner position. sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData] sortWindowsByPosition wins = do let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)@@ -684,6 +756,16 @@ (windowMinimized b, getLeftPos b) return $ sortBy compareWindowData wins +-- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order.+-- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first.+-- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST.+sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]+sortWindowsByStackIndex wins = do+ stackingWindows <- liftX11Def [] getWindowsStacking+ let getStackIdx wd = fromMaybe (-1) $ elemIndex (windowId wd) stackingWindows+ compareWindowData a b = compare (getStackIdx b) (getStackIdx a)+ return $ sortBy compareWindowData wins+ updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget] updateImages ic ws = do WorkspacesContext {workspacesConfig = cfg} <- ask@@ -749,9 +831,11 @@ , iconForceUpdate = updateIcon } windowData = do let statusString = maybe "inactive" getWindowStatusString windowData :: T.Text+ title = T.pack . windowTitle <$> windowData setIconWidgetProperties = updateWidgetClasses iconButton [statusString] possibleStatusStrings void $ updateVar windowRef $ const $ return windowData+ Gtk.widgetSetTooltipText iconButton title lift $ updateIcon >> setIconWidgetProperties data WorkspaceButtonController = WorkspaceButtonController@@ -791,7 +875,7 @@ return $ WWC WorkspaceButtonController- {button = ebox, buttonWorkspace = workspace, contentsController = cc}+ { button = ebox, buttonWorkspace = workspace, contentsController = cc } switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool switch ctx idx = do
src/System/Taffybar/Widget/WttrIn.hs view
@@ -1,66 +1,90 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This is a simple weather widget that polls wttr.in to retrieve the weather,--- instead of relying on noaa data. +-- instead of relying on noaa data. -- -- Useful if NOAA data doesn't cover your needs, or if you just like wttr.in--- better. +-- better. -- -- For more information on how to use wttr.in, see <https://wttr.in/:help>.+module System.Taffybar.Widget.WttrIn (textWttrNew) where -module System.Taffybar.Widget.WttrIn ( textWttrNew ) where-import System.Log.Logger-import Control.Exception as E-import Control.Monad.IO.Class-import GI.Gtk-import qualified Data.Text as T+import Control.Exception as E (handle)+import Control.Monad.IO.Class (MonadIO)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict) import Data.Maybe (isJust)+import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8)-import Data.ByteString.Lazy (toStrict)-import Data.ByteString (ByteString)-import Text.Regex+import GI.Gtk (Widget) import Network.HTTP.Client+ ( HttpException,+ Request (requestHeaders),+ Response (responseBody, responseStatus),+ defaultManagerSettings,+ httpLbs,+ newManager,+ parseRequest,+ ) import Network.HTTP.Types.Status (statusIsSuccessful)-import System.Taffybar.Widget.Generic.PollingLabel+import System.Log.Logger (Priority (ERROR), logM)+import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNew)+import Text.Regex (matchRegex, mkRegex) -- | Creates a GTK Label widget that polls the requested wttr.in url for weather--- information. +-- information. -- -- Not compatible with image endpoints and binary data, such as the %.png%--- endpoints. +-- endpoints. -- -- > -- Yields a label with the text "London: ⛅️ +72°F". Updates every 60 -- > -- seconds. -- > textWttrNew "http://wttr.in/London?format=3" 60-textWttrNew - :: MonadIO m - => String -- ^ URL. All non-alphanumeric characters must be properly %-encoded.- -> Double -- ^ Update Interval (in seconds)- -> m Widget+textWttrNew ::+ MonadIO m =>+ -- | URL. All non-alphanumeric characters must be properly %-encoded.+ String ->+ -- | Update Interval (in seconds)+ Double ->+ m Widget textWttrNew url interval = pollingLabelNew interval (callWttr url) --- | IO Action that calls wttr.in as per the user's request. +-- | IO Action that calls wttr.in as per the user's request. callWttr :: String -> IO T.Text-callWttr url = do- let unknownLocation rsp = -- checks for a common wttr.in bug+callWttr url =+ let unknownLocation rsp =+ -- checks for a common wttr.in bug case T.stripPrefix "Unknown location; please try" rsp of- Nothing -> False+ Nothing -> False Just strippedRsp -> T.length strippedRsp < T.length rsp- isImage = isJust . (matchRegex $ mkRegex ".png")- getResponseData r = ( statusIsSuccessful $ responseStatus r- , toStrict $ responseBody r)- catchAndLog = flip E.catch $ logException- manager <- newManager defaultManagerSettings- request <- parseRequest url- (isOk, response) <- catchAndLog (getResponseData <$> httpLbs request manager) - let body = decodeUtf8 response- if not isOk || isImage url || unknownLocation body- then return $ "✨"- else return $ body+ isImage = isJust . matchRegex (mkRegex ".png")+ getResponseData r =+ ( statusIsSuccessful $ responseStatus r,+ toStrict $ responseBody r+ )+ in do+ manager <- newManager defaultManagerSettings+ request <- parseRequest url+ (isOk, response) <-+ handle+ logException+ ( getResponseData+ <$> httpLbs+ (request {requestHeaders = [("User-Agent", "curl")]})+ manager+ )+ let body = decodeUtf8 response+ return $+ if not isOk || isImage url || unknownLocation body+ then "✨"+ else body -- Logs an Http Exception and returns wttr.in's weather unknown label. logException :: HttpException -> IO (Bool, ByteString) logException e = do let errmsg = show e- logM "System.Taffybar.Widget.WttrIn" ERROR $+ logM+ "System.Taffybar.Widget.WttrIn"+ ERROR ("Warning: Couldn't call wttr.in. \n" ++ errmsg)- return $ (False, "✨")+ return (False, "✨")
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 3.3.0+version: 4.0.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -21,11 +21,9 @@ dbus-xml/org.mpris.MediaPlayer2.Player.xml dbus-xml/org.mpris.MediaPlayer2.xml -description:- 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.+flag cryptocurrency+ description: Enable crypto assets widget.+ default: True library default-extensions:@@ -38,14 +36,17 @@ , ConfigFile , HStringTemplate >= 0.8 && < 0.9 , X11 >= 1.5.0.1+ , aeson , ansi-terminal , broadcast-chan >= 0.2.0.2 , bytestring+ , conduit , containers+ , data-default , dbus >= 1.2.11 && < 2.0.0 , dbus-hslogger >= 0.1.0.1 && < 0.2.0.0 , directory- , dyre >= 0.8.6 && < 0.10+ , dyre >= 0.9.0 && < 0.10 , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath@@ -64,6 +65,7 @@ , haskell-gi >= 0.24 , haskell-gi-base >= 0.24 , hslogger+ , http-conduit , http-client >= 0.5 , http-client-tls , http-types@@ -107,6 +109,7 @@ , System.Taffybar.Information.CPU , System.Taffybar.Information.CPU2 , System.Taffybar.Information.Chrome+ , System.Taffybar.Information.Crypto , System.Taffybar.Information.DiskIO , System.Taffybar.Information.EWMHDesktopInfo , System.Taffybar.Information.MPRIS2@@ -124,7 +127,7 @@ , System.Taffybar.Widget.Battery , System.Taffybar.Widget.CPUMonitor , System.Taffybar.Widget.CommandRunner- , System.Taffybar.Widget.Decorators+ , System.Taffybar.Widget.Crypto , System.Taffybar.Widget.DiskIOMonitor , System.Taffybar.Widget.FSMonitor , System.Taffybar.Widget.FreedesktopNotifications@@ -149,9 +152,9 @@ , System.Taffybar.Widget.Text.NetworkMonitor , System.Taffybar.Widget.Util , System.Taffybar.Widget.Weather- , System.Taffybar.Widget.WttrIn , System.Taffybar.Widget.Windows , System.Taffybar.Widget.Workspaces+ , System.Taffybar.Widget.WttrIn , System.Taffybar.Widget.XDGMenu.Menu , System.Taffybar.Widget.XDGMenu.MenuWidget , System.Taffybar.WindowIcon@@ -169,6 +172,7 @@ executable taffybar default-language: Haskell2010 build-depends: base > 3 && < 5+ , data-default , directory , hslogger , optparse-applicative