diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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
diff --git a/src/System/Information/Battery.hs b/src/System/Information/Battery.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Information/Battery.hs
@@ -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)
+
diff --git a/src/System/Information/CPU.hs b/src/System/Information/CPU.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Information/CPU.hs
@@ -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)
diff --git a/src/System/Information/Memory.hs b/src/System/Information/Memory.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Information/Memory.hs
@@ -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
+ }
+
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar.hs
@@ -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 "%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.
+--
+-- 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 ()
diff --git a/src/System/Taffybar/Battery.hs b/src/System/Taffybar/Battery.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Battery.hs
@@ -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)
diff --git a/src/System/Taffybar/FreedesktopNotifications.hs b/src/System/Taffybar/FreedesktopNotifications.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/FreedesktopNotifications.hs
@@ -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)
diff --git a/src/System/Taffybar/MPRIS.hs b/src/System/Taffybar/MPRIS.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/MPRIS.hs
@@ -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 = "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
+
+ setupDBus l
+ widgetShowAll l
+ return (toWidget l)
diff --git a/src/System/Taffybar/SimpleClock.hs b/src/System/Taffybar/SimpleClock.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/SimpleClock.hs
@@ -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)
diff --git a/src/System/Taffybar/StrutProperties.hs b/src/System/Taffybar/StrutProperties.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/StrutProperties.hs
@@ -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)
+
diff --git a/src/System/Taffybar/Systray.hs b/src/System/Taffybar/Systray.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Systray.hs
@@ -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)
diff --git a/src/System/Taffybar/Weather.hs b/src/System/Taffybar/Weather.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Weather.hs
@@ -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
diff --git a/src/System/Taffybar/Widgets/Graph.hs b/src/System/Taffybar/Widgets/Graph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widgets/Graph.hs
@@ -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)
diff --git a/src/System/Taffybar/Widgets/PollingBar.hs b/src/System/Taffybar/Widgets/PollingBar.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widgets/PollingBar.hs
@@ -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
diff --git a/src/System/Taffybar/Widgets/PollingGraph.hs b/src/System/Taffybar/Widgets/PollingGraph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widgets/PollingGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widgets/PollingLabel.hs b/src/System/Taffybar/Widgets/PollingLabel.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widgets/PollingLabel.hs
@@ -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)
diff --git a/src/System/Taffybar/Widgets/VerticalBar.hs b/src/System/Taffybar/Widgets/VerticalBar.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widgets/VerticalBar.hs
@@ -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)
diff --git a/src/System/Taffybar/XMonadLog.hs b/src/System/Taffybar/XMonadLog.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/XMonadLog.hs
@@ -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)
diff --git a/src/gdk_property_change_wrapper.c b/src/gdk_property_change_wrapper.c
new file mode 100644
--- /dev/null
+++ b/src/gdk_property_change_wrapper.c
@@ -0,0 +1,28 @@
+////////////////////////////////////////////////////////////////////////////
+// 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);
+}
diff --git a/taffybar.cabal b/taffybar.cabal
new file mode 100644
--- /dev/null
+++ b/taffybar.cabal
@@ -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
diff --git a/taffybar.hs.example b/taffybar.hs.example
new file mode 100644
--- /dev/null
+++ b/taffybar.hs.example
@@ -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 "%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 ]
+ }