taffybar-0.4.5/0000755000000000000000000000000012507657545011524 5ustar0000000000000000taffybar-0.4.5/CHANGELOG.md0000644000000000000000000000617112507657545013342 0ustar0000000000000000# 0.4.5 * GHC 7.10 compat # 0.4.4 * Fix compilation with gtk 0.13.1 # 0.4.3 * Try again to fix the network dependency # 0.4.2 * Expand the version range for time * Depend on network-uri instead of network # 0.4.1 * Make the clock react to time zone changes # 0.4.0 ## Features * Resize the bar when the screen configuration changes (Robert Helgesson) * Support bypassing `dyre` by exposing `taffybarMain` (Christian Hoener zu Siederdissen) * Textual CPU and memory monitors (Zakhar Voit) * A new window switcher menu in the pager (José Alfredo Romero L) * Dynamic workspace support in the workspace switcher (Nick Hu) * More configurable network monitor (Arseniy Seroka) * New widget: text-based command runner (Arseniy Seroka) * The Graph widget supports lines graphs (via graphDataStyles) (Joachim Breitner) * Compile with gtk2hs 0.13 ## Bug Fixes * Reduce wakeups by tweaking the default GHC RTS options (Joachim Breitner) * UTF8 fixes (Nathan Maxson) * Various fixes to EWMH support (José Alfredo Romero L) ## Deprecations The `XMonadLog` module is deprecated. This module let taffybar display XMonad desktop information through a dbus connection. The EWMH desktop support by José Alfredo Romero L is better in every way, so that (through TaffyPager) is the recommended replacement. Upgrading should be straightforward. # 0.3.0: * A new pager (System.Taffybar.TaffyPager) from José A. Romero L. This pager is a drop-in replacement for the dbus-based XMonadLog widget. It communicates via X atoms and EWMH like a real pager. It even supports changing workspaces by clicking on them. I recommend this over the old widget. * Added an MPRIS2 widget (contributed by Igor Babuschkin) * Ported to use the newer merged dbus library instead of dbus-client/dbus-core (contributed by CJ van den Berg) * Finally have the calendar widget pop up over the date/time widget (contributed by José A. Romero) * GHC 7.6 compatibility * Vertical bars can now have dynamic background colors (suggested by Elliot Wolk) * Bug fixes # 0.2.1: * More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson) * New widgets from José A. Romero (network monitor, fs monitor, another CPU monitor) * Allow the bar widget to grow vertically (also contributed by José A. Romero) # 0.2.0: * Add some more flexible formatting options for the XMonadLog widget (contributed by cnervi). * Make the PollingLabel more robust with an exception handler for IOExceptions * Added more documentation for a few widgets # 0.1.3: * Depend on gtk 0.12.1+ to be able to build under ghc 7.2 * Fix the background colors in the calendar so that it follows the GTK theme instead of the bar-specific color settings * Fix the display of non-ASCII window titles in the XMonad log applet (assuming you use the dbusLog function) * Add a horrible hack to force the bar to not resize to be larger than the screen due to notifications or long window titles # 0.1.2: * Readable widget for freedesktop notifications * Fixed a few potential deadlocks on startup * Use the GTK+ rc-file styling system for colors instead of hard coding them taffybar-0.4.5/LICENSE0000644000000000000000000000276712507657545012545 0ustar0000000000000000Copyright (c)2011, Tristan Ravitch All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Tristan Ravitch nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. taffybar-0.4.5/README.md0000644000000000000000000000271012507657545013003 0ustar0000000000000000This is a desktop information bar intended for use with XMonad and similar window managers. It is similar in spirit to xmobar; it is different in that it gives up some simplicity for a reasonable helping of eye candy. This bar is based on GTK+ (via gtk2hs) and uses fancy graphics where doing so is reasonable and useful. Example: ![](https://github.com/travitch/taffybar/blob/master/doc/screenshot.png) The bar is configured much like XMonad. It uses ~/.config/taffybar/taffybar.hs as its configuration file. This file is just a Haskell program that invokes the real _main_ function with a configuration object. The configuration file basically just specifies which widgets to use, though any arbitrary Haskell code can be executed before the bar is created. There are some generic pre-defined widgets available: * Graph (modeled after the graph widget in Awesome) * Vertical bar (also similar to a widget in Awesome) * Periodically-updating labels, graphs, and vertical bars There are also several more specialized widgets: * Battery widget * Textual clock * Freedesktop.org notifications (via dbus) * MPRIS1 and MPRIS2 widgets * Weather widget * XMonad log widget (listens on dbus instead of stdin) * System tray TODO ==== An incomplete list of things that would be cool to have: * xrandr widget (for dealing changing clone/extend mode and orientation) * Better behavior when adding/removing monitors (never tried it) * Make MPRIS more configurable taffybar-0.4.5/Setup.hs0000644000000000000000000000005612507657545013161 0ustar0000000000000000import Distribution.Simple main = defaultMain taffybar-0.4.5/taffybar.hs.example0000644000000000000000000000311612507657545015311 0ustar0000000000000000import System.Taffybar import System.Taffybar.Systray import System.Taffybar.TaffyPager import System.Taffybar.SimpleClock import System.Taffybar.FreedesktopNotifications import System.Taffybar.Weather import System.Taffybar.MPRIS import System.Taffybar.Widgets.PollingBar import System.Taffybar.Widgets.PollingGraph import System.Information.Memory import System.Information.CPU memCallback = do mi <- parseMeminfo return [memoryUsedRatio mi] cpuCallback = do (userLoad, systemLoad, totalLoad) <- cpuLoad return [totalLoad, systemLoad] main = do let memCfg = defaultGraphConfig { graphDataColors = [(1, 0, 0, 1)] , graphLabel = Just "mem" } cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1) , (1, 0, 1, 0.5) ] , graphLabel = Just "cpu" } let clock = textClockNew Nothing "%a %b %_d %H:%M" 1 pager = taffyPagerNew defaultPagerConfig note = notifyAreaNew defaultNotificationConfig wea = weatherNew (defaultWeatherConfig "KMSN") 10 mpris = mprisNew mem = pollingGraphNew memCfg 1 memCallback cpu = pollingGraphNew cpuCfg 0.5 cpuCallback tray = systrayNew defaultTaffybar defaultTaffybarConfig { startWidgets = [ pager, note ] , endWidgets = [ tray, wea, clock, mem, cpu, mpris ] } taffybar-0.4.5/taffybar.cabal0000644000000000000000000001046412507657545014313 0ustar0000000000000000name: taffybar version: 0.4.5 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE author: Tristan Ravitch maintainer: tristan@nochair.net category: System build-type: Simple cabal-version: >=1.10 homepage: http://github.com/travitch/taffybar data-files: taffybar.rc extra-source-files: README.md, CHANGELOG.md, taffybar.hs.example description: A somewhat fancier desktop bar than xmobar. This bar is based on gtk2hs and provides several widgets (including a few graphical ones). It also sports an optional snazzy system tray. flag network-uri description: network hack default: True library default-language: Haskell2010 build-depends: base > 3 && < 5, time >= 1.4 && < 1.6, time-locale-compat >= 0.1 && < 0.2, old-locale, containers, text, HTTP, parsec >= 3.1, mtl >= 2, cairo, dbus >= 0.10.1 && < 1.0, gtk >= 0.12.1 && < 0.14, dyre >= 0.8.6, HStringTemplate, gtk-traymanager >= 0.1.2 && < 0.2, xmonad-contrib, xmonad, xdg-basedir, filepath, utf8-string, process, stm, transformers >= 0.3.0.0, X11 >= 1.5.0.1, safe >= 0.3 && < 1, split >= 0.1.4.2, process >= 1.0.1.1, enclosed-exceptions >= 1.0.0.1 if flag(network-uri) build-depends: network-uri >= 2.6 && < 3, network >= 2.6 && < 3 else build-depends: network-uri < 2.6, network < 2.6 hs-source-dirs: src pkgconfig-depends: gtk+-2.0 exposed-modules: System.Taffybar, System.Taffybar.XMonadLog, System.Taffybar.Systray, System.Taffybar.SimpleClock, System.Taffybar.FreedesktopNotifications, System.Taffybar.Weather, System.Taffybar.MPRIS, System.Taffybar.MPRIS2, System.Taffybar.Battery, System.Taffybar.CPUMonitor, System.Taffybar.CommandRunner, System.Taffybar.DiskIOMonitor, System.Taffybar.FSMonitor, System.Taffybar.LayoutSwitcher, System.Taffybar.NetMonitor, System.Taffybar.Pager, System.Taffybar.TaffyPager, System.Taffybar.Text.CPUMonitor, System.Taffybar.Text.MemoryMonitor, System.Taffybar.WindowSwitcher, System.Taffybar.WorkspaceSwitcher, System.Taffybar.Hooks.PagerHints, System.Taffybar.Widgets.Graph, System.Taffybar.Widgets.PollingBar, System.Taffybar.Widgets.PollingGraph, System.Taffybar.Widgets.PollingLabel, System.Taffybar.Widgets.Util, System.Taffybar.Widgets.VerticalBar, System.Information.StreamInfo, System.Information.Battery, System.Information.EWMHDesktopInfo, System.Information.X11DesktopInfo, System.Information.Memory, System.Information.Network, System.Information.CPU, System.Information.CPU2, System.Information.DiskIO other-modules: System.Taffybar.StrutProperties, Paths_taffybar c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -auto-all executable taffybar default-language: Haskell2010 build-depends: base > 3 && < 5, dyre >= 0.8.6, gtk >= 0.12 && < 0.14, safe >= 0.3 && < 1, xdg-basedir, filepath hs-source-dirs: src main-is: Main.hs pkgconfig-depends: gtk+-2.0 c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -rtsopts -threaded ghc-prof-options: -auto-all source-repository head type: git location: git://github.com/travitch/taffybar.git taffybar-0.4.5/taffybar.rc0000644000000000000000000000102012507657545013641 0ustar0000000000000000gtk_color_scheme = "black:#000000\nwhite:#FFFFFF\ngreen:#00FF00\nred:#FF0000" style "default" { bg[NORMAL] = @black fg[NORMAL] = @white text[NORMAL] = @white fg[PRELIGHT] = @green bg[PRELIGHT] = @black } style "active-window" = "default" { fg[NORMAL] = @green } style "notification-button" = "default" { text[NORMAL] = @red fg[NORMAL] = @red } widget "Taffybar*" style "default" widget "Taffybar*WindowSwitcher*label" style "active-window" widget "*NotificationCloseButton" style "notification-button" taffybar-0.4.5/src/0000755000000000000000000000000012507657545012313 5ustar0000000000000000taffybar-0.4.5/src/Main.hs0000644000000000000000000000033012507657545013527 0ustar0000000000000000-- | This is just a stub executable that uses dyre to read the config -- file and recompile itself. module Main ( main ) where import System.Taffybar main :: IO () main = do defaultTaffybar defaultTaffybarConfig taffybar-0.4.5/src/gdk_property_change_wrapper.c0000644000000000000000000000211712507657545020236 0ustar0000000000000000//////////////////////////////////////////////////////////////////////////// // Copyright : (c) Jan Vornberger 2009 // License : BSD3-style (see LICENSE) // // Maintainer : jan.vornberger@informatik.uni-oldenburg.de ////////////////////////////////////////////////////////////////////////////- #include #include void set_strut_properties(GtkWindow *window, long left, long right, long top, long bottom, long left_start_y, long left_end_y, long right_start_y, long right_end_y, long top_start_x, long top_end_x, long bottom_start_x, long bottom_end_x) { gulong data[12] = {0}; data[0] = left; data[1] = right; data[2] = top; data[3] = bottom; data[4] = left_start_y; data[5] = left_end_y; data[6] = right_start_y; data[7] = right_end_y; data[8] = top_start_x; data[9] = top_end_x; data[10] = bottom_start_x; data[11] = bottom_end_x; gdk_property_change(GTK_WIDGET(window)->window, gdk_atom_intern("_NET_WM_STRUT_PARTIAL", FALSE), gdk_atom_intern ("CARDINAL", FALSE), 32, GDK_PROP_MODE_REPLACE, (unsigned char *)data, 12); } taffybar-0.4.5/src/System/0000755000000000000000000000000012507657545013577 5ustar0000000000000000taffybar-0.4.5/src/System/Taffybar.hs0000644000000000000000000003041512507657545015674 0ustar0000000000000000-- | The main module of Taffybar module System.Taffybar ( -- * Detail -- -- | This is a system status bar meant for use with window manager -- like XMonad. It is similar to xmobar, but with more visual flare -- and a different widget set. Contributed widgets are more than -- welcome. The bar is drawn using gtk and cairo. It is actually -- the simplest possible thing that could plausibly work: you give -- Taffybar a list of GTK widgets and it will render them in a -- horizontal bar for you (taking care of ugly details like -- reserving strut space so that window managers don't put windows -- over it). -- -- This is the real main module. The default bar should be -- customized to taste in the config file -- (~/.config/taffybar/taffybar.hs). Typically, this means adding -- widgets to the default config. A default configuration file is -- included in the distribution, but the essentials are covered -- here. -- * Config File -- -- | The config file is just a Haskell source file that is compiled -- at startup (if it has changed) to produce a custom executable -- with the desired set of widgets. You will want to import this -- module along with the modules of any widgets you want to add to -- the bar. Note, you can define any widgets that you want in your -- config file or other libraries. Taffybar only cares that you -- give it some GTK widgets to display. -- -- Below is a fairly typical example: -- -- > import System.Taffybar -- > import System.Taffybar.Systray -- > import System.Taffybar.XMonadLog -- > import System.Taffybar.SimpleClock -- > import System.Taffybar.Widgets.PollingGraph -- > import System.Information.CPU -- > -- > cpuCallback = do -- > (_, systemLoad, totalLoad) <- cpuLoad -- > return [ totalLoad, systemLoad ] -- > -- > main = do -- > let cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)] -- > , graphLabel = Just "cpu" -- > } -- > clock = textClockNew Nothing "%a %b %_d %H:%M" 1 -- > log = xmonadLogNew -- > tray = systrayNew -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback -- > defaultTaffybar defaultTaffybarConfig { startWidgets = [ log ] -- > , endWidgets = [ tray, clock, cpu ] -- > } -- -- This configuration creates a bar with four widgets. On the left is -- the XMonad log. The rightmost widget is the system tray, with a -- clock and then a CPU graph. The clock is formatted using standard -- strftime-style format strings (see the clock module). Note that -- the clock is colored using Pango markup (again, see the clock -- module). -- -- The CPU widget plots two graphs on the same widget: total CPU use -- in green and then system CPU use in a kind of semi-transparent -- purple on top of the green. -- -- It is important to note that the widget lists are *not* [Widget]. -- They are actually [IO Widget] since the bar needs to construct them -- after performing some GTK initialization. -- * XMonad Integration (via DBus) -- -- | The XMonadLog widget differs from its counterpart in xmobar: it -- listens for updates over DBus instead of reading from stdin. -- This makes it easy to restart Taffybar independently of XMonad. -- XMonad does not come with a DBus logger, so here is an example of -- how to make it work. Note: this requires the dbus-core (>0.9) -- package, which is installed as a dependency of Taffybar. -- -- > import XMonad.Hooks.DynamicLog -- > import XMonad.Hooks.ManageDocks -- > import DBus.Client -- > import System.Taffybar.XMonadLog ( dbusLog ) -- > -- > main = do -- > client <- connectSession -- > let pp = defaultPP -- > xmonad defaultConfig { logHook = dbusLog client pp -- > , manageHook = manageDocks -- > } -- -- The complexity is handled in the System.Tafftbar.XMonadLog -- module. Note that manageDocks is required to have XMonad put -- taffybar in the strut space that it reserves. If you have -- problems with taffybar appearing almost fullscreen, check to -- see if you have manageDocks in your manageHook. -- ** A note about DBus: -- | -- * If you start xmonad using a graphical login manager like gdm or -- kdm, DBus should be started automatically for you. -- -- * If you start xmonad with a different graphical login manager that -- does not start DBus for you automatically, put the line @eval -- \`dbus-launch --auto-syntax\`@ into your ~\/.xsession *before* -- xmonad and taffybar are started. This command sets some -- environment variables that the two must agree on. -- -- * If you start xmonad via @startx@ or a similar command, add the -- above command to ~\/.xinitrc -- * Colors -- -- | While taffybar is based on GTK+, it ignores your GTK+ theme. -- The default theme that it uses is in -- @~\/.cabal\/share\/taffybar-\\/taffybar.rc@. You can -- customize this theme by copying it to -- @~\/.config\/taffybar\/taffybar.rc@. For an idea of the customizations you can make, -- see . TaffybarConfig(..), defaultTaffybar, defaultTaffybarConfig, Position(..), taffybarMain ) where import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre import Control.Monad ( when ) import Data.Maybe ( fromMaybe ) import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.FilePath ( () ) import Graphics.UI.Gtk import Safe ( atMay ) import System.Exit ( exitFailure ) import qualified System.IO as IO import Text.Printf ( printf ) import Paths_taffybar ( getDataDir ) import System.Taffybar.StrutProperties data Position = Top | Bottom deriving (Show, Eq) strutProperties :: Position -- ^ Bar position -> Int -- ^ Bar height -> Rectangle -- ^ Current monitor rectangle -> [Rectangle] -- ^ All monitors -> StrutProperties strutProperties pos bh (Rectangle mX mY mW mH) monitors = propertize pos sX sW sH where sX = mX sW = mW - 1 sH = case pos of Top -> bh + mY Bottom -> bh + totalH - mY - mH totalH = maximum $ map bottomY monitors bottomY (Rectangle _ y _ h) = y + h propertize p x w h = case p of Top -> (0, 0, h, 0, 0, 0, 0, 0, x, x+w, 0, 0) Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0, 0, x, x+w) data TaffybarConfig = TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine) , monitorNumber :: Int -- ^ The xinerama/xrandr monitor number to put the bar on (default: 0) , barHeight :: Int -- ^ Number of pixels to reserve for the bar (default: 25 pixels) , barPosition :: Position -- ^ The position of the bar on the screen (default: Top) , widgetSpacing :: Int -- ^ The number of pixels between widgets , errorMsg :: Maybe String -- ^ Used by the application , startWidgets :: [IO Widget] -- ^ Widgets that are packed in order at the left end of the bar , endWidgets :: [IO Widget] -- ^ Widgets that are packed from right-to-left in the bar } -- | The default configuration gives an empty bar 25 pixels high on monitor 0. defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { screenNumber = 0 , monitorNumber = 0 , barHeight = 25 , barPosition = Top , widgetSpacing = 10 , errorMsg = Nothing , startWidgets = [] , endWidgets = [] } showError :: TaffybarConfig -> String -> TaffybarConfig showError cfg msg = cfg { errorMsg = Just msg } -- | The default parameters need to tell GHC to compile using -- -threaded so that the GTK event loops doesn't block all of the -- widgets defaultParams :: Dyre.Params TaffybarConfig defaultParams = Dyre.defaultParams { Dyre.projectName = "taffybar" , Dyre.realMain = realMain , Dyre.showError = showError , Dyre.ghcOpts = ["-threaded", "-rtsopts"] , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"] } -- | The entry point of the application. Feed it a custom config. defaultTaffybar :: TaffybarConfig -> IO () defaultTaffybar = Dyre.wrapMain defaultParams realMain :: TaffybarConfig -> IO () realMain cfg = do case errorMsg cfg of Nothing -> taffybarMain cfg Just err -> do IO.hPutStrLn IO.stderr ("Error: " ++ err) exitFailure getDefaultConfigFile :: String -> IO FilePath getDefaultConfigFile name = do dataDir <- getDataDir return (dataDir name) -- | Given a Taffybar configuration and the Taffybar window, this -- action sets up the window size and strut properties. May be called -- multiple times, e.g., when the monitor resolution changes. setTaffybarSize :: TaffybarConfig -> Window -> IO () setTaffybarSize cfg window = do screen <- windowGetScreen window nmonitors <- screenGetNMonitors screen allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)] when (monitorNumber cfg < nmonitors) $ do IO.hPutStrLn IO.stderr $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg) let monitorSize = fromMaybe (allMonitorSizes !! 0) $ do allMonitorSizes `atMay` monitorNumber cfg let Rectangle x y w h = monitorSize yoff = case barPosition cfg of Top -> 0 Bottom -> h - barHeight cfg windowMove window x (y + yoff) -- Set up the window size using fixed min and max sizes. This -- prevents the contained horizontal box from affecting the window -- size. windowSetGeometryHints window (Nothing :: Maybe Widget) (Just (w, barHeight cfg)) -- Min size. (Just (w, barHeight cfg)) -- Max size. Nothing Nothing Nothing let setStrutProps = setStrutProperties window $ strutProperties (barPosition cfg) (barHeight cfg) monitorSize allMonitorSizes winRealized <- widgetGetRealized window if winRealized then setStrutProps else onRealize window setStrutProps >> return () taffybarMain :: TaffybarConfig -> IO () taffybarMain cfg = 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. -- Users can override this default. defaultGtkConfig <- getDefaultConfigFile "taffybar.rc" userGtkConfig <- getUserConfigFile "taffybar" "taffybar.rc" rcSetDefaultFiles [ defaultGtkConfig, userGtkConfig ] _ <- initGUI Just disp <- displayGetDefault nscreens <- displayGetNScreens disp screen <- case screenNumber cfg < nscreens of False -> error $ printf "Screen %d is not available in the default display" (screenNumber cfg) True -> displayGetScreen disp (screenNumber cfg) window <- windowNew widgetSetName window "Taffybar" windowSetTypeHint window WindowTypeHintDock windowSetScreen window screen setTaffybarSize cfg window -- Reset the size of the Taffybar window if the monitor setup has -- changed, e.g., after a laptop user has attached an external -- monitor. _ <- on screen screenMonitorsChanged (setTaffybarSize cfg window) box <- hBoxNew False $ widgetSpacing cfg containerAdd window box mapM_ (\io -> do wid <- io widgetSetSizeRequest wid (-1) (barHeight cfg) boxPackStart box wid PackNatural 0) (startWidgets cfg) mapM_ (\io -> do wid <- io widgetSetSizeRequest wid (-1) (barHeight cfg) boxPackEnd box wid PackNatural 0) (endWidgets cfg) widgetShow window widgetShow box mainGUI return () taffybar-0.4.5/src/System/Information/0000755000000000000000000000000012507657545016064 5ustar0000000000000000taffybar-0.4.5/src/System/Information/CPU2.hs0000644000000000000000000000443712507657545017141 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Information.CPU2 -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about used CPU times, obtained from parsing the -- @\/proc\/stat@ file using some of the facilities included in the -- "System.Information.StreamInfo" module. -- And also provides information about the temperature of cores. -- (Now supports only physical cpu). -- ----------------------------------------------------------------------------- module System.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where import Data.Maybe ( mapMaybe ) import Safe ( atMay, readDef, tailSafe ) import System.Information.StreamInfo ( getLoad, getParsedInfo ) import Control.Monad (liftM) -- | Returns a two-element list containing relative system and user times -- calculated using two almost simultaneous samples of the @\/proc\/stat@ file -- for the given core (or all of them aggregated, if \"cpu\" is passed). getCPULoad :: String -> IO [Double] getCPULoad cpu = do load <- getLoad 0.05 $ getCPUInfo cpu case load of l0:l1:l2:_ -> return [ l0 + l1, l2 ] _ -> return [] -- | Returns a list containing temperatures of user given cpu cores. -- Use ["cpu1", "cpu2".."cpuN"] to get temperature of exact cores. -- Use ["cpu0"] to get common temperature. getCPUTemp :: [String] -> IO [Int] getCPUTemp cpus = do let cpus' = map (\s -> [last s]) cpus liftM concat $ mapM (\cpu -> getParsedInfo ("/sys/bus/platform/devices/coretemp.0/temp" ++ show ((read cpu::Int) + 1) ++ "_input") (\s -> [("temp", [(read s::Int) `div` 1000])]) "temp") cpus' --TODO and suppoprt for more than 1 physical cpu. -- | Returns a list of 5 to 7 elements containing all the values available for -- the given core (or all of them aggregated, if "cpu" is passed). getCPUInfo :: String -> IO [Int] getCPUInfo = getParsedInfo "/proc/stat" parse parse :: String -> [(String, [Int])] parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do cpu <- s `atMay` 0 return (cpu, map (readDef (-1)) (tailSafe s)) taffybar-0.4.5/src/System/Information/DiskIO.hs0000644000000000000000000000305512507657545017545 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Information.DiskIO -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about read/write operations in a given disk or -- partition, obtained from parsing the @\/proc\/diskstats@ file with some -- of the facilities included in the "System.Information.StreamInfo" module. ----------------------------------------------------------------------------- module System.Information.DiskIO ( getDiskTransfer ) where import Data.Maybe ( mapMaybe ) import Safe ( atMay, headMay, readDef ) import System.Information.StreamInfo ( getParsedInfo, getTransfer ) -- | Returns a two-element list containing the speed of transfer for read and -- write operations performed in the given disk\/partition (e.g. \"sda\", -- \"sda1\"). getDiskTransfer :: String -> IO [Double] getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk -- | Returns the list of all the values available in @\/proc\/diskstats@ -- for the given disk or partition. getDiskInfo :: String -> IO [Int] getDiskInfo = getParsedInfo "/proc/diskstats" parse parse :: String -> [(String, [Int])] parse = mapMaybe tuplize . map (drop 2 . words) . lines tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do device <- headMay s used <- s `atMay` 3 capacity <- s `atMay` 7 return (device, [readDef (-1) used, readDef (-1) capacity]) taffybar-0.4.5/src/System/Information/EWMHDesktopInfo.hs0000644000000000000000000001040112507657545021322 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Information.EWMHDesktopInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Functions to access data provided by the X11 desktop via EWHM hints. This -- module requires that the EwmhDesktops hook from the XMonadContrib project -- be installed in your @~\/.xmonad\/xmonad.hs@ configuration: -- -- > import XMonad -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > -- > main = xmonad $ ewmh $ ... -- ----------------------------------------------------------------------------- module System.Information.EWMHDesktopInfo ( X11Window -- re-exported from X11DesktopInfo , X11WindowHandle , withDefaultCtx -- re-exported from X11DesktopInfo , isWindowUrgent -- re-exported from X11DesktopInfo , getCurrentWorkspace , getVisibleWorkspaces , getWorkspaceNames , switchToWorkspace , getWindowTitle , getWindowClass , getActiveWindowTitle , getWindows , getWindowHandles , getWorkspace , focusWindow ) where import Data.List (elemIndex) import Data.Maybe (listToMaybe, mapMaybe) import System.Information.X11DesktopInfo -- | Convenience alias for a pair of the form (props, window), where props is a -- tuple of the form (workspace index, window title, window class), and window -- is the internal ID of an open window. type X11WindowHandle = ((Int, String, String), X11Window) noFocus :: String noFocus = "..." -- | Retrieve the index of the current workspace in the desktop, -- starting from 0. getCurrentWorkspace :: X11Property Int getCurrentWorkspace = readAsInt Nothing "_NET_CURRENT_DESKTOP" -- | Retrieve the indexes of all currently visible workspaces -- with the active workspace at the head of the list. getVisibleWorkspaces :: X11Property [Int] getVisibleWorkspaces = do vis <- getVisibleTags allNames <- getWorkspaceNames cur <- getCurrentWorkspace return $ cur : mapMaybe (`elemIndex` allNames) vis -- | Return a list with the names of all the workspaces currently -- available. getWorkspaceNames :: X11Property [String] getWorkspaceNames = readAsListOfString Nothing "_NET_DESKTOP_NAMES" -- | Ask the window manager to switch to the workspace with the given -- index, starting from 0. switchToWorkspace :: Int -> X11Property () switchToWorkspace idx = do cmd <- getAtom "_NET_CURRENT_DESKTOP" sendCommandEvent cmd (fromIntegral idx) -- | Get the title of the given X11 window. getWindowTitle :: X11Window -> X11Property String getWindowTitle window = do let w = Just window prop <- readAsString w "_NET_WM_NAME" case prop of "" -> readAsString w "WM_NAME" _ -> return prop -- | Get the class of the given X11 window. getWindowClass :: X11Window -> X11Property String getWindowClass window = readAsString (Just window) "WM_CLASS" withActiveWindow :: (X11Window -> X11Property String) -> X11Property String withActiveWindow getProp = do awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW" let w = listToMaybe $ filter (>0) awt maybe (return noFocus) getProp w -- | Get the title of the currently focused window. getActiveWindowTitle :: X11Property String getActiveWindowTitle = withActiveWindow getWindowTitle -- | Return a list of all windows getWindows :: X11Property [X11Window] getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST" -- | Return a list of X11 window handles, one for each window open. Refer to the -- documentation of 'X11WindowHandle' for details on the structure returned. getWindowHandles :: X11Property [X11WindowHandle] getWindowHandles = do windows <- getWindows workspaces <- mapM getWorkspace windows wtitles <- mapM getWindowTitle windows wclasses <- mapM getWindowClass windows return $ zip (zip3 workspaces wtitles wclasses) windows -- | Return the index (starting from 0) of the workspace on which the -- given window is being displayed. getWorkspace :: X11Window -> X11Property Int getWorkspace window = readAsInt (Just window) "_NET_WM_DESKTOP" -- | Ask the window manager to give focus to the given window. focusWindow :: X11Window -> X11Property () focusWindow wh = do cmd <- getAtom "_NET_ACTIVE_WINDOW" sendWindowEvent cmd (fromIntegral wh) taffybar-0.4.5/src/System/Information/CPU.hs0000644000000000000000000000170312507657545017050 0ustar0000000000000000module System.Information.CPU ( cpuLoad ) where import Control.Concurrent ( threadDelay ) import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose ) procData :: IO [Double] procData = do h <- openFile "/proc/stat" ReadMode firstLine <- hGetLine h (length firstLine) `seq` return () hClose h return (procParser firstLine) procParser :: String -> [Double] procParser = map read . tail . words truncVal :: Double -> Double truncVal v | isNaN v || v < 0.0 = 0.0 | otherwise = v -- | Return a pair with (user time, system time, total time) (read -- from /proc/stat). The function waits for 50 ms between samples. cpuLoad :: IO (Double, Double, Double) cpuLoad = do a <- procData threadDelay 50000 b <- procData let dif = zipWith (-) b a tot = foldr (+) 0 dif pct = map (/ tot) dif user = foldr (+) 0 $ take 2 pct system = pct !! 2 t = user + system return (truncVal user, truncVal system, truncVal t) taffybar-0.4.5/src/System/Information/Network.hs0000644000000000000000000000337512507657545020061 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Information.Network -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about network traffic over selected interfaces, -- obtained from parsing the @\/proc\/net\/dev@ file using some of the -- facilities provided by the "System.Information.StreamInfo" module. -- ----------------------------------------------------------------------------- module System.Information.Network ( getNetInfo ) where import Control.Applicative import Data.Maybe ( mapMaybe ) import Safe ( atMay, initSafe, readDef ) import System.Information.StreamInfo ( getParsedInfo ) import Prelude -- | Returns a two-element list containing the current number of bytes -- received and transmitted via the given network interface (e.g. \"wlan0\"), -- according to the contents of the @\/proc\/dev\/net@ file. getNetInfo :: String -> IO (Maybe [Integer]) getNetInfo iface = do isUp <- isInterfaceUp iface case isUp of True -> Just <$> getParsedInfo "/proc/net/dev" parse iface False -> return Nothing parse :: String -> [(String, [Integer])] parse = mapMaybe tuplize . map words . drop 2 . lines tuplize :: [String] -> Maybe (String, [Integer]) tuplize s = do dev <- initSafe <$> s `atMay` 0 down <- readDef (-1) <$> s `atMay` 1 up <- readDef (-1) <$> s `atMay` out return (dev, [down, up]) where out = (length s) - 8 isInterfaceUp :: String -> IO Bool isInterfaceUp iface = do state <- readFile $ "/sys/class/net/" ++ iface ++ "/operstate" case state of 'u' : _ -> return True _ -> return False taffybar-0.4.5/src/System/Information/Battery.hs0000644000000000000000000002051712507657545020037 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This is a simple library to query the Linux UPower daemon (via -- DBus) for battery information. Currently, it only retrieves -- information for the first battery it finds. module System.Information.Battery ( -- * Types BatteryContext, BatteryInfo(..), BatteryState(..), BatteryTechnology(..), BatteryType(..), -- * Accessors batteryContextNew, getBatteryInfo ) where import Data.Map ( Map ) import qualified Data.Map as M import Data.Maybe ( fromMaybe ) import Data.Word import Data.Int import DBus import DBus.Client import Data.List ( find, isInfixOf ) import Data.Text ( Text ) import qualified Data.Text as T import Safe ( atMay ) -- | An opaque wrapper around some internal library state data BatteryContext = BC Client ObjectPath data BatteryType = BatteryTypeUnknown | BatteryTypeLinePower | BatteryTypeBatteryType | BatteryTypeUps | BatteryTypeMonitor | BatteryTypeMouse | BatteryTypeKeyboard | BatteryTypePda | BatteryTypePhone deriving (Show, Ord, Eq, Enum) data BatteryState = BatteryStateUnknown | BatteryStateCharging | BatteryStateDischarging | BatteryStateEmpty | BatteryStateFullyCharged | BatteryStatePendingCharge | BatteryStatePendingDischarge deriving (Show, Ord, Eq, Enum) data BatteryTechnology = BatteryTechnologyUnknown | BatteryTechnologyLithiumIon | BatteryTechnologyLithiumPolymer | BatteryTechnologyLithiumIronPhosphate | BatteryTechnologyLeadAcid | BatteryTechnologyNickelCadmium | BatteryTechnologyNickelMetalHydride deriving (Show, Ord, Eq, Enum) -- | There are a few fields supported by UPower that aren't exposed -- here.. could be easily. data BatteryInfo = BatteryInfo { batteryNativePath :: Text , batteryVendor :: Text , batteryModel :: Text , batterySerial :: Text -- , batteryUpdateTime :: Time , batteryType :: BatteryType , batteryPowerSupply :: Bool , batteryHasHistory :: Bool , batteryHasStatistics :: Bool , batteryOnline :: Bool , batteryEnergy :: Double , batteryEnergyEmpty :: Double , batteryEnergyFull :: Double , batteryEnergyFullDesign :: Double , batteryEnergyRate :: Double , batteryVoltage :: Double , batteryTimeToEmpty :: Int64 , batteryTimeToFull :: Int64 , batteryPercentage :: Double , batteryIsPresent :: Bool , batteryState :: BatteryState , batteryIsRechargable :: Bool , batteryCapacity :: Double , batteryTechnology :: BatteryTechnology {- , batteryRecallNotice :: Bool , batteryRecallVendor :: Text , batteryRecallUr :: Text -} } -- | Find the first power source that is a battery in the list. The -- simple heuristic is a substring search on 'BAT' firstBattery :: [ObjectPath] -> Maybe ObjectPath firstBattery = find (isInfixOf "BAT" . formatObjectPath) -- | The name of the power daemon bus powerBusName :: BusName powerBusName = "org.freedesktop.UPower" -- | The base object path powerBaseObjectPath :: ObjectPath powerBaseObjectPath = "/org/freedesktop/UPower" -- | A helper to read the variant contents of a dict with a default -- value. readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a readDict dict key dflt = fromMaybe dflt $ do variant <- M.lookup key dict fromVariant variant -- | Read the variant contents of a dict which is of an unknown integral type. readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do v <- M.lookup key dict case variantType v of TypeWord8 -> return $ fromIntegral (f v :: Word8) TypeWord16 -> return $ fromIntegral (f v :: Word16) TypeWord32 -> return $ fromIntegral (f v :: Word32) TypeWord64 -> return $ fromIntegral (f v :: Word64) TypeInt16 -> return $ fromIntegral (f v :: Int16) TypeInt32 -> return $ fromIntegral (f v :: Int32) TypeInt64 -> return $ fromIntegral (f v :: Int64) _ -> Nothing where f :: (Num a, IsVariant a) => Variant -> a f = fromMaybe (fromIntegral dflt) . fromVariant -- | Query the UPower daemon about information on a specific battery. -- If some fields are not actually present, they may have bogus values -- here. Don't bet anything critical on it. getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo) getBatteryInfo (BC systemConn battPath) = do -- Grab all of the properties of the battery each call with one -- message. reply <- call_ systemConn (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll") { methodCallDestination = Just "org.freedesktop.UPower" , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"] } return $ do body <- methodReturnBody reply `atMay` 0 dict <- fromVariant body return BatteryInfo { batteryNativePath = readDict dict "NativePath" "" , batteryVendor = readDict dict "Vendor" "" , batteryModel = readDict dict "Model" "" , batterySerial = readDict dict "Serial" "" , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0 , batteryPowerSupply = readDict dict "PowerSupply" False , batteryHasHistory = readDict dict "HasHistory" False , batteryHasStatistics = readDict dict "HasStatistics" False , batteryOnline = readDict dict "Online" False , batteryEnergy = readDict dict "Energy" 0.0 , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0 , batteryEnergyFull = readDict dict "EnergyFull" 0.0 , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0 , batteryEnergyRate = readDict dict "EnergyRate" 0.0 , batteryVoltage = readDict dict "Voltage" 0.0 , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0 , batteryTimeToFull = readDict dict "TimeToFull" 0 , batteryPercentage = readDict dict "Percentage" 0.0 , batteryIsPresent = readDict dict "IsPresent" False , batteryState = toEnum $ readDictIntegral dict "State" 0 , batteryIsRechargable = readDict dict "IsRechargable" True , batteryCapacity = readDict dict "Capacity" 0.0 , batteryTechnology = toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0 } -- | Construct a battery context if possible. This could fail if the -- UPower daemon is not running. The context can be used to get -- actual battery state with 'getBatteryInfo'. batteryContextNew :: IO (Maybe BatteryContext) batteryContextNew = do systemConn <- connectSystem -- First, get the list of devices. For now, we just get the stats -- for the first battery reply <- call_ systemConn (methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices") { methodCallDestination = Just powerBusName } return $ do body <- methodReturnBody reply `atMay` 0 powerDevices <- fromVariant body battPath <- firstBattery powerDevices return $ BC systemConn battPath taffybar-0.4.5/src/System/Information/Memory.hs0000644000000000000000000000313012507657545017665 0ustar0000000000000000module System.Information.Memory ( MemoryInfo(..), parseMeminfo ) where toMB :: String -> Double toMB size = (read size :: Double) / 1024 data MemoryInfo = MemoryInfo { memoryTotal :: Double , memoryFree :: Double , memoryBuffer :: Double , memoryCache :: Double , memoryRest :: Double -- free + buffer + cache , memoryUsed :: Double -- total - rest , memoryUsedRatio :: Double -- used / total } emptyMemoryInfo :: MemoryInfo emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 parseLines :: [String] -> MemoryInfo -> MemoryInfo parseLines (line:rest) memInfo = parseLines rest newMemInfo where (label:size:_) = words line newMemInfo = case label of "MemTotal:" -> memInfo { memoryTotal = toMB size } "MemFree:" -> memInfo { memoryFree = toMB size } "Buffers:" -> memInfo { memoryBuffer = toMB size } "Cached:" -> memInfo { memoryCache = toMB size } _ -> memInfo parseLines _ memInfo = memInfo parseMeminfo :: IO MemoryInfo parseMeminfo = do s <- readFile "/proc/meminfo" let m = parseLines (lines s) emptyMemoryInfo rest = memoryFree m + memoryBuffer m + memoryCache m used = memoryTotal m - rest usedRatio = used / memoryTotal m return m { memoryRest = rest , memoryUsed = used , memoryUsedRatio = usedRatio } taffybar-0.4.5/src/System/Information/StreamInfo.hs0000644000000000000000000000645112507657545020475 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Information.StreamInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Generic code to poll any of the many data files maintained by the kernel in -- POSIX systems. Provides methods for applying a custom parsing function to the -- contents of the file and to calculate differentials across one or more values -- provided via the file. -- -------------------------------------------------------------------------------- module System.Information.StreamInfo ( getParsedInfo , getLoad , getAccLoad , getTransfer ) where import Control.Concurrent ( threadDelay ) import Data.IORef import Data.Maybe ( fromMaybe ) -- | Apply the given parser function to the file under the given path to produce -- a lookup map, then use the given selector as key to extract from it the -- desired value. getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a] getParsedInfo path parser selector = do file <- readFile path (length file) `seq` return () return (fromMaybe [] $ lookup selector $ parser file) truncVal :: (RealFloat a) => a -> a truncVal v | isNaN v || v < 0.0 = 0.0 | otherwise = v -- | Convert the given list of Integer to a list of the ratios of each of its -- elements against their sum. toRatioList :: (Integral a, RealFloat b) => [a] -> [b] toRatioList deltas = map truncVal ratios where total = fromIntegral $ foldr (+) 0 deltas ratios = map ((/total) . fromIntegral) deltas -- | Execute the given action twice with the given delay in-between and return -- the difference between the two samples. probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a] probe action delay = do a <- action threadDelay $ round (delay * 1e6) b <- action return $ zipWith (-) b a -- | Execute the given action once and return the difference between the -- obtained sample and the one contained in the given IORef. accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a] accProbe action sample = do a <- readIORef sample b <- action writeIORef sample b return $ zipWith (-) b a -- | Probe the given action and, interpreting the result as a variation in time, -- return the speed of change of its values. getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b] getTransfer interval action = do deltas <- probe action interval return $ map (truncVal . (/interval) . fromIntegral) deltas -- | Probe the given action and return the relative variation of each of the -- obtained values against the whole, where the whole is calculated as the sum -- of all the values in the probe. getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b] getLoad interval action = do deltas <- probe action interval return $ toRatioList deltas -- | Similar to getLoad, but execute the given action only once and use the -- given IORef to calculate the result and to save the current value, so it -- can be reused in the next call. getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b] getAccLoad sample action = do deltas <- accProbe action sample return $ toRatioList deltas taffybar-0.4.5/src/System/Information/X11DesktopInfo.hs0000644000000000000000000001677212507657545021154 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Information.X11DesktopInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Low-level functions to access data provided by the X11 desktop via window -- properties. One of them ('getVisibleTags') depends on the PagerHints hook -- being installed in your @~\/.xmonad\/xmonad.hs@ configuration: -- -- > import System.Taffybar.Hooks.PagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ ... -- ----------------------------------------------------------------------------- module System.Information.X11DesktopInfo ( X11Context , X11Property , X11Window , withDefaultCtx , readAsInt , readAsString , readAsListOfString , readAsListOfWindow , isWindowUrgent , getVisibleTags , getAtom , eventLoop , sendCommandEvent , sendWindowEvent ) where import Codec.Binary.UTF8.String as UTF8 import Control.Monad.Reader import Data.Bits (testBit, (.|.)) import Data.List.Split (endBy) import Data.Maybe (fromMaybe) import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window } type X11Property a = ReaderT X11Context IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a]) -- | Put the current display and root window objects inside a Reader -- transformer for further computation. withDefaultCtx :: X11Property a -> IO a withDefaultCtx fun = do ctx <- getDefaultCtx res <- runReaderT fun ctx closeDisplay (contextDisplay ctx) return res -- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a value of type Int. If that -- property hasn't been set, then return -1. readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property Int readAsInt window name = do prop <- fetch getWindowProperty32 window name case prop of Just (x:_) -> return (fromIntegral x) _ -> return (-1) -- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a String. If the property -- hasn't been set, then return an empty string. readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property String readAsString window name = do prop <- fetch getWindowProperty8 window name case prop of Just xs -> return . UTF8.decode . map fromIntegral $ xs _ -> return [] -- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a list of Strings. If the -- property hasn't been set, then return an empty list. readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [String] readAsListOfString window name = do prop <- fetch getWindowProperty8 window name case prop of Just xs -> return (parse xs) _ -> return [] where parse = endBy "\0" . UTF8.decode . map fromIntegral -- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a list of X11 Window IDs. If -- the property hasn't been set, then return an empty list. readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [X11Window] readAsListOfWindow window name = do prop <- fetch getWindowProperty32 window name case prop of Just xs -> return $ map fromIntegral xs _ -> return [] -- | Determine whether the \"urgent\" flag is set in the WM_HINTS of -- the given window. isWindowUrgent :: X11Window -> X11Property Bool isWindowUrgent window = do hints <- fetchWindowHints window return $ testBit (wmh_flags hints) urgencyHintBit -- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set -- by the PagerHints hook provided by Taffybar (see module documentation for -- instructions on how to do this), or an empty list of strings if the -- PagerHints hook is not available. getVisibleTags :: X11Property [String] getVisibleTags = return =<< readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES" -- | Return the Atom with the given name. getAtom :: String -> X11Property Atom getAtom s = do (X11Context d _) <- ask atom <- liftIO $ internAtom d s False return atom -- | Spawn a new thread and listen inside it to all incoming events, -- invoking the given function to every event of type @MapNotifyEvent@ that -- arrives, and subscribing to all events of this type emitted by newly -- created windows. eventLoop :: (Event -> IO ()) -> X11Property () eventLoop dispatch = do (X11Context d w) <- ask liftIO $ do xSetErrorHandler selectInput d w $ propertyChangeMask .|. substructureNotifyMask allocaXEvent $ \e -> forever $ do event <- nextEvent d e >> getEvent e case event of MapNotifyEvent _ _ _ _ _ window _ -> do selectInput d window propertyChangeMask _ -> return () dispatch event -- | Emit a \"command\" event with one argument for the X server. This is -- used to send events that can be received by event hooks in the XMonad -- process and acted upon in that context. sendCommandEvent :: Atom -> Atom -> X11Property () sendCommandEvent cmd arg = do (X11Context dpy root) <- ask sendCustomEvent dpy cmd arg root root -- | Similar to 'sendCommandEvent', but with an argument of type Window. sendWindowEvent :: Atom -> X11Window -> X11Property () sendWindowEvent cmd win = do (X11Context dpy root) <- ask sendCustomEvent dpy cmd cmd root win -- | Build a new X11Context containing the current X11 display and its root -- window. getDefaultCtx :: IO X11Context getDefaultCtx = do d <- openDisplay "" w <- rootWindow d $ defaultScreen d return $ X11Context d w -- | Apply the given function to the given window in order to obtain the X11 -- property with the given name, or Nothing if no such property can be read. fetch :: (Integral a) => PropertyFetcher a -- ^ Function to use to retrieve the property. -> Maybe X11Window -- ^ Window to read from. Nothing means the root Window. -> String -- ^ Name of the property to retrieve. -> X11Property (Maybe [a]) fetch fetcher window name = do (X11Context dpy root) <- ask atom <- getAtom name prop <- liftIO $ fetcher dpy atom (fromMaybe root window) return prop -- | Retrieve the @WM_HINTS@ mask assigned by the X server to the given window. fetchWindowHints :: X11Window -> X11Property WMHints fetchWindowHints window = do (X11Context d _) <- ask hints <- liftIO $ getWMHints d window return hints -- | Emit an event of type @ClientMessage@ that can be listened to and -- consumed by XMonad event hooks. sendCustomEvent :: Display -> Atom -> Atom -> X11Window -> X11Window -> X11Property () sendCustomEvent dpy cmd arg root win = do liftIO $ allocaXEvent $ \e -> do setEventType e clientMessage setClientMessageEvent e win cmd 32 arg currentTime sendEvent dpy root False structureNotifyMask e sync dpy False taffybar-0.4.5/src/System/Taffybar/0000755000000000000000000000000012507657545015335 5ustar0000000000000000taffybar-0.4.5/src/System/Taffybar/MPRIS2.hs0000644000000000000000000001125712507657545016653 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This is a "Now Playing"-style widget that listens for MPRIS -- events on DBus. Various media players implement this. This widget -- works with version 2 of the MPRIS protocol -- (http://www.mpris.org/2.0/spec.html). -- module System.Taffybar.MPRIS2 ( mpris2New ) where import Data.Maybe ( listToMaybe ) import DBus import DBus.Client import Data.List (isPrefixOf) import Graphics.UI.Gtk hiding ( Signal, Variant ) import Text.Printf mpris2New :: IO Widget mpris2New = do label <- labelNew (Nothing :: Maybe String) widgetShowAll label _ <- on label realize $ initLabel label return (toWidget label) unpack :: IsVariant a => Variant -> a unpack var = case fromVariant var of Just x -> x Nothing -> error("Could not unpack variant: " ++ show var) initLabel :: Label -> IO () initLabel w = do client <- connectSession -- Set initial song state/info reqSongInfo w client listen client propMatcher (callBack w) return () where callBack label s = do let items = dictionaryItems $ unpack (signalBody s !! 1) updatePlaybackStatus label items updateMetadata label items return () propMatcher = matchAny { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/org/mpris/MediaPlayer2" , matchInterface = Just "org.freedesktop.DBus.Properties" , matchMember = Just "PropertiesChanged" } reqSongInfo :: Label -> Client -> IO () reqSongInfo w client = do rep <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames") { methodCallDestination = Just "org.freedesktop.DBus" } let plist = unpack $ methodReturnBody rep !! 0 let players = filter (isPrefixOf "org.mpris.MediaPlayer2.") plist case length players of 0 -> return () _ -> do reply <- getProperty client (players !! 0) "Metadata" updateSongInfo w $ dictionaryItems $ (unpack . unpack) (methodReturnBody reply !! 0) reply' <- getProperty client (players !! 0) "PlaybackStatus" let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String case status of "Playing" -> postGUIAsync $ widgetShowAll w "Paused" -> postGUIAsync $ widgetHideAll w "Stopped" -> postGUIAsync $ widgetHideAll w _ -> return () getProperty :: Client -> String -> String -> IO MethodReturn getProperty client name property = do call_ client (methodCall "/org/mpris/MediaPlayer2" "org.freedesktop.DBus.Properties" "Get") { methodCallDestination = Just (busName_ name) , methodCallBody = [ toVariant ("org.mpris.MediaPlayer2.Player" :: String), toVariant property ] } setSongInfo :: Label -> String -> String -> IO () setSongInfo w artist title = do let msg :: String msg = case artist of "" -> escapeMarkup $ printf "%s" (truncateString 30 title) _ -> escapeMarkup $ printf "%s - %s" (truncateString 15 artist) (truncateString 30 title) txt = "▶ " ++ msg postGUIAsync $ do labelSetMarkup w txt truncateString :: Int -> String -> String truncateString n xs | length xs <= n = xs | otherwise = take n xs ++ "…" updatePlaybackStatus :: Label -> [(Variant, Variant)] -> IO () updatePlaybackStatus w items = do case lookup (toVariant ("PlaybackStatus" :: String)) items of Just a -> do case (unpack . unpack) a :: String of "Playing" -> postGUIAsync $ widgetShowAll w "Paused" -> postGUIAsync $ widgetHideAll w "Stopped" -> postGUIAsync $ widgetHideAll w _ -> return () Nothing -> do return () updateSongInfo :: Label -> [(Variant, Variant)] -> IO () updateSongInfo w items = do let artist = case readArtist of Just x -> x Nothing -> "" case readTitle of Just title -> do setSongInfo w artist title Nothing -> return () where readArtist :: Maybe String readArtist = do artist <- lookup (toVariant ("xesam:artist" :: String)) items listToMaybe $ ((unpack . unpack) artist :: [String]) readTitle :: Maybe String readTitle = do title <- lookup (toVariant ("xesam:title" :: String)) items Just $ (unpack . unpack) title updateMetadata :: Label -> [(Variant, Variant)] -> IO () updateMetadata w items = do case lookup (toVariant ("Metadata" :: String)) items of Just meta -> do let metaItems = dictionaryItems $ (unpack . unpack) meta updateSongInfo w metaItems Nothing -> return () taffybar-0.4.5/src/System/Taffybar/LayoutSwitcher.hs0000644000000000000000000000755312507657545020671 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.LayoutSwitcher -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple text widget that shows the XMonad layout used in the currently -- active workspace, and that allows to change it by clicking with the -- mouse: left-click to switch to the next layout in the list, right-click -- to switch to the first one (as configured in @xmonad.hs@) -- -- N.B. If you're just looking for a drop-in replacement for the -- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require -- DBus, you may want to see first "System.Taffybar.TaffyPager". -- ----------------------------------------------------------------------------- module System.Taffybar.LayoutSwitcher ( -- * Usage -- $usage layoutSwitcherNew ) where import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras (Event) import System.Taffybar.Pager import System.Information.X11DesktopInfo import System.Taffybar.Widgets.Util -- $usage -- -- This widget requires that the "System.Taffybar.Hooks.PagerHints" hook be -- installed in your @xmonad.hs@: -- -- > import System.Taffybar.Hooks.PagerHints (pagerHints) -- > main = do -- > xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- -- Once you've properly configured @xmonad.hs@, you can use the widget in -- your @taffybar.hs@ file: -- -- > import System.Taffybar.LayoutSwitcher -- > main = do -- > pager <- pagerNew defaultPagerConfig -- > let los = layoutSwitcherNew pager -- -- now you can use @los@ as any other Taffybar widget. -- | Name of the X11 events to subscribe, and of the hint to look for for -- the name of the current layout. xLayoutProp :: String xLayoutProp = "_XMONAD_CURRENT_LAYOUT" -- | Create a new LayoutSwitcher widget that will use the given Pager as -- its source of events. layoutSwitcherNew :: Pager -> IO Gtk.Widget layoutSwitcherNew pager = do label <- Gtk.labelNew (Nothing :: Maybe String) -- This callback is run in a separate thread and needs to use -- postGUIAsync let cfg = config pager callback = pagerCallback cfg label subscribe pager callback xLayoutProp assembleWidget label -- | Build a suitable callback function that can be registered as Listener -- of "_XMONAD_CURRENT_LAYOUT" custom events. These events are emitted by -- the PagerHints hook to notify of changes in the current layout. pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO () pagerCallback cfg label _ = Gtk.postGUIAsync $ do layout <- withDefaultCtx $ readAsString Nothing xLayoutProp let decorate = activeLayout cfg Gtk.labelSetMarkup label (decorate layout) -- | Build the graphical representation of the widget. assembleWidget :: Gtk.Label -> IO Gtk.Widget assembleWidget label = do ebox <- Gtk.eventBoxNew Gtk.containerAdd ebox label _ <- Gtk.on ebox Gtk.buttonPressEvent dispatchButtonEvent Gtk.widgetShowAll ebox return $ Gtk.toWidget ebox -- | Call 'switch' with the appropriate argument (1 for left click, -1 for -- right click), depending on the click event received. dispatchButtonEvent :: Gtk.EventM Gtk.EButton Bool dispatchButtonEvent = do btn <- Gtk.eventButton let trigger = onClick [Gtk.SingleClick] case btn of Gtk.LeftButton -> trigger $ switch 1 Gtk.RightButton -> trigger $ switch (-1) _ -> return False -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be -- intercepted by the PagerHints hook, which in turn can instruct XMonad to -- switch to a different layout. switch :: (MonadIO m) => Int -> m () switch n = liftIO $ withDefaultCtx $ do cmd <- getAtom xLayoutProp sendCommandEvent cmd (fromIntegral n) taffybar-0.4.5/src/System/Taffybar/DiskIOMonitor.hs0000644000000000000000000000277712507657545020400 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.DiskIOMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of -- read/write operations in one selected disk or partition. -- -------------------------------------------------------------------------------- module System.Taffybar.DiskIOMonitor ( dioMonitorNew ) where import qualified Graphics.UI.Gtk as Gtk import System.Information.DiskIO ( getDiskTransfer ) import System.Taffybar.Widgets.PollingGraph ( GraphConfig, pollingGraphNew ) -- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by -- regular calls to 'getDiskTransfer'. The results of calling this function -- are normalized to the maximum value of the obtained probe (either read or -- write transfer). dioMonitorNew :: GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\"). -> IO Gtk.Widget dioMonitorNew cfg pollSeconds = pollingGraphNew cfg pollSeconds . probeDisk probeDisk :: String -> IO [Double] probeDisk disk = do transfer <- getDiskTransfer disk let top = foldr max 1.0 transfer return $ map (/top) transfer taffybar-0.4.5/src/System/Taffybar/XMonadLog.hs0000644000000000000000000001014112507657545017516 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for Log events from XMonad and -- displays the formatted status string. To log to this widget using -- the excellent dbus-core library, use code like the following: -- -- > import DBus.Client.Simple -- > main = do -- > session <- connectSession -- > emit session "/org/xmonad/Log" "org.xmonad.Log" "Update" [toVariant "msg"] -- -- There is a more complete example of xmonad integration in the -- top-level module. module System.Taffybar.XMonadLog {-# DEPRECATED "Use TaffyPager instead. This module will be removed." #-} ( -- * Constructor xmonadLogNew, -- * Log hooks for xmonad.hs dbusLog, dbusLogWithPP, -- * Styles taffybarPP, taffybarDefaultPP, taffybarColor, taffybarEscape ) where import Codec.Binary.UTF8.String ( decodeString ) import DBus ( toVariant, fromVariant, Signal(..), signal ) import DBus.Client ( listen, matchAny, MatchRule(..), connectSession, emit, Client ) import Graphics.UI.Gtk hiding ( Signal ) import XMonad import XMonad.Hooks.DynamicLog -- | This is a DBus-based logger that can be used from XMonad to log -- to this widget. This version lets you specify the format for the -- log using a pretty printer (e.g., 'taffybarPP'). dbusLogWithPP :: Client -> PP -> X () dbusLogWithPP client pp = dynamicLogWithPP pp { ppOutput = outputThroughDBus client } -- | A DBus-based logger with a default pretty-print configuration dbusLog :: Client -> X () dbusLog client = dbusLogWithPP client taffybarDefaultPP taffybarColor :: String -> String -> String -> String taffybarColor fg bg = wrap t "" . taffybarEscape where t = concat [""] -- | Escape strings so that they can be safely displayed by Pango in -- the bar widget taffybarEscape :: String -> String taffybarEscape = escapeMarkup -- | The same as the default PP in XMonad.Hooks.DynamicLog taffybarDefaultPP :: PP taffybarDefaultPP = #if MIN_VERSION_xmonad_contrib(0, 12, 0) def { #else defaultPP { #endif ppCurrent = taffybarEscape . wrap "[" "]" , ppVisible = taffybarEscape . wrap "<" ">" , ppHidden = taffybarEscape , ppHiddenNoWindows = taffybarEscape , ppUrgent = taffybarEscape , ppTitle = taffybarEscape . shorten 80 , ppLayout = taffybarEscape } -- | The same as xmobarPP in XMonad.Hooks.DynamicLog taffybarPP :: PP taffybarPP = taffybarDefaultPP { ppCurrent = taffybarColor "yellow" "" . wrap "[" "]" , ppTitle = taffybarColor "green" "" . shorten 40 , ppVisible = wrap "(" ")" , ppUrgent = taffybarColor "red" "yellow" } outputThroughDBus :: Client -> String -> IO () outputThroughDBus client str = do -- The string that we get from XMonad here isn't quite a normal -- string - each character is actually a byte in a utf8 encoding. -- We need to decode the string back into a real String before we -- send it over dbus. let str' = decodeString str emit client (signal "/org/xmonad/Log" "org.xmonad.Log" "Update") { signalBody = [ toVariant str' ] } setupDbus :: Label -> IO () setupDbus w = do let matcher = matchAny { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/org/xmonad/Log" , matchInterface = Just "org.xmonad.Log" , matchMember = Just "Update" } client <- connectSession listen client matcher (callback w) callback :: Label -> Signal -> IO () callback w sig = do let [bdy] = signalBody sig status :: String Just status = fromVariant bdy postGUIAsync $ labelSetMarkup w status -- | Return a new XMonad log widget xmonadLogNew :: IO Widget xmonadLogNew = do l <- labelNew (Nothing :: Maybe String) _ <- on l realize $ setupDbus l widgetShowAll l return (toWidget l) {-# DEPRECATED xmonadLogNew "Use taffyPagerNew instead." #-} taffybar-0.4.5/src/System/Taffybar/MPRIS.hs0000644000000000000000000000735512507657545016575 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This is a "Now Playing"-style widget that listens for MPRIS -- events on DBus. Various media players implement this. This widget -- only works with version 1 of the MPRIS protocol -- (http://www.mpris.org/1.0/spec.html). Support for version 2 will -- be in a separate widget. module System.Taffybar.MPRIS ( TrackInfo (..) , MPRISConfig (..) , defaultMPRISConfig , mprisNew ) where import Data.Int ( Int32 ) import qualified Data.Map as M import Data.Text ( Text ) import qualified Data.Text as T import DBus import DBus.Client import Graphics.UI.Gtk hiding ( Signal, Variant ) import Text.Printf data TrackInfo = TrackInfo { trackArtist :: Maybe String -- ^ Artist name, if available. , trackTitle :: Maybe String -- ^ Track name, if available. , trackAlbum :: Maybe String -- ^ Album name, if available. } data MPRISConfig = MPRISConfig { trackLabel :: TrackInfo -> String -- ^ Calculate a label to display. } setupDBus :: MPRISConfig -> Label -> IO () setupDBus cfg w = do let trackMatcher = matchAny { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/Player" , matchInterface = Just "org.freedesktop.MediaPlayer" , matchMember = Just "TrackChange" } stateMatcher = matchAny { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/Player" , matchInterface = Just "org.freedesktop.MediaPlayer" , matchMember = Just "StatusChange" } client <- connectSession listen client trackMatcher (trackCallback cfg w) listen client stateMatcher (stateCallback w) variantDictLookup :: (IsVariant b, Ord k) => k -> M.Map k Variant -> Maybe b variantDictLookup k m = do val <- M.lookup k m fromVariant val trackCallback :: MPRISConfig -> Label -> Signal -> IO () trackCallback cfg w s = do let v :: Maybe (M.Map Text Variant) v = fromVariant variant [variant] = signalBody s case v of Just m -> do let getInfo key = fmap (escapeMarkup . T.unpack) $ variantDictLookup key m txt = trackLabel cfg info info = TrackInfo { trackArtist = getInfo "artist" , trackTitle = getInfo "title" , trackAlbum = getInfo "album" } postGUIAsync $ do -- In case the widget was hidden due to a stop/pause, forcibly -- show it again when the track changes. labelSetMarkup w txt widgetShowAll w _ -> return () stateCallback :: Label -> Signal -> IO () stateCallback w s = case fromVariant (signalBody s !! 0) of Just st -> case structureItems st of (pstate:_) -> case (fromVariant pstate) :: Maybe Int32 of Just 2 -> postGUIAsync $ widgetHideAll w Just 1 -> postGUIAsync $ widgetHideAll w Just 0 -> postGUIAsync $ widgetShowAll w _ -> return () _ -> return () _ -> return () defaultMPRISConfig :: MPRISConfig defaultMPRISConfig = MPRISConfig { trackLabel = display } where artist track = maybe "[unknown]" id (trackArtist track) title track = maybe "[unknown]" id (trackTitle track) display :: TrackInfo -> String display track = "▶ " ++ printf "%s - %s" (artist track) (title track) mprisNew :: MPRISConfig -> IO Widget mprisNew cfg = do l <- labelNew (Nothing :: Maybe String) _ <- on l realize $ setupDBus cfg l widgetShowAll l return (toWidget l) taffybar-0.4.5/src/System/Taffybar/SimpleClock.hs0000644000000000000000000000751512507657545020106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | This module implements a very simple text-based clock widget. -- The widget also toggles a calendar widget when clicked. This -- calendar is not fancy at all and has no data backend. module System.Taffybar.SimpleClock ( textClockNew, textClockNewWith, defaultClockConfig, ClockConfig(..) ) where import Control.Monad.Trans ( MonadIO, liftIO ) import Data.Time.Calendar ( toGregorian ) import qualified Data.Time.Clock as Clock import Data.Time.Format import Data.Time.LocalTime import Graphics.UI.Gtk import qualified Data.Time.Locale.Compat as L import System.Taffybar.Widgets.PollingLabel import System.Taffybar.Widgets.Util makeCalendar :: IO Window makeCalendar = do container <- windowNew cal <- calendarNew containerAdd container cal -- update the date on show _ <- onShow container $ liftIO $ resetCalendarDate cal -- prevent calendar from being destroyed, it can be only hidden: _ <- on container deleteEvent $ do liftIO (widgetHideAll container) return True return container resetCalendarDate :: Calendar -> IO () resetCalendarDate cal = do (y,m,d) <- Clock.getCurrentTime >>= return . toGregorian . Clock.utctDay calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y) calendarSelectDay cal (fromIntegral d) toggleCalendar :: WidgetClass w => w -> Window -> IO Bool toggleCalendar w c = do isVis <- get c widgetVisible if isVis then widgetHideAll c else do attachPopup w "Calendar" c displayPopup w c return True -- | Create the widget. I recommend passing @Nothing@ for the -- TimeLocale parameter. The format string can include Pango markup -- (http://developer.gnome.org/pango/stable/PangoMarkupFormat.html). textClockNew :: Maybe L.TimeLocale -> String -> Double -> IO Widget textClockNew userLocale fmt updateSeconds = textClockNewWith cfg fmt updateSeconds where cfg = defaultClockConfig { clockTimeLocale = userLocale } data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone , clockTimeLocale :: Maybe L.TimeLocale } deriving (Eq, Ord, Show) -- | A clock configuration that defaults to the current locale defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig Nothing Nothing data TimeInfo = TimeInfo { getTZ :: IO TimeZone , getLocale :: IO L.TimeLocale } systemGetTZ :: IO TimeZone systemGetTZ = setTZ >> getCurrentTimeZone -- | Old versions of time do not call localtime_r properly. We set -- the time zone manually, if required. setTZ :: IO () #if MIN_VERSION_time(1, 4, 2) setTZ = return () #else setTZ = c_tzset foreign import ccall unsafe "time.h tzset" c_tzset :: IO () #endif -- | A configurable text-based clock widget. It currently allows for -- a configurable time zone through the 'ClockConfig'. -- -- See also 'textClockNew'. textClockNewWith :: ClockConfig -> String -> Double -> IO Widget textClockNewWith cfg fmt updateSeconds = do let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone , getLocale = maybe (return L.defaultTimeLocale) return userLocale } l <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt) ebox <- eventBoxNew containerAdd ebox l eventBoxSetVisibleWindow ebox False cal <- makeCalendar _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal) widgetShowAll ebox return (toWidget ebox) where userZone = clockTimeZone cfg userLocale = clockTimeLocale cfg -- alternate getCurrentTime that takes a specific TZ getCurrentTime' :: TimeInfo -> String -> IO String getCurrentTime' ti f = do l <- getLocale ti z <- getTZ ti t <- Clock.getCurrentTime return $ formatTime l f $ utcToZonedTime z t taffybar-0.4.5/src/System/Taffybar/Weather.hs0000644000000000000000000002312212507657545017270 0ustar0000000000000000-- | This module defines a simple textual weather widget that polls -- NOAA for weather data. To find your weather station, you can use -- -- -- -- For example, Madison, WI is KMSN. -- -- NOAA provides several pieces of information in each request; you -- can control which pieces end up in your weather widget by providing -- a _template_ that is filled in with the current information. The -- template is just a 'String' with variables between dollar signs. -- The variables will be substituted with real data by the widget. -- Example: -- -- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" } -- > weatherWidget = weatherNew wcfg 10 -- -- This example makes a new weather widget that checks the weather at -- KMSN (Madison, WI) every 10 minutes, and displays the results in -- Celcius. -- -- Available variables: -- -- [@stationPlace@] The name of the weather station -- -- [@stationState@] The state that the weather station is in -- -- [@year@] The year the report was generated -- -- [@month@] The month the report was generated -- -- [@day@] The day the report was generated -- -- [@hour@] The hour the report was generated -- -- [@wind@] The direction and strength of the wind -- -- [@visibility@] Description of current visibility conditions -- -- [@skyCondition@] ? -- -- [@tempC@] The temperature in Celcius -- -- [@tempF@] The temperature in Farenheit -- -- [@dewPoint@] The current dew point -- -- [@humidity@] The current relative humidity -- -- [@pressure@] The current pressure -- -- -- As an example, a template like -- -- > "$tempF$ °F" -- -- would yield a widget displaying the temperature in Farenheit with a -- small label after it. -- -- Implementation Note: the weather data parsing code is taken from -- xmobar. This version of the code makes direct HTTP requests -- instead of invoking a separate cURL process. module System.Taffybar.Weather ( -- * Types WeatherConfig(..), WeatherInfo(..), WeatherFormatter(WeatherFormatter), -- * Constructor weatherNew, weatherCustomNew, defaultWeatherConfig ) where import Network.HTTP import Network.URI import Graphics.UI.Gtk import Text.Parsec import Text.Printf import Text.StringTemplate import System.Taffybar.Widgets.PollingLabel data WeatherInfo = WI { stationPlace :: String , stationState :: String , year :: String , month :: String , day :: String , hour :: String , wind :: String , visibility :: String , skyCondition :: String , tempC :: Int , tempF :: Int , dewPoint :: String , humidity :: Int , pressure :: Int } deriving (Show) -- Parsers stolen from xmobar type Parser = Parsec String () pTime :: Parser (String, String, String, String) pTime = do y <- getNumbersAsString _ <- char '.' m <- getNumbersAsString _ <- char '.' d <- getNumbersAsString _ <- char ' ' (h:hh:mi:mimi) <- getNumbersAsString _ <- char ' ' return (y, m, d ,([h]++[hh]++":"++[mi]++mimi)) pTemp :: Parser (Int, Int) pTemp = do let num = digit <|> char '-' <|> char '.' f <- manyTill num $ char ' ' _ <- manyTill anyChar $ char '(' c <- manyTill num $ char ' ' _ <- skipRestOfLine return $ (floor (read c :: Double), floor (read f :: Double)) pRh :: Parser Int pRh = do s <- manyTill digit $ (char '%' <|> char '.') return $ read s pPressure :: Parser Int pPressure = do _ <- manyTill anyChar $ char '(' s <- manyTill digit $ char ' ' _ <- skipRestOfLine return $ read s parseData :: Parser WeatherInfo parseData = do st <- getAllBut "," _ <- space ss <- getAllBut "(" _ <- skipRestOfLine >> getAllBut "/" (y,m,d,h) <- pTime w <- getAfterString "Wind: " v <- getAfterString "Visibility: " sk <- getAfterString "Sky conditions: " _ <- skipTillString "Temperature: " (tC,tF) <- pTemp dp <- getAfterString "Dew Point: " _ <- skipTillString "Relative Humidity: " rh <- pRh _ <- skipTillString "Pressure (altimeter): " p <- pPressure _ <- manyTill skipRestOfLine eof return $ WI st ss y m d h w v sk tC tF dp rh p getAllBut :: String -> Parser String getAllBut s = manyTill (noneOf s) (char $ head s) getAfterString :: String -> Parser String getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>") where pAfter = do _ <- try $ manyTill skipRestOfLine $ string s v <- manyTill anyChar $ newline return v skipTillString :: String -> Parser String skipTillString s = manyTill skipRestOfLine $ string s getNumbersAsString :: Parser String getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n skipRestOfLine :: Parser Char skipRestOfLine = do _ <- many $ noneOf "\n\r" newline -- | Simple: download the document at a URL. Taken from Real World -- Haskell. downloadURL :: String -> IO (Either String String) downloadURL url = do resp <- simpleHTTP request case resp of Left x -> return $ Left ("Error connecting: " ++ show x) Right r -> case rspCode r of (2,_,_) -> return $ Right (rspBody r) (3,_,_) -> -- A HTTP redirect case findHeader HdrLocation r of Nothing -> return $ Left (show r) Just url' -> downloadURL url' _ -> return $ Left (show r) where request = Request { rqURI = uri , rqMethod = GET , rqHeaders = [] , rqBody = "" } Just uri = parseURI url getWeather :: String -> IO (Either String WeatherInfo) getWeather url = do dat <- downloadURL url case dat of Right dat' -> case parse parseData url dat' of Right d -> return (Right d) Left err -> return (Left (show err)) Left err -> return (Left (show err)) defaultFormatter :: StringTemplate String -> WeatherInfo -> String defaultFormatter tpl wi = render tpl' where tpl' = setManyAttrib [ ("stationPlace", stationPlace wi) , ("stationState", stationState wi) , ("year", year wi) , ("month", month wi) , ("day", day wi) , ("hour", hour wi) , ("wind", wind wi) , ("visibility", visibility wi) , ("skyCondition", skyCondition wi) , ("tempC", show (tempC wi)) , ("tempF", show (tempF wi)) , ("dewPoint", dewPoint wi) , ("humidity", show (humidity wi)) , ("pressure", show (pressure wi)) ] tpl getCurrentWeather :: IO (Either String WeatherInfo) -> StringTemplate String -> WeatherFormatter -> IO String getCurrentWeather getter tpl formatter = do dat <- getter case dat of Right wi -> do case formatter of DefaultWeatherFormatter -> return (defaultFormatter tpl wi) WeatherFormatter f -> return (f wi) Left err -> do putStrLn err return "N/A" -- | The NOAA URL to get data from baseUrl :: String baseUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded" -- | A wrapper to allow users to specify a custom weather formatter. -- The default interpolates variables into a string as described -- above. Custom formatters can do basically anything. data WeatherFormatter = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo' | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter -- | The configuration for the weather widget. You can provide a custom -- format string through 'weatherTemplate' as described above, or you can -- provide a custom function to turn a 'WeatherInfo' into a String via the -- 'weatherFormatter' field. data WeatherConfig = WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above) } -- | A sensible default configuration for the weather widget that just -- renders the temperature. defaultWeatherConfig :: String -> WeatherConfig defaultWeatherConfig station = WeatherConfig { weatherStation = station , weatherTemplate = "$tempF$ °F" , weatherFormatter = DefaultWeatherFormatter } -- | Create a periodically-updating weather widget that polls NOAA. weatherNew :: WeatherConfig -- ^ Configuration to render -> Double -- ^ Polling period in _minutes_ -> IO Widget weatherNew cfg delayMinutes = do let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg) getter = getWeather url weatherCustomNew getter (weatherTemplate cfg) (weatherFormatter cfg) delayMinutes -- | Create a periodically-updating weather widget using custom weather getter weatherCustomNew :: IO (Either String WeatherInfo) -- ^ Weather querying action -> String -- ^ Weather template -> WeatherFormatter -- ^ Weather formatter -> Double -- ^ Polling period in _minutes_ -> IO Widget weatherCustomNew getter tpl formatter delayMinutes = do let tpl' = newSTMP tpl l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather getter tpl' formatter) widgetShowAll l return l taffybar-0.4.5/src/System/Taffybar/FSMonitor.hs0000644000000000000000000000303512507657545017552 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.FSMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple text widget that monitors the current usage of selected disk -- partitions by regularly parsing the output of the df command in Linux -- systems. -- ----------------------------------------------------------------------------- module System.Taffybar.FSMonitor ( fsMonitorNew ) where import qualified Graphics.UI.Gtk as Gtk import System.Process ( readProcess ) import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) -- | Creates a new filesystem monitor widget. It contains one 'PollingLabel' -- that displays the data returned by the df command. The usage level of all -- requested partitions is extracted in one single operation. fsMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 500) -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"]) -> IO Gtk.Widget fsMonitorNew interval fsList = do label <- pollingLabelNew "" interval $ showFSInfo fsList Gtk.widgetShowAll label return $ Gtk.toWidget label showFSInfo :: [String] -> IO String showFSInfo fsList = do fsOut <- readProcess "df" (["-kP"] ++ fsList) "" let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss taffybar-0.4.5/src/System/Taffybar/Systray.hs0000644000000000000000000000121012507657545017341 0ustar0000000000000000-- | This is a very basic system tray widget. That said, it works -- very well since it is based on eggtraymanager. module System.Taffybar.Systray ( systrayNew ) where import Graphics.UI.Gtk import Graphics.UI.Gtk.Misc.TrayManager systrayNew :: IO Widget systrayNew = do box <- hBoxNew False 5 trayManager <- trayManagerNew Just screen <- screenGetDefault _ <- trayManagerManageScreen trayManager screen _ <- on trayManager trayIconAdded $ \w -> do widgetShowAll w boxPackStart box w PackNatural 0 _ <- on trayManager trayIconRemoved $ \_ -> do putStrLn "Tray icon removed" widgetShowAll box return (toWidget box)taffybar-0.4.5/src/System/Taffybar/CPUMonitor.hs0000644000000000000000000000307112507657545017671 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.CPUMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple CPU monitor that uses a PollingGraph to visualize variations in the -- user and system CPU times in one selected core, or in all cores available. -- -------------------------------------------------------------------------------- module System.Taffybar.CPUMonitor where import Data.IORef import Graphics.UI.Gtk import System.Information.CPU2 (getCPUInfo) import System.Information.StreamInfo (getAccLoad) import System.Taffybar.Widgets.PollingGraph -- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to -- getCPUInfo, associated to an IORef used to remember the values yielded by the -- last call to this function. cpuMonitorNew :: GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\"). -> IO Widget cpuMonitorNew cfg interval cpu = do info <- getCPUInfo cpu sample <- newIORef info pollingGraphNew cfg interval $ probe sample cpu probe :: IORef [Int] -> String -> IO [Double] probe sample cpuName = do load <- getAccLoad sample $ getCPUInfo cpuName case load of l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system _ -> return [] taffybar-0.4.5/src/System/Taffybar/FreedesktopNotifications.hs0000644000000000000000000002742012507657545022703 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for freedesktop notifications -- (http://developer.gnome.org/notification-spec/). Currently it is -- somewhat ugly, but the format is somewhat configurable. A visual -- overhaul of the widget is coming. -- -- The widget only displays one notification at a time and -- notifications are cancellable. module System.Taffybar.FreedesktopNotifications ( -- * Types Notification(..), NotificationConfig(..), -- * Constructor notifyAreaNew, defaultNotificationConfig ) where import Control.Concurrent import Control.Concurrent.STM import Control.Monad ( forever ) import Control.Monad.Trans ( liftIO ) import Data.Int ( Int32 ) import Data.Map ( Map ) import Data.Monoid ( mconcat ) import qualified Data.Sequence as S import Data.Sequence ( Seq, (|>), viewl, ViewL(..) ) import Data.Text ( Text ) import qualified Data.Text as T import Data.Word ( Word32 ) import DBus import DBus.Client import Graphics.UI.Gtk hiding ( Variant ) -- | A simple structure representing a Freedesktop notification data Notification = Notification { noteAppName :: Text , noteReplaceId :: Word32 , noteSummary :: Text , noteBody :: Text , noteExpireTimeout :: Int32 , noteId :: Word32 } deriving (Show, Eq) data NotifyState = NotifyState { noteWidget :: Label , noteContainer :: Widget , noteConfig :: NotificationConfig , noteQueue :: TVar (Seq Notification) -- ^ The queue of active (but not yet -- displayed) notifications , noteIdSource :: TVar Word32 -- ^ A source of new notification ids , noteCurrent :: TVar (Maybe Notification) -- ^ The current note being displayed , noteChan :: Chan () -- ^ Wakes up the GUI update thread } initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do m <- newTVarIO 1 q <- newTVarIO S.empty c <- newTVarIO Nothing ch <- newChan return NotifyState { noteQueue = q , noteIdSource = m , noteWidget = l , noteContainer = wrapper , noteCurrent = c , noteConfig = cfg , noteChan = ch } getServerInformation :: IO (Text, Text, Text, Text) getServerInformation = return ("haskell-notification-daemon", "nochair.net", "0.0.1", "1.1") getCapabilities :: IO [Text] getCapabilities = return ["body", "body-markup"] nextNotification :: NotifyState -> STM () nextNotification s = do q <- readTVar (noteQueue s) case viewl q of EmptyL -> do writeTVar (noteCurrent s) Nothing next :< rest -> do writeTVar (noteQueue s) rest writeTVar (noteCurrent s) (Just next) -- | Filter any notifications with this id from the current queue. If -- it is the current notification, replace it with the next, if any. closeNotification :: NotifyState -> Word32 -> IO () closeNotification istate nid = do atomically $ do modifyTVar' (noteQueue istate) removeNote curNote <- readTVar (noteCurrent istate) case curNote of Nothing -> return () Just cnote | noteId cnote /= nid -> return () | otherwise -> -- in this case, the note was current so we take the next, -- if any nextNotification istate wakeupDisplayThread istate where removeNote = S.filter (\n -> noteId n /= nid) -- | Apply the user's formatter and truncate the result with the -- specified maxlen. formatMessage :: NotifyState -> Notification -> String formatMessage s = take maxlen . fmt where maxlen = notificationMaxLength $ noteConfig s fmt = notificationFormatter $ noteConfig s -- | The notificationDaemon thread looks at the notification queue. -- If the queue is empty and there is no current message, it sets the -- new message as the current message in a TVar (Just Notification) -- and displays the message itself and sets up a thread to remove the -- message after its timeout. -- -- If there is a current message, add the new message to the queue. -- -- The timeout thread just sleeps for its timeout and then atomically -- replaces the current message with the next one from the queue. It -- then displays the new current message. However, if the current -- message has changed (because of a user cancellation), the timer -- thread just exits. -- -- User cancellation atomically reads (and replaces) the current -- notification (if there is another in the queue). If it found a new -- notification, that node is then displayed. notify :: NotifyState -> Text -- ^ Application name -> Word32 -- ^ Replaces id -> Text -- ^ App icon -> Text -- ^ Summary -> Text -- ^ Body -> [Text] -- ^ Actions -> Map Text Variant -- ^ Hints -> Int32 -- ^ Expires timeout (milliseconds) -> IO Word32 notify istate appName replaceId _ summary body _ _ timeout = do nid <- atomically $ do tid <- readTVar idsrc modifyTVar' idsrc (+1) return tid let realId = if replaceId == 0 then fromIntegral nid else replaceId n = Notification { noteAppName = appName , noteReplaceId = replaceId , noteSummary = escapeText summary , noteBody = escapeText body , noteExpireTimeout = tout , noteId = realId } -- If we are replacing an existing note, atomically do the swap in -- the note queue and then make this the new current if the queue is -- empty OR if the current has this id. dn <- atomically $ do modifyTVar' (noteQueue istate) (replaceNote n) cnote <- readTVar (noteCurrent istate) case cnote of Nothing -> do writeTVar (noteCurrent istate) (Just n) return (Just n) Just curNote | noteId curNote == realId -> do writeTVar (noteCurrent istate) (Just n) return (Just n) | otherwise -> do modifyTVar' (noteQueue istate) (|>n) return Nothing -- This is a little gross - if we added the new notification to the -- queue, we can't call displayNote on it because that will -- obliterate the current active notification. case dn of -- take no action; timeout threads will handle it Nothing -> return () Just _ -> wakeupDisplayThread istate return realId where replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n) idsrc = noteIdSource istate escapeText = T.pack . escapeMarkup . T.unpack maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate) tout = case timeout of 0 -> maxtout (-1) -> maxtout _ -> min maxtout timeout notificationDaemon :: (AutoMethod f1, AutoMethod f2) => f1 -> f2 -> IO () notificationDaemon onNote onCloseNote = do client <- connectSession _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting] export client "/org/freedesktop/Notifications" [ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation , autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities , autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote , autoMethod "org.freedesktop.Notifications" "Notify" onNote ] -- | Wakeup the display thread and have it switch out the displayed -- message for the new current message. wakeupDisplayThread :: NotifyState -> IO () wakeupDisplayThread s = writeChan (noteChan s) () -- | This thread displayThread :: NotifyState -> IO () displayThread s = forever $ do _ <- readChan (noteChan s) cur <- atomically $ readTVar (noteCurrent s) case cur of Nothing -> postGUIAsync (widgetHideAll (noteContainer s)) Just n -> postGUIAsync $ do labelSetMarkup (noteWidget s) (formatMessage s n) widgetShowAll (noteContainer s) startTimeoutThread s n startTimeoutThread :: NotifyState -> Notification -> IO () startTimeoutThread s n = do _ <- forkIO $ do let seconds = noteExpireTimeout n threadDelay (fromIntegral seconds * 1000000) atomically $ do curNote <- readTVar (noteCurrent s) case curNote of Nothing -> return () Just cnote | cnote /= n -> return () | otherwise -> -- The note was not invalidated or changed since the timeout -- began, so we replace it with the next (if any) nextNotification s wakeupDisplayThread s return () data NotificationConfig = NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds). Default: 10 , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 50 , notificationFormatter :: Notification -> String -- ^ Function used to format notifications } defaultFormatter :: Notification -> String defaultFormatter note = msg where msg = case T.null (noteBody note) of True -> T.unpack $ noteSummary note False -> T.unpack $ mconcat [ "Note:" , noteSummary note, ": ", noteBody note ] -- | The default formatter is one of -- -- * Summary : Body -- -- * Summary -- -- depending on the presence of a notification body. defaultNotificationConfig :: NotificationConfig defaultNotificationConfig = NotificationConfig { notificationMaxTimeout = 10 , notificationMaxLength = 100 , notificationFormatter = defaultFormatter } -- | Create a new notification area with the given configuration. notifyAreaNew :: NotificationConfig -> IO Widget notifyAreaNew cfg = do frame <- frameNew box <- hBoxNew False 3 textArea <- labelNew (Nothing :: Maybe String) button <- eventBoxNew sep <- vSeparatorNew bLabel <- labelNew (Nothing :: Maybe String) widgetSetName bLabel ("NotificationCloseButton" :: String) labelSetMarkup bLabel ("×" :: String) labelSetMaxWidthChars textArea (notificationMaxLength cfg) labelSetEllipsize textArea EllipsizeEnd containerAdd button bLabel boxPackStart box textArea PackGrow 0 boxPackStart box sep PackNatural 0 boxPackStart box button PackNatural 0 containerAdd frame box widgetHideAll frame istate <- initialNoteState (toWidget frame) textArea cfg _ <- on button buttonReleaseEvent (userCancel istate) realizableWrapper <- hBoxNew False 0 boxPackStart realizableWrapper frame PackNatural 0 widgetShow realizableWrapper -- We can't start the dbus listener thread until we are in the GTK -- main loop, otherwise things are prone to lock up and block -- infinitely on an mvar. Bad stuff - only start the dbus thread -- after the fake invisible wrapper widget is realized. _ <- on realizableWrapper realize $ do _ <- forkIO (displayThread istate) notificationDaemon (notify istate) (closeNotification istate) -- Don't show the widget by default - it will appear when needed return (toWidget realizableWrapper) where -- | Close the current note and pull up the next, if any userCancel s = do liftIO $ do atomically $ nextNotification s wakeupDisplayThread s return True taffybar-0.4.5/src/System/Taffybar/WindowSwitcher.hs0000644000000000000000000001266412507657545020662 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.WindowSwitcher -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Menu widget that shows the title of the currently focused window and that, -- when clicked, displays the list of all currently open windows allowing to -- switch to any of them. -- -- N.B. If you're just looking for a drop-in replacement for the -- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require -- DBus, you may want to see first "System.Taffybar.TaffyPager". -- ----------------------------------------------------------------------------- module System.Taffybar.WindowSwitcher ( -- * Usage -- $usage windowSwitcherNew ) where import Control.Monad (forM_) import Control.Monad.IO.Class ( liftIO ) import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras (Event) import System.Information.EWMHDesktopInfo import System.Taffybar.Pager -- $usage -- -- This widget requires that the EwmhDesktops hook from the XMonadContrib -- project be installed in your @xmonad.hs@ file: -- -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > main = do -- > xmonad $ ewmh $ defaultConfig -- > ... -- -- Once you've properly configured @xmonad.hs@, you can use the widget in -- your @taffybar.hs@ file: -- -- > import System.Taffybar.WindowSwitcher -- > main = do -- > pager <- pagerNew defaultPagerConfig -- > let wnd = windowSwitcherNew pager -- -- now you can use @wnd@ as any other Taffybar widget. -- | Create a new WindowSwitcher widget that will use the given Pager as -- its source of events. windowSwitcherNew :: Pager -> IO Gtk.Widget windowSwitcherNew pager = do label <- Gtk.labelNew (Nothing :: Maybe String) Gtk.widgetSetName label "label" -- This callback is registered through 'subscribe', which runs the -- callback in another thread. We need to use postGUIAsync in it. let cfg = config pager callback = pagerCallback cfg label subscribe pager callback "_NET_ACTIVE_WINDOW" assembleWidget label -- | Build a suitable callback function that can be registered as Listener -- of "_NET_ACTIVE_WINDOW" standard events. It will keep track of the -- currently focused window. pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO () pagerCallback cfg label _ = do title <- withDefaultCtx getActiveWindowTitle let decorate = activeWindow cfg Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title) -- | Build the graphical representation of the widget. assembleWidget :: Gtk.Label -> IO Gtk.Widget assembleWidget label = do title <- Gtk.menuItemNew Gtk.widgetSetName title "title" Gtk.containerAdd title label switcher <- Gtk.menuBarNew Gtk.widgetSetName switcher "WindowSwitcher" Gtk.containerAdd switcher title Gtk.rcParseString $ unlines [ "style 'WindowSwitcher' {" , " xthickness = 0" , " GtkMenuBar::internal-padding = 0" , "}" , "style 'title' {" , " xthickness = 0" , " GtkMenuItem::horizontal-padding = 0" , "}" , "widget '*WindowSwitcher' style 'WindowSwitcher'" , "widget '*WindowSwitcher*title' style 'title'" ] menu <- Gtk.menuNew Gtk.widgetSetName menu "menu" menuTop <- Gtk.widgetGetToplevel menu Gtk.widgetSetName menuTop "Taffybar_WindowSwitcher" Gtk.menuItemSetSubmenu title menu -- These callbacks are run in the GUI thread automatically and do -- not need to use postGUIAsync _ <- Gtk.on title Gtk.menuItemActivate $ fillMenu menu _ <- Gtk.on title Gtk.menuItemDeselect $ emptyMenu menu Gtk.widgetShowAll switcher return $ Gtk.toWidget switcher -- | Populate the given menu widget with the list of all currently open windows. fillMenu :: Gtk.MenuClass menu => menu -> IO () fillMenu menu = withDefaultCtx $ do handles <- getWindowHandles if null handles then return () else do wsNames <- getWorkspaceNames forM_ handles $ \handle -> liftIO $ do item <- Gtk.menuItemNewWithLabel (formatEntry wsNames handle) _ <- Gtk.on item Gtk.buttonPressEvent $ liftIO $ do withDefaultCtx (focusWindow $ snd handle) return True Gtk.menuShellAppend menu item Gtk.widgetShow item -- | Remove all contents from the given menu widget. emptyMenu :: Gtk.MenuClass menu => menu -> IO () emptyMenu menu = Gtk.containerForeach menu $ \item -> Gtk.containerRemove menu item >> Gtk.widgetDestroy item -- | Build the name to display in the list of windows by prepending the name -- of the workspace it is currently in to the name of the window itself formatEntry :: [String] -- ^ List of names of all available workspaces -> X11WindowHandle -- ^ Handle of the window to name -> String formatEntry wsNames ((ws, wtitle, _), _) = wsName ++ ": " ++ (nonEmpty wtitle) where wsName = if 0 <= ws && ws < length wsNames then wsNames !! ws else "WS#" ++ show ws -- | Return the given String if it's not empty, otherwise return "(nameless window)" nonEmpty :: String -> String nonEmpty x = case x of [] -> "(nameless window)" _ -> x taffybar-0.4.5/src/System/Taffybar/Battery.hs0000644000000000000000000001130412507657545017302 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | 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 batterym 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. module System.Taffybar.Battery ( batteryBarNew, textBatteryNew, defaultBatteryConfig ) where import qualified Control.Exception.Enclosed as E import Data.Int ( Int64 ) import Data.IORef import Graphics.UI.Gtk import qualified System.IO as IO import Text.Printf ( printf ) import Text.StringTemplate import System.Information.Battery import System.Taffybar.Widgets.PollingBar import System.Taffybar.Widgets.PollingLabel safeGetBatteryInfo :: IORef BatteryContext -> IO (Maybe BatteryInfo) safeGetBatteryInfo mv = do ctxt <- readIORef mv E.catchAny (getBatteryInfo ctxt) $ \_ -> reconnect where reconnect = do mctxt <- batteryContextNew case mctxt of Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower" Just ctxt -> writeIORef mv ctxt return Nothing battInfo :: IORef BatteryContext -> String -> IO String battInfo r fmt = do minfo <- safeGetBatteryInfo r case minfo of Nothing -> return "" Just info -> do let battPctNum :: Int battPctNum = floor (batteryPercentage info) formatTime :: Int64 -> String formatTime seconds = let minutes = seconds `div` 60 hours = minutes `div` 60 minutes' = minutes `mod` 60 in printf "%02d:%02d" hours minutes' battTime :: String battTime = case (batteryState info) of BatteryStateCharging -> (formatTime $ batteryTimeToFull info) BatteryStateDischarging -> (formatTime $ batteryTimeToEmpty info) _ -> "-" tpl = newSTMP fmt tpl' = setManyAttrib [ ("percentage", show battPctNum) , ("time", battTime) ] tpl return $ render tpl' -- | A simple textual battery widget that auto-updates once every -- polling period (specified in seconds). The displayed format is -- specified format 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 -> Double -- ^ Poll period in seconds -> IO Widget textBatteryNew fmt pollSeconds = do battCtxt <- batteryContextNew case battCtxt of Nothing -> do let lbl :: Maybe String lbl = Just "No battery" labelNew lbl >>= return . toWidget Just ctxt -> do r <- newIORef ctxt l <- pollingLabelNew "" pollSeconds (battInfo r fmt) widgetShowAll l return l -- | Returns the current battery percent as a double in the range [0, -- 1] battPct :: IORef BatteryContext -> IO Double battPct r = do minfo <- safeGetBatteryInfo r case minfo of Nothing -> return 0 Just info -> return (batteryPercentage info / 100) -- | A default configuration for the graphical battery display. The -- bar will be red when power is critical (< 10%), green if it is full -- (> 90%), and grey otherwise. -- -- You can customize this with any of the options in 'BarConfig' defaultBatteryConfig :: BarConfig defaultBatteryConfig = defaultBarConfig colorFunc where colorFunc pct | pct < 0.1 = (1, 0, 0) | pct < 0.9 = (0.5, 0.5, 0.5) | otherwise = (0, 1, 0) -- | A fancy graphical battery widget that represents the current -- charge as a colored vertical bar. There is also a textual -- percentage readout next to the bar. batteryBarNew :: BarConfig -- ^ Configuration options for the bar display -> Double -- ^ Polling period in seconds -> IO Widget batteryBarNew battCfg pollSeconds = do battCtxt <- batteryContextNew case battCtxt of Nothing -> do let lbl :: Maybe String lbl = Just "No battery" labelNew lbl >>= return . toWidget Just ctxt -> do -- This is currently pretty inefficient - each poll period it -- queries the battery twice (once for the label and once for -- the bar). -- -- Converting it to combine the two shouldn't be hard. b <- hBoxNew False 1 txt <- textBatteryNew "$percentage$%" pollSeconds r <- newIORef ctxt bar <- pollingBarNew battCfg pollSeconds (battPct r) boxPackStart b bar PackNatural 0 boxPackStart b txt PackNatural 0 widgetShowAll b return (toWidget b) taffybar-0.4.5/src/System/Taffybar/WorkspaceSwitcher.hs0000644000000000000000000002450012507657545021341 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.WorkspaceSwitcher -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Composite widget that displays all currently configured workspaces and -- allows to switch to any of them by clicking on its label. Supports also -- urgency hints and (with an additional hook) display of other visible -- workspaces besides the active one (in Xinerama or XRandR installations). -- -- N.B. If you're just looking for a drop-in replacement for the -- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require -- DBus, you may want to see first "System.Taffybar.TaffyPager". -- ----------------------------------------------------------------------------- module System.Taffybar.WorkspaceSwitcher ( -- * Usage -- $usage wspaceSwitcherNew ) where import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) import Data.List ((\\), findIndices) import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras import System.Taffybar.Pager import System.Information.EWMHDesktopInfo type Desktop = [Workspace] data Workspace = Workspace { label :: Gtk.Label , name :: String , urgent :: Bool } -- $usage -- -- This widget requires that the EwmhDesktops hook from the XMonadContrib -- project be installed in your @xmonad.hs@ file: -- -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > main = do -- > xmonad $ ewmh $ defaultConfig -- > ... -- -- Urgency hooks are not required for the urgency hints displaying to work -- (since it is also based on desktop events), but if you use @focusUrgent@ -- you may want to keep the \"@withUrgencyHook NoUrgencyHook@\" anyway. -- -- Unfortunately, in multiple monitor installations EWMH does not provide a -- way to determine what desktops are shown in secondary displays. Thus, if -- you have more than one monitor you may want to additionally install the -- "System.Taffybar.Hooks.PagerHints" hook in your @xmonad.hs@: -- -- > import System.Taffybar.Hooks.PagerHints (pagerHints) -- > main = do -- > xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- -- Once you've properly configured @xmonad.hs@, you can use the widget in -- your @taffybar.hs@ file: -- -- > import System.Taffybar.WorkspaceSwitcher -- > main = do -- > pager <- pagerNew defaultPagerConfig -- > let wss = wspaceSwitcherNew pager -- -- now you can use @wss@ as any other Taffybar widget. -- | Create a new WorkspaceSwitcher widget that will use the given Pager as -- its source of events. wspaceSwitcherNew :: Pager -> IO Gtk.Widget wspaceSwitcherNew pager = do switcher <- Gtk.hBoxNew False 0 desktop <- getDesktop pager deskRef <- MV.newMVar desktop populateSwitcher switcher deskRef -- These callbacks need to use postGUIAsync since they run in -- another thread let cfg = config pager activecb = activeCallback cfg deskRef redrawcb = redrawCallback pager deskRef switcher urgentcb = urgentCallback cfg deskRef subscribe pager activecb "_NET_CURRENT_DESKTOP" subscribe pager redrawcb "_NET_NUMBER_OF_DESKTOPS" subscribe pager urgentcb "WM_HINTS" return $ Gtk.toWidget switcher -- | List of indices of all available workspaces. allWorkspaces :: Desktop -> [Int] allWorkspaces desktop = [0 .. length desktop - 1] -- | List of indices of all the workspaces that contain at least one window. nonEmptyWorkspaces :: IO [Int] nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows -- | Return a list of two-element tuples, one for every workspace, -- containing the Label widget used to display the name of that specific -- workspace and a String with its default (unmarked) representation. getDesktop :: Pager -> IO Desktop getDesktop pager = do names <- withDefaultCtx getWorkspaceNames labels <- toLabels $ map (hiddenWorkspace $ config pager) names return $ zipWith (\n l -> Workspace l n False) names labels -- | Take an existing Desktop IORef and update it if necessary, store the result -- in the IORef, then return True if the reference was actually updated, False -- otherwise. updateDesktop :: Pager -> MV.MVar Desktop -> IO Bool updateDesktop pager deskRef = do wsnames <- withDefaultCtx getWorkspaceNames MV.modifyMVar deskRef $ \desktop -> case length wsnames /= length desktop of True -> do desk' <- getDesktop pager return (desk', True) False -> return (desktop, False) -- | Clean up the given box, then fill it up with the buttons for the current -- state of the desktop. populateSwitcher :: Gtk.BoxClass box => box -> MV.MVar Desktop -> IO () populateSwitcher switcher deskRef = do containerClear switcher desktop <- MV.readMVar deskRef mapM_ (addButton switcher desktop) (allWorkspaces desktop) Gtk.widgetShowAll switcher -- | Build a suitable callback function that can be registered as Listener -- of "_NET_CURRENT_DESKTOP" standard events. It will track the position of -- the active workspace in the desktop. activeCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO () activeCallback cfg deskRef _ = Gtk.postGUIAsync $ do curr <- withDefaultCtx getVisibleWorkspaces desktop <- MV.readMVar deskRef case curr of visible : _ | length desktop > visible -> do when (urgent (desktop !! visible)) $ do toggleUrgent deskRef visible False transition cfg desktop curr _ -> return () -- | Build a suitable callback function that can be registered as Listener -- of "WM_HINTS" standard events. It will display in a different color any -- workspace (other than the active one) containing one or more windows -- with its urgency hint set. urgentCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO () urgentCallback cfg deskRef event = Gtk.postGUIAsync $ do desktop <- MV.readMVar deskRef withDefaultCtx $ do let window = ev_window event isUrgent <- isWindowUrgent window when isUrgent $ do this <- getCurrentWorkspace that <- getWorkspace window when (this /= that) $ liftIO $ do toggleUrgent deskRef that True mark desktop (urgentWorkspace cfg) that -- | Build a suitable callback function that can be registered as Listener -- of "_NET_NUMBER_OF_DESKTOPS" standard events. It will handle dynamically -- adding and removing workspaces. redrawCallback :: Gtk.BoxClass box => Pager -> MV.MVar Desktop -> box -> Event -> IO () redrawCallback pager deskRef box _ = Gtk.postGUIAsync $ do -- updateDesktop indirectly invokes some gtk functions, so it also -- needs to be guarded by postGUIAsync deskChanged <- updateDesktop pager deskRef when deskChanged $ populateSwitcher box deskRef -- | Remove all children of a container. containerClear :: Gtk.ContainerClass self => self -> IO () containerClear container = Gtk.containerForeach container (Gtk.containerRemove container) -- | Convert the given list of Strings to a list of Label widgets. toLabels :: [String] -> IO [Gtk.Label] toLabels = mapM labelNewMarkup where labelNewMarkup markup = do lbl <- Gtk.labelNew (Nothing :: Maybe String) Gtk.labelSetMarkup lbl markup return lbl -- | Build a new clickable event box containing the Label widget that -- corresponds to the given index, and add it to the given container. addButton :: Gtk.BoxClass self => self -- ^ Graphical container. -> Desktop -- ^ List of all workspace Labels available. -> Int -- ^ Index of the workspace to use. -> IO () addButton hbox desktop idx | length desktop > idx = do let index = desktop !! idx lbl = label index ebox <- Gtk.eventBoxNew Gtk.widgetSetName ebox $ name index Gtk.eventBoxSetVisibleWindow ebox False _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch idx Gtk.containerAdd ebox lbl Gtk.boxPackStart hbox ebox Gtk.PackNatural 0 | otherwise = return () -- | Re-mark all workspace labels. transition :: PagerConfig -- ^ Configuration settings. -> Desktop -- ^ All available Labels with their default values. -> [Int] -- ^ Currently visible workspaces (first is active). -> IO () transition cfg desktop wss = do nonEmpty <- fmap (filter (>=0)) nonEmptyWorkspaces let urgentWs = findIndices urgent desktop allWs = (allWorkspaces desktop) \\ urgentWs nonEmptyWs = nonEmpty \\ urgentWs mapM_ (mark desktop $ hiddenWorkspace cfg) nonEmptyWs mapM_ (mark desktop $ emptyWorkspace cfg) (allWs \\ nonEmpty) case wss of active:rest -> do mark desktop (activeWorkspace cfg) active mapM_ (mark desktop $ visibleWorkspace cfg) rest _ -> return () mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs -- | Apply the given marking function to the Label of the workspace with -- the given index. mark :: Desktop -- ^ List of all available labels. -> (String -> String) -- ^ Marking function. -> Int -- ^ Index of the Label to modify. -> IO () mark desktop decorate idx | length desktop > idx = do let ws = desktop !! idx Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ decorate' (name ws) | otherwise = return () where decorate' = pad . decorate pad m | m == [] = m | otherwise = ' ' : m -- | Switch to the workspace with the given index. switch :: (MonadIO m) => Int -> m Bool switch idx = do liftIO $ withDefaultCtx (switchToWorkspace idx) return True -- | Modify the Desktop inside the given IORef, so that the Workspace at the -- given index has its "urgent" flag set to the given value. toggleUrgent :: MV.MVar Desktop -- ^ IORef to modify. -> Int -- ^ Index of the Workspace to replace. -> Bool -- ^ New value of the "urgent" flag. -> IO () toggleUrgent deskRef idx isUrgent = MV.modifyMVar_ deskRef $ \desktop -> do let ws = desktop !! idx case length desktop > idx of True | isUrgent /= urgent ws -> do let ws' = ws { urgent = isUrgent } (ys, zs) = splitAt idx desktop case zs of _ : rest -> return $ ys ++ (ws' : rest) _ -> return (ys ++ [ws']) _ -> return desktop taffybar-0.4.5/src/System/Taffybar/CommandRunner.hs0000644000000000000000000000377512507657545020455 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.CommandRunner -- Copyright : (c) Arseniy Seroka -- License : BSD3-style (see LICENSE) -- -- Maintainer : Arseniy Seroka -- Stability : unstable -- Portability : unportable -- -- Simple function which runs user defined command and -- returns it's output in PollingLabel widget -- -------------------------------------------------------------------------------- module System.Taffybar.CommandRunner ( commandRunnerNew ) where import qualified Graphics.UI.Gtk as Gtk import System.Taffybar.Pager (colorize) import System.Taffybar.Widgets.PollingLabel import Control.Monad import System.Exit (ExitCode (..)) import qualified System.IO as IO import qualified System.Process as P -- | Creates a new command runner widget. This is a 'PollingLabel' fed by -- regular calls to command given by argument. The results of calling this function -- are displayed as string. commandRunnerNew :: Double -- ^ Polling period (in seconds). -> String -- ^ Command to execute. Should be in $PATH or an absolute path -> [String] -- ^ Command argument. May be @[]@ -> String -- ^ If command fails this will be displayed. -> String -- ^ Output color -> IO Gtk.Widget commandRunnerNew interval cmd args defaultOutput color = do label <- pollingLabelNew "" interval $ runCommand cmd args defaultOutput color Gtk.widgetShowAll label return $ Gtk.toWidget label runCommand :: FilePath -> [String] -> String -> String -> IO String runCommand cmd args defaultOutput color = do (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args "" unless (null stderr) $ do IO.hPutStrLn IO.stderr stderr return $ colorize color "" $ case ecode of ExitSuccess -> stdout ExitFailure _ -> defaultOutput taffybar-0.4.5/src/System/Taffybar/Pager.hs0000644000000000000000000001304612507657545016733 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Pager -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Common support for pager widgets. This module does not provide itself -- any widgets, but implements an event dispatcher on which widgets can -- subscribe the desktop events they're interested in, as well as common -- configuration facilities. -- -- N.B. If you're just looking for a drop-in replacement for the -- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require -- DBus, you may want to see first "System.Taffybar.TaffyPager". -- -- You need only one Pager component to instantiate any number of pager -- widgets: -- -- > pager <- pagerNew defaultPagerConfig -- > -- > let wss = wspaceSwitcherNew pager -- Workspace Switcher widget -- > los = layoutSwitcherNew pager -- Layout Switcher widget -- > wnd = windowSwitcherNew pager -- Window Switcher widget -- ----------------------------------------------------------------------------- module System.Taffybar.Pager ( Pager (config) , PagerConfig (..) , defaultPagerConfig , pagerNew , subscribe , colorize , shorten , wrap , escape ) where import Control.Concurrent (forkIO) import Control.Exception import Control.Exception.Enclosed (catchAny) import Control.Monad.Reader import Data.IORef import Graphics.UI.Gtk (escapeMarkup) import Graphics.X11.Types import Graphics.X11.Xlib.Extras import Text.Printf (printf) import System.Information.X11DesktopInfo type Listener = Event -> IO () type Filter = Atom type SubscriptionList = IORef [(Listener, Filter)] -- | Structure contanining functions to customize the pretty printing of -- different widget elements. data PagerConfig = PagerConfig { activeWindow :: String -> String -- ^ the name of the active window. , activeLayout :: String -> String -- ^ the currently active layout. , activeWorkspace :: String -> String -- ^ the currently active workspace. , hiddenWorkspace :: String -> String -- ^ inactive workspace with windows. , emptyWorkspace :: String -> String -- ^ inactive workspace with no windows. , visibleWorkspace :: String -> String -- ^ all other visible workspaces (Xinerama or XRandR). , urgentWorkspace :: String -> String -- ^ workspaces containing windows with the urgency hint set. , widgetSep :: String -- ^ separator to use between desktop widgets in 'TaffyPager'. } -- | Structure containing the state of the Pager. data Pager = Pager { config :: PagerConfig -- ^ the configuration settings. , clients :: SubscriptionList -- ^ functions to apply on incoming events depending on their types. } -- | Default pretty printing options. defaultPagerConfig :: PagerConfig defaultPagerConfig = PagerConfig { activeWindow = escape . shorten 40 , activeLayout = escape , activeWorkspace = colorize "yellow" "" . wrap "[" "]" . escape , hiddenWorkspace = escape , emptyWorkspace = escape , visibleWorkspace = wrap "(" ")" . escape , urgentWorkspace = colorize "red" "yellow" . escape , widgetSep = " : " } -- | Creates a new Pager component (wrapped in the IO Monad) that can be -- used by widgets for subscribing X11 events. pagerNew :: PagerConfig -> IO Pager pagerNew cfg = do ref <- newIORef [] let pager = Pager cfg ref _ <- forkIO $ withDefaultCtx $ eventLoop (handleEvent ref) return pager where handleEvent :: SubscriptionList -> Event -> IO () handleEvent ref event = do listeners <- readIORef ref mapM_ (notify event) listeners -- | Passes the given Event to the given Listener, but only if it was -- registered for that type of events via 'subscribe'. notify :: Event -> (Listener, Filter) -> IO () notify event (listener, eventFilter) = case event of PropertyEvent _ _ _ _ _ atom _ _ -> when (atom == eventFilter) $ catchAny (listener event) ignoreException _ -> return () -- | Registers the given Listener as a subscriber of events of the given -- type: whenever a new event of the type with the given name arrives to -- the Pager, it will execute Listener on it. subscribe :: Pager -> Listener -> String -> IO () subscribe pager listener filterName = do eventFilter <- withDefaultCtx $ getAtom filterName registered <- readIORef (clients pager) let next = (listener, eventFilter) writeIORef (clients pager) (next : registered) ignoreException :: SomeException -> IO () ignoreException _ = return () -- | Creates markup with the given foreground and background colors and the -- given contents. colorize :: String -- ^ Foreground color. -> String -- ^ Background color. -> String -- ^ Contents. -> String colorize fg bg = printf "%s" (attr "fg" fg) (attr "bg" bg) where attr name value | null value = "" | otherwise = printf " %scolor=\"%s\"" name value -- | Limit a string to a certain length, adding "..." if truncated. shorten :: Int -> String -> String shorten l s | length s <= l = s | l >= 3 = take (l - 3) s ++ "..." | otherwise = "..." -- | Wrap the given string in the given delimiters. wrap :: String -- ^ Left delimiter. -> String -- ^ Right delimiter. -> String -- ^ Output string. -> String wrap open close s = open ++ s ++ close -- | Escape strings so that they can be safely displayed by Pango in the -- bar widget escape :: String -> String escape = escapeMarkup taffybar-0.4.5/src/System/Taffybar/StrutProperties.hs0000644000000000000000000000325012507657545021067 0ustar0000000000000000module System.Taffybar.StrutProperties ( setStrutProperties , StrutProperties ) where import Graphics.UI.Gtk import Foreign import Foreign.C.Types import Unsafe.Coerce ( unsafeCoerce ) type StrutProperties = (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) foreign import ccall "set_strut_properties" c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> () -- | Reserve EWMH struts setStrutProperties :: Window -> StrutProperties -> IO () setStrutProperties gtkWindow (left, right, top, bottom, left_start_y, left_end_y, right_start_y, right_end_y, top_start_x, top_end_x, bottom_start_x, bottom_end_x) = do let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window let fi = fromIntegral withForeignPtr ptrWin $ \realPointer -> do return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom) (fi left_start_y) (fi left_end_y) (fi right_start_y) (fi right_end_y) (fi top_start_x) (fi top_end_x) (fi bottom_start_x) (fi bottom_end_x) taffybar-0.4.5/src/System/Taffybar/TaffyPager.hs0000644000000000000000000000576112507657545017732 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.TaffyPager -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- This module provides a drop-in replacement for the XMonadLog widget -- that allows to: -- -- * click on a workspace label to switch to that workspace, -- -- * left-click on the layout label to switch to the next layout, and -- right-click to switch to the first layout, -- -- * click on the window title to pop-up a list of all the currently open -- windows that can be clicked to switch to any of them, -- -- All its interactions with the windows manager are performed via EWMH -- hints and X11 events. -- -- This widget is actually only a convenience wrapper around a Pager, a -- WorkspaceSwitcher, a LayoutSwitcher and a WindowSwitcher. If you are -- looking for more advanced configurations (like having components -- displayed separately, or using only part of them), consult directly the -- documentation for each of the components. -- ----------------------------------------------------------------------------- module System.Taffybar.TaffyPager ( -- * Usage -- $usage taffyPagerNew , PagerConfig (..) , defaultPagerConfig ) where import Graphics.UI.Gtk import System.Taffybar.Pager import System.Taffybar.WorkspaceSwitcher import System.Taffybar.LayoutSwitcher import System.Taffybar.WindowSwitcher -- $usage -- -- This widget requires that two hooks be installed in your @xmonad.hs@ -- configuration: EwmhDesktops from the XMonadContrib project, and the one -- provided in the "System.Taffybar.Hooks.PagerHints" module: -- -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > import System.Taffybar.Hooks.PagerHints (pagerHints) -- > main = do -- > xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- -- That's all: no log hooks, no urgency hooks, no DBus client. Once you've -- configured @xmonad.hs@, you can use the widget in your @taffybar.hs@ -- file: -- -- > import System.Taffybar.TaffyPager -- > main = do -- > let pager = taffyPagerNew defaultPagerConfig -- -- now you can use @pager@ as any other Taffybar widget. -- | Create a new TaffyPager widget. taffyPagerNew :: PagerConfig -> IO Widget taffyPagerNew cfg = do pgr <- pagerNew cfg wss <- wspaceSwitcherNew pgr los <- layoutSwitcherNew pgr wnd <- windowSwitcherNew pgr sp1 <- separator cfg sp2 <- separator cfg box <- hBoxNew False 0 boxPackStart box wss PackNatural 0 boxPackStart box sp1 PackNatural 0 boxPackStart box los PackNatural 0 boxPackStart box sp2 PackNatural 0 boxPackStart box wnd PackNatural 0 widgetShowAll box return (toWidget box) -- | Create a new separator label to put between two sub-components. separator :: PagerConfig -> IO Label separator cfg = do sep <- labelNew (Nothing :: Maybe String) labelSetMarkup sep (widgetSep cfg) return sep taffybar-0.4.5/src/System/Taffybar/NetMonitor.hs0000644000000000000000000000677512507657545020006 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.NetMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple text widget that displays incoming\/outgoing network traffic over -- one selected interface, as provided by the "System.Information.Network" -- module. -- ----------------------------------------------------------------------------- module System.Taffybar.NetMonitor ( netMonitorNew, netMonitorNewWith, defaultNetFormat ) where import Data.IORef import Graphics.UI.Gtk import System.Information.Network (getNetInfo) import System.Taffybar.Widgets.PollingLabel import Text.Printf (printf) import Text.StringTemplate defaultNetFormat :: String defaultNetFormat = "▼ $inKB$kb/s ▲ $outKB$kb/s" -- | Creates a new network monitor widget. It consists of two 'PollingLabel's, -- one for incoming and one for outgoing traffic fed by regular calls to -- 'getNetInfo'. netMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 1.5) -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\") -> IO Widget netMonitorNew interval interface = netMonitorNewWith interval interface 2 defaultNetFormat -- | Creates a new network monitor widget with custom template and precision. -- Similar to 'netMonitorNew'. -- -- The format template currently supports three units: bytes, -- kilobytes, and megabytes. Automatic intelligent unit selection is -- planned, eventually. netMonitorNewWith :: Double -- ^ Polling interval (in seconds, e.g. 1.5) -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\") -> Integer -- ^ Precision for an output -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $outB$, $outKB$, $outMB$ -> IO Widget netMonitorNewWith interval interface prec template = do sample <- newIORef [0, 0] label <- pollingLabelNew "" interval $ showInfo sample interval interface template prec widgetShowAll label return $ toWidget label showInfo :: IORef [Integer] -> Double -> String -> String -> Integer -> IO String showInfo sample interval interface template prec = do maybeThisSample <- getNetInfo interface case maybeThisSample of Nothing -> return "" Just thisSample -> do lastSample <- readIORef sample writeIORef sample thisSample let deltas = map (max 0 . fromIntegral) $ zipWith (-) thisSample lastSample speed@[incomingb, outgoingb] = map (/(interval)) deltas [incomingkb, outgoingkb] = map (setDigits prec . (/1024)) speed [incomingmb, outgoingmb] = map (setDigits prec . (/square 1024)) speed attribs = [ ("inB", show incomingb) , ("inKB", incomingkb) , ("inMB", incomingmb) , ("outB", show outgoingb) , ("outKB", outgoingkb) , ("outMB", outgoingmb) ] return . render . setManyAttrib attribs $ newSTMP template square :: Double -> Double square x = x ^ (2 :: Int) setDigits :: Integer -> Double -> String setDigits dig a = printf format a where format = "%." ++ show dig ++ "f" taffybar-0.4.5/src/System/Taffybar/Text/0000755000000000000000000000000012507657545016261 5ustar0000000000000000taffybar-0.4.5/src/System/Taffybar/Text/MemoryMonitor.hs0000644000000000000000000000233012507657545021433 0ustar0000000000000000module System.Taffybar.Text.MemoryMonitor(textMemoryMonitorNew) where import qualified Text.StringTemplate as ST import System.Information.Memory import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) import qualified Graphics.UI.Gtk as Gtk -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds). textMemoryMonitorNew :: String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "used". -> Double -- ^ Polling period in seconds. -> IO Gtk.Widget textMemoryMonitorNew fmt period = do label <- pollingLabelNew fmt period callback Gtk.widgetShowAll label return label where callback = do info <- parseMeminfo let template = ST.newSTMP fmt let labels = ["used", "total", "free", "buffer", "cache", "rest", "used"] let actions = [memoryUsed, memoryTotal, memoryFree, memoryBuffer, memoryCache, memoryRest] actions' = map ((show . intRound).) actions let stats = [f info | f <- actions'] let template' = ST.setManyAttrib (zip labels stats) template return $ ST.render template' intRound :: Double -> Int intRound = round taffybar-0.4.5/src/System/Taffybar/Text/CPUMonitor.hs0000644000000000000000000000226312507657545020617 0ustar0000000000000000module System.Taffybar.Text.CPUMonitor(textCpuMonitorNew) where import Text.Printf ( printf ) import qualified Text.StringTemplate as ST import System.Information.CPU import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) import qualified Graphics.UI.Gtk as Gtk -- | Creates a simple textual CPU monitor. It updates once every polling -- period (in seconds). textCpuMonitorNew :: String -- ^ Format. You can use variables: $total$, $user$, $system$ -> Double -- ^ Polling period (in seconds) -> IO Gtk.Widget textCpuMonitorNew fmt period = do label <- pollingLabelNew fmt period callback Gtk.widgetShowAll label return label where callback = do (userLoad, systemLoad, totalLoad) <- cpuLoad let [userLoad', systemLoad', totalLoad'] = map (formatPercent.(*100)) [userLoad, systemLoad, totalLoad] let template = ST.newSTMP fmt let template' = ST.setManyAttrib [ ("user", userLoad'), ("system", systemLoad'), ("total", totalLoad') ] template return $ ST.render template' formatPercent :: Double -> String formatPercent = printf "%.2f" taffybar-0.4.5/src/System/Taffybar/Hooks/0000755000000000000000000000000012507657545016420 5ustar0000000000000000taffybar-0.4.5/src/System/Taffybar/Hooks/PagerHints.hs0000644000000000000000000000765212507657545021032 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Hooks.PagerHints -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints -- not contemplated by the EWMH standard: -- -- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the -- windows layout currently used in the active workspace. -- -- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the -- names of all the workspaces that are currently showed in a secondary -- display, or an empty list if in the current installation there's only -- one monitor. -- -- The first hint can be set directly on the root window of the default -- display, or indirectly via X11 events with an atom of the same -- name. This allows both to track any changes that occur in the layout of -- the current workspace, as well as to have it changed automatically by -- just sending a custom event to the hook. -- -- The second one should be considered read-only, and is set every time -- XMonad calls its log hooks. -- ----------------------------------------------------------------------------- module System.Taffybar.Hooks.PagerHints ( -- * Usage -- $usage pagerHints ) where import Codec.Binary.UTF8.String (encode) import Control.Monad import Data.Monoid import Foreign.C.Types (CInt) import XMonad import qualified XMonad.StackSet as W -- $usage -- -- You can use this module with the following in your @xmonad.hs@ file: -- -- > import System.Taffybar.Hooks.PagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- | The \"Current Layout\" custom hint. xLayoutProp :: X Atom xLayoutProp = return =<< getAtom "_XMONAD_CURRENT_LAYOUT" -- | The \"Visible Workspaces\" custom hint. xVisibleProp :: X Atom xVisibleProp = return =<< getAtom "_XMONAD_VISIBLE_WORKSPACES" -- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom -- hints to the given config. pagerHints :: XConfig a -> XConfig a pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook , logHook = logHook c +++ pagerHintsLogHook } where x +++ y = x `mappend` y -- | Update the current values of both custom hints. pagerHintsLogHook :: X () pagerHintsLogHook = do withWindowSet (setCurrentLayout . description . W.layout . W.workspace . W.current) withWindowSet (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible) -- | Set the value of the \"Current Layout\" custom hint to the one given. setCurrentLayout :: String -> X () setCurrentLayout l = withDisplay $ \dpy -> do r <- asks theRoot a <- xLayoutProp c <- getAtom "UTF8_STRING" let l' = map fromIntegral (encode l) io $ changeProperty8 dpy r a c propModeReplace l' -- | Set the value of the \"Visible Workspaces\" hint to the one given. setVisibleWorkspaces :: [String] -> X () setVisibleWorkspaces vis = withDisplay $ \dpy -> do r <- asks theRoot a <- xVisibleProp c <- getAtom "UTF8_STRING" let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis io $ changeProperty8 dpy r a c propModeReplace vis' -- | Handle all \"Current Layout\" events received from pager widgets, and -- set the current layout accordingly. pagerHintsEventHook :: Event -> X All pagerHintsEventHook (ClientMessageEvent { ev_message_type = mt, ev_data = d }) = withWindowSet $ \_ -> do a <- xLayoutProp when (mt == a) $ sendLayoutMessage d return (All True) pagerHintsEventHook _ = return (All True) -- | Request a change in the current layout by sending an internal message -- to XMonad. sendLayoutMessage :: [CInt] -> X () sendLayoutMessage evData = case evData of [] -> return () x:_ -> if x < 0 then sendMessage FirstLayout else sendMessage NextLayout taffybar-0.4.5/src/System/Taffybar/Widgets/0000755000000000000000000000000012507657545016743 5ustar0000000000000000taffybar-0.4.5/src/System/Taffybar/Widgets/PollingBar.hs0000644000000000000000000000162012507657545021327 0ustar0000000000000000-- | Like the vertical bar, but this widget automatically updates -- itself with a callback at fixed intervals. module System.Taffybar.Widgets.PollingBar ( -- * Types VerticalBarHandle, BarConfig(..), BarDirection(..), -- * Constructors and accessors pollingBarNew, defaultBarConfig ) where import Control.Concurrent import qualified Control.Exception.Enclosed as E import Control.Monad ( forever ) import Graphics.UI.Gtk import System.Taffybar.Widgets.VerticalBar pollingBarNew :: BarConfig -> Double -> IO Double -> IO Widget pollingBarNew cfg pollSeconds action = do (drawArea, h) <- verticalBarNew cfg _ <- on drawArea realize $ do _ <- forkIO $ forever $ do esample <- E.tryAny action case esample of Left _ -> return () Right sample -> verticalBarSetPercent h sample threadDelay $ floor (pollSeconds * 1000000) return () return drawArea taffybar-0.4.5/src/System/Taffybar/Widgets/VerticalBar.hs0000644000000000000000000001160112507657545021474 0ustar0000000000000000-- | A vertical bar that can plot data in the range [0, 1]. The -- colors are configurable. module System.Taffybar.Widgets.VerticalBar ( -- * Types VerticalBarHandle, BarConfig(..), BarDirection(..), -- * Accessors/Constructors verticalBarNew, verticalBarSetPercent, defaultBarConfig ) where import Control.Concurrent import qualified Graphics.Rendering.Cairo as C import Graphics.UI.Gtk newtype VerticalBarHandle = VBH (MVar VerticalBarState) data VerticalBarState = VerticalBarState { barIsBootstrapped :: Bool , barPercent :: Double , barCanvas :: DrawingArea , barConfig :: BarConfig } data BarDirection = HORIZONTAL | VERTICAL data BarConfig = BarConfig { barBorderColor :: (Double, Double, Double) -- ^ Color of the border drawn around the widget , barBackgroundColor :: Double -> (Double, Double, Double) -- ^ The background color of the widget , barColor :: Double -> (Double, Double, Double) -- ^ A function to determine the color of the widget for the current data point , barPadding :: Int -- ^ Number of pixels of padding around the widget , barWidth :: Int , barDirection :: BarDirection } -- | A default bar configuration. The color of the active portion of -- the bar must be specified. defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig defaultBarConfig c = BarConfig { barBorderColor = (0.5, 0.5, 0.5) , barBackgroundColor = const (0, 0, 0) , barColor = c , barPadding = 2 , barWidth = 15 , barDirection = VERTICAL } verticalBarSetPercent :: VerticalBarHandle -> Double -> IO () verticalBarSetPercent (VBH mv) pct = do s <- readMVar mv let drawArea = barCanvas s case barIsBootstrapped s of False -> return () True -> do modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct }) postGUIAsync $ widgetQueueDraw drawArea clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d renderFrame :: Double -> BarConfig -> Int -> Int -> C.Render () renderFrame pct cfg width height = do let fwidth = fromIntegral width fheight = fromIntegral height -- Now draw the user's requested background, respecting padding let (bgR, bgG, bgB) = barBackgroundColor cfg pct pad = barPadding cfg fpad = fromIntegral pad C.setSourceRGB bgR bgG bgB C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad) C.fill -- Now draw a nice frame let (frameR, frameG, frameB) = barBorderColor cfg C.setSourceRGB frameR frameG frameB C.setLineWidth 1.0 C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1) C.stroke renderBar :: Double -> BarConfig -> Int -> Int -> C.Render () renderBar pct cfg width height = do let direction = barDirection cfg activeHeight = case direction of VERTICAL -> pct * (fromIntegral height) HORIZONTAL -> fromIntegral height activeWidth = case direction of VERTICAL -> fromIntegral width HORIZONTAL -> pct * (fromIntegral width) newOrigin = case direction of VERTICAL -> fromIntegral height - activeHeight HORIZONTAL -> 0 pad = barPadding cfg renderFrame pct cfg width height -- After we draw the frame, transform the coordinate space so that -- we only draw within the frame. C.translate (fromIntegral pad + 1) (fromIntegral pad + 1) let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height C.scale xS yS let (r, g, b) = (barColor cfg) pct C.setSourceRGB r g b C.translate 0 newOrigin C.rectangle 0 0 activeWidth activeHeight C.fill drawBar :: MVar VerticalBarState -> DrawingArea -> IO () drawBar mv drawArea = do (w, h) <- widgetGetSize drawArea drawWin <- widgetGetDrawWindow drawArea s <- readMVar mv let pct = barPercent s modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True }) renderWithDrawable drawWin (renderBar pct (barConfig s) w h) verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle) verticalBarNew cfg = do drawArea <- drawingAreaNew mv <- newMVar VerticalBarState { barIsBootstrapped = False , barPercent = 0 , barCanvas = drawArea , barConfig = cfg } widgetSetSizeRequest drawArea (barWidth cfg) (-1) _ <- on drawArea exposeEvent $ tryEvent $ C.liftIO (drawBar mv drawArea) box <- hBoxNew False 1 boxPackStart box drawArea PackGrow 0 widgetShowAll box return (toWidget box, VBH mv) taffybar-0.4.5/src/System/Taffybar/Widgets/PollingGraph.hs0000644000000000000000000000172412507657545021671 0ustar0000000000000000-- | A variant of the Graph widget that automatically updates itself -- with a callback at a fixed interval. module System.Taffybar.Widgets.PollingGraph ( -- * Types GraphHandle, GraphConfig(..), GraphDirection(..), GraphStyle(..), -- * Constructors and accessors pollingGraphNew, defaultGraphConfig ) where import Control.Concurrent import qualified Control.Exception.Enclosed as E import Control.Monad ( forever ) import Graphics.UI.Gtk import System.Taffybar.Widgets.Graph pollingGraphNew :: GraphConfig -> Double -> IO [Double] -> IO Widget pollingGraphNew cfg pollSeconds action = do (da, h) <- graphNew cfg _ <- on da realize $ do _ <- forkIO $ forever $ do esample <- E.tryAny action case esample of Left _ -> return () Right sample -> graphAddSample h sample threadDelay $ floor (pollSeconds * 1000000) return () return da taffybar-0.4.5/src/System/Taffybar/Widgets/Graph.hs0000644000000000000000000002163312507657545020345 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | This is a graph widget inspired by the widget of the same name in -- Awesome (the window manager). It plots a series of data points -- similarly to a bar graph. This version must be explicitly fed data -- with 'graphAddSample'. For a more automated version, see -- 'PollingGraph'. -- -- Like Awesome, this graph can plot multiple data sets in one widget. -- The data sets are plotted in the order provided by the caller. -- -- Note: all of the data fed to this widget should be in the range -- [0,1]. module System.Taffybar.Widgets.Graph ( -- * Types GraphHandle, GraphConfig(..), GraphDirection(..), GraphStyle(..), -- * Functions graphNew, graphAddSample, defaultGraphConfig ) where import Prelude hiding ( mapM_ ) import Control.Concurrent import Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) import Data.Foldable ( mapM_ ) import Control.Monad ( when ) import Control.Monad.Trans ( liftIO ) import qualified Data.Sequence as S import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as M import qualified Graphics.UI.Gtk as Gtk newtype GraphHandle = GH (MVar GraphState) data GraphState = GraphState { graphIsBootstrapped :: Bool , graphHistory :: [Seq Double] , graphCanvas :: Gtk.DrawingArea , graphConfig :: GraphConfig } data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq) -- | The style of the graph. Generally, you will want to draw all 'Area' graphs first, and then all 'Line' graphs. data GraphStyle = Area -- ^ Thea area below the value is filled | Line -- ^ The values are connected by a line (one pixel wide) -- | The configuration options for the graph. The padding is the -- number of pixels reserved as blank space around the widget in each -- direction. data GraphConfig = GraphConfig { graphPadding :: Int -- ^ Number of pixels of padding on each side of the graph widget , graphBackgroundColor :: (Double, Double, Double) -- ^ The background color of the graph (default black) , graphBorderColor :: (Double, Double, Double) -- ^ The border color drawn around the graph (default gray) , graphBorderWidth :: Int -- ^ The width of the border (default 1, use 0 to disable the border) , graphDataColors :: [(Double, Double, Double, Double)] -- ^ Colors for each data set (default cycles between red, green and blue) , graphDataStyles :: [GraphStyle] -- ^ How to draw each data point (default @repeat Area@) , graphHistorySize :: Int -- ^ The number of data points to retain for each data set (default 20) , graphLabel :: Maybe String -- ^ May contain Pango markup (default @Nothing@) , graphWidth :: Int -- ^ The width (in pixels) of the graph widget (default 50) , graphDirection :: GraphDirection } defaultGraphConfig :: GraphConfig defaultGraphConfig = GraphConfig { graphPadding = 2 , graphBackgroundColor = (0.0, 0.0, 0.0) , graphBorderColor = (0.5, 0.5, 0.5) , graphBorderWidth = 1 , graphDataColors = cycle [(1,0,0,0), (0,1,0,0), (0,0,1,0)] , graphDataStyles = repeat Area , graphHistorySize = 20 , graphLabel = Nothing , graphWidth = 50 , graphDirection = LEFT_TO_RIGHT } -- | Add a data point to the graph for each of the tracked data sets. -- There should be as many values in the list as there are data sets. graphAddSample :: GraphHandle -> [Double] -> IO () graphAddSample (GH mv) rawData = do s <- readMVar mv let drawArea = graphCanvas s histSize = graphHistorySize (graphConfig s) histsAndNewVals = zip pcts (graphHistory s) newHists = case graphHistory s of [] -> map S.singleton pcts _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals case graphIsBootstrapped s of False -> return () True -> do modifyMVar_ mv (\s' -> return s' { graphHistory = newHists }) Gtk.postGUIAsync $ Gtk.widgetQueueDraw drawArea where pcts = map (clamp 0 1) rawData clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d outlineData :: (Double -> Double) -> Double -> Double -> C.Render () outlineData pctToY xStep pct = do (curX,_) <- C.getCurrentPoint C.lineTo (curX + xStep) (pctToY pct) renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render () renderFrameAndBackground cfg w h = do let (backR, backG, backB) = graphBackgroundColor cfg (frameR, frameG, frameB) = graphBorderColor cfg pad = graphPadding cfg fpad = fromIntegral pad fw = fromIntegral w fh = fromIntegral h -- Draw the requested background C.setSourceRGB backR backG backB C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad) C.fill -- Draw a frame around the widget area -- (unless equal to background color, which likely means the user does not -- want a frame) when (graphBorderWidth cfg > 0) $ do let p = fromIntegral (graphBorderWidth cfg) C.setLineWidth p C.setSourceRGB frameR frameG frameB C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw - 2 * fpad - p) (fh - 2 * fpad - p) C.stroke renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render () renderGraph hists cfg w h xStep = do renderFrameAndBackground cfg w h C.setLineWidth 0.1 let pad = fromIntegral $ graphPadding cfg let framePad = fromIntegral $ graphBorderWidth cfg -- Make the new origin be inside the frame and then scale the -- drawing area so that all operations in terms of width and height -- are inside the drawn frame. C.translate (pad + framePad) (pad + framePad) let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h C.scale xS yS -- If right-to-left direction is requested, apply an horizontal inversion -- transformation with an offset to the right equal to the width of the widget. if graphDirection cfg == RIGHT_TO_LEFT then C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0 else return () let pctToY pct = fromIntegral h * (1 - pct) renderDataSet hist color style | S.length hist <= 1 = return () | otherwise = do let (r, g, b, a) = color originY = pctToY newestSample originX = 0 newestSample :< hist' = viewl hist C.setSourceRGBA r g b a C.moveTo originX originY mapM_ (outlineData pctToY xStep) hist' case style of Area -> do (endX, _) <- C.getCurrentPoint C.lineTo endX (fromIntegral h) C.lineTo 0 (fromIntegral h) C.fill Line -> do C.setLineWidth 1.0 C.stroke sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg) drawBorder :: MVar GraphState -> Gtk.DrawingArea -> IO () drawBorder mv drawArea = do (w, h) <- Gtk.widgetGetSize drawArea drawWin <- Gtk.widgetGetDrawWindow drawArea s <- readMVar mv let cfg = graphConfig s Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h) modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True }) return () drawGraph :: MVar GraphState -> Gtk.DrawingArea -> IO () drawGraph mv drawArea = do (w, h) <- Gtk.widgetGetSize drawArea drawWin <- Gtk.widgetGetDrawWindow drawArea s <- readMVar mv let hist = graphHistory s cfg = graphConfig s histSize = graphHistorySize cfg -- Subtract 1 here since the first data point doesn't require -- any movement in the X direction xStep = fromIntegral w / fromIntegral (histSize - 1) case hist of [] -> Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h) _ -> Gtk.renderWithDrawable drawWin (renderGraph hist cfg w h xStep) graphNew :: GraphConfig -> IO (Gtk.Widget, GraphHandle) graphNew cfg = do drawArea <- Gtk.drawingAreaNew mv <- newMVar GraphState { graphIsBootstrapped = False , graphHistory = [] , graphCanvas = drawArea , graphConfig = cfg } Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (-1) _ <- Gtk.on drawArea Gtk.exposeEvent $ Gtk.tryEvent $ liftIO (drawGraph mv drawArea) _ <- Gtk.on drawArea Gtk.realize $ liftIO (drawBorder mv drawArea) box <- Gtk.hBoxNew False 1 case graphLabel cfg of Nothing -> return () Just lbl -> do l <- Gtk.labelNew (Nothing :: Maybe String) Gtk.labelSetMarkup l lbl Gtk.boxPackStart box l Gtk.PackNatural 0 Gtk.boxPackStart box drawArea Gtk.PackGrow 0 Gtk.widgetShowAll box return (Gtk.toWidget box, GH mv) taffybar-0.4.5/src/System/Taffybar/Widgets/PollingLabel.hs0000644000000000000000000000310012507657545021635 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | This is a simple text widget that updates its contents by calling -- a callback at a set interval. module System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) where import Control.Concurrent ( forkIO, threadDelay ) import Control.Exception.Enclosed as E import Control.Monad ( forever ) import Graphics.UI.Gtk -- | Create a new widget that updates itself at regular intervals. The -- function -- -- > pollingLabelNew initialString cmd interval -- -- returns a widget with initial text @initialString@. The widget -- forks a thread to update its contents every @interval@ seconds. -- The command should return a string with any HTML entities escaped. -- This is not checked by the function, since Pango markup shouldn't -- be escaped. Proper input sanitization is up to the caller. -- -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires. pollingLabelNew :: String -- ^ Initial value for the label -> Double -- ^ Update interval (in seconds) -> IO String -- ^ Command to run to get the input string -> IO Widget pollingLabelNew initialString interval cmd = do l <- labelNew (Nothing :: Maybe String) labelSetMarkup l initialString _ <- on l realize $ do _ <- forkIO $ forever $ do estr <- E.tryAny cmd case estr of Left _ -> return () Right str -> postGUIAsync $ labelSetMarkup l str threadDelay $ floor (interval * 1000000) return () return (toWidget l) taffybar-0.4.5/src/System/Taffybar/Widgets/Util.hs0000644000000000000000000000451612507657545020222 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widgets.Util -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Utility functions to facilitate building GTK interfaces. -- ----------------------------------------------------------------------------- module System.Taffybar.Widgets.Util where import Control.Monad import Control.Monad.IO.Class (liftIO) import Graphics.UI.Gtk -- | Execute the given action as a response to any of the given types -- of mouse button clicks. onClick :: [Click] -- ^ Types of button clicks to listen to. -> IO a -- ^ Action to execute. -> EventM EButton Bool onClick triggers action = tryEvent $ do click <- eventClick when (click `elem` triggers) $ liftIO action >> return () -- | Attach the given widget as a popup with the given title to the -- given window. The newly attached popup is not shown initially. Use -- the 'displayPopup' function to display it. attachPopup :: (WidgetClass w, WindowClass wnd) => w -- ^ The widget to set as popup. -> String -- ^ The title of the popup. -> wnd -- ^ The window to attach the popup to. -> IO () attachPopup widget title window = do set window [ windowTitle := title , windowTypeHint := WindowTypeHintTooltip , windowSkipTaskbarHint := True ] windowSetSkipPagerHint window True windowSetKeepAbove window True windowStick window Just topLevel <- widgetGetAncestor widget gTypeWindow let topLevelWindow = castToWindow topLevel windowSetTransientFor window topLevelWindow -- | Display the given popup widget (previously prepared using the -- 'attachPopup' function) immediately beneath (or above) the given -- window. displayPopup :: (WidgetClass w, WindowClass wnd) => w -- ^ The popup widget. -> wnd -- ^ The window the widget was attached to. -> IO () displayPopup widget window = do windowSetPosition window WinPosMouse (x, y ) <- windowGetPosition window (_, y') <- widgetGetSize widget widgetShowAll window if y > y' then windowMove window x (y - y') else windowMove window x y'