taffybar (empty) → 0.1.0
raw patch · 24 files changed
+2007/−0 lines, 24 filesdep +HStringTemplatedep +HTTPdep +basesetup-changed
Dependencies added: HStringTemplate, HTTP, base, cairo, containers, dbus-core, dyre, gtk, gtk-traymanager, mtl, network, old-locale, parsec, text, time, web-encodings, xmonad, xmonad-contrib
Files
- LICENSE +30/−0
- README.md +38/−0
- Setup.hs +2/−0
- src/Main.hs +9/−0
- src/System/Information/Battery.hs +166/−0
- src/System/Information/CPU.hs +35/−0
- src/System/Information/Memory.hs +34/−0
- src/System/Taffybar.hs +176/−0
- src/System/Taffybar/Battery.hs +93/−0
- src/System/Taffybar/FreedesktopNotifications.hs +322/−0
- src/System/Taffybar/MPRIS.hs +85/−0
- src/System/Taffybar/SimpleClock.hs +72/−0
- src/System/Taffybar/StrutProperties.hs +32/−0
- src/System/Taffybar/Systray.hs +26/−0
- src/System/Taffybar/Weather.hs +272/−0
- src/System/Taffybar/Widgets/Graph.hs +204/−0
- src/System/Taffybar/Widgets/PollingBar.hs +27/−0
- src/System/Taffybar/Widgets/PollingGraph.hs +30/−0
- src/System/Taffybar/Widgets/PollingLabel.hs +32/−0
- src/System/Taffybar/Widgets/VerticalBar.hs +129/−0
- src/System/Taffybar/XMonadLog.hs +58/−0
- src/gdk_property_change_wrapper.c +28/−0
- taffybar.cabal +64/−0
- taffybar.hs.example +43/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ README.md view
@@ -0,0 +1,38 @@+This 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Main.hs view
@@ -0,0 +1,9 @@+-- | 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
+ src/System/Information/Battery.hs view
@@ -0,0 +1,166 @@+{-# 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.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++-- | 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 $ readDict dict "Type" (0 :: Word64)+ , 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 $ fromIntegral $ readDict dict "State" (0 :: Word64)+ , batteryIsRechargable = readDict dict "IsRechargable" True+ , batteryCapacity = readDict dict "Capacity" 0.0+ , batteryTechnology =+ toEnum $ fromIntegral $ readDict dict "Technology" (0 :: Word64)+ }++-- | 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)+
+ src/System/Information/CPU.hs view
@@ -0,0 +1,35 @@+module 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)
+ src/System/Information/Memory.hs view
@@ -0,0 +1,34 @@+module 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+ }+
+ src/System/Taffybar.hs view
@@ -0,0 +1,176 @@+-- | 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.+--+-- 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 "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 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.+--+-- 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 DBus.Client.Simple+-- > import System.Taffybar.XMonadLog ( dbusLog )+-- >+-- > main = do+-- > client <- connectSession+-- > let pp = defaultPP+-- > xmonad defaultConfig { logHook = dbusLog client pp }+--+-- The complexity is handled in the System.Tafftbar.XMonadLog module.+module System.Taffybar (+ TaffybarConfig(..),+ defaultTaffybar,+ defaultTaffybarConfig+ ) where++import qualified Config.Dyre as Dyre++import Graphics.UI.Gtk+import Text.Printf++import System.Taffybar.StrutProperties++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)+ , 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+ , 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)++taffybarMain :: TaffybarConfig -> IO ()+taffybarMain cfg = do+ _ <- 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+ monitorSize <- case monitorNumber cfg < nmonitors of+ False -> error $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg)+ True -> screenGetMonitorGeometry screen (monitorNumber cfg)++ window <- windowNew+ let Rectangle x y w _ = monitorSize+ windowSetTypeHint window WindowTypeHintDock+ windowSetScreen window screen+ windowSetDefaultSize window w (barHeight cfg)+ windowMove window x y+ widgetModifyBg window StateNormal (Color 0 0 0)+ _ <- onRealize window $ setStrutProperties window (0, 0, barHeight cfg, 0,+ 0, 0,+ 0, 0,+ x, x + w - 10,+ 0, 0)+ 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)+ widgetShow window+ widgetShow box+ mainGUI+ return ()
+ src/System/Taffybar/Battery.hs view
@@ -0,0 +1,93 @@+{-# 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)
+ src/System/Taffybar/FreedesktopNotifications.hs view
@@ -0,0 +1,322 @@+{-# 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 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 :: InfoBar+ , noteTimerThread :: MVar (Maybe ThreadId)+ , noteConfig :: NotificationConfig+ }++initialNoteState :: InfoBar -> Label -> NotificationConfig -> IO NotifyState+initialNoteState ib 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 = ib+ , 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 _ = writeChan (noteWorkerChan s) (CancelNote Nothing)++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 [ 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 = 50+ , notificationFormatter = defaultFormatter+ }++-- | Create a new notification area with the given configuration.+notifyAreaNew :: NotificationConfig -> IO Widget+notifyAreaNew cfg = do+ ib <- infoBarNew+ l <- labelNew Nothing+ button <- buttonNew -- FromStock stockClose+ img <- imageNewFromStock stockClose (IconSizeUser 16)+ ca <- infoBarGetContentArea ib+ let container = castToContainer ca+ containerAdd container l+ containerAdd button img+ infoBarAddActionWidget ib button 0+ widgetHideAll ib++++ istate <- initialNoteState ib l cfg+ _ <- on ib infoBarResponse (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+ notificationDaemon (notify idSrc istate) (closeNotification istate)++ -- Don't show ib by default - it will appear when needed+ return (toWidget ib)
+ src/System/Taffybar/MPRIS.hs view
@@ -0,0 +1,85 @@+{-# 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 = "<span fgcolor='yellow'>Now Playing:</span> " ++ 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++ setupDBus l+ widgetShowAll l+ return (toWidget l)
+ src/System/Taffybar/SimpleClock.hs view
@@ -0,0 +1,72 @@+-- | 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)
+ src/System/Taffybar/StrutProperties.hs view
@@ -0,0 +1,32 @@+module System.Taffybar.StrutProperties ( setStrutProperties ) where++import Graphics.UI.Gtk++import Foreign+import Foreign.C.Types+import Unsafe.Coerce ( unsafeCoerce )++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 -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) -> 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)+
+ src/System/Taffybar/Systray.hs view
@@ -0,0 +1,26 @@+-- | 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+ widgetModifyBg box StateNormal (Color 0 0 0)++ trayManager <- trayManagerNew+ Just screen <- screenGetDefault+ _ <- trayManagerManageScreen trayManager screen++ _ <- on trayManager trayIconAdded $ \w -> do+ widgetModifyBg w StateNormal (Color 0 0 0)+ widgetShowAll w+ boxPackStart box w PackNatural 0++ _ <- on trayManager trayIconRemoved $ \w -> do+ putStrLn "Tray icon removed"++ widgetShowAll box+ return (toWidget box)
+ src/System/Taffybar/Weather.hs view
@@ -0,0 +1,272 @@+-- | 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.+--+-- 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(..),+ -- * 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)+ | DefaultWeatherFormatter++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 l
+ src/System/Taffybar/Widgets/Graph.hs view
@@ -0,0 +1,204 @@+-- | 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++ -- Clear the background to match the bar+ setSourceRGB 0 0 0+ rectangle 0 0 fw fh+ fill++ -- 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)++ case graphLabel cfg of+ Nothing -> do+ widgetShowAll drawArea+ return (toWidget drawArea, GH mv)+ Just lbl -> do+ l <- labelNew Nothing+ box <- hBoxNew False 1+ labelSetMarkup l lbl+ boxPackStart box l PackNatural 0+ boxPackStart box drawArea PackGrow 0++ widgetShowAll box++ return (toWidget box, GH mv)
+ src/System/Taffybar/Widgets/PollingBar.hs view
@@ -0,0 +1,27 @@+-- | Like the vertical bar, but this widget automatically updates+-- itself with a callback at fixed intervals.+module System.Taffybar.Widgets.PollingBar (+ -- * Types+ VerticalBarHandle,+ BarConfig(..),+ -- * 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++ _ <- forkIO $ forever $ do+ sample <- action+ verticalBarSetPercent h sample+ threadDelay $ floor (pollSeconds * 1000000)++ return drawArea
+ src/System/Taffybar/Widgets/PollingGraph.hs view
@@ -0,0 +1,30 @@+-- | 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++ _ <- forkIO $ forever $ do+ sample <- action+ graphAddSample h sample+ threadDelay $ floor (pollSeconds * 1000000)++ return da
+ src/System/Taffybar/Widgets/PollingLabel.hs view
@@ -0,0 +1,32 @@+-- | 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.Monad ( forever )+import Graphics.UI.Gtk++-- | Create a new widget that updates itself at regular intervals. The+-- function+--+-- > updatingLabelNew 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.+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++ _ <- forkIO $ forever $ do+ str <- cmd+ postGUIAsync $ labelSetMarkup l str+ threadDelay $ floor (interval * 1000000)++ return (toWidget l)
+ src/System/Taffybar/Widgets/VerticalBar.hs view
@@ -0,0 +1,129 @@+-- | A vertical bar that can plot data in the range [0, 1]. The+-- colors are configurable.+module System.Taffybar.Widgets.VerticalBar (+ -- * Types+ VerticalBarHandle,+ BarConfig(..),+ -- * 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 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+ }++-- | 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+ }++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+ -- Make a full black background for the whole widget+ setSourceRGB 0 0 0+ rectangle 0 0 fwidth fheight+ fill++ -- 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 activeHeight = pct * (fromIntegral height)+ activeWidth = fromIntegral width+ newOrigin = fromIntegral height - activeHeight+ 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+ }++ widgetModifyBg drawArea StateNormal (Color 0 0 0)++ widgetSetSizeRequest drawArea (barWidth cfg) (-1)+ _ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawBar mv drawArea)++ widgetShowAll drawArea+ return (toWidget drawArea, VBH mv)
+ src/System/Taffybar/XMonadLog.hs view
@@ -0,0 +1,58 @@+{-# 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 ( xmonadLogNew, dbusLog ) where++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++-- | This is a DBus-based logger that can be used from XMonad to log+-- to this widget.+dbusLog :: Client -> PP -> X ()+dbusLog client pp = do+ dynamicLogWithPP pp { ppOutput = outputThroughDBus client }++outputThroughDBus :: Client -> String -> IO ()+outputThroughDBus client 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++xmonadLogNew :: IO Widget+xmonadLogNew = do+ l <- labelNew Nothing+ _ <- on l realize $ setupDbus l+ widgetShowAll l+ return (toWidget l)
+ src/gdk_property_change_wrapper.c view
@@ -0,0 +1,28 @@+////////////////////////////////////////////////////////////////////////////+// Copyright : (c) Jan Vornberger 2009+// License : BSD3-style (see LICENSE)+//+// Maintainer : jan.vornberger@informatik.uni-oldenburg.de+////////////////////////////////////////////////////////////////////////////-++#include <gtk/gtk.h>+#include <gdk/gdk.h>++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.cabal view
@@ -0,0 +1,64 @@+name: taffybar+version: 0.1.0+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+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.+++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, dyre >= 0.8.6,+ HStringTemplate, gtk-traymanager, xmonad-contrib, xmonad+ 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.Widgets.Graph,+ System.Taffybar.Widgets.PollingBar,+ System.Taffybar.Widgets.PollingGraph,+ System.Taffybar.Widgets.PollingLabel,+ System.Taffybar.Widgets.VerticalBar,+ System.Information.Battery,+ System.Information.Memory,+ System.Information.CPU+ other-modules: System.Taffybar.StrutProperties++ 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+ 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.hs.example view
@@ -0,0 +1,43 @@+import 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 "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 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 ]+ }