diff --git a/src/System/Information/Battery.hs b/src/System/Information/Battery.hs --- a/src/System/Information/Battery.hs +++ b/src/System/Information/Battery.hs @@ -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 diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -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 . 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 diff --git a/src/System/Taffybar/StrutProperties.hs b/src/System/Taffybar/StrutProperties.hs --- a/src/System/Taffybar/StrutProperties.hs +++ b/src/System/Taffybar/StrutProperties.hs @@ -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, diff --git a/src/System/Taffybar/Weather.hs b/src/System/Taffybar/Weather.hs --- a/src/System/Taffybar/Weather.hs +++ b/src/System/Taffybar/Weather.hs @@ -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 diff --git a/src/System/Taffybar/Widgets/Graph.hs b/src/System/Taffybar/Widgets/Graph.hs --- a/src/System/Taffybar/Widgets/Graph.hs +++ b/src/System/Taffybar/Widgets/Graph.hs @@ -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) diff --git a/src/System/Taffybar/Widgets/PollingLabel.hs b/src/System/Taffybar/Widgets/PollingLabel.hs --- a/src/System/Taffybar/Widgets/PollingLabel.hs +++ b/src/System/Taffybar/Widgets/PollingLabel.hs @@ -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 () diff --git a/src/System/Taffybar/Widgets/VerticalBar.hs b/src/System/Taffybar/Widgets/VerticalBar.hs --- a/src/System/Taffybar/Widgets/VerticalBar.hs +++ b/src/System/Taffybar/Widgets/VerticalBar.hs @@ -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) diff --git a/src/System/Taffybar/XMonadLog.hs b/src/System/Taffybar/XMonadLog.hs --- a/src/System/Taffybar/XMonadLog.hs +++ b/src/System/Taffybar/XMonadLog.hs @@ -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 "" . taffybarEscape + where t = concat [""] + +-- | Escape strings so that they can be safely displayed by Pango in +-- the bar widget +taffybarEscape :: String -> String +taffybarEscape = encodeHtml . decodeHtml + +-- | The same as defaultPP in XMonad.Hooks.DynamicLog +taffybarDefaultPP :: PP +taffybarDefaultPP = defaultPP { ppCurrent = taffybarEscape . wrap "[" "]" + , ppVisible = taffybarEscape . wrap "<" ">" + , ppHidden = taffybarEscape + , ppHiddenNoWindows = taffybarEscape + , ppUrgent = taffybarEscape + , ppTitle = taffybarEscape . shorten 80 + , ppLayout = taffybarEscape + } +-- | The same as xmobarPP in XMonad.Hooks.DynamicLog +taffybarPP :: PP +taffybarPP = taffybarDefaultPP { ppCurrent = taffybarColor "yellow" "" . wrap "[" "]" + , ppTitle = taffybarColor "green" "" . shorten 40 + , ppVisible = wrap "(" ")" + , ppUrgent = taffybarColor "red" "yellow" + } + + + outputThroughDBus :: Client -> String -> IO () outputThroughDBus client str = do -- The string that we get from XMonad here isn't quite a normal @@ -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 diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -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: .