taffybar-0.2.1/0000755000000000000000000000000012017734056011503 5ustar0000000000000000taffybar-0.2.1/taffybar.rc0000644000000000000000000000044412017734056013631 0ustar0000000000000000style "default" { bg[NORMAL] = "#000000" fg[NORMAL] = "#FFFFFF" text[NORMAL] = "#FFFFFF" } style "notification-button" = "default" { text[NORMAL] = "#FF0000" fg[NORMAL] = "#FF0000" } widget "Taffybar*" style "default" widget "*NotificationCloseButton" style "notification-button" taffybar-0.2.1/LICENSE0000644000000000000000000000276712017734056012524 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.2.1/README.md0000644000000000000000000000263112017734056012764 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. 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) * MPRIS widget (currently only supports MPRIS1) * 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) * MPRIS2 widget * Better behavior when adding/removing monitors (never tried it) * Make MPRIS more configurable taffybar-0.2.1/taffybar.hs.example0000644000000000000000000000306512017734056015273 0ustar0000000000000000import System.Taffybar import System.Taffybar.Systray import System.Taffybar.XMonadLog 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 log = xmonadLogNew 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 = [ log, note ] , endWidgets = [ tray, wea, clock, mem, cpu, mpris ] } taffybar-0.2.1/Setup.hs0000644000000000000000000000005612017734056013140 0ustar0000000000000000import Distribution.Simple main = defaultMain taffybar-0.2.1/taffybar.cabal0000644000000000000000000000762012017734056014272 0ustar0000000000000000name: taffybar version: 0.2.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE author: Tristan Ravitch maintainer: travitch@cs.wisc.edu category: System build-type: Simple cabal-version: >=1.10 homepage: http://github.com/travitch/taffybar data-files: taffybar.rc extra-source-files: README.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. . Changes in v0.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) . Changes in v0.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 . Changes in v0.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 . Changes in v0.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 library default-language: Haskell2010 build-depends: base > 3 && < 5, time, old-locale, containers, text, HTTP, parsec >= 3.1, mtl >= 2, network, web-encodings, cairo, dbus-core >= 0.9.1 && < 1.0, gtk >= 0.12.1, dyre >= 0.8.6, HStringTemplate, gtk-traymanager >= 0.1.2 && < 0.2, xmonad-contrib, xmonad, xdg-basedir, filepath, utf8-string, process 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.Battery, System.Taffybar.FSMonitor System.Taffybar.NetMonitor System.Taffybar.Widgets.Graph, System.Taffybar.Widgets.PollingBar, System.Taffybar.Widgets.PollingGraph, System.Taffybar.Widgets.PollingLabel, System.Taffybar.Widgets.VerticalBar, System.Information.StreamInfo, System.Information.Battery, System.Information.Memory, System.Information.Network, System.Information.CPU, System.Information.CPU2 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, 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.2.1/src/0000755000000000000000000000000012017734056012272 5ustar0000000000000000taffybar-0.2.1/src/gdk_property_change_wrapper.c0000644000000000000000000000211712017734056020215 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.2.1/src/Main.hs0000644000000000000000000000033012017734056013506 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.2.1/src/System/0000755000000000000000000000000012017734055013555 5ustar0000000000000000taffybar-0.2.1/src/System/Taffybar.hs0000644000000000000000000002541612017734055015657 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.Simple -- > 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(..) ) where import qualified Config.Dyre as Dyre import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.FilePath ( () ) import Graphics.UI.Gtk import Text.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) , 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 , 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"] } -- | 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 -> error ("Error: " ++ err) getDefaultConfigFile :: String -> IO FilePath getDefaultConfigFile name = do dataDir <- getDataDir return (dataDir name) 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) nmonitors <- screenGetNMonitors screen allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)] monitorSize <- case monitorNumber cfg < nmonitors of False -> error $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg) True -> return $ allMonitorSizes !! monitorNumber cfg window <- windowNew widgetSetName window "Taffybar" let Rectangle x y w h = monitorSize windowSetTypeHint window WindowTypeHintDock windowSetScreen window screen windowSetDefaultSize window w (barHeight cfg) windowMove window x (y + case barPosition cfg of Top -> 0 Bottom -> h - barHeight cfg) _ <- onRealize window $ setStrutProperties window $ strutProperties (barPosition cfg) (barHeight cfg) monitorSize allMonitorSizes box <- hBoxNew False 10 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) _ <- on box sizeRequest $ return (Requisition w (barHeight cfg)) widgetShow window widgetShow box mainGUI return () taffybar-0.2.1/src/System/Taffybar/0000755000000000000000000000000012017734056015314 5ustar0000000000000000taffybar-0.2.1/src/System/Taffybar/XMonadLog.hs0000644000000000000000000000764312017734055017511 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | 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 ( -- * Constructor xmonadLogNew, -- * Log hooks for xmonad.hs dbusLog, dbusLogWithPP, -- * Styles taffybarPP, taffybarDefaultPP, taffybarColor, taffybarEscape ) where import Codec.Binary.UTF8.String ( decodeString ) import DBus.Client.Simple ( connectSession, emit, Client ) import DBus.Client ( listen, MatchRule(..) ) import DBus.Types import DBus.Message import Graphics.UI.Gtk hiding ( Signal ) import XMonad import XMonad.Hooks.DynamicLog import Web.Encodings ( decodeHtml, encodeHtml ) -- | 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 = encodeHtml . decodeHtml -- | The same as defaultPP in XMonad.Hooks.DynamicLog taffybarDefaultPP :: PP taffybarDefaultPP = defaultPP { 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 "/org/xmonad/Log" "org.xmonad.Log" "Update" [ toVariant str' ] setupDbus :: Label -> IO () setupDbus w = do let matcher = MatchRule { 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 -> BusName -> Signal -> IO () callback w _ sig = do let [bdy] = signalBody sig Just status = fromVariant bdy postGUIAsync $ labelSetMarkup w status -- | Return a new XMonad log widget xmonadLogNew :: IO Widget xmonadLogNew = do l <- labelNew Nothing _ <- on l realize $ setupDbus l widgetShowAll l return (toWidget l) taffybar-0.2.1/src/System/Taffybar/Systray.hs0000644000000000000000000000121012017734055017317 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 $ \w -> do putStrLn "Tray icon removed" widgetShowAll box return (toWidget box)taffybar-0.2.1/src/System/Taffybar/SimpleClock.hs0000644000000000000000000000474412017734055020065 0ustar0000000000000000-- | 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 ) where import Control.Monad.Trans ( MonadIO, liftIO ) import Data.Time.Format import Data.Time.LocalTime import Graphics.UI.Gtk import System.Locale import System.Taffybar.Widgets.PollingLabel getCurrentTime :: TimeLocale -> String -> IO String getCurrentTime timeLocale fmt = do zt <- getZonedTime return $ formatTime timeLocale fmt zt makeCalendar :: IO Window makeCalendar = do container <- windowNew cal <- calendarNew containerAdd container cal return container toggleCalendar w c = liftIO $ do isVis <- get c widgetVisible case isVis of True -> widgetHideAll c False -> do windowSetKeepAbove c True windowStick c windowSetTypeHint c WindowTypeHintTooltip windowSetSkipTaskbarHint c True windowSetSkipPagerHint c True Just topLevel <- widgetGetAncestor w gTypeWindow let topLevelWindow = castToWindow topLevel windowSetTransientFor c topLevelWindow widgetShowAll 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 TimeLocale -- ^ An TimeLocale - if not specified, the default is used. This can be used to customize how different aspects of time are localized -> String -- ^ The time format string (see http://www.haskell.org/ghc/docs/6.12.2/html/libraries/time-1.1.4/Data-Time-Format.html) -> Double -- ^ The number of seconds to wait between clock updates -> IO Widget textClockNew userLocale fmt updateSeconds = do let timeLocale = maybe defaultTimeLocale id userLocale -- Use a label to display the time. Since we want to be able to -- click on it to show a calendar, we need an eventbox wrapper to -- actually receive events. l <- pollingLabelNew "" updateSeconds (getCurrentTime timeLocale fmt) -- l <- labelNew Nothing ebox <- eventBoxNew containerAdd ebox l eventBoxSetVisibleWindow ebox False -- Allocate a hidden calendar and just show/hide it on clicks. cal <- makeCalendar _ <- on ebox buttonPressEvent (toggleCalendar l cal) widgetShowAll ebox -- The widget in the bar is actuall the eventbox return (toWidget ebox) taffybar-0.2.1/src/System/Taffybar/FreedesktopNotifications.hs0000644000000000000000000003257412017734055022667 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | 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.Monad.Trans ( liftIO ) import Data.Int ( Int32 ) import Data.IORef 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.Client.Simple import Graphics.UI.Gtk hiding ( Variant ) import Web.Encodings ( decodeHtml, encodeHtml ) -- | 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 WorkType = CancelNote (Maybe Word32) | ReplaceNote Word32 Notification | NewNote | ExpireNote Word32 data NotifyState = NotifyState { noteQueue :: MVar (Seq Notification) , noteIdSource :: MVar Word32 , noteWorkerChan :: Chan WorkType , noteWidget :: Label , noteContainer :: Widget , noteTimerThread :: MVar (Maybe ThreadId) , noteConfig :: NotificationConfig } initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do c <- newChan m <- newMVar 1 q <- newMVar S.empty t <- newMVar Nothing return NotifyState { noteQueue = q , noteIdSource = m , noteWorkerChan = c , noteWidget = l , noteContainer = wrapper , noteTimerThread = t , noteConfig = cfg } 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"] closeNotification :: NotifyState -> Word32 -> IO () closeNotification istate nid = do -- FIXME: filter anything with this nid out of the queue before -- posting to the queue so that the worker doesn't need to scan the -- queue writeChan (noteWorkerChan istate) (CancelNote (Just 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 notify :: MVar Int -> 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 idSrc istate appName replaceId icon summary body actions hints timeout = do let maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate) tout = case timeout of 0 -> maxtout (-1) -> maxtout _ -> min maxtout timeout case replaceId of 0 -> do nid <- modifyMVar idSrc (\x -> return (x+1, x)) let n = Notification { noteAppName = appName , noteReplaceId = 0 , noteSummary = encodeHtml $ decodeHtml summary , noteBody = encodeHtml $ decodeHtml body , noteExpireTimeout = tout , noteId = fromIntegral nid } modifyMVar_ (noteQueue istate) (\x -> return (x |> n)) writeChan (noteWorkerChan istate) NewNote return (fromIntegral nid) i -> do let n = Notification { noteAppName = appName , noteReplaceId = i , noteSummary = summary , noteBody = body , noteExpireTimeout = tout , noteId = i } -- First, replace any notes in the note queue with this note, if -- applicable. Next, notify the worker and have it replace the -- current note if that note has this id. modifyMVar_ (noteQueue istate) (\q -> return $ fmap (replaceNote i n) q) writeChan (noteWorkerChan istate) (ReplaceNote i n) return i replaceNote :: Word32 -> Notification -> Notification -> Notification replaceNote nid newNote curNote = case noteId curNote == nid of False -> curNote True -> newNote notificationDaemon onNote onCloseNote = do client <- connectSession _ <- requestName client "org.freedesktop.Notifications" [AllowReplacement, ReplaceExisting] export client "/org/freedesktop/Notifications" [ method "org.freedesktop.Notifications" "GetServerInformation" getServerInformation , method "org.freedesktop.Notifications" "GetCapabilities" getCapabilities , method "org.freedesktop.Notifications" "CloseNotification" onCloseNote , method "org.freedesktop.Notifications" "Notify" onNote ] -- When a notification is received, add it to the queue. Post a token to the channel that the -- worker blocks on. -- The worker thread should sit idle waiting on a chan read. When it -- wakes up, check to see if the current notification needs to be -- expired (due to a cancellation) or just expired on its own. If it -- expired on its own, just empty it out and post the next item in the -- queue, if any. If posting, start a thread that just calls -- theadDelay for the lifetime of the notification. workerThread :: NotifyState -> IO () workerThread s = do currentNote <- newIORef Nothing workerThread' currentNote where workerThread' currentNote = do work <- readChan (noteWorkerChan s) case work of NewNote -> onNewNote currentNote ReplaceNote nid n -> onReplaceNote currentNote nid n CancelNote Nothing -> userCancelNote currentNote CancelNote nid -> do workerThread' currentNote ExpireNote nid -> expireNote currentNote nid -- | The user closed the notification manually userCancelNote currentNote = do writeIORef currentNote Nothing postGUIAsync $ widgetHideAll (noteContainer s) showNextNoteIfAny currentNote onReplaceNote currentNote nid n = do cnote <- readIORef currentNote case cnote of Nothing -> do writeIORef currentNote (Just n) postGUIAsync $ do labelSetMarkup (noteWidget s) (formatMessage s n) widgetShowAll (noteContainer s) timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n) modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId)) workerThread' currentNote Just cnote' -> case noteId cnote' == nid of -- The replaced note was not current and it either does not -- exist or it was already replaced in the note queue False -> workerThread' currentNote -- Otherwise, swap out the current note True -> do withMVar (noteTimerThread s) (maybe (return ()) killThread) writeIORef currentNote (Just n) postGUIAsync $ labelSetMarkup (noteWidget s) (formatMessage s n) timerId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n) modifyMVar_ (noteTimerThread s) $ const $ return (Just timerId) workerThread' currentNote -- | If the current note has the ID being expired, clear the -- notification area and see if there is a pending note to post. expireNote currentNote nid = do cnote <- readIORef currentNote case cnote of Nothing -> showNextNoteIfAny currentNote Just cnote' -> case noteId cnote' == nid of False -> workerThread' currentNote -- Already expired True -> do -- Drop the reference and clear the notification area -- before trying to show a new note writeIORef currentNote Nothing postGUIAsync $ widgetHideAll (noteContainer s) showNextNoteIfAny currentNote onNewNote currentNote = do maybeCurrent <- readIORef currentNote case maybeCurrent of Nothing -> showNextNoteIfAny currentNote -- Grab the next note, show it, and then start a timer Just note -> do -- Otherwise, the current note isn't expired yet and we need -- to wait for it. workerThread' currentNote -- For use when there is no current note, attempt to show the next -- node and then block to wait for the next event. This is -- guarded by a postGUIAsync. showNextNoteIfAny noCurrentNote = do nextNote <- modifyMVar (noteQueue s) takeNote case nextNote of Nothing -> workerThread' noCurrentNote Just nextNote' -> do writeIORef noCurrentNote nextNote postGUIAsync $ do labelSetMarkup (noteWidget s) (formatMessage s nextNote') widgetShowAll (noteContainer s) timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId nextNote') (noteExpireTimeout nextNote') modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId)) workerThread' noCurrentNote takeNote :: Monad m => Seq a -> m (Seq a, Maybe a) takeNote q = case viewl q of EmptyL -> return (q, Nothing) n :< rest -> return (rest, Just n) setExpireTimeout :: Chan WorkType -> Word32 -> Int32 -> IO () setExpireTimeout c nid seconds = do threadDelay (fromIntegral seconds * 1000000) writeChan c (ExpireNote nid) userCancel s = do liftIO $ writeChan (noteWorkerChan s) (CancelNote Nothing) return True 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 button <- eventBoxNew sep <- vSeparatorNew buttonLabel <- labelNew Nothing widgetSetName buttonLabel "NotificationCloseButton" buttonStyle <- rcGetStyle buttonLabel buttonTextColor <- styleGetText buttonStyle StateNormal labelSetMarkup buttonLabel "×" labelSetMaxWidthChars textArea (notificationMaxLength cfg) labelSetEllipsize textArea EllipsizeEnd containerAdd button buttonLabel 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) _ <- forkIO (workerThread istate) -- This is only available to the notify handler, so it doesn't need -- to be protected from the worker thread. There might be multiple -- notifiation handler threads, though (not sure), so keep it safe -- and use an mvar. idSrc <- newMVar 1 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 $ notificationDaemon (notify idSrc istate) (closeNotification istate) -- Don't show ib by default - it will appear when needed return (toWidget realizableWrapper)taffybar-0.2.1/src/System/Taffybar/Weather.hs0000644000000000000000000002175312017734055017256 0ustar0000000000000000-- | This module defines a simple textual weather widget that polls -- NOAA for weather data. To find your weather station, you can use -- -- > http://lwf.ncdc.noaa.gov/oa/climate/stationlocator.html -- -- 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, 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 :: String -> StringTemplate String -> WeatherConfig -> IO String getCurrentWeather url tpl cfg = do dat <- getWeather url case dat of Right wi -> do case weatherFormatter cfg 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) tpl' = newSTMP (weatherTemplate cfg) l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather url tpl' cfg) widgetShowAll l return ltaffybar-0.2.1/src/System/Taffybar/MPRIS.hs0000644000000000000000000000616512017734055016551 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | 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. -- -- This widget isn't as configurable as the others yet - that will be -- fixed. module System.Taffybar.MPRIS ( mprisNew ) where import Data.Int ( Int32 ) import qualified Data.Map as M import Data.Text ( Text ) import qualified Data.Text as T import DBus.Client.Simple ( connectSession ) import DBus.Client import DBus.Types import DBus.Message import Graphics.UI.Gtk hiding ( Signal, Variant ) import Web.Encodings ( encodeHtml, decodeHtml ) import Text.Printf setupDBus :: Label -> IO () setupDBus w = do let trackMatcher = MatchRule { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/Player" , matchInterface = Just "org.freedesktop.MediaPlayer" , matchMember = Just "TrackChange" } stateMatcher = MatchRule { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/Player" , matchInterface = Just "org.freedesktop.MediaPlayer" , matchMember = Just "StatusChange" } client <- connectSession listen client trackMatcher (trackCallback 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 :: Label -> BusName -> Signal -> IO () trackCallback w _ Signal { signalBody = [variant] } = do let v :: Maybe (M.Map Text Variant) v = fromVariant variant case v of Just m -> do let artist = maybe "[unknown]" id (variantDictLookup "artist" m) track = maybe "[unknown]" id (variantDictLookup "title" m) msg = encodeHtml $ decodeHtml $ printf "%s - %s" (T.unpack artist) (T.unpack track) txt = "Now Playing: " ++ msg 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 () trackCallback _ _ _ = return () stateCallback :: Label -> BusName -> Signal -> IO () stateCallback w _ Signal { signalBody = [bdy] } = case fromVariant bdy 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 () stateCallback _ _ _ = return () mprisNew :: IO Widget mprisNew = do l <- labelNew Nothing _ <- on l realize $ setupDBus l widgetShowAll l return (toWidget l) taffybar-0.2.1/src/System/Taffybar/Battery.hs0000644000000000000000000000636112017734055017267 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | 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 Graphics.UI.Gtk import Text.Printf import System.Information.Battery import System.Taffybar.Widgets.PollingBar import System.Taffybar.Widgets.PollingLabel battInfo :: BatteryContext -> String -> IO String battInfo ctxt fmt = do info <- getBatteryInfo ctxt let battPctNum :: Int battPctNum = floor (batteryPercentage info) return $ printf fmt battPctNum -- | A simple textual battery widget that auto-updates once every -- polling period (specified in seconds). The displayed format is -- specified using a printf-style format string. The format string -- must have a single format argument: %d (and any number of %% -- sequences to insert a literal percent sign). -- -- More, fewer, or different format arguments will result in a runtime -- error. textBatteryNew :: String -- ^ Display format -> Double -- ^ Poll period in seconds -> IO Widget textBatteryNew fmt pollSeconds = do battCtxt <- batteryContextNew case battCtxt of Nothing -> labelNew (Just "No battery") >>= return . toWidget Just ctxt -> do l <- pollingLabelNew "" pollSeconds (battInfo ctxt fmt) widgetShowAll l return l -- | Returns the current battery percent as a double in the range [0, -- 1] battPct :: BatteryContext -> IO Double battPct ctxt = do info <- getBatteryInfo ctxt 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 -> labelNew (Just "No battery") >>= 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 "%d%%" pollSeconds bar <- pollingBarNew battCfg pollSeconds (battPct ctxt) boxPackStart b bar PackNatural 0 boxPackStart b txt PackNatural 0 widgetShowAll b return (toWidget b) taffybar-0.2.1/src/System/Taffybar/FSMonitor.hs0000644000000000000000000000123212017734055017525 0ustar0000000000000000module System.Taffybar.FSMonitor where import Graphics.UI.Gtk import System.Process (readProcess) import System.Taffybar.Widgets.PollingLabel import Text.Printf (printf) fsMonitorNew :: Double -> [String] -> IO Widget fsMonitorNew interval fsList = do label <- pollingLabelNew "" interval $ showFSInfo fsList widgetShowAll label return $ toWidget label where showFSInfo :: [String] -> IO String showFSInfo fsDict = 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.2.1/src/System/Taffybar/NetMonitor.hs0000644000000000000000000000131312017734055017743 0ustar0000000000000000module System.Taffybar.NetMonitor where import Graphics.UI.Gtk import System.Information.Network (getNetInfo) import System.Information.StreamInfo (getTransfer) import System.Taffybar.Widgets.PollingLabel import Text.Printf (printf) netMonitorNew :: Double -> String -> IO Widget netMonitorNew interval interface = do label <- pollingLabelNew "" interval $ showNetInfo interface widgetShowAll label return $ toWidget label where showNetInfo :: String -> IO String showNetInfo interface = do trans <- getTransfer 0.3 $ getNetInfo interface let [incoming, outgoing] = map (/1e3) trans return $ printf "▼ %.2fkb/s ▲ %.2fkb/s" incoming outgoing taffybar-0.2.1/src/System/Taffybar/StrutProperties.hs0000644000000000000000000000325012017734056021046 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.2.1/src/System/Taffybar/Widgets/0000755000000000000000000000000012017734055016721 5ustar0000000000000000taffybar-0.2.1/src/System/Taffybar/Widgets/Graph.hs0000644000000000000000000001575012017734055020326 0ustar0000000000000000-- | 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(..), -- * Functions graphNew, graphAddSample, defaultGraphConfig ) where import Prelude hiding ( mapM_ ) import Control.Concurrent import Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) import Data.Foldable ( mapM_ ) import qualified Data.Sequence as S import Graphics.Rendering.Cairo import Graphics.UI.Gtk newtype GraphHandle = GH (MVar GraphState) data GraphState = GraphState { graphIsBootstrapped :: Bool , graphHistory :: [Seq Double] , graphCanvas :: DrawingArea , graphConfig :: GraphConfig } -- | 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) , graphDataColors :: [(Double, Double, Double, Double)] -- ^ Colors for each data set (default []) , 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) } defaultGraphConfig :: GraphConfig defaultGraphConfig = GraphConfig { graphPadding = 2 , graphBackgroundColor = (0.0, 0.0, 0.0) , graphBorderColor = (0.5, 0.5, 0.5) , graphDataColors = [] , graphHistorySize = 20 , graphLabel = Nothing , graphWidth = 50 } -- | 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 }) postGUIAsync $ 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 -> Render () outlineData pctToY xStep pct = do (curX,_) <- getCurrentPoint lineTo (curX + xStep) (pctToY pct) renderFrameAndBackground :: GraphConfig -> Int -> Int -> 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 setSourceRGB backR backG backB rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad) fill -- Draw a frame around the widget area setLineWidth 1.0 setSourceRGB frameR frameG frameB rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad) stroke renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> Render () renderGraph hists cfg w h xStep = do renderFrameAndBackground cfg w h setLineWidth 0.1 let pad = graphPadding 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. translate (fromIntegral pad + 1) (fromIntegral pad + 1) let xS = fromIntegral (w - 2 * pad - 2) / fromIntegral w yS = fromIntegral (h - 2 * pad - 2) / fromIntegral h scale xS yS let pctToY pct = fromIntegral h * (1 - pct) histsAndColors = zip hists (graphDataColors cfg) renderDataSet (hist, color) | S.length hist <= 1 = return () | otherwise = do let (r, g, b, a) = color originY = pctToY newestSample originX = 0 newestSample :< hist' = viewl hist setSourceRGBA r g b a moveTo originX originY mapM_ (outlineData pctToY xStep) hist' (endX, _) <- getCurrentPoint lineTo endX (fromIntegral h) lineTo 0 (fromIntegral h) fill mapM_ renderDataSet histsAndColors drawBorder :: MVar GraphState -> DrawingArea -> IO () drawBorder mv drawArea = do (w, h) <- widgetGetSize drawArea drawWin <- widgetGetDrawWindow drawArea s <- readMVar mv let cfg = graphConfig s renderWithDrawable drawWin (renderFrameAndBackground cfg w h) modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True }) return () drawGraph :: MVar GraphState -> DrawingArea -> IO () drawGraph mv drawArea = do (w, h) <- widgetGetSize drawArea drawWin <- 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 [] -> renderWithDrawable drawWin (renderFrameAndBackground cfg w h) _ -> renderWithDrawable drawWin (renderGraph hist cfg w h xStep) graphNew :: GraphConfig -> IO (Widget, GraphHandle) graphNew cfg = do drawArea <- drawingAreaNew mv <- newMVar GraphState { graphIsBootstrapped = False , graphHistory = [] , graphCanvas = drawArea , graphConfig = cfg } widgetSetSizeRequest drawArea (graphWidth cfg) (-1) _ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawGraph mv drawArea) _ <- on drawArea realize $ liftIO (drawBorder mv drawArea) box <- hBoxNew False 1 case graphLabel cfg of Nothing -> return () Just lbl -> do l <- labelNew Nothing labelSetMarkup l lbl boxPackStart box l PackNatural 0 boxPackStart box drawArea PackGrow 0 widgetShowAll box return (toWidget box, GH mv) taffybar-0.2.1/src/System/Taffybar/Widgets/PollingBar.hs0000644000000000000000000000142012017734055021303 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 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 sample <- action verticalBarSetPercent h sample threadDelay $ floor (pollSeconds * 1000000) return () return drawAreataffybar-0.2.1/src/System/Taffybar/Widgets/PollingGraph.hs0000644000000000000000000000144612017734055021650 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(..), -- * Constructors and accessors pollingGraphNew, defaultGraphConfig ) where import Control.Concurrent 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 sample <- action graphAddSample h sample threadDelay $ floor (pollSeconds * 1000000) return () return dataffybar-0.2.1/src/System/Taffybar/Widgets/PollingLabel.hs0000644000000000000000000000315212017734055021622 0ustar0000000000000000-- | 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 Prelude hiding ( catch ) import Control.Concurrent ( forkIO, threadDelay ) import Control.Exception 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 labelSetMarkup l initialString _ <- on l realize $ do _ <- forkIO $ forever $ do let tryUpdate = do str <- cmd postGUIAsync $ labelSetMarkup l str catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () return (toWidget l) ignoreIOException :: IOException -> IO () ignoreIOException _ = return ()taffybar-0.2.1/src/System/Taffybar/Widgets/VerticalBar.hs0000644000000000000000000001161712017734055021461 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 Graphics.Rendering.Cairo 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) -- ^ 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 = (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 :: BarConfig -> Int -> Int -> Render () renderFrame 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 pad = barPadding cfg fpad = fromIntegral pad setSourceRGB bgR bgG bgB rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad) fill -- Now draw a nice frame let (frameR, frameG, frameB) = barBorderColor cfg setSourceRGB frameR frameG frameB setLineWidth 1.0 rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad) stroke -- renderBar :: Double -> (Double, Double, Double) -> Int -> Int -> Render () renderBar :: Double -> BarConfig -> Int -> Int -> Render () renderBar pct cfg width height = do -- renderBar pct (r, g, b) 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 cfg width height -- After we draw the frame, transform the coordinate space so that -- we only draw within the frame. translate (fromIntegral pad + 1) (fromIntegral pad + 1) let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height scale xS yS let (r, g, b) = (barColor cfg) pct setSourceRGB r g b translate 0 newOrigin rectangle 0 0 activeWidth activeHeight 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 $ liftIO (drawBar mv drawArea) box <- hBoxNew False 1 boxPackStart box drawArea PackGrow 0 widgetShowAll box return (toWidget box, VBH mv) taffybar-0.2.1/src/System/Information/0000755000000000000000000000000012017734056016043 5ustar0000000000000000taffybar-0.2.1/src/System/Information/StreamInfo.hs0000644000000000000000000000371212017734055020450 0ustar0000000000000000-- | 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 , getTransfer) where import Control.Concurrent (threadDelay) import Data.Maybe (fromJust) -- | 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, [Integer])]) -> String -> IO [Integer] getParsedInfo path parser selector = do file <- readFile path (length file) `seq` return () return (fromJust $ lookup selector $ parser file) truncVal :: Double -> Double truncVal v | isNaN v || v < 0.0 = 0.0 | otherwise = v -- | Execute the given action twice with the given delay in-between and return -- the difference between the two samples. probe :: IO [Integer] -> Double -> IO [Integer] probe action delay = do a <- action threadDelay $ round (delay * 1e6) b <- action 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 :: Double -> IO [Integer] -> IO [Double] 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 :: Double -> IO [Integer] -> IO [Double] getLoad interval action = do deltas <- probe action interval let total = fromIntegral $ foldr (+) 0 deltas ratios = map ((/total) . fromIntegral) deltas return $ map truncVal ratios taffybar-0.2.1/src/System/Information/Battery.hs0000644000000000000000000002012612017734055020011 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 import Data.Word import Data.Int import DBus.Client.Simple import Data.List ( find ) import Data.Text ( isInfixOf, Text ) -- | An opaque wrapper around some internal library state newtype BatteryContext = BC Proxy 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" . objectPathText) -- | 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 = val where Just val = fromVariant variant variant = M.findWithDefault (toVariant dflt) key dict -- | 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 = case variantType variant of TypeWord8 -> fromIntegral (f variant :: Word8) TypeWord16 -> fromIntegral (f variant :: Word16) TypeWord32 -> fromIntegral (f variant :: Word32) TypeWord64 -> fromIntegral (f variant :: Word64) TypeInt16 -> fromIntegral (f variant :: Int16) TypeInt32 -> fromIntegral (f variant :: Int32) TypeInt64 -> fromIntegral (f variant :: Int64) t -> error $ "readDictIntegral " ++ show key ++ ": got type " ++ show t where variant = M.findWithDefault (toVariant dflt) key dict f :: IsVariant a => Variant -> a f = fromJust . 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 BatteryInfo getBatteryInfo (BC batteryProxy) = do -- Grab all of the properties of the battery each call with one -- message. let iface :: Variant iface = toVariant ("org.freedesktop.UPower.Device" :: Text) [val] <- call batteryProxy "org.freedesktop.DBus.Properties" "GetAll" [iface] let dict :: Map Text Variant Just dict = fromVariant val 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 powerProxy <- proxy systemConn powerBusName powerBaseObjectPath [ powerDevicesV ] <- call powerProxy "org.freedesktop.UPower" "EnumerateDevices" [] let Just powerDevices = fromVariant powerDevicesV case firstBattery powerDevices of Nothing -> return Nothing Just battPath -> proxy systemConn powerBusName battPath >>= (return . Just . BC) taffybar-0.2.1/src/System/Information/Memory.hs0000644000000000000000000000220112017734055017641 0ustar0000000000000000module System.Information.Memory ( MemoryInfo(..), parseMeminfo ) where toMB :: [String] -> Double toMB line = (read $ line !! 1 :: Double) / 1024 data MemoryInfo = MemoryInfo { memoryUsedRatio :: Double , memoryTotal :: Double , memoryFree :: Double , memoryBuffer :: Double , memoryCache :: Double , memoryRest :: Double , memoryUsed :: Double } parseMeminfo :: IO MemoryInfo parseMeminfo = do s <- readFile "/proc/meminfo" let content = map words $ take 4 $ lines s [total, free, buffer, cache ] = map toMB content rest = free + buffer + cache used = total - rest usedRatio = used / total return MemoryInfo { memoryUsedRatio = usedRatio , memoryTotal = total , memoryFree = free , memoryBuffer = buffer , memoryCache = cache , memoryRest = rest , memoryUsed = used } taffybar-0.2.1/src/System/Information/Network.hs0000644000000000000000000000063512017734056020034 0ustar0000000000000000module System.Information.Network (getNetInfo) where import System.Information.StreamInfo (getParsedInfo) getNetInfo :: String -> IO [Integer] getNetInfo = getParsedInfo "/proc/net/dev" parse parse :: String -> [(String, [Integer])] parse = map tuplize . map words . drop 2 . lines tuplize :: [String] -> (String, [Integer]) tuplize s = (init $ head s, map read [s!!1, s!!out]) where out = (length s) - 7 taffybar-0.2.1/src/System/Information/CPU.hs0000644000000000000000000000170312017734056017027 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.2.1/src/System/Information/CPU2.hs0000644000000000000000000000102712017734056017110 0ustar0000000000000000module System.Information.CPU2 (getCPULoad) where import System.Information.StreamInfo (getLoad, getParsedInfo) getCPULoad :: String -> IO [Double] getCPULoad cpu = do load <- getLoad 0.05 $ getCPUInfo cpu return [load!!0 + load!!1, load!!2] getCPUInfo :: String -> IO [Integer] getCPUInfo = getParsedInfo "/proc/stat" parse parse :: String -> [(String, [Integer])] parse = map (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines tuplize :: [String] -> (String, [Integer]) tuplize s = (head s, map read $ tail s)