diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
--- a/src/System/Taffybar.hs
+++ b/src/System/Taffybar.hs
@@ -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
diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs
--- a/src/System/Taffybar/Context.hs
+++ b/src/System/Taffybar/Context.hs
@@ -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)
diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs
--- a/src/System/Taffybar/DBus/Toggle.hs
+++ b/src/System/Taffybar/DBus/Toggle.hs
@@ -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
diff --git a/src/System/Taffybar/Example.hs b/src/System/Taffybar/Example.hs
--- a/src/System/Taffybar/Example.hs
+++ b/src/System/Taffybar/Example.hs
@@ -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 $
diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs
--- a/src/System/Taffybar/Hooks.hs
+++ b/src/System/Taffybar/Hooks.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs
--- a/src/System/Taffybar/Information/Battery.hs
+++ b/src/System/Taffybar/Information/Battery.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs
--- a/src/System/Taffybar/Information/Chrome.hs
+++ b/src/System/Taffybar/Information/Chrome.hs
@@ -13,7 +13,7 @@
import qualified GI.GdkPixbuf as Gdk
import Prelude
import System.Log.Logger
-import System.Taffybar.Context hiding (logIO)
+import System.Taffybar.Context
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Information.SafeX11
import Text.Read hiding (lift)
diff --git a/src/System/Taffybar/Information/Crypto.hs b/src/System/Taffybar/Information/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Crypto.hs
@@ -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
diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
--- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs
+++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
@@ -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.
diff --git a/src/System/Taffybar/Information/MPRIS2.hs b/src/System/Taffybar/Information/MPRIS2.hs
--- a/src/System/Taffybar/Information/MPRIS2.hs
+++ b/src/System/Taffybar/Information/MPRIS2.hs
@@ -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)
diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs
--- a/src/System/Taffybar/SimpleConfig.hs
+++ b/src/System/Taffybar/SimpleConfig.hs
@@ -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)
diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs
--- a/src/System/Taffybar/Util.hs
+++ b/src/System/Taffybar/Util.hs
@@ -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
diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs
--- a/src/System/Taffybar/Widget.hs
+++ b/src/System/Taffybar/Widget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs
--- a/src/System/Taffybar/Widget/Battery.hs
+++ b/src/System/Taffybar/Widget/Battery.hs
@@ -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]
diff --git a/src/System/Taffybar/Widget/Crypto.hs b/src/System/Taffybar/Widget/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Crypto.hs
@@ -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"))
diff --git a/src/System/Taffybar/Widget/Decorators.hs b/src/System/Taffybar/Widget/Decorators.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widget/Decorators.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
--- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs
+++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
@@ -4,12 +4,11 @@
{-# LANGUAGE ScopedTypeVariables #-}
-- | This widget listens on DBus for freedesktop notifications
-- (). 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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
--- a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
--- a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
+++ b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs
--- a/src/System/Taffybar/Widget/Generic/Graph.hs
+++ b/src/System/Taffybar/Widget/Generic/Graph.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/Generic/PollingGraph.hs b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
--- a/src/System/Taffybar/Widget/Generic/PollingGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs
--- a/src/System/Taffybar/Widget/Layout.hs
+++ b/src/System/Taffybar/Widget/Layout.hs
@@ -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.
diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs
--- a/src/System/Taffybar/Widget/MPRIS2.hs
+++ b/src/System/Taffybar/Widget/MPRIS2.hs
@@ -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
-- ().
-----------------------------------------------------------------------------
-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
diff --git a/src/System/Taffybar/Widget/NetworkGraph.hs b/src/System/Taffybar/Widget/NetworkGraph.hs
--- a/src/System/Taffybar/Widget/NetworkGraph.hs
+++ b/src/System/Taffybar/Widget/NetworkGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SNITray.hs b/src/System/Taffybar/Widget/SNITray.hs
--- a/src/System/Taffybar/Widget/SNITray.hs
+++ b/src/System/Taffybar/Widget/SNITray.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs
--- a/src/System/Taffybar/Widget/SimpleClock.hs
+++ b/src/System/Taffybar/Widget/SimpleClock.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
--- a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
+++ b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs
--- a/src/System/Taffybar/Widget/Util.hs
+++ b/src/System/Taffybar/Widget/Util.hs
@@ -1,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 "%s" (attr "fg" fg) (attr "bg" bg)
+colorize fg bg = printf "%s" (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
diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs
--- a/src/System/Taffybar/Widget/Weather.hs
+++ b/src/System/Taffybar/Widget/Weather.hs
@@ -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:
---
---
+--
+--
--
--
-- For example, Madison, WI is KMSN.
diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs
--- a/src/System/Taffybar/Widget/Windows.hs
+++ b/src/System/Taffybar/Widget/Windows.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs
--- a/src/System/Taffybar/Widget/Workspaces.hs
+++ b/src/System/Taffybar/Widget/Workspaces.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/WttrIn.hs b/src/System/Taffybar/Widget/WttrIn.hs
--- a/src/System/Taffybar/Widget/WttrIn.hs
+++ b/src/System/Taffybar/Widget/WttrIn.hs
@@ -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 .
+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, "✨")
diff --git a/taffybar.cabal b/taffybar.cabal
--- a/taffybar.cabal
+++ b/taffybar.cabal
@@ -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