taffybar 0.1.3 → 0.2.0
raw patch · 9 files changed
+159/−36 lines, 9 files
Files
- src/System/Information/Battery.hs +20/−3
- src/System/Taffybar.hs +33/−10
- src/System/Taffybar/StrutProperties.hs +5/−2
- src/System/Taffybar/Weather.hs +15/−2
- src/System/Taffybar/Widgets/Graph.hs +5/−8
- src/System/Taffybar/Widgets/PollingLabel.hs +14/−3
- src/System/Taffybar/Widgets/VerticalBar.hs +5/−2
- src/System/Taffybar/XMonadLog.hs +52/−5
- taffybar.cabal +10/−1
src/System/Information/Battery.hs view
@@ -16,6 +16,7 @@ import Data.Map ( Map ) import qualified Data.Map as M+import Data.Maybe import Data.Word import Data.Int import DBus.Client.Simple@@ -107,6 +108,22 @@ Just val = fromVariant variant variant = M.findWithDefault (toVariant dflt) key dict +-- | Read the variant contents of a dict which is of an unknown integral type.+readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int+readDictIntegral dict key dflt = case variantType variant of+ TypeWord8 -> fromIntegral (f variant :: Word8)+ TypeWord16 -> fromIntegral (f variant :: Word16)+ TypeWord32 -> fromIntegral (f variant :: Word32)+ TypeWord64 -> fromIntegral (f variant :: Word64)+ TypeInt16 -> fromIntegral (f variant :: Int16)+ TypeInt32 -> fromIntegral (f variant :: Int32)+ TypeInt64 -> fromIntegral (f variant :: Int64)+ t -> error $ "readDictIntegral " ++ show key ++ ": got type " ++ show t+ where+ variant = M.findWithDefault (toVariant dflt) key dict+ f :: IsVariant a => Variant -> a+ f = fromJust . fromVariant+ -- | Query the UPower daemon about information on a specific battery. -- If some fields are not actually present, they may have bogus values -- here. Don't bet anything critical on it.@@ -125,7 +142,7 @@ , batteryVendor = readDict dict "Vendor" "" , batteryModel = readDict dict "Model" "" , batterySerial = readDict dict "Serial" ""- , batteryType = toEnum $ fromIntegral $ readDict dict "Type" (0 :: Word64)+ , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0 , batteryPowerSupply = readDict dict "PowerSupply" False , batteryHasHistory = readDict dict "HasHistory" False , batteryHasStatistics = readDict dict "HasStatistics" False@@ -140,11 +157,11 @@ , batteryTimeToFull = readDict dict "TimeToFull" 0 , batteryPercentage = readDict dict "Percentage" 0.0 , batteryIsPresent = readDict dict "IsPresent" False- , batteryState = toEnum $ fromIntegral $ readDict dict "State" (0 :: Word64)+ , batteryState = toEnum $ readDictIntegral dict "State" 0 , batteryIsRechargable = readDict dict "IsRechargable" True , batteryCapacity = readDict dict "Capacity" 0.0 , batteryTechnology =- toEnum $ fromIntegral $ readDict dict "Technology" (0 :: Word64)+ toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0 } -- | Construct a battery context if possible. This could fail if the
src/System/Taffybar.hs view
@@ -79,15 +79,22 @@ -- package, which is installed as a dependency of Taffybar. -- -- > import XMonad.Hooks.DynamicLog+ -- > import XMonad.Hooks.ManageDocks -- > import DBus.Client.Simple -- > import System.Taffybar.XMonadLog ( dbusLog ) -- > -- > main = do -- > client <- connectSession -- > let pp = defaultPP- -- > xmonad defaultConfig { logHook = dbusLog client pp }+ -- > xmonad defaultConfig { logHook = dbusLog client pp+ -- > , manageHook = manageDocks+ -- > } --- -- The complexity is handled in the System.Tafftbar.XMonadLog module.+ -- The complexity is handled in the System.Tafftbar.XMonadLog+ -- module. Note that manageDocks is required to have XMonad put+ -- taffybar in the strut space that it reserves. If you have+ -- problems with taffybar appearing almost fullscreen, check to+ -- see if you have manageDocks in your manageHook. -- ** A note about DBus: -- |@@ -113,7 +120,8 @@ -- see <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>. TaffybarConfig(..), defaultTaffybar,- defaultTaffybarConfig+ defaultTaffybarConfig,+ Position(..) ) where import qualified Config.Dyre as Dyre@@ -125,10 +133,23 @@ import Paths_taffybar ( getDataDir ) import System.Taffybar.StrutProperties +data Position = Top | Bottom+ deriving (Show, Eq)++strutProperties :: Position -- ^ Bar position+ -> Int -- ^ Bar height+ -> Rectangle -- ^ Monitor rectangle+ -> StrutProperties+strutProperties pos bh (Rectangle x _ w _) = case pos of+ Top -> (0, 0, bh, 0, 0, 0, 0, 0, x, x2, 0, 0)+ Bottom -> (0, 0, 0, bh, 0, 0, 0, 0, 0, 0, x, x2)+ where x2 = x + w - 10+ data TaffybarConfig = TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine) , monitorNumber :: Int -- ^ The xinerama/xrandr monitor number to put the bar on (default: 0) , barHeight :: Int -- ^ Number of pixels to reserve for the bar (default: 25 pixels)+ , barPosition :: Position -- ^ The position of the bar on the screen (default: Top) , errorMsg :: Maybe String -- ^ Used by the application , startWidgets :: [IO Widget] -- ^ Widgets that are packed in order at the left end of the bar , endWidgets :: [IO Widget] -- ^ Widgets that are packed from right-to-left in the bar@@ -140,6 +161,7 @@ TaffybarConfig { screenNumber = 0 , monitorNumber = 0 , barHeight = 25+ , barPosition = Top , errorMsg = Nothing , startWidgets = [] , endWidgets = []@@ -197,16 +219,17 @@ window <- windowNew widgetSetName window "Taffybar"- let Rectangle x y w _ = monitorSize+ let Rectangle x y w h = monitorSize windowSetTypeHint window WindowTypeHintDock windowSetScreen window screen windowSetDefaultSize window w (barHeight cfg)- windowMove window x y- _ <- onRealize window $ setStrutProperties window (0, 0, barHeight cfg, 0,- 0, 0,- 0, 0,- x, x + w - 10,- 0, 0)+ windowMove window x (y + case barPosition cfg of+ Top -> 0+ Bottom -> h - barHeight cfg)+ _ <- onRealize window $ setStrutProperties window+ $ strutProperties (barPosition cfg)+ (barHeight cfg)+ monitorSize box <- hBoxNew False 10 containerAdd window box
src/System/Taffybar/StrutProperties.hs view
@@ -1,4 +1,5 @@-module System.Taffybar.StrutProperties ( setStrutProperties ) where+module System.Taffybar.StrutProperties ( setStrutProperties+ , StrutProperties ) where import Graphics.UI.Gtk @@ -6,6 +7,8 @@ import Foreign.C.Types import Unsafe.Coerce ( unsafeCoerce ) +type StrutProperties = (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)+ foreign import ccall "set_strut_properties" c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong@@ -15,7 +18,7 @@ -> () -- | Reserve EWMH struts-setStrutProperties :: Window -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) -> IO ()+setStrutProperties :: Window -> StrutProperties -> IO () setStrutProperties gtkWindow (left, right, top, bottom, left_start_y, left_end_y, right_start_y, right_end_y,
src/System/Taffybar/Weather.hs view
@@ -10,7 +10,15 @@ -- a _template_ that is filled in with the current information. The -- template is just a 'String' with variables between dollar signs. -- The variables will be substituted with real data by the widget.+-- Example: --+-- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }+-- > weatherWidget = weatherNew wcfg 10+--+-- This example makes a new weather widget that checks the weather at+-- KMSN (Madison, WI) every 10 minutes, and displays the results in+-- Celcius.+-- -- Available variables: -- -- [@stationPlace@] The name of the weather station@@ -56,6 +64,7 @@ -- * Types WeatherConfig(..), WeatherInfo(..),+ WeatherFormatter(WeatherFormatter), -- * Constructor weatherNew, defaultWeatherConfig@@ -241,9 +250,13 @@ -- | 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 WeatherFormatter = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'+ | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter +-- | The configuration for the weather widget. You can provide a custom+-- format string through 'weatherTemplate' as described above, or you can+-- provide a custom function to turn a 'WeatherInfo' into a String via the+-- 'weatherFormatter' field. data WeatherConfig = WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F
src/System/Taffybar/Widgets/Graph.hs view
@@ -182,18 +182,15 @@ widgetSetSizeRequest drawArea (graphWidth cfg) (-1) _ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawGraph mv drawArea) _ <- on drawArea realize $ liftIO (drawBorder mv drawArea)+ box <- hBoxNew False 1 case graphLabel cfg of- Nothing -> do- widgetShowAll drawArea- return (toWidget drawArea, GH mv)+ Nothing -> return () 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)+ boxPackStart box drawArea PackGrow 0+ widgetShowAll box+ return (toWidget box, GH mv)
src/System/Taffybar/Widgets/PollingLabel.hs view
@@ -2,20 +2,26 @@ -- a callback at a set interval. module System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) where +import Prelude hiding ( catch )+ import Control.Concurrent ( forkIO, threadDelay )+import Control.Exception import Control.Monad ( forever ) import Graphics.UI.Gtk -- | Create a new widget that updates itself at regular intervals. The -- function ----- > updatingLabelNew initialString cmd interval+-- > pollingLabelNew initialString cmd interval -- -- returns a widget with initial text @initialString@. The widget -- forks a thread to update its contents every @interval@ seconds. -- The command should return a string with any HTML entities escaped. -- This is not checked by the function, since Pango markup shouldn't -- be escaped. Proper input sanitization is up to the caller.+--+-- If the IO action throws an exception, it will be swallowed and the+-- label will not update until the update interval expires. pollingLabelNew :: String -- ^ Initial value for the label -> Double -- ^ Update interval (in seconds) -> IO String -- ^ Command to run to get the input string@@ -26,9 +32,14 @@ _ <- on l realize $ do _ <- forkIO $ forever $ do- str <- cmd- postGUIAsync $ labelSetMarkup l str+ let tryUpdate = do+ str <- cmd+ postGUIAsync $ labelSetMarkup l str+ catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () return (toWidget l)++ignoreIOException :: IOException -> IO ()+ignoreIOException _ = return ()
src/System/Taffybar/Widgets/VerticalBar.hs view
@@ -119,5 +119,8 @@ widgetSetSizeRequest drawArea (barWidth cfg) (-1) _ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawBar mv drawArea) - widgetShowAll drawArea- return (toWidget drawArea, VBH mv)+ box <- hBoxNew False 1+ boxPackStart box drawArea PackGrow 0+ widgetShowAll box++ return (toWidget box, VBH mv)
src/System/Taffybar/XMonadLog.hs view
@@ -10,7 +10,18 @@ -- -- There is a more complete example of xmonad integration in the -- top-level module.-module System.Taffybar.XMonadLog ( xmonadLogNew, dbusLog ) where+module System.Taffybar.XMonadLog (+ -- * Constructor+ xmonadLogNew,+ -- * Log hooks for xmonad.hs+ dbusLog,+ dbusLogWithPP,+ -- * Styles+ taffybarPP,+ taffybarDefaultPP,+ taffybarColor,+ taffybarEscape+ ) where import Codec.Binary.UTF8.String ( decodeString ) import DBus.Client.Simple ( connectSession, emit, Client )@@ -22,12 +33,47 @@ import XMonad import XMonad.Hooks.DynamicLog +import Web.Encodings ( decodeHtml, encodeHtml )+ -- | This is a DBus-based logger that can be used from XMonad to log--- to this widget.-dbusLog :: Client -> PP -> X ()-dbusLog client pp = do- dynamicLogWithPP pp { ppOutput = outputThroughDBus client }+-- to this widget. This version lets you specify the format for the+-- log using a pretty printer (e.g., 'taffybarPP').+dbusLogWithPP :: Client -> PP -> X ()+dbusLogWithPP client pp = dynamicLogWithPP pp { ppOutput = outputThroughDBus client } +-- | A DBus-based logger with a default pretty-print configuration+dbusLog :: Client -> X ()+dbusLog client = dbusLogWithPP client taffybarDefaultPP++taffybarColor :: String -> String -> String -> String+taffybarColor fg bg = wrap t "</span>" . taffybarEscape+ where t = concat ["<span fgcolor=\"", fg, if null bg then "" else "\" bgcolor=\"" ++ bg , "\">"]++-- | Escape strings so that they can be safely displayed by Pango in+-- the bar widget+taffybarEscape :: String -> String+taffybarEscape = encodeHtml . decodeHtml++-- | The same as defaultPP in XMonad.Hooks.DynamicLog+taffybarDefaultPP :: PP+taffybarDefaultPP = defaultPP { ppCurrent = taffybarEscape . wrap "[" "]"+ , ppVisible = taffybarEscape . wrap "<" ">"+ , ppHidden = taffybarEscape+ , ppHiddenNoWindows = taffybarEscape+ , ppUrgent = taffybarEscape+ , ppTitle = taffybarEscape . shorten 80+ , ppLayout = taffybarEscape+ }+-- | The same as xmobarPP in XMonad.Hooks.DynamicLog+taffybarPP :: PP+taffybarPP = taffybarDefaultPP { ppCurrent = taffybarColor "yellow" "" . wrap "[" "]"+ , ppTitle = taffybarColor "green" "" . shorten 40+ , ppVisible = wrap "(" ")"+ , ppUrgent = taffybarColor "red" "yellow"+ }+++ outputThroughDBus :: Client -> String -> IO () outputThroughDBus client str = do -- The string that we get from XMonad here isn't quite a normal@@ -56,6 +102,7 @@ Just status = fromVariant bdy postGUIAsync $ labelSetMarkup w status +-- | Return a new XMonad log widget xmonadLogNew :: IO Widget xmonadLogNew = do l <- labelNew Nothing
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 0.1.3+version: 0.2.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -17,6 +17,15 @@ A somewhat fancier desktop bar than xmobar. This bar is based on gtk2hs and provides several widgets (including a few graphical ones). It also sports an optional snazzy system tray.+ .+ Changes in v0.2.0:+ .+ * Add some more flexible formatting options for the XMonadLog widget (contributed by+ cnervi).+ .+ * Make the PollingLabel more robust with an exception handler for IOExceptions+ .+ * Added more documentation for a few widgets . Changes in v0.1.3: .